!*********************************************************************** !* !* 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