!***********************************************************************
!*
!* Utility program to list members of a partitioned file
!*
!* R.R. McLeod ERCC MCMLXXIX
!* R.D.Eager UKC MCMLXXXIII
!*
!***********************************************************************
!
constantinteger version = 5; ! Major version number
constantinteger edit = 0; ! Edit number within major version
!
!***********************************************************************
!*
!* Constants
!*
!***********************************************************************
!
constantinteger no = 0, yes = 1
constantinteger maxint = 99999; ! Must not be altered without changing 'transfer'
constantbyteinteger nl = x'0a'
constantbyteinteger np = x'0c'; ! Newpage character
constantinteger maxmembers = 1000; ! Maximum number of members
constantinteger sscharfiletype = 3
constantinteger sspdfiletype = 6
constantstring (1) snl = "
"
constantinteger keymax = 8; ! Number of parameter keywords
constantstring (7)array keys(1:keymax) = c
"FILE",
"OUTPUT",
"NUMBER",
"PATTERN",
"PAGE",
"LORIGIN",
"LSTEP",
"VERSION"
!
!
!***********************************************************************
!*
!* Record formats
!*
!***********************************************************************
!
recordformat arf(string (31) name,integer type)
recordformat hf(integer dataend,datastart,filesize,filetype,
sum,datetime,format,records)
recordformat rf(integer conad,filetype,datastart,dataend)
!
!
!***********************************************************************
!*
!* Subsystem references
!*
!***********************************************************************
!
systemroutinespec changefilesize(string (31) file,
integer newsize,integername flag)
systemroutinespec connect(string (31) file,integer mode,hole,
prot,record (rf)name r,integername flag)
systemintegerfunctionspec devcode(string (16) device)
systemroutinespec disconnect(string (31) file,integername flag)
systemstringfunctionspec failuremessage(integer mess)
systemroutinespec fileanal(string (31) file,record (arf)arrayname r,
integername count,flag)
systemstringfunctionspec itos(integer n)
systemroutinespec move(integer length,from,to)
systemstringfunctionspec nexttemp
systemroutinespec outfile(string (31) file,integer size,hole,
prot,integername conad,flag)
systemintegerfunctionspec pstoi(string (63) s)
systemroutinespec sendfile(string (31) file,string (16) device,
string (11) name,integer copies,forms,
integername flag)
systemroutinespec setfname(string (63) s)
externalroutinespec set return code(integer i)
systemroutinespec trim(string (31) file,integername flag)
externalintegerfunctionspec uinfi(integer entry)
!
!
!***********************************************************************
!*
!* Service routines
!*
!***********************************************************************
!
integerfunction matchstrings(stringname a,string (255) b)
integer l
!
l = length(a)
result = no if length(b) < l
length(b) = l
if a = b then result = yes else result = no
end ; ! of matchstrings
!
!-----------------------------------------------------------------------
!
integerfunction paramdecode(string (255) param,integer pmax,
stringarrayname keys,pars)
integer i,pnum,pn,res,c,parptr,parleng
string (255) wksp
!
integerfunction findkey
integer f,i
!
if length(wksp) = 0 then result = -2; ! Missing keyword
f = 0
for i = 1,1,pmax cycle
if matchstrings(wksp,keys(i)) = yes then start
unless f = 0 then result = -1
f = i
finish
repeat
result = f
end ; ! of findkey
!
integerfunction getpar
integer c,inpr
!
inpr = 0
wksp = ""
!
cycle
parptr = parptr + 1
if parptr > parleng then result = -1
c = charno(param,parptr)
if c = ',' or c = '=' then result = c
wksp = wksp.tostring(c)
repeat
end ; ! of getpar
!
for i = 1,1,pmax cycle
pars(i) = ""; ! Initialise
repeat
parptr = 0
pnum = 1
parleng = length(param)
!
cycle
c = getpar
res = 0
if c # '=' then start
pn = pnum
else
pn = findkey
if pn = 0 then res = 322; ! Unknown keyword
if pn = -1 then res = 321; ! Ambiguous keyword
if pn = -2 then res = 325; ! Missing keyword
c = getpar
if c = '=' then res = 320; ! Format error
finish
if pn > pmax then res = 323; ! Too many parameters
if res = 0 then start
if wksp # "" # pars(pn) then res = 324
! Duplicated parameter
pars(pn) = wksp
finish
if res # 0 then result = res
if c = -1 then result = 0; ! Finished, all OK
pnum = pnum + 1
repeat
end ; ! of paramdecode
!
!-----------------------------------------------------------------------
!
routine fail(integer n)
printstring(snl."LISTPD fails -".failuremessage(n))
set return code(n)
stop
end ; ! of fail
!
!-----------------------------------------------------------------------
!
routine asort(record (arf)arrayname p,integerarrayname x,integer num)
integer i,j,jg,k,gap
!
return if num <= 0
for i = 1,1,num cycle
x(i) = i
repeat
gap = num//2
while gap > 0 cycle
i = gap + 1
while i <= num cycle
j = i - gap
while j > 0 cycle
jg = j + gap
if p(x(j))_name > p(x(jg))_name then start
k = x(j)
x(j) = x(jg)
x(jg) = k
finish
j = j - gap
repeat
i = i + 1
repeat
gap = gap//2
repeat
end ; ! of asort
!
!-----------------------------------------------------------------------
!
integerfunction match(string (11) file,string (255) pattern)
owninteger pattype = 0
! pattype = 0 before initialisation,
! 1 for *A*,
! 2 for *A,
! 3 for A* or A*B,
! 4 for A
ownstring (255) pats,patt
string (15) work1
string (255) work2
switch typ(1:4)
!
if pattern = "" then result = yes; ! Common case
work2 = "&".pattern."&"
result = yes if work2 -> ("&".file."&")
result = no if pattern -> ("&")
if pattype = 0 then start ; ! First time in - analyse pattern
if pattern -> work2.("*").pats and work2 = "" then start
if charno(pats,length(pats)) = '*' then start
patt = substring(pats,1,length(pats)-1)
pattype = 1
else
patt = pats
pattype = 2
finish
else
if pattern -> pats.("*").patt then start
pattype = 3
finish else pattype = 4
finish
finish
!
-> typ(pattype)
!
typ(4):
if pattern = file then result = yes else result = no
!
typ(3):
unless file -> work2.(pats).file and work2 = "" then result = no
if patt = "" then result = yes
!
typ(2):
typ(1):
unless file -> work1.(patt).work2 then result = no
if pattype = 1 then result = yes
while file -> work1.(patt).work2 cycle
if work2 = "" then result = yes
file = substring(file,length(work1)+2,length(file))
repeat
result = no
end ; ! of match
!
!-----------------------------------------------------------------------
!
routine expand(stringname file,integername conad)
integer flag,cursize,maxfsize
record (rf) rr
record (hf)name r
!
r == record(conad)
cursize = r_filesize
maxfsize = (uinfi(6)+1)*1024
if cursize >= maxfsize then fail(280)
! User individual limit exceeded
if cursize < 16384 then cursize = 16384 else start
cursize = (cursize+65536) & x'ffff0000'
finish
if cursize > maxfsize then cursize = maxfsize
!
changefilesize(file,cursize,flag)
if flag # 0 then start
fail(flag) unless flag = 261; ! VM hole too small
disconnect(file,flag)
changefilesize(file,cursize,flag)
if flag = 0 then start
connect(file,3,0,0,rr,flag)
if flag = 0 then conad = rr_conad
r == record(conad); ! Re-map - it may have moved
finish
finish
fail(flag) unless flag = 0
r_filesize = cursize
end ; ! of expand
!
!-----------------------------------------------------------------------
!
integerfunction transfer(integer len,from,to,origin,step,
string (11) out,integername outconad)
integer fdr0,fdr1,tdr0,tdr1,tempdr0,tempdr1
! Keep pairs together
integer line,i,tptr,count
record (hf)name outhd
!
count = 0
line = origin - step
fdr0 = x'18000000' ! len
fdr1 = from
tdr0 = x'18000000'; ! Bound filled in later
tdr1 = to
outhd == record(outconad)
!
! Set bound check inhibit, so that MODD will work sensibly
!
*cpsr _i
i = i!x'400'
*mpsr _i
!
! Main copy loop
!
cycle
*lb _nl
*ld _fdr0; ! and fdr1
*jat _11,<endoffile>; ! *jzdl_<endoffile>
*swne _l =dr ; ! Scan to end of line
*jat _11,<eof>; ! *jzdl_<eof>
*modd _1; ! Move past newline
eof:
*std _tempdr0; ! and tempdr1
i = tempdr1-fdr1; ! Length of line
fdr0 = x'18000000'!i; ! Descriptor to line
while tdr1 - outconad + i + 7 > outhd_filesize cycle
tptr = tdr1 - outconad
expand(out,outconad)
outhd == record(outconad)
tdr1 = outconad+tptr; ! In case file has moved
repeat
line = line + step
line = origin if line > maxint
count = count + 1
*cdec _0
*dsh _10
*ld _tdr0; ! and tdr1
*ldb _7
*cpb _b ; ! set CC=0
*supk _l =5,0,32; ! unpack and space fill
*jcc _8,<waszero>
*asf _-2; ! remove sign descriptor
waszero:
*ld _tdr0; ! and tdr1
*ldb _7
*mvl _l =5,63,0; ! force ISO zone codes
*lss _32; ! space
*st _(dr )
*modd _1
*st _(dr )
*modd _1
*std _tdr0; ! and tdr1
*ld _fdr0
*cyd _0
*lda _tdr1
*mv _l =dr
*std _tdr0; ! and tdr1
*lsd _tempdr0; ! and tempdr1
*st _fdr0; ! and fdr1
repeat
endoffile:
result = len + count*7
end ; ! of transfer
!
!-----------------------------------------------------------------------
!
integerfunction yes or no(stringname s,integer keyno)
integer reply
!
reply = no
if s # "" then start
if matchstrings(s,"YES") = yes then reply = yes else start
unless matchstrings(s,"NO") = yes then start
setfname(keys(keyno))
fail(326); ! Invalid value for parameter
finish
finish
finish
result = reply
end ; ! of yes or no
!
!
!***********************************************************************
!*
!* L I S T P D
!*
!***********************************************************************
!
externalroutine listpd(string (255) s)
integer count,flag,i,j,numbering,stream,spool,ptr,size,outconad
integer line,paging,gversion,pd,origin,step
integerarray n(1:maxmembers)
stringname pdfile,out,number,curname,pattern,page,os,ss,vs
string (3) trailer
string (15) device,title
string (63) header
string (255)array options(1:keymax)
record (rf) rr
record (arf)array r(1:maxmembers)
record (hf)name outhd
!
set return code(1000); ! In case of catastrophic failure
flag = paramdecode(s,keymax,keys,options)
if flag # 0 then fail(flag)
pdfile == options(1)
out == options(2)
number == options(3)
pattern == options(4)
page == options(5)
os == options(6)
ss == options(7)
vs == options(8)
!
if pdfile = "" then fail(263); ! Wrong number of parameters
if out = "" then out = ".OUT"
!
numbering = yes or no(number,3)
paging = yes or no(page,5)
gversion = yes or no(vs,8)
!
pattern = "" if pattern = "*"
!
if os # "" then start ; ! Line origin specified
origin = pstoi(os)
unless 0 <= origin <= maxint then start
setfname(os)
fail(202); ! Invalid parameter
finish
finish else origin = 1
!
if ss # "" then start ; ! Line step opecified
step = pstoi(ss)
unless 0 < step <= maxint then start
setfname(ss)
fail(202); ! Invalid parameter
finish
finish else step = 1
!
if gversion = yes then start
printstring("Version: E".itos(version).".".itos(edit).snl)
finish
!
connect(pdfile,1,0,0,rr,flag)
if flag # 0 then fail(flag)
if rr_filetype # sspdfiletype then start
if rr_filetype # sscharfiletype then start
setfname(pdfile)
fail(267); ! Invalid filetype
finish else pd = no
finish else pd = yes
!
if out = ".OUT" then stream = yes else start
stream = no
if charno(out,1) = '.' then start
if devcode(out) <= 0 then start
! Illegal, or .TEMP, or .NULL
setfname(out)
fail(264); ! Invalid device code
finish
spool = yes; device = out
out = "T#".nexttemp
finish else spool = no
outfile(out,-4096,0,0,outconad,flag)
! Create any size for now
if flag # 0 then fail(flag)
outhd == record(outconad)
outhd_filetype = sscharfiletype
finish
!
title <- pdfile
if pd = yes then start
count = maxmembers
fileanal(pdfile,r,count,flag)
if flag # 0 then fail(flag)
pdfile = pdfile."_"
asort(r,n,count)
else
n(1) = 1
r(1)_name = pdfile
count = 1
pdfile = ""
finish
!
if paging = no then trailer = snl.snl.snl else trailer = snl
for i = 1,1,count cycle
curname == r(n(i))_name
connect(pdfile.curname,1,0,0,rr,flag)
if flag # 0 then fail(flag)
continue unless rr_filetype = sscharfiletype
continue unless match(curname,pattern) = yes
if pd = no then start
header = "*** File: ".curname." ***".snl.snl
else
header = "*** Member: ".curname." ***".snl.snl
finish
if paging = yes then start
header = tostring(np).snl.snl.header
finish
size = rr_dataend - rr_datastart
if stream = no then start
ptr = outhd_dataend
j = length(header)+size+length(trailer)
while ptr + j > outhd_filesize cycle
expand(out,outconad)
outhd == record(outconad); ! Re-map - it may have moved
repeat
move(length(header),addr(header)+1,outconad+ptr)
ptr = ptr + length(header)
if numbering = no then start
move(size,rr_conad+rr_datastart,outconad+ptr)
ptr = ptr + size
else
ptr = ptr + transfer(size,rr_conad+rr_datastart,outconad+ptr,
origin,step,out,outconad)
outhd == record(outconad); ! Re-map - it may have moved
while ptr+length(trailer) > outhd_filesize cycle
expand(out,outconad)
outhd == record(outconad); ! Re-map - it may have moved
repeat
finish
move(length(trailer),addr(trailer)+1,outconad+ptr)
ptr = ptr+length(trailer)
outhd_dataend = ptr
else
printstring(header)
flag = yes
line = origin
for j = rr_conad+rr_datastart,1,rr_conad+rr_dataend-1 cycle
if flag = yes and numbering = yes then start
write(line,4)
spaces(2)
line = line + step
line = origin if line > maxint
finish
printch(byteinteger(j))
if byteinteger(j) = nl then flag = yes else flag = no
repeat
printstring(trailer)
finish
repeat
!
if stream = no then start
trim(out,flag)
disconnect(out,flag)
if spool = yes then start
sendfile(out,device,title,0,0,flag)
if flag # 0 then fail(flag)
finish
finish
!
set return code(0)
end ; ! of listpd
endoffile