! CLEAN for VAX, GDMR
! Utility to manage files on VMS
!
! Revision History, in reverse order
!
! 2.1.0 18-Jul-1986 JGH changed to use the Latice Logic command line
! parsing library and added /IDENT to print version
!
! This must be compiled with checks off, (gets integer overflow otherwise)
external string (31) Product Code = "CLEAN",
Version = "2",
Release = "1",
Revision = "0"
recordformat dfidf(shortinteger a, b, c)
recordformat namf(byteinteger bid {16_2}, bln {16_38}, rss, rsl, c
integer rsa, shortinteger spare1, c
byteinteger ess, esl, integer esa, c
record (namf)name rfl, c
integer dvi1, dvi2, dvi3, dvi4, c
record (dfidf) fid, did, integer wcc, fnb)
recordformat fabf(byteinteger bid {16_3}, bln {16_50}, c
shortinteger ifi, integer fop, sts, stv, c
integer alq, shortinteger deq, byteinteger fac, shr, c
integer ctx, byteinteger rtv, org, rat, rfm, c
integer jnl, record (*)name xab, c
record (namf)name nam, integer fna, dna, c
byteinteger fns, dns, shortinteger mrs, integer mrn, c
shortinteger bls, byteinteger bks, fsz, c
integer dev, sdc, integer spare1, spare2)
recordformat fibf(string (2) acctl, byteinteger wsize, c
record (dfidf) fid, did, integer wcc, c
shortinteger nmctl, exctl, integer exsz, exvbn, c
byteinteger alopts, alalign, string (9) alloc)
recordformat rabf(byteinteger bid {16_1}, bln {16_44}, c
shortinteger isi, integer rop, sts, stv, c
shortinteger rfa1, rfa2, rfa3, spare1, c
integer ctx, shortinteger spare2, c
byteinteger rac, tmo, c
shortinteger usz, rsz, integer ubf, rbf, rhb, kbf, c
byteinteger ksz, spare3, mbf, mbc, integer bkt, c
record (fabf)name fab, integer spare4)
systemintegerfnspec get(record (rabf)name r, integer i, j)
systemintegerfnspec put(record (rabf)name r, integer i, j)
systemintegerfnspec readblock alias "SYS$READ" {block IO input} c
(record (rabf)name r, integer i, j)
systemintegerfnspec writeblock alias "SYS$WRITE" {block IO output} c
(record (rabf)name r, integer i, j)
systemintegerfnspec connect(record (rabf)name r, integer i, j)
systemintegerfnspec open(record (fabf)name f, integer i, j)
systemintegerfnspec close(record (fabf)name f, integer i, j)
systemintegerfnspec create(record (fabf)name f, integer x, y)
systemintegerfnspec erase(record (fabf)name f, integer i, j)
systemintegerfnspec parse(record (fabf)name f, integer i, j)
systemintegerfnspec search(record (fabf)name f, integer i, j)
systemintegerfnspec rename(record (fabf)name old, integer i, j, c
record (fabf)name new)
recordformat iosbf(shortinteger status, count, integer divdep)
recordformat acbf(shortinteger size, type, integer addr)
systemintegerfnspec qiow(integer efn, chan, func, c
record (iosbf)name iosb, c
integer astadr, astprm, p1, p2, p3, p4, p5, p6)
recordformat desc(integer length, addr)
systemintegerfnspec assign(record (desc)name d, integername chan, c
integer acmode, mbxnam)
systemintegerfnspec dassgn(integer chan)
recordformat recattrf(byteinteger rfo, atr, shortinteger lrl, c
spare1, hbk, spare2, ebk, ffb, c
byteinteger bkz, hsz, shortinteger mrz, dxq)
systemroutinespec exit(integer i)
from Imp include CLI Parse
routine report(integer e1, e2)
recordformat errf(short count, flags, integer e1, e2)
systemroutinespec putmsg(record (errf)name msgvec, integer actrtn, facnam)
record (desc) fac
record (errf) mess
ownstring (5) name = "CLEAN"
if e1&16_fffff000 = 0 then mess_count = 1 else mess_count = 2
mess_flags = 1; mess_e1 = e1; mess_e2 = e2
fac_length = 5; fac_addr = addr(name)+1
putmsg(mess, 0, 0); !addr(fac))
end
owninteger safe = 0; ! = 1 for deletion confirmation
routine wait(integer i)
systemintegerfnspec schdwk(integer pir, prcnam, integername daytim, c
integer reptim)
systemroutinespec hiber
integer status, t2 = -1, t1
t1 = -10000*i
status = schdwk(0, 0, t1, 0)
signal 15, status if status&1 = 0
hiber
end
routine readline(string (*)name s)
byteinteger ch
string (255) t
t=""
cycle
readsymbol(ch)
s = t and return if ch = nl
ch = ch-32 if 'a' <= ch <= 'z'; ! to upper case
t = t.tostring(ch)
repeat
end
constinteger abort = 16_2c, fnf = 16_18292, nmf = 16_182ca
routine poct(integer i)
integer j, k, flag = 0
for j = 30, -3, 0 cycle
k = (i>>j)&7+'0'
printsymbol(k) unless k = '0' and flag = 0 and j # 0
flag = flag+1 unless k = '0'
repeat
end
recordformat timef(integer t1, t2)
string (24)fn time(record (timef)name x)
!
! convert time in system format into an ascii string
!
systemintegerfnspec asctim(integer a, record (desc)name d, c
record (timef)name x, integer c)
record (desc) d
string (24) s
integer status
d_length = 23; d_addr = addr(s)+1; ! set up descriptor
status = asctim(0, d, x, 0) ; ! convert x to ascii
signal 15, status if status&1 = 0
length(s) = 23
result = s
end
integerfn getchan(string (255) file)
!
! get an IO channel to the disk file is on (for qiow later)
!
string (255) junk
integer status, chan = 0
record (desc) d
file -> file.(":").junk; ! only want device name
file = file.":"; ! put back colon (unnecessary?)
d_length = length(file); ! set up descriptor length field
d_addr = addr(file)+1; ! and address
status = assign(d,chan,3,0)
signal 15, status if status&1 = 0
result = chan
end
routine dropchan(integer chan)
!
! finished with channel, so deassign it
!
integer status
status = dassgn(chan)
signal 15, status if status&1 = 0
end
routine acp(record (dfidf)name fid, record (acbf)name a, c
integer chan, func)
!
! queue an IO request to the ACP
! fid is file id (6 bytes)
! a is start of attribute control block list
! chan is IO channel
! func is the function required (IO$_....)
!
record (fibf) f = 0; ! file information block
record (iosbf) iosb; ! io status block
record (desc) d
integer status
f_fid = fid; ! only fid field is set
d_length = 44; ! descriptor length field for fib
d_addr = addr(f); ! and address
status = qiow(0,chan,func,iosb,0,0,addr(d),0,0,0,addr(a),0)
signal 15, status if status&1 = 0
signal 15, iosb_status if iosb_status&1 = 0
end
predicate privileged
!
! %true %if SYSPRV
! %false %otherwise
!
recordformat if(short len, code, integer addr, retlen)
recordformat pf(integer p1, p2)
systemintegerfnspec getjpi(integer s1, pidadr, prcnam, itmlst, s2, s3, s4)
record (if) end = 0, item = 0
record (pf) p
integer status
item_len = 8; item_code = 16_204; item_addr = addr(p)
status = getjpi(0, 0, 0, addr(item), 0, 0, 0)
signal 15, status if status&1 = 0
false if p_p1&(1<<16_1c) = 0
true
end
routine showowner(integer x)
!
! write out uic in octal
!
routine woct(shortinteger i)
printsymbol(i>>6&7+'0')
printsymbol(i>>3&7+'0')
printsymbol(i&7+'0')
end
printsymbol('[')
woct(x>>16)
printsymbol(',')
woct(x&16_ffff)
printsymbol(']')
end
routine setowner(integername x)
!
! put a new uic into the appropriate file attribute field
!
shortinteger g, m
routine readoct(shortintegername k)
string (255) line
integer ptr = 1
readline(line)
cycle
return if ptr > length(line)
exit if byteinteger(addr(line)+ptr) > ' '
ptr = ptr+1
repeat
signal 3, 1, byteinteger(addr(line)+ptr) c
unless '0' <= byteinteger(addr(line)+ptr) <= '7'
k = 0
while ptr <= length(line) and c
'0' <= byteinteger(addr(line)+ptr) <= '7' cycle
k = k<<3+(byteinteger(addr(line)+ptr)-'0')
signal 1 unless k <= 8_377
ptr = ptr+1
repeat
end
routine getgroup
!
! read in group number
!
on 1, 3 start
if event_event = 1 start
printstring("group number out of range")
else
printstring("non-octal character """.tostring(event_extra)."""")
finish
newline
finish
prompt("group: ")
readoct(g)
end
routine getmember
!
! read in member number
!
on 1, 3 start
if event_event = 1 start
printstring("member number out of range")
newline
else
printstring("non-octal character """.tostring(event_extra)."""")
newline
finish
finish
prompt("member: ")
readoct(m)
end
g = x>>16; m = x&16_ffff; ! unpack old uic
getgroup
getmember
x = g<<16+m; ! pack into longword
end
routine o(record (dfidf)name fid, string (255) file)
!
! change owner of file (privileged)
! fid is file id (6 bytes)
! file is only to give device name
!
record (acbf) term = 0, a = 0; ! attribute control block list
integer owner, chan
signal 6 unless privileged
chan = getchan(file); ! need an IO channel to the disk
a_size = 4; a_type = 16_15; a_addr = addr(owner)
acp(fid,a,chan,16_32); ! access file
printstring("current owner is "); showowner(owner); newline
setowner(owner); ! change owner field
acp(fid,a,chan,16_36); ! modify attribute
printstring("new owner is "); showowner(owner); newline
dropchan(chan); ! finished with IO channel
end
routine showprot(integer x)
!
! unpack and print file protection
!
routine putprot(integer i)
!
! print protection for one class
!
i = i&15
printstring("none") and return if i = 15
printsymbol('r') if i&1 = 0
printsymbol('w') if i&2 = 0
printsymbol('e') if i&4 = 0
printsymbol('d') if i&8 = 0
end
printstring("system:"); putprot(x)
printstring(" owner:"); putprot(x>>4)
printstring(" group:"); putprot(x>>8)
printstring(" world:"); putprot(x>>12)
end
routine setprot(shortintegername prot)
!
! set protection field of file attribute
!
routine getprot(shortintegername i)
!
! read in, decode and pack file protection
!
string (255) line
integer j, ptr
cycle
readline(line); ptr = 0
i = -1
cycle
ptr = ptr+1
return if ptr > length(line); ! no more
j = byteinteger(addr(line)+ptr)
if j = 'R' start
i = i&10; ! read and execute
continue
else if j = 'W'
i = i&8; ! write, read, execute
continue
else if j = 'E'
i = i&11; ! execute
continue
else if j = 'D'
i = 0; ! all
continue
else if j = 'N'
i = i&15; ! none
continue
else
printstring("spurious character """.tostring(j)."""")
newline
exit ; ! throw away the last line
finish
repeat
repeat
end
shortinteger sys, own, gro, wor
prompt("system: "); getprot(sys)
prompt("owner: "); getprot(own)
prompt("group: "); getprot(gro)
prompt("world: "); getprot(wor)
prot = (prot&16_fff0)+sys unless sys = -1; ! set system
prot = (prot&16_ff0f)+own<<4 unless own = -1; ! set owner
prot = (prot&16_f0ff)+gro<<8 unless gro = -1; ! set group
prot = (prot&16_0fff)+wor<<12 unless wor = -1; ! set world
prot = (prot&16_f0ff)+(prot&(prot>>4)&16_0f00); ! group >= world
prot = (prot&16_ff0f)+(prot&(prot>>4)&16_00f0); ! owner >= group
!! prot = (prot&16_fff0)+(prot&(prot>>8)&16_000f); ! system >= group
end
routine p(record (dfidf)name fid, string (255) file)
!
! change file protection
! fid is file id (6 bytes)
! file is for device name only
!
record (acbf) term = 0, a = 0; ! attribute list
integer chan
shortinteger x; ! for protection code
chan = getchan(file); ! get IO channel to disk
a_size = 2; a_type = 16_16; a_addr = addr(x)
acp(fid,a,chan,16_32); ! access file
printstring("current protection - "); showprot(x); newline
setprot(x); ! set up new protection
acp(fid,a,chan,16_36); ! modify file attribute
printstring("new protection - "); showprot(x); newline
dropchan(chan); ! finished with IO channel
end
routine d(record (fabf)name f)
!
! delete file in NAM block
!
integer status
status = erase(f, 0, 0)
signal 15, status, f_stv if status&1 = 0
end
routinespec locate(record (fabf)name f)
routine l(record (fabf)name f, string (255)name rs)
!
! list remaining files in directory
!
integer i = 0, xtl
string (255) oldfile = "#", ext, dir, file
on 15 start
newline unless i = 0
signal 15, event_sub, f_stv
finish
cycle
locate(f); ! get next file
length(rs) = f_nam_rsl; ! set resultant string length
rs -> dir.("]").file; ! strip off directory
file -> file.(".").ext; ! separate off extension
unless file = oldfile start ; ! a new file name
oldfile = file; ! remember it
newline unless i = 0; ! not the first time through
printstring(file)
spaces(9-length(file))
i = 1
printsymbol('.')
printstring(ext)
xtl = length(ext); ! remember length of extension
else ; ! same name, new ext/version
i = i+1
if i = 8 start ; ! no more room on line
newline
spaces(9)
i = 1
else
spaces(8-xtl)
finish
printsymbol('.')
printstring(ext)
xtl = length(ext)
finish
repeat
end
conststring (10)array org(0:1) =
"sequential",
"relative"
conststring (27)array rfm(0:5) =
"undefined",
"fixed-length",
"variable-length",
"variable with fixed control",
"stream-CR?",
"stream-LF"
routine i(record (dfidf)name fid, string (255) file)
!
! info on file
! fid is file id (6 bytes)
! file is for device name only
!
record (acbf) term = 0, revdate, credate, uic, fpro, revcnt, bakdate, c
recattr, uchar; ! attributes list
record (recattrf) a
record (timef) rev, cre, bak
integer u, chan, uch
shortinteger prot, revns
string (255) s = ""
! first set up attribute control blocks
bakdate_size = 8; bakdate_type = 16_14; bakdate_addr = addr(bak)
revdate_size = 8; revdate_type = 16_12; revdate_addr = addr(rev)
credate_size = 8; credate_type = 16_11; credate_addr = addr(cre)
revcnt_size = 2; revcnt_type = 16_d; revcnt_addr = addr(revns)
uic_size = 4; uic_type = 16_15; uic_addr = addr(u)
fpro_size = 2; fpro_type = 16_16; fpro_addr = addr(prot)
recattr_size = 20; recattr_type = 4; recattr_addr = addr(a)
uchar_size = 4; uchar_type = 3; uchar_addr = addr(uch)
! all done, we can now get the info
chan = getchan(file)
acp(fid,uchar,chan,16_32)
dropchan(chan)
! and print it out
printstring("owner: "); showowner(u)
printstring("; file id: "); write(fid_a,0)
printstring(", sequence no: "); write(fid_b,0)
unless fid_c = 0 start
printstring(", rel vol no: "); write(fid_c,0)
finish
newline
printstring("created ".time(cre))
unless revns = 1 start
printstring("; revised ".time(rev)." (")
write(revns,1)
printsymbol(')')
finish
newline
unless bak_t1 = 0 and bak_t2 = 0 start
printstring("last backed up ".time(bak))
newline
finish
printstring("protection - "); showprot(prot); newline
printstring("blocks allocated:"); write(a_hbk,1)
a_ebk = a_ebk-1 and a_ffb = 512 if a_ffb = 0
printstring("; blocks used:"); write(a_ebk,1)
printstring(" (bytes used in last:"); write(a_ffb,1)
printsymbol(')'); newline
printstring("organisation: ".org(a_rfo>>4&1))
a_rfo = a_rfo&15; ! clear out organisation
printstring("; format: ".rfm(a_rfo)); newline
if a_rfo >= 2 start
printstring("maximum allowed record length:")
if a_mrz = 0 then printstring(" undefined") else c
write(a_mrz,1) and printstring(" bytes")
newline
printstring("longest actual record:")
write(a_lrl,1); printstring(" bytes")
newline
else if a_rfo = 1
printstring("record length:"); write(a_lrl,1)
printstring(" bytes"); newline
finish
if a_atr > 7 start ; ! nospan
s = "nospan, "
a_atr = a_atr&7; ! clear nospan - the others are mutually exclusive
finish
if a_atr = 1 start
s = s."FORTRAN CC, "
else if a_atr = 2
s = s."implied CC, "
else if a_atr = 4
s = s."print-file CC, "
finish else s = s."no CC, "
s = s."marked for deletion, " unless uch&16_8000 = 0
s = s."bad block, " unless uch&16_4000 = 0
s = s."directory, " unless uch&16_2000 = 0
s = s."spool, " unless uch&16_1000 = 0
s = s."contiguous, " unless uch&16_80 = 0
s = s."locked, " unless uch&16_40 = 0
s = s."contig-best-try, " unless uch&16_20 = 0
s = s."write-check, " unless uch&16_10 = 0
byteinteger(addr(s)) = byteinteger(addr(s))-2; ! remove last ", "
printstring("characteristics: ".s)
newline
end
record (timef)fn systime(string (255) t)
!
! convert time in ascii to system-format quadword
!
systemintegerfnspec bintim(record (desc)name d, record (timef)name t)
record (desc) d
record (timef) b
integer status
d_length = length(t); d_addr = addr(t)+1
status = bintim(d,b)
signal 15, status if status&1 = 0
result = b
end
integerfn stoi(string (255) s)
!
! convert string containing an integer to its value
!
integer i = 0, ch, j
for j = 1, 1, length(s) cycle
ch = charno(s,j)
signal 15, 16_12 unless '0' <= ch <= '9'
i = i*10+(ch-'0')
signal 15, 16_11ea unless i < 16_0fffffff; ! too big
repeat
result = i
end
routine dates(record (dfidf)name f, string (255) file)
!
! modify time attributes of file
!
integer chan
record (acbf) term = 0, credate, revdate, bakdate, revcnt
record (timef) cre, rev, bak
shortinteger cnt
string (255) line
signal 6 unless privileged
chan = getchan(file)
revcnt_size = 2; revcnt_type = 16_d; revcnt_addr = addr(cnt)
bakdate_size = 8; bakdate_type = 16_14; bakdate_addr = addr(bak)
revdate_size = 8; revdate_type = 16_12; revdate_addr = addr(rev)
credate_size = 8; credate_type = 16_11; credate_addr = addr(cre)
acp(f,revcnt,chan,16_32)
printstring("created ".time(cre))
if cnt > 1 start
printstring(", revised ".time(rev)." (")
write(cnt,1)
printsymbol(')')
finish
newline
printstring("backed up ".time(bak)) and newline c
unless bak_t1 = 0 and bak_t2 = 0
prompt("creation date/time "); readline(line)
cre = systime(line) unless line = ""
prompt("revision date/time "); readline(line)
rev = systime(line) unless line = ""
prompt("revision number "); readline(line)
cnt = stoi(line)&16_7fff unless line = ""
prompt("backup date/time "); readline(line)
bak = systime(line) unless line = ""
acp(f,revcnt,chan,16_36)
dropchan(chan)
end
predicate directory(record (dfidf)name fid, string (255) d)
!
! %true if file is a directory
! %false otherwise
! don't believe file extension, look at file characteristics
!
record (acbf) temp = 0, uchar; ! attributes list
integer uch, chan
uchar_size = 4; uchar_type = 3; uchar_addr = addr(uch)
chan = getchan(d)
acp(fid,uchar,chan,16_32); ! access file
dropchan(chan)
true unless uch&16_2000 = 0; ! a directory
false
end
ownstring (5) defnam = "*.*;*"
routine setup(string (*)name file, def, string (255)name es, rs, c
record (fabf)name f, record (namf)name n)
!
! set up FAB, NAM blocks
!
f_bid = 3; f_bln = 16_50
n_bid = 2; n_bln = 16_38
f_fna = addr(file)+1; f_fns = length(file)
f_dna = addr(def)+1; f_dns = length(def)
n_esa = addr(es)+1; n_ess = 127
n_rsa = addr(rs)+1; n_rss = 127
f_nam == n
f_fop = 16_01000040; ! nam, sqo
end
routine checkname(record (fabf)name f)
!
! check and parse file name
!
integer status
status = parse(f, 0, 0)
signal 15, status, f_stv if status&1 = 0
end
routine locate(record (fabf)name f)
!
! look for a file and get its fid
!
integer status
status = search(f, 0, 0)
signal 15, status, f_stv if status&1 = 0
end
routine name(string (255) oldname, newname, string (*)name newrs)
!
! rename file to newname
! return it in newrs
!
record (fabf) f1 = 0, f = 0
record (namf) n1 = 0, n = 0
string (255) es1, rs1, es, rs, def
integer status
oldname -> def.(";").es; ! lose version number
def = def.";0"; ! want new one to be highest version
setup(oldname, def, es, rs, f, n)
setup(newname, def, es1, rs1, f1, n1)
checkname(f)
checkname(f1)
locate(f)
signal 15, abort if n_fid_a = n1_did_a; ! MT trap
status = rename(f, 0, 0, f1)
signal 15, status, f_stv if status&1 = 0
length(rs1) = n1_rsl
newrs = rs1
end
predicate dirempty(string (255) dir)
!
! %true if directory is empty
! %false otherwise
!
record (fabf) f = 0
record (namf) n = 0
string (255) es, rs
on 15 start
true if event_sub = fnf; ! file not found => empty
false ; ! some other error - assume it isn't empty
finish
setup(dir, defnam, es, rs, f, n)
checkname(f)
locate(f)
false ; ! we suceeded in finding a file - not empty
end
routine nlines(record (fabf) f)
record (rabf) r = 0
integer status, count = 0
systemintegerfnspec find(record (rabf)name r, integer i, J)
r_bid = 1; r_bln = 16_44
r_fab == f
r_rop = 16_10000; ! loc
f_fac = 2; ! put
status = open(f, 0, 0)
signal 15, status, f_stv if status&1 = 0
status = connect(r, 0, 0)
signal 15, status, r_stv if status&1 = 0
count = count+1 and status = find(r, 0, 0) until status&1 = 0
signal 15, status, r_stv unless status = 16_1827a
printstring("file contains")
write(count-1, 1)
printstring(" record")
printsymbol('s') unless count = 2
newline
status = close(f, 0, 0)
signal 15, status, f_stv if status&1 = 0
end
routine t(record (fabf)name f, integer n)
!
! type out first n lines of file
!
record (rabf) r = 0
record (fabf) f1 = f; ! copy the FAB - we want to change it
string (255) s
integer status, i, j, k
if Interrupted start ; finish ; ! no ^C pending
n = 16_7fffffff if n = 0; ! whole file (a large no. of lines)
f1_fac = 2; ! get
r_bid = 1; r_bln = 16_44
r_fab == f1
r_ubf = addr(s)+1
r_usz = 255
status = open(f1, 0, 0)
signal 15, status, f1_stv if status&1 = 0
unless f1_org = 0 start
printstring("file is not sequential")
newline
-> e
finish
status = connect(r, 0, 0)
signal 15, status, r_stv if status&1 = 0
for i = 1, 1, n cycle
exit if Interrupted; ! ^C - stop printing
status = get(r, 0, 0)
exit if status = 16_1827a; ! end of file
signal 15, status, r_stv if status&1 = 0
unless r_rsz = 0 start
for j = r_ubf,1,r_rsz+r_ubf-1 cycle ; ! down record
k = byteinteger(j)&16_7f; ! lose parity
printsymbol(k) if k >= ' ' or k = 9 or k = 13
repeat
finish
newline
repeat
e: status = close(f1, 0, 0)
signal 15, status, f1_stv if status&1 = 0
end
routine help
newline
printstring( c
"? to print the current filespec")
newline
printstring( c
"A <file> to append the file to another file")
newline
printstring( c
"C <file> to copy the file into another file")
newline
printstring( c
"D to delete the file (note that directories must be empty)")
newline
printstring( c
"E to exit from the directory currently being scanned")
newline
printstring( c
"F <filespec> to change temporarily to a new filespec")
newline
printstring( c
"H to type this information")
newline
printstring( c
"I to display details of the file characteristics")
newline
printstring( c
"K to count the number of lines in the file")
newline
printstring( c
"L to list the remaining files in the current directory")
newline
printstring( c
"N <newfile> to rename the file to newfile")
newline
!
! O to change file owner
!
printstring( c
"P to change the file protection - reply with r, w, e, d or n (for none)")
newline
printstring( c
"Q to quit the program (^Z has the same effect)")
newline
printstring( c
"R to restart the scan of the current directory from the top")
newline
printstring( c
"S to enter and examine a subdirectory")
newline
printstring( c
"T <n> to type out the first n lines of the file (default whole file)")
newline
!
! U to allow alteration of end of file block
!
!
! W to alter time attributes
!
printstring( c
"X to exit from the directory currently being scanned")
newline
printstring( c
"Z to clear the screen of a Tektronix and reprompt")
newline
printstring( c
"<cr> to go on to the next file")
newline
printstring( c
"^C to abort T")
newlines(2)
end
routine u(record (dfidf)name fid, string (255) file)
record (acbf) term = 0, recattr
record (recattrf) a
integer chan
recattr_size = 20; recattr_type = 4; recattr_addr = addr(a)
chan = getchan(file)
acp(fid, recattr, chan, 16_32)
printstring("size = "); write(a_hbk, 0)
printstring(", block with ffb = "); write(a_ebk, 0); newline
l: prompt("last block "); read(a_ebk)
unless 0 <= a_ebk <= a_hbk start
printstring("illegal block"); newline
-> l
finish
skipsymbol while nextsymbol # nl; skipsymbol; ! trailing junk
a_ebk = a_ebk+1; a_ffb = 0
acp(fid, recattr, chan, 16_36)
dropchan(chan)
end
routine copy(record (fabf)name from, string (255) to)
!
! copy from file FROM to file TO
! use block-IO for speed
!
record (fabf) f = from, t
record (namf) n = 0
record (rabf) rf = 0, rt = 0
string (255) es, rs
bytearray buff(1:512)
integer status, blocks
f_ifi = 0; ! must be zero
f_fac = 16_22; ! bio, get
status = open(f, 0, 0)
signal 15, status, f_stv if status&1 = 0
t = f; ! most of the output FAB fields are as in the input file
t_ifi = 0; ! must be zero
t_fac = 16_21; ! bio, put
t_fop = t_fop+16_20000000; ! ofp
t_fna = addr(to)+1; t_fns = length(to)
t_dna = 0; t_dns = 0
t_nam == n
n_bid = 2; n_bln = 16_38
n_esa = addr(es)+1; n_ess = 127
n_rsa = addr(rs)+1; n_rss = 127
n_rfl == f_nam; ! related NAM block gives filename defaults
status = create(t, 0, 0)
signal 15, status, t_stv if status&1 = 0
rf_bid = 1; rf_bln = 16_44
rf_fab == f
rf_rbf = addr(buff(1)); rf_rsz = 512
rf_ubf = addr(buff(1)); rf_usz = 512
rt = rf; rt_fab == t
status = connect(rf, 0, 0)
signal 15, status, rf_stv if status&1 = 0
status = connect(rt, 0, 0)
signal 15, status, rt_stv if status&1 = 0
blocks = 0
cycle
status = readblock(rf, 0, 0)
exit if status = 16_1827a; ! eof
signal 15, status, rf_stv if status&1 = 0
rt_rsz = rf_rsz; ! bytes transferred
status = writeblock(rt, 0, 0)
signal 15, status, rt_stv if status&1 = 0
blocks = blocks+1
repeat
status = close(f, 0, 0)
signal 15, status, f_stv if status&1 = 0
status = close(t, 0, 0)
signal 15, status, t_stv if status&1 = 0
length(rs) = n_rsl
write(blocks,0); printstring(" block")
printsymbol('s') if blocks # 1
printstring(" copied to ".rs); newline
end
routine append(record (fabf)name f, string (255) to)
bytearray buff(0:511)
record (fabf) t = 0
record (namf) n = 0
record (rabf) rf = 0, rt = 0
string (255) rs, junk, junkk
integer status, i
to = to.";0" unless to -> junk.(";").junkk
t_bid = 3; t_bln = 16_50
t_fna = addr(to)+1; t_fns = length(to)
t_dna = f_nam_rsa; t_dns = f_nam_rsl
t_fac = 1; ! put
t_fop = 16_40; ! sqo
t_nam == n
n_bid = 2; n_bln = 16_38
n_rsa = addr(rs)+1; n_rss = 127
rf_bid = 1; rf_bln = 16_44
rf_rop = 16_00010000; ! loc
rf_ubf = addr(buff(0)); rf_usz = 512
rf_fab == f
rt_bid = 1; rt_bln = 16_44
rt_fab == t
rt_rop = 16_100; ! eof
status = open(t, 0, 0)
signal 15, status&16_fffffff8, t_stv if status&1 = 0
status = open(f, 0, 0)
if status&1 = 0 start
i = close(t, 0, 0)
signal 15, status, f_stv
finish
unless f_rfm = t_rfm and f_mrs = t_mrs start
status = close(f, 0, 0)
status = close(t, 0, 0)
signal 15, 16_18570
finish
status = connect(rt, 0, 0)
signal 15, status, rt_stv if status&1 = 0
status = connect(rf, 0, 0)
signal 15, status, rf_stv if status&1 = 0
i = 0
cycle
status = get(rf, 0, 0)
exit if status = 16_1827a; ! eof
signal 15, status, rf_stv if status&1 = 0
rt_rbf = rf_rbf; rt_rsz = rf_rsz
status = put(rt, 0, 0)
signal 15, status, rt_stv if status&1 = 0
i = i+1
repeat
status = close(f, 0, 0)
signal 15, status, f_stv if status&1 = 0
status = close(t, 0, 0)
signal 15, status, t_stv if status&1 = 0
write(i, 0); printstring(" record")
printsymbol('s') unless i = 1
printstring(" appended to ")
length(rs) = n_rsl
printstring(rs); newline
end
routine perform(string (255) filespec, default)
!
! the main command interpreter
!
integer marker = 16_12345678
string (255) es
record (fabf) f = 0
record (namf) n = 0
string (255) rs
switch com('?':'Z'+1)
string (255) comline, dir, prmpt, file, junk, filex, filexx
integer ok = 0, firsttime = 0, ii
bytename bb
on 6, 15 start
-> com('Z'+1) if event_event = 6; ! probably strange command character
if event_sub = fnf start ; ! couldn't find file
length(es) = n_esl
printstring("No files """.es."""")
newline
return
else if event_sub = nmf; ! no more files
return
finish
report(event_sub, event_extra)
return if ok = 0; ! unsafe
-> retry
finish
restart:
setup(filespec, default, es, rs, f, n)
checkname(f)
firsttime = 0
comloop:
return if firsttime = 1 and n_fnb&16_100 = 0; ! no wildcards
ok = 0
locate(f); ! get next file
ok = 1
length(rs) = n_rsl
unless rs -> dir.("]").file start ; ! NJR trap
rs -> dir.(">").file
dir -> filex.("<").filexx
dir = filex."[".filexx
rs = dir."]".file
finish
if firsttime = 0 start
length(es) = n_esl
printstring("Current filespec ".es)
newline
firsttime = 1
finish
prmpt = file." "
for ii = 2, 1, length(prmpt) - 3 cycle ; ! can ignore ";n "
bb == charno(prmpt, ii)
bb = bb - 'A' + 'a' if 'A' <= bb <= 'Z'
repeat
prmpt = " ".prmpt while length(prmpt) < 19
again:
retry:
prompt(prmpt)
readline(comline)
comline -> (" ").comline while comline # "" and charno(comline, 1) = ' '
junk = "" unless comline -> comline.(" ").junk
junk -> (" ").junk while junk # "" and charno(junk, 1) = ' '
-> comloop if comline = ""
-> com(charno(comline,1))
com('?'): ! current filespec
length(es) = n_esl
printstring("Current filespec ".es)
newline
-> again
com('A'): ! append
prompt("append to:")
readline(junk) while junk = ""
append(f, junk)
-> again
com('C'): ! copy
prompt("copy to: ")
readline(junk) while junk = ""
copy(f, junk)
-> again
com('D'): ! delete
if safe = 1 start ; ! confirm deletion
unless charno(comline, length(comline)) = '!' or c
(junk # "" and charno(junk, 1) = '!') start
prompt("delete ? ")
readline(junk)
junk -> (" ").junk while junk # "" and charno(junk, 1) = ' '
-> again if junk = "" or charno(junk, 1) # 'Y'
finish
finish
if directory(n_fid,dir) start
file -> filex.(".").junk
junk = dir.".".filex."]"
unless dirempty(junk) start
printstring("cannot delete a non-empty directory")
newline
-> again
finish
finish
d(f)
printstring("deleted")
newline
-> comloop
com('E'):
com('X'): ! exit
return
com('F'): ! filespec
prompt("filespec: ")
readline(junk) while junk = ""
perform(junk, es)
printstring("Returning to previous filespec")
newline
-> comloop
com('H'): ! help
help
-> again
com('I'): ! file info
i(n_fid, rs)
-> again
com('K'): ! count records in file
nlines(f)
-> again
com('L'): ! list remaining files
l(f, rs)
com('N'): ! new name for file
prompt("new name: ")
readline(junk) while junk = ""
name(rs, junk, filexx)
filexx -> filex.("]").junk
if filex = dir start
printstring("renamed to ".junk)
newline
else
printstring("renamed to ".filexx)
newline
finish
-> comloop
com('O'): ! change owner (privileged)
o(n_fid, dir)
-> again
com('P'): ! change protection
p(n_fid, dir)
-> again
com('Q'): ! quit program
stop
com('R'): ! restart
-> restart
com('S'): ! subdirectory
unless directory(n_fid, dir) start
printstring(file." is not a directory")
newline
-> again
finish
file -> filex.(".").junk; ! drop extension
junk = dir.".".filex."]"; ! form new directory name
perform(junk, defnam); ! do stuff on subdirectory
printstring("Returning from subdirectory")
newline
-> again
com('T'): ! type
if junk = "" and length(comline) > 1 start
junk = substring(comline,2,length(comline))
ii = 1
ii = ii+1 while ii <= length(junk) and c
'0' <= charno(junk,ii) <= '9'
length(junk) = ii-1
finish
t(f, stoi(junk))
-> again
com('U'): ! unscrew
u(n_fid, dir)
-> again
com('W'): ! when (priv)
dates(n_fid, dir)
-> again
com('Z'): ! clear Tektronix screen & reprompt
print symbol(27); print symbol(140); newline
wait(950)
-> again
com(*): ! everything else
printstring("command ".comline." ?")
newline
-> again
end
begin
externalpredicatespec batchmode alias "IMP_BATCH_MODE"
string (255) junk, thisfile
on 9, 15 start
stop if event_event = 9
exit(event_sub)
finish
if Qualifier Present ("IDENTIFY") start
Select Output (0)
Print String (Product Code." version ".Version.".".Release)
Print String (".".Revision) if Revision # "0"
Newline
return unless Qualifier Present ("FILES")
finish
if batchmode start
printstring("CLEAN must be run interactively"); newline
return
finish
Safe = 1 if Qualifier Present ("CONFIRM")
This File = Qualifier S ("FILES")
This File = "*.*;*" if This File = "" { Default is *.*;* }
while This File # "" cycle
thisfile = thisfile."[".junk while thisfile -> thisfile.("<").junk
thisfile = thisfile."]".junk while thisfile -> thisfile.(">").junk
perform(thisfile, defnam)
This File = Qualifier S ("FILES")
repeat
end
endoffile