!*********************************************************************** !* !* Program to read files from an IBM labelled tape !* !* Copyright (C) R.D. Eager University of Kent MCMLXXXV !* !*********************************************************************** ! constantinteger version = 1; ! Major version number constantinteger edit = 0; ! Edit number within major version ! !*********************************************************************** !* !* Constants !* !*********************************************************************** ! constantinteger no = 0, yes = 1 constantinteger sscharfiletype = 3; ! Subsystem file type constantinteger ssdatafiletype = 4; ! Subsystem file type constantinteger maxblk = 2400; ! Max size of tape blocks constantinteger chan = 1; ! Channel for tape operations constantinteger maxaction = 5 constantbyteintegerarray actions(1:maxaction) = c 'E','P','H','L','V' constantbyteintegerarray monc(0:11) = c 31,28,31,30,31,30,31,31,30,31,30,31 constantbyteintegerarray etoitable(0:255) = c x'00',x'01',x'02',x'03',x'9c',x'09',x'86',x'7f',x'97',x'8d', x'8e',x'0b',x'0c',x'0d',x'0e',x'0f',x'10',x'11',x'12',x'13', x'9d',x'85',x'08',x'87',x'18',x'19',x'92',x'8f',x'1c',x'1d', x'1e',x'1f',x'80',x'81',x'82',x'83',x'84',x'0a',x'17',x'1b', x'88',x'89',x'8a',x'8b',x'8c',x'05',x'06',x'07',x'90',x'91', x'16',x'93',x'94',x'95',x'96',x'04',x'98',x'99',x'9a',x'9b', x'14',x'15',x'9e',x'1a',x'20',x'a0', '[', ']', '{', '}', x'a5',x'a6',x'a7',x'a8',x'5b',x'2e',x'3c',x'28',x'2b', '|', x'26',x'a9',x'aa',x'ab',x'ac',x'ad',x'ae',x'af',x'b0',x'b1', '!',x'24',x'2a',x'29',x'3b', '~',x'2d',x'2f', '¬',x'b3', x'b4',x'b5',x'b6',x'b7',x'b8',x'b9',x'7c',x'2c',x'25',x'5f', x'3e',x'3f',x'ba',x'bb',x'bc',x'bd',x'be',x'bf',x'c0',x'c1', x'c2',x'60',x'3a',x'23',x'40',x'27',x'3d',x'22',x'c3',x'61', x'62',x'63',x'64',x'65',x'66',x'67',x'68',x'69',x'c4',x'c5', x'c6',x'c7',x'c8',x'c9',x'ca',x'6a',x'6b',x'6c',x'6d',x'6e', x'6f',x'70',x'71',x'72',x'cb',x'cc',x'cd',x'ce',x'cf',x'd0', x'd1',x'ff',x'73',x'74',x'75',x'76',x'77',x'78',x'79',x'7a', x'd2',x'd3',x'd4',x'd5',x'd6',x'd7',x'd8',x'd9',x'da',x'db', x'dc',x'dd',x'de',x'df',x'e0',x'e1',x'e2',x'e3',x'e4',x'e5', x'e6',x'e7',x'7b',x'41',x'42',x'43',x'44',x'45',x'46',x'47', x'48',x'49',x'e8',x'e9',x'ea',x'eb',x'ec',x'ed',x'7d',x'4a', x'4b',x'4c',x'4d',x'4e',x'4f',x'50',x'51',x'52',x'ee',x'ef', x'f0',x'f1',x'f2',x'f3',x'ff',x'9f',x'53',x'54',x'55',x'56', x'57',x'58',x'59',x'5a',x'f4',x'f5',x'f6',x'f7',x'f8',x'f9', x'30',x'31',x'32',x'33',x'34',x'35',x'36',x'37',x'38',x'39', x'fa',x'fb',x'fc',x'fd',x'fe',x'ff' constantstring (1) snl = " " constantstring (3)array mons(0:11) = c "Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec" ! ! !*********************************************************************** !* !* Record and array formats !* !*********************************************************************** ! recordformat hf(integer dataend,datastart,filesize,filetype,sum, datetime, (integer spare1,spare2 or c { Character file } integer format,records or c { Data file } integer adir,count or c { Pdfile } integer pstart,spare3 or c { Old directory file } integer spare4,controlmode or c { Background control file } integer lda,ofm)) { Object file } recordformat rf(integer conad,filetype,datastart,dataend) ! ! !*********************************************************************** !* !* Subsystem references !* !*********************************************************************** ! externalroutinespec changefilesize alias "S#CHANGEFILESIZE"(string (31) file, integer newsize,integername flag) externalroutinespec connect alias "S#CONNECT"(string (31) file, integer mode,hole,prot, record (rf)name r,integername flag) externalstringfunctionspec date externalroutinespec destroy alias "S#DESTROY"(string (31) file, integername flag) externalroutinespec disconnect alias "S#DISCONNECT"(string (31) file, integername flag) externalstringfunctionspec failuremessage alias "S#FAILUREMESSAGE"(integer mess) externalstringfunctionspec interrupt externalstringfunctionspec itos alias "S#ITOS"(integer n) externalroutinespec modpdfile alias "S#MODPDFILE"(integer ep,string (31) pdfile, string (11) member,string (31) infile, integername flag) externalroutinespec move alias "S#MOVE"(integer length,from,to) externalstringfunctionspec nexttemp alias "S#NEXTTEMP" externalroutinespec outfile alias "S#OUTFILE"(string (31) file,integer size, hole,prot,integername conad,flag) externalintegerfunctionspec outpos externalintegerfunctionspec parmap alias "S#PARMAP" externalroutinespec prompt(string (255) s) externalintegerfunctionspec pstoi alias "S#PSTOI"(string (63) s) externalroutinespec setpar alias "S#SETPAR"(string (255) s) externalroutinespec set return code(integer i) externalstringfunctionspec spar alias "S#SPAR"(integer n) externalstringfunctionspec time externalroutinespec trim alias "S#TRIM"(string (31) file,integername flag) externalroutinespec uctranslate alias "S#UCTRANSLATE"(integer ad,len) ! externalroutinespec define(string (255) s) ! ! !*********************************************************************** !* !* Magnetic tape interface routines !* !*********************************************************************** ! externalroutinespec askmag(integer channel,string (7) vol, integername flag) externalroutinespec readmag(integer channel,ad,integername len,flag) externalroutinespec rewindmag(integer channel) externalroutinespec skipmag(integer channel,n) externalroutinespec skiptmmag(integer channel,n) externalroutinespec unloadmag(integer channel) ! ! !*********************************************************************** !* !* Own variables !* !*********************************************************************** ! owninteger masktype; ! Used to record type of current mask owninteger magblk = 0 ! ! !*********************************************************************** !* !* Service routines !* !*********************************************************************** ! integerfunction stopping ! Yields 'yes' iff INT:STOP has been issued. string (15) s ! s = interrupt uctranslate(addr(s)+1,length(s)) if s = "STOP" then result = yes else result = no end ; ! of stopping ! !----------------------------------------------------------------------- ! stringfunction specmessage(integer n) switch sw(1000:1000) ! -> sw(n) ! sw(1000): result = "Failed to claim tape" end ; ! of specmessage ! !----------------------------------------------------------------------- ! routine strip(stringname s) ! Strips trailing spaces from 's'. length(s) = length(s) - 1 while charno(s,length(s)) = ' ' end ; ! of strip ! !----------------------------------------------------------------------- ! routine fail(integer n) string (255) s ! selectoutput(0) if n < 1000 then s = failuremessage(n) else s = specmessage(n) printstring(snl."IBMMT fails -".s) unloadmag(chan) set return code(n) stop end ; ! of fail ! !----------------------------------------------------------------------- ! routine reset rewindmag(chan) skipmag(chan,1) end ; ! of reset ! !----------------------------------------------------------------------- ! routine skiptm(integer n) integer i ! for i = 1,1,n cycle skiptmmag(chan,1) repeat magblk = magblk + n end ; ! of skiptm ! !----------------------------------------------------------------------- ! routine readline(stringname s) integer c ! s = "" cycle cycle readsymbol(c) exit if c = nl s <- s.tostring(c) repeat strip(s) exit unless s = "" repeat uctranslate(addr(s)+1,length(s)) end ; ! of readline ! !----------------------------------------------------------------------- ! integerfunction match(string (63) s,mask) ! masktype = 0 before initialisation, ! 1 for *A*, ! 2 for *A, ! 3 for A* or A*B, ! 4 for A ownstring (15) masks,maskt string (63) work1,work2 switch typ(1:4) ! result = yes if mask = "*" or mask = "" ! Common case if masktype = 0 then start ; ! First time in for this mask - analyse it if mask -> work1.("*").masks and work1 = "" then start if charno(masks,length(masks)) = '*' then start maskt = substring(masks,1,length(masks)-1) masktype = 1 finish else start maskt = masks masktype = 2 finish finish else start if mask -> masks.("*").maskt then start masktype = 3 finish else masktype = 4 finish finish ! -> typ(masktype) ! typ(4): if mask = s then result = yes else result = no ! typ(3): unless s -> work1.(masks).s and work1 = "" then result = no if maskt = "" then result = yes ! typ(2): typ(1): unless s -> work1.(maskt).work2 then result = no if masktype = 1 then result = yes while s -> work1.(maskt).work2 cycle if work2 = "" then result = yes s = substring(s,length(work1)+2,length(s)) repeat result = no end ; ! of match ! !----------------------------------------------------------------------- ! routine etoi(integer ad,len) ! Translates 'len' bytes from IBM EBCDIC to ASCII, starting at 'ad'. integer j ! j = addr(etoitable(0)) *lb _len *jat _14,<l99> *ldtb _x'18000000' *ldb _b *lda _ad *lss _j *luh _x'18000100' *ttr _l =dr ! l99: end ; ! of etoi ! !----------------------------------------------------------------------- ! routine rdmag(integer channel,ad,integername len,flag) ! Reads a tape block and translates it from EBCDIC to ASCII. readmag(channel,ad,len,flag) magblk = magblk + 1 ! %if flag = 0 %then etoi(ad,len) end ; ! of rdmag ! !----------------------------------------------------------------------- ! integerfunction checkswitch(integer c) integer i ! for i = 1,1,maxaction cycle if c = actions(i) then result = i repeat result = -1 end ; ! of checkswitch ! !----------------------------------------------------------------------- ! routine getcommand(integername type,stringname srce,dest) integer l string (63) line string (255) work1,work2 ! type = 0 readline(line) line = work1.work2 while line -> work1.(" ").work2 l = length(line) if l >= 2 then start if charno(line,l-1) = '/' then start type = checkswitch(charno(line,l)) length(line) = l - 2 finish finish if line -> work1.("/").work2 then start type = -1 return finish ! if line -> work1.("=").work2 then start dest <- work1 srce <- work2 finish else start dest = "" srce <- line finish end ; ! of getcommand ! !----------------------------------------------------------------------- ! integerfunction wild(string (31) s) if s -> ("*") then result = yes result = no end ; ! of wild ! !----------------------------------------------------------------------- ! stringfunction tdate(integer n) integer year,month,m string (2) y string (9) s ! year = n//1000 n = n - year*1000 month = 0 cycle m = monc(month) if month = 1 and year//4*4 = year then m = m + 1 exit if n <= m month = month + 1 n = n - m repeat s = itos(n) y = itos(year) if length(y) = 1 then y = "0".y if length(s) = 1 then s = "0".s result = s."-".mons(month)."-".y end ; ! of tdate ! !----------------------------------------------------------------------- ! routine printhelp printstring(" Program call is: IBMMT(tape[,commands]) Command format is: destination=source/switch where one or two items may be null. ") printstring(" File specs are: up to 17 alphanumeric characters where an asterisk is also allowed, denoting a 'wild' component that matches any substring. ") printstring(" Switches are: /E - exit from IBMMT. /P - set current pdfile.") printstring(" /H - print this help text. /L - give a directory of all or part of the tape. /V - display version number of IBMMT. ") end ; ! of printhelp ! !----------------------------------------------------------------------- ! routine directory(stringname mask) integer ad,len,flag,i,adw,blocks,files,wildcard,labelno string (255) work byteintegerarray buf(0:maxblk-1) ! ad = addr(buf(0)) adw = addr(work) + 1 ! rewindmag(chan) len = maxblk rdmag(chan,ad,len,flag) if flag # 0 then start if flag = 1 then printstring("?Unexpected tape mark".snl) else c printstring("?Tape read error".snl) reset return finish etoi(ad,len) move(6,ad+4,adw) length(work) = 6 strip(work) printstring(snl."Directory of IBM standard multi-file labelled tape ".work.snl) printstring(" on ".date." at ".time.snl) move(14,ad+37,adw) length(work) = 14 strip(work) work = substring(work,2,length(work)) while length(work) > 0 and charno(work,1) = ' ' printstring("Owned by ".work.snl.snl) ! wildcard = wild(mask) files = 0 blocks = 0 labelno = 0 ! printstring("Label Name Details".snl.snl) cycle exit if stopping = yes len = maxblk rdmag(chan,ad,len,flag) exit if flag = 1; ! Final tape mark if flag > 1 then start printstring("?Tape read error".snl) reset return finish etoi(ad,len) move(4,ad,addr(i)) if i # m'HDR1' then start printstring("?HDR1 not found when expected".snl) reset return finish length(work) = 17 move(17,ad+4,adw) strip(work) labelno = labelno + 1 if match(work,mask) = no then start skiptm(3) continue finish printstring(" ".itos(labelno)) spaces(13-outpos) printstring(work) files = files + 1 spaces(30-outpos) skiptm(2) len = maxblk rdmag(chan,ad,len,flag) etoi(ad,len) move(4,ad,addr(i)) if i # m'EOF1' then start printstring("?EOF1 not found where expected".snl) reset return finish move(6,ad+54,adw) length(work) = 6 i = pstoi(work); ! Number of blocks blocks = blocks + i write(i,3) printstring(" Block") if i = 1 then space else printsymbol('s') space move(5,ad+42,adw) length(work) = 5 printstring(tdate(pstoi(work)).snl) exit if wildcard = no skiptmmag(chan,1) repeat ! printstring(snl."Total of ".itos(blocks)." block") printsymbol('s') unless blocks = 1 printstring(" in ".itos(files)." file") printsymbol('s') unless files = 1 newlines(2) end ; ! of directory ! !----------------------------------------------------------------------- ! routine transfer(stringname srce,dest,pdfile) integer i,pd,rewound,ad,len,flag,ptr,conad,adt,wildcard,recsize,recfm,nrecs string (11) name string (31) out,temp,rtemp byteintegerarray buf(0:maxblk-1) record (rf) rr record (hf)name r ! dest = "*" if dest = "" ad = addr(buf(0)) adt = addr(temp) + 1 if wild(srce) = yes then start wildcard = yes reset rewound = yes finish else start wildcard = no rewound = no finish ! cycle exit if stopping = yes len = maxblk rdmag(chan,ad,len,flag) if flag > 1 then start printstring("?Tape read error".snl) reset return finish if flag = 1 then start ; ! Final tape mark reset if rewound = no then start rewound = yes continue finish if wildcard = no then printstring("?File not found".snl) return finish etoi(ad,len) move(4,ad,addr(i)) if i # m'HDR1' then start printstring("?HDR1 not found when expected".snl) reset return finish length(temp) = 17 move(17,ad+4,adt) strip(temp) if match(temp,srce) = no then start skiptm(3) continue finish ! len = maxblk rdmag(chan,ad,len,flag) if flag > 1 then start printstring("?Tape read error".snl) reset return finish if flag = 1 then start ; ! Tape mark printstring("?Unexpected tape mark after HDR1".snl) reset return finish etoi(ad,len) move(4,ad,addr(i)) if i # m'HDR2' then start printstring("?HDR2 not found when expected".snl) reset return finish recfm = byteinteger(ad+4) if recfm = 'F' then recfm = 1 else recfm = 2 length(rtemp) = 5 move(5,ad+10,addr(rtemp)+1) strip(rtemp) recsize = pstoi(rtemp) ! skiptmmag(chan,1); ! Skip to just before first data block magblk = magblk + 1 name <- temp if wildcard = yes then start printstring("[".name."]".snl) finish if wild(dest) = yes then out = name else out = dest if pdfile # "" then start out = "T#".nexttemp pd = yes finish else pd = no outfile(out,4096,0,0,conad,flag) if flag # 0 then start printstring("%".failuremessage(flag)) skiptm(2) continue finish r == record(conad) r_filetype = ssdatafiletype r_format = (recsize<<16)!recfm ptr = r_dataend nrecs = 0 ! cycle exit if stopping = yes len = maxblk rdmag(chan,ad,len,flag) if flag > 1 then start printstring("?Tape read error".snl) destroy(out,flag) reset return finish if flag = 1 then exit ; ! End of file if ptr + len >= r_filesize then start i = (r_filesize+131072) & (¬131071) changefilesize(out,i,flag) if flag = 261 then start ; ! VM hole too small disconnect(out,flag) changefilesize(out,i,flag) if flag = 0 then connect(out,3,0,0,rr,flag) if flag = 0 then start conad = rr_conad r == record(conad); ! Re-map - it may have moved finish finish if flag # 0 then start printstring("?".failuremessage(flag)) skiptm(2) return finish r_filesize = i finish if recfm = 1 then start ; ! Fixed length records move(len,ad,conad+ptr) etoi(conad+ptr,len) ptr = ptr + len nrecs = nrecs + len//recsize else ad = ad + 4; ! Lose block header len = len - 4 cycle i = halfinteger(ad) halfinteger(conad+ptr) = i - 2 ad = ad + 4 len = len - 4 move(i-4,ad,conad+ptr+2) etoi(conad+ptr+2,i-4) ptr = ptr + i - 2 ad = ad + i - 4 len = len - i + 4 nrecs = nrecs + 1 repeat until len <= 0 finish repeat ! r_dataend = ptr r_records = nrecs trim(out,flag) skiptmmag(chan,1) magblk = magblk + 3 ! if pd = yes then start connect(pdfile,0,0,0,rr,flag) if flag = 218 then start ; ! Create pdfile modpdfile(4,pdfile,"","",flag) if flag # 0 then start printstring("?".failuremessage(flag)) return finish printstring("%Creating pdfile ".pdfile.snl) finish name = dest if wild(dest) = no modpdfile(2,pdfile,name,"",flag); ! Delete any existing member of same name modpdfile(1,pdfile,name,out,flag);! Insert new member if flag # 0 then start printstring("?".failuremessage(flag)) return finish destroy(out,flag) finish else start disconnect(out,flag) finish unless wildcard = yes then exit repeat end ; ! of transfer ! ! !*********************************************************************** !* !* I B M M T !* !*********************************************************************** ! externalroutine ibmmt(string (255) parms) integer flag,type string (6) vol string (11) pdfile string (31) input,srce,dest switch sw(0:maxaction) ! set return code(9999) setpar(parms) if parmap > 3 then fail(263); ! Wrong number of parameters vol <- spar(1) input <- spar(2) if vol = "" then fail(263); ! Wrong number of parameters if input = "" then input = ".IN" define("1,".input) selectinput(1) ! askmag(chan,vol,flag) if flag # 0 then fail(1000); ! Failed to claim tape reset ! pdfile = "" prompt("*") cycle masktype = 0 getcommand(type,srce,dest) if type < 0 or (type = 0 and srce = "") then start printstring("?Illegal command".snl) continue finish -> sw(type) ! sw(0): transfer(srce,dest,pdfile) continue ! sw(1): ! /E exit ! sw(2): ! /P pdfile <- srce if dest # "" then start printstring("%File ".dest." ignored".snl) finish continue ! sw(3): ! /H unless srce = "" = dest then start printstring("%Files ignored".snl) finish printhelp continue ! sw(4): ! /L if dest # "" then start printstring("%File ".dest." ignored".snl) finish if srce = "" then srce = "*" directory(srce) reset continue ! sw(5): ! /V unless srce = "" = dest then start printstring("%Files ignored".snl) finish printstring("Version: E".itos(version).".".itos(edit).snl) continue repeat ! unloadmag(chan) set return code(0) end ; ! of ibmmt endoffile