! H2 file system proccesses. These processes interpret requests in standard
! internal message form, whether from an external-service manager or from a
! local process. The processes make requests to a remote server using the
! 1976 H2 protocol.
! This version converted to use the raw ether handler.
%externalstring(47) copyright %alias "GDMR_(C)_F_H2" = %c
"Copyright (C) 1987 George D.M. Ross"
! To do: implement redirection
%option "-nonstandard-low-nocheck-nodiag-noline-nostack"
!%option "-nonstandard-low"
%constinteger processes = 4
%constinteger priority = 6
%constinteger default initial allocation = 32
%constinteger file tokens = 32
%constinteger filestore specifier = 1
%include "Moose:Mouse.Inc"
%include "GDMR_H:FSysAcc.Inc"
%include "GDMR_H:NFac.Inc"
%include "GDMR_E:2Meg.Inc"
%include "GDMR_H:Lights.Inc"
%externalpredicatespec FS lookup(%string(31) what, %integername value)
%constinteger change file = modify file mode ! append to file mode
%conststring(1) SNL = "
"
%recordformat path fm(%record(path fm)%name next,
%integer version, %string(*)%name key,
%string(255) text)
%systemroutinespec phex(%integer i)
%systemroutinespec phex2(%integer i)
%systemstring(31)%fnspec itos(%integer i, j)
%systemintegerfnspec free store
%externalroutinespec FS insert(%string(31) name, %integer value)
%externalroutinespec dump(%integer n, %bytename b)
%ownrecord(semaphore fm) request semaphore = 0
%ownrecord(mailbox fm) request mailbox = 0
! Diagnostic
!! %routine show path(%record(path fm)%name p)
!! %while p ## nil %cycle
!! print symbol('@'); phex(addr(p))
!! printstring(" -> "); phex(addr(p_next))
!! printstring(" v "); write(p_version, 0)
!! printstring(" c "); printstring(p_key)
!! newline
!! p == p_next
!! %repeat
!! %end
!! %routine xprintstring(%string(255) s)
!! %integer i, ch
!! %return %if s = ""
!! %for i = 1, 1, length(s) %cycle
!! ch = charno(s, i)
!! %if ' ' <= ch <= '~' %start
!! print symbol(ch)
!! %else
!! print symbol('<')
!! write(ch, 0)
!! print symbol('>')
!! %finish
!! %repeat
!! %end
! Filestore connection tables
%constinteger first filestore = 'A'
%constinteger last filestore = 'Z'
%recordformat filestore fm(%record(semaphore fm) semaphore,
%integer context, Uno)
%ownrecord(filestore fm)%array filestore(first filestore : last filestore) = 0(*)
%constintegerarray filestore addresses(first filestore : last filestore) =
16_14 { A }, 16_15 { B }, 16_1B { C }, 16_35 { D },
16_00 { E }, 16_00 { F }, 16_7E { G }, 16_00 { H },
16_00 { I }, 16_00 { J }, 16_00 { K }, 16_00 { L },
16_44 { M }, 16_00 { N }, 16_00 { O }, 16_00 { P },
16_00 { Q }, 16_00 { R }, 16_48 { S }, 16_00 { T },
16_00 { U }, 16_72 { V }, 16_00 { W }, 16_3E { X },
16_00 { Y }, 16_00 { Z }
! Filestore communications
! reserved '@' { Can't be used for some reason!
%constinteger FC openmod = 'A' { Uno: filename : Xno
%constinteger FC rename = 'B' { Uno: filename, filename :
%constinteger FC dchange = 'C' { Uno: filename, date :
%constinteger FC delete = 'D' { Uno: filename :
%constinteger FC permit = 'E' { Uno: filename, permissions :
%constinteger FC finfo = 'F' { Uno: ownername, file-number : packet
%constinteger FC general = 'G' { Uno: : packet
%constinteger FC uclose = 'H' { Xno: :
%constinteger FC readback = 'I' { Xno: : packet
%constinteger FC setdir = 'J' { Uno: ownername :
%constinteger FC close = 'K' { Xno: :
%constinteger FC logon = 'L' { 0 : ownername, password : Uno
%constinteger FC logoff = 'M' { Uno: :
%constinteger FC ninfo = 'N' { Uno: filename : packet
%constinteger FC copyfile = 'O' { Uno: filename, filename :
%constinteger FC pass = 'P' { Uno: password, username :
%constinteger FC quote = 'Q' { Uno: password :
%constinteger FC readda = 'R' { Xno: block-number, blocks : packet
%constinteger FC openr = 'S' { Uno: filename : Xno
%constinteger FC openw = 'T' { Uno: filename : Xno
%constinteger FC reset = 'U' { Xno: block-number :
%constinteger FC credir = 'V' { Uno: new-diectory-name :
%constinteger FC writeda = 'W' { Xno: block-number, ...packet :
%constinteger FC readsq = 'X' { Xno: blocks : packet
%constinteger FC writesq = 'Y' { Xno: ...packet :
%constinteger FC readfile = 'Z' { Uno: filename : ...file
%constinteger FC new owner = '[' { Uno:
ownername, quota :
%constinteger FC owners = '\' { Uno: partition number : packet
%constinteger FC fcomm = ']' { Uno: system command : packet
%constinteger FC new quota = '^' { Uno: ownername, delta :
! unused '_' {
%constinteger first FC = '@'; ! This one is reserved.
%constinteger last FC = '_'
%integerfn H to I(%string(127) h)
%integer i, j, k
%result = 0 %if h = ""
%result = -1 %if charno(h, 1) = '-'
i = 0
%for j = 1, 1, length(h) %cycle
k = charno(h, j) - '0'
%exit %if k < 0
i = 16 * i + k
%repeat
%result = i
%end
%string(7)%fn I to H(%integer i)
%string(31) h
%integer j
h = ""
h = h . to string((i >> j) & 15 + '0') %for j = 12, -4, 0
%result = h
%end
%ownrecord(mailbox fm)%name ether mailbox == nil
%integerfn transact(%integer ether context,
%bytename send buffer, %integer send bytes,
%bytename receive buffer, %integername receive bytes)
%record(semaphore fm) semaphore
%record(mailbox fm) mailbox
%record(ether request fm) request = 0
%record(ether request fm)%name response
%if ether mailbox == nil %start
printstring("F_H2: ether mailbox unknown??")
newline
%result = -1
%finish
setup semaphore(semaphore)
setup mailbox(mailbox, semaphore)
setup message(request, size of(request))
request_code = ether old write
request_context = ether context
request_buffer == send buffer
request_bytes = send bytes
send message(request, ether mailbox, mailbox)
response == receive message(mailbox)
%result = response_status %if response_status < 0
request_code = ether old read
request_context = ether context
request_buffer == receive buffer
request_timeout = 100; ! Deciseconds
send message(request, ether mailbox, mailbox)
response == receive message(mailbox)
%result = response_status %if response_status < 0
receive bytes = response_bytes
%result = 0
%end
%integerfn receive more(%integer ether context,
%bytename receive buffer, %integername receive bytes)
%record(semaphore fm) semaphore
%record(mailbox fm) mailbox
%record(ether request fm) request = 0
%record(ether request fm)%name response
%if ether mailbox == nil %start
printstring("F_H2: ether mailbox unknown??")
newline
%result = -1
%finish
setup semaphore(semaphore)
setup mailbox(mailbox, semaphore)
setup message(request, size of(request))
request_code = ether old read
request_context = ether context
request_buffer == receive buffer
request_timeout = 100; ! Deciseconds
send message(request, ether mailbox, mailbox)
response == receive message(mailbox)
%result = response_status %if response_status < 0
receive bytes = response_bytes
%result = 0
%end
%integerfn establish connection(%integer target)
%record(semaphore fm) semaphore
%record(mailbox fm) mailbox
%record(ether request fm) request = 0
%record(ether request fm)%name response
%record(filestore fm)%name f
%string(127) from FS = "Dummy"
%integer n, i
%byte two = 2
%if ether mailbox == nil %start
%if FS lookup(ether mailbox name, i) %start
ether mailbox == record(i)
%else
printstring("F_H2: No ether mailbox?"); newline
%result = -1
%finish
%finish
f == filestore(target)
setup semaphore(semaphore)
setup mailbox(mailbox, semaphore)
setup message(request, size of(request))
request_code = ether old define
request_ra = filestore addresses(target)
request_rp = 0
send message(request, ether mailbox, mailbox)
response == receive message(mailbox)
n = response_status %and -> error %if response_status < 0
f_context = response_context
n = transact(f_context, two, 1, charno(from FS, 1), i)
-> error %if n < 0
length(from FS) = i
i = H to I(from FS)
%if i < 0 %start
! Error response from filestore
printstring("F_H2: Filestore "); print symbol(target)
printstring(": "); printstring(from FS); ! NL supplied in response
-> undef
%finish
request_code = ether old redefine
request_context = f_context
request_rp = i
send message(request, ether mailbox, mailbox)
response == receive message(mailbox)
n = response_status %and -> error %if response_status < 0
!! printstring("Connected to Filestore "); print symbol(target)
!! printstring(" ("); phex2(filestore addresses(target)); print symbol(')')
!! printstring(" context "); write(f_context, 0)
!! newline
%result = 0
error:printstring("F_H2: "); printstring(ether errors(n)); newline
undef:%if f_context # 0 %start
! Connection was defined. Break it.
request_code = ether old undefine
request_context = f_context
send message(request, ether mailbox, mailbox)
response == receive message(mailbox)
! Ignore any error status here
f_context = 0
%finish
%result = -1
%end
%routine break connection(%integer target)
%record(semaphore fm) semaphore
%record(mailbox fm) mailbox
%record(ether request fm) request
%record(ether request fm)%name response
%record(filestore fm)%name f
%integer n, i
%byte twelve = 12
!! printstring("Break connection to filestore ")
!! print symbol(target); newline
f == filestore(target)
setup semaphore(semaphore)
setup mailbox(mailbox, semaphore)
setup message(request, size of(request))
semaphore wait(f_semaphore)
signal semaphore(f_semaphore) %and %return %if f_context = 0
request_code = ether old write
request_context = f_context
request_buffer == twelve
request_bytes = 1
send message(request, ether mailbox, mailbox)
response == receive message(mailbox)
n = response_status
request_code = ether old undefine
request_context = f_context
send message(request, ether mailbox, mailbox)
response == receive message(mailbox)
f_context = 0
signal semaphore(f_semaphore)
n = response_status %if n = 0
%if n < 0 %start
printstring("F_H2 (informational): ")
printstring(ether errors(n)); newline
%finish
%end
%string(255)%fn send command(%integer target, UXno, command,
%string(255) parameters)
%record(filestore fm)%name f
%string(255) sending, response
%integer status = 0, n
!! printstring("Send command to "); print symbol(target); newline
%result = "-- Bad target filestore " . to string(target) %c
%unless first filestore <= target <= last filestore
%result = "-- Undefined target filestore " . to string(target) %c
%if filestore addresses(target) = 0
f == filestore(target)
semaphore wait(f_semaphore)
%if f_context = 0 %start
status = establish connection(target)
%if status < 0 %start
signal semaphore(f_semaphore)
%result = "-- Connect to filestore " . %c
to string(target) . " rejected"
%finish
%finish
%if command = FC logon %and f_Uno # 0 %start
signal semaphore(f_semaphore)
%result = "-- Already logged on to " . to string(target)
%else %if command = FC logoff %and f_Uno = 0
! Not logged on, so do nothing
signal semaphore(f_semaphore)
%result = ""
%finish
UXno = f_Uno %if UXno < 0
response = "-- Dummy"
sending = to string(command) . to string(UXno + '0') . parameters . SNL
!! printstring(">>> "); xprintstring(sending); newline
status = transact(f_context, charno(sending, 1), length(sending),
charno(response, 1), n)
response = "-- Send command: " . ether errors(status) %c
%and -> out %if status < 0
%if n > 0 %and charno(response, n) = NL %start
! Non-packet response -- drop the trailing NewLine
length(response) = n - 1
%else
! No trailing NewLine. Must be a packet response, so we'll let
! our caller worry about decoding it all....
length(response) = n
%finish
!! printstring("<<< "); xprintstring(response); newline
%if response # "" %and charno(response, 1) = '-' %start
signal semaphore(f_semaphore)
%result = response
%finish
out: %if command = FC logon %start
n = H to I(response)
f_Uno = n
%else %if command = FC logoff
f_uno = 0
%finish
signal semaphore(f_semaphore)
%result = response
%end
%routine copy block(%integer n, %bytename from, to)
D0 = D0 - 1
L: *move.b (A0)+, (A1)+
*dbra D0, L
%end
%string(255)%fn make read request(%integer target, Xno,
%integername next block,
%integer block,
%bytename buffer,
%integername bytes)
%bytearray b(0 : 532)
%record(filestore fm)%name f
%string(255) sending
%string(*)%name response
%integer status = 0, n, newline pos, i, expecting, got
%result = "-- Bad target filestore " . to string(target) %c
%unless first filestore <= target <= last filestore
%result = "-- Undefined target filestore " . to string(target) %c
%if filestore addresses(target) = 0
f == filestore(target)
semaphore wait(f_semaphore)
%if f_context = 0 %start
status = establish connection(target)
%if status < 0 %start
signal semaphore(f_semaphore)
%result = "-- Connect to filestore " . %c
to string(target) . " rejected"
%finish
%finish
!! printstring("R . "); write(next block, 1); write(block, 1); newline
! Now for a horrible hack: the old-style filestores don't understand
! multi-block readDAs, just readSQs.... VAX doesn't even know about multi-
! block readSQs!
%if target = 'B' %or target = 'C' %or target = 'M' %start
%if block = next block %start
! Sequential access, so we can use a multi-block readSQ
expecting = bytes >> 9
%if expecting <= 0 %start
signal semaphore(f_semaphore)
next block = -1
%result = "-- Dud byte count to "
%finish
sending = to string(FC readSQ) . to string(Xno + '0') . %c
I to H(expecting) . SNL
%else
! Non-sequential, convert it to single-block readDA
sending = to string(FC readDA) . to string(Xno + '0') . %c
I to H(block) . SNL
expecting = 1
%finish
%else %if target = 'V'
! VAX -- turn it into a single-block read (but only if it's sequential).
%if block # next block %start
signal semaphore(f_semaphore)
next block = -1
%result = "-- Unsupported non-sequential read to ECSVAX: " . %c
itos(block, 0) . " " . itos(next block, 0)
%finish
bytes = 512; expecting = 1
sending = to string(FC readSQ) . to string(Xno + '0') . SNL
%else
! Must be a new-style filestore, so can use multi-block readDA
expecting = bytes >> 9
%if expecting <= 0 %start
signal semaphore(f_semaphore)
next block = -1
%result = "-- Dud byte count to "
%finish
sending = to string(FC readDA) . to string(Xno + '0') . %c
I to H(block) . "," . I to H(expecting) . SNL
%finish
bytes = 0
!! printstring("R > "); xprintstring(sending); newline
status = transact(f_context, charno(sending, 1), length(sending), b(1), n)
%if status < 0 %start
signal semaphore(f_semaphore)
!! printstring("R ! "); printstring(ether errors(status)); newline
next block = -1
%result = "-- Make read request: " . ether errors(status)
%finish
! The first block of data has come back as part of the above call....
newline pos = 531
%for i = 1, 1, n %cycle
newline pos = i %and %exit %if b(i) = NL
%repeat
b(0) = newline pos - 1; ! Drop the NewLine
response == string(addr(b(0)))
!! printstring("R < "); xprintstring(response); newline
%if response # "" %and charno(response, 1) = '-' %start
signal semaphore(f_semaphore)
next block = -1
%result = response
%finish
got = n - newline pos
copy block(got, b(newline pos + 1), buffer) %if got > 0
bytes = bytes + got
next block = next block + 1
expecting = expecting - 1
buffer == buffer [512]
! Now process any following blocks
%while expecting > 0 %and got = 512 %cycle
status = receive more(f_context, b(1), n)
%if status < 0 %start
signal semaphore(f_semaphore)
!! printstring("R ! "); printstring(ether errors(status)); newline
next block = -1
%result = "-- Make read request: " . ether errors(status)
%finish
newline pos = 531
%for i = 1, 1, n %cycle
newline pos = i %and %exit %if b(i) = NL
%repeat
b(0) = newline pos - 1; ! Drop the NewLine
response == string(addr(b(0)))
!! printstring("R + "); xprintstring(response); newline
%if response # "" %and charno(response, 1) = '-' %start
signal semaphore(f_semaphore)
next block = -1
%result = response
%finish
got = n - newline pos
%exit %if got <= 0; ! Special for empty last block (avoid "copy")
copy block(got, b(newline pos + 1), buffer)
bytes = bytes + got
next block = next block + 1
expecting = expecting - 1
buffer == buffer [512]
%repeat
signal semaphore(f_semaphore)
next block = -1 %if got # 512
%result = response
%end
%string(255)%fn make write request(%integer target, Xno, block, bytes,
%bytename buffer)
%bytearray b(0 : 532)
%record(filestore fm)%name f
%string(255) sending, response = "Dummy"
%integer status, n
%result = "-- Bad target filestore " . to string(target) %c
%unless first filestore <= target <= last filestore
%result = "-- Undefined target filestore " . to string(target) %c
%if filestore addresses(target) = 0
f == filestore(target)
semaphore wait(f_semaphore)
%if f_context = 0 %start
status = establish connection(target)
%if status < 0 %start
signal semaphore(f_semaphore)
%result = "-- Connect to filestore " . %c
to string(target) . " rejected"
%finish
%finish
sending = to string(FC writeDA) . to string(Xno + '0') . %c
I to H(block) . "," . I to H(bytes) . SNL
string(addr(b(0))) = sending
copy block(bytes, buffer, b(length(sending) + 1)) %if bytes > 0
!! printstring("W > "); xprintstring(sending); newline
status = transact(f_context, b(1), length(sending) + bytes,
charno(response, 1), n)
%if status < 0 %start
signal semaphore(f_semaphore)
!! printstring("W ! "); printstring(ether errors(status)); newline
%result = "-- Make write request: " . ether errors(status)
%finish
length(response) = n - 1
!! printstring("W < "); xprintstring(response); newline
signal semaphore(f_semaphore)
%result = response
%end
%string(255)%fn make packet request(%integer target, Uno, command,
%string(255) parameters,
%bytename buffer,
%integername bytes)
%bytearray b(0 : 532)
%record(filestore fm)%name f
%string(255) sending
%string(*)%name response
%integer status = 0, n, newline pos, i
%result = "-- Bad target filestore " . to string(target) %c
%unless first filestore <= target <= last filestore
%result = "-- Undefined target filestore " . to string(target) %c
%if filestore addresses(target) = 0
f == filestore(target)
semaphore wait(f_semaphore)
%if f_context = 0 %start
status = establish connection(target)
%if status < 0 %start
signal semaphore(f_semaphore)
%result = "-- Connect to filestore " . %c
to string(target) . " rejected"
%finish
%finish
bytes = 0
Uno = f_Uno %if Uno < 0
sending = to string(command) . to string(Uno + '0') . parameters . SNL
!! printstring("P > "); xprintstring(sending); newline
status = transact(f_context, charno(sending, 1), length(sending), b(1), n)
%if status < 0 %start
signal semaphore(f_semaphore)
!! printstring("P ! "); printstring(ether errors(status)); newline
%result = "-- Make packet request: " . ether errors(status)
%finish
newline pos = 531
%for i = 1, 1, n %cycle
newline pos = i %and %exit %if b(i) = NL
%repeat
b(0) = newline pos - 1; ! Drop the NewLine
response == string(addr(b(0)))
!! printstring("P < "); xprintstring(response); newline
%if response # "" %and charno(response, 1) = '-' %start
signal semaphore(f_semaphore)
%result = response
%finish
bytes = n - newline pos
copy block(bytes, b(newline pos + 1), buffer) %if bytes > 0
signal semaphore(f_semaphore)
%result = response
%end
! File tokens (issued by us, incorporating lower-level ones)
%recordformat file token fm(%integer filestore, Xno, next block)
%ownrecord(file token fm)%array our file tokens(1 : file tokens) = 0(*)
%ownrecord(semaphore fm) file token semaphore = 0
%record(file token fm)%map get new file token
%record(file token fm)%name t
%integer i
semaphore wait(file token semaphore)
%for i = 1, 1, file tokens %cycle
t == our file tokens(i)
%if t_Xno = 0 %start
! Found a free one
t_Xno = -1
signal semaphore(file token semaphore)
%result == t
%finish
%repeat
signal semaphore(file token semaphore)
%result == nil
%end
%routine validate file token(%record(fs message fm)%name m, %integer allow)
%record(file token fm)%name t
%integer i
%for i = 1, 1, file tokens %cycle
%if m_file token = addr(our file tokens(i)) %start
t == record(m_file token)
%exit %if t_Xno <= 0 %and t_Xno # allow; ! Invalid
m_error code = 0
%return
%finish
%repeat
m_error code = -302; m_status = -3
m_textual response = "Invalid file token"
%end
! Error code interpretation
%routine set status(%record(fs message fm)%name m)
%if m_error code = 0 %start
m_status = 0
%else
m_status = -2; ! Meantime
m_textual response = "Unknown error " . itos(m_error code, 0)
%finish
%end
! Filename munging. Always fill in the target filestore from the first
! component of the filename
%routine determine filename(%record(fs message fm)%name m,
%string(255)%name filename)
%record(path fm)%name p, last p
p == m_filename
m_fsys work = charno(p_key, 1)
p == p_next
filename = ""
last p == p
%while p ## nil %cycle
filename = filename . ":" %if filename # ""
filename = filename . p_key
last p == p
p == p_next
%repeat
filename = filename . ":" . itos(last p_version, 0) %c
%if last p ## nil %and last p_version # 0
!! printstring("Filename is "); printstring(filename)
!! printstring(" at "); print symbol(m_fsys work); newline
%end
%routine determine second filename(%record(fs message fm)%name m,
%string(255)%name filename,
%integername target filestore)
%record(path fm)%name p, last p
p == m_filename2
target filestore = m_fsys work; ! i.e. from first filename
target filestore = charno(p_key, 1)
p == p_next
filename = ""
last p == p
%while p ## nil %cycle
filename = filename . ":" %if filename # ""
filename = filename . p_key
last p == p
p == p_next
%repeat
filename = filename . ":" . itos(last p_version, 0) %c
%if last p ## nil %and last p_version # 0
!! printstring("Filename is "); printstring(filename)
!! printstring(" at "); print symbol(m_fsys work); newline
%end
%routine split at newline(%string(*)%name s, d1, d2)
%bytename ch
%integer i
d1 = ""; d2 = ""
%return %if s = ""
ch == charno(s, 1); i = length(s)
%while i > 0 %and ch # NL %cycle
d1 = d1 . to string(ch)
ch == ch [1]; i = i - 1
%repeat
ch == ch [1]; i = i - 1
%while i > 0 %cycle
d2 = d2 . to string(ch)
ch == ch [1]; i = i -1
%repeat
%end
! One action routine for each of the request (sub)types.
%ownbytearray root directory(0 : 16 * 512 - 1)
%owninteger root directory size = 0
%ownbytearray root buffer(0 : 511)
%routine copy root
! This routine copies the contents of a "register" buffer as supplied by
! an old-style filestore into the root directory. It knows about the
! format supplied to it, and assumes that the buffer provided is correct.
%integer n, name = 0, bad = 0
%bytename reg
%for n = 0, 1, 511 %cycle
reg == root buffer(n)
%if bad = 0 %and ('A' <= reg <= 'Z' %or '0' <= reg <= '9' %c
%or reg = '$' %or reg = '.' %c
%or reg = '_' %or reg = '#') %start
root directory(root directory size) = reg
root directory size = root directory size + 1
name = 1
%else %if reg = '*'
bad = 1
%else %if reg = ' ' %or reg = NL
%if bad = 0 %and name # 0 %start
root directory(root directory size) = ':'
root directory size = root directory size + 1
root directory(root directory size) = NL
root directory size = root directory size + 1
%finish
bad = 0
name = 0
%finish
%repeat
%end
%routine do open file(%record(fs message fm)%name m)
%record(file token fm)%name file token
%string(255) filename, response, size, pad
%integer command, i, bytes
!! printstring("Do open file: mode "); phex2(m_mode)
!! printstring(", compatible "); phex2(m_compatible mode)
!! printstring(", flags "); phex(m_request flags); newline
!! show path(m_filename)
m_response flags = 0; m_byte count = 0; m_file token = 0; ! Provisionally
%if m_mode & change file = 0 %start
! Open for reading only
command = FC openR
%else
! Open for writing. Should we create a new one (unconditionally)?
%if m_request flags & create flag = 0 %then command = FC openMod %c
%else command = FC openW
%finish
! Translate the name from list form
determine filename(m, filename)
%if filename = "" %start
%if command = FC openR %start
!! printstring("Get root directory for ")
!! print symbol(m_fsys work); newline
%if m_fsys work = 'B' %or m_fsys work = 'C' %or m_fsys work = 'M' %start
%if root directory size # 0 %start
m_error code = -303; m_status = -3
m_textual response = "(F_H2) Root directory buffer busy"
%return
%finish
%for i = 0, 1, 15 %cycle
response = make packet request(m_fsys work, -1, '\',
to string(i + '0'),
root buffer(0), bytes)
%exit %if response # "" %and charno(response, 1) = '-'
%if bytes # 512 %start
m_error code = -303; m_status = -3
m_textual response = "(F_H2) Dud register response size"
%return
%finish
copy root
%repeat
!! printstring("Root directory size is ")
!! write(root directory size, 0); newline
file token == get new file token
%if file token == nil %start
m_error code = -303; m_status = -3
m_textual response = "(F_H2) No free file token"
root directory size = 0
%else
file token_Xno = -2
m_file token = addr(file token)
m_response flags = 0; m_byte count = root directory size
m_error code = 0; m_status = 0
%finish
%return
%else %if m_fsys work = 'V'
m_error code = -303; m_status = -3
m_textual response = "(F_H2) Root not available from VAX"
%return
%else
filename = "Local:"
-> open real file
%finish
%else
m_error code = -303; m_status = -3
m_textual response = "(F_H2) Invalid (write) operation on root directory"
%return
%finish
%finish
open real file:
! Get a file token for the file
file token == get new file token
!! printstring("New file token is at ")
!! phex(addr(file token)); newline
%if file token == nil %start
m_error code = -303; m_status = -3
m_textual response = "(F_H2) No free file token"
%return
%finish
! Open file file
response = send command(m_fsys work, -1, command, filename)
%if response # "" %and charno(response, 1) = '-' %start
! Open failed. Drop the token & return error
file token_Xno = 0
m_error code = H to I(response); m_status = -1
m_textual response = response
%return
%finish
file token_Xno = charno(response, 1) - '0'
file token_filestore = m_fsys work
file token_next block = 0
%if command = FC openW %start
m_byte count = 0
%else
%if length(response) < 5 %start
! Dud response
file token_Xno = 0
m_error code = -304; m_status = -1
m_textual response = "Dud (short) response from filestore"
%return
%finish
response = sub string(response, 3, length(response))
%unless response -> size . (",") . pad %start
! Dud response
file token_Xno = 0
m_error code = -304; m_status = -1
m_textual response = "Dud (missing fields) response from filestore"
%return
%finish
m_byte count = 512 * H to I(size) - H to I(pad)
%finish
m_file token = addr(file token)
m_response flags = 0
m_error code = 0; m_status = 0
%end
%routine do read data(%record(fs message fm)%name m)
%record(file token fm)%name t
%integer n
validate file token(m, -2); %return %if m_error code < 0
t == record(m_file token)
%if t_Xno > 0 %start
m_textual response = make read request(t_filestore, t_Xno,
t_next block, m_byte offset >> 9,
m_data buffer, m_byte count)
%if m_textual response # "" %and charno(m_textual response, 1) = '-' %start
m_error code = -1; m_status = -1
%else
m_error code = 0; m_status = 0
%finish
%else {%if t_Xno = -2
! Root directory buffer
!! printstring("Root directory read: offset "); write(m_byte offset, 0)
!! printstring(", bytes "); write(m_byte count, 0); newline
n = root directory size - m_byte offset
%if n <= 0 %start
!! printstring("End of root directory"); newline
m_byte count = 0
m_error code = 0; m_status = 0
%return
%finish
n = m_byte count %if n > m_byte count
copy block(n, root directory(m_byte offset), m_data buffer) %if n > 0
m_byte count = n
m_error code = 0; m_status = 0
!! printstring("Returning "); write(m_byte count, 0); newline
%finish
%end
%routine do write data(%record(fs message fm)%name m)
%record(file token fm)%name t
validate file token(m, 1); %return %if m_error code < 0
t == record(m_file token)
m_textual response = make write request(t_filestore, t_Xno,
m_byte offset >>9, m_byte count,
m_data buffer)
%if m_textual response # "" %and charno(m_textual response, 1) = '-' %start
m_error code = -1; m_status = -1
%else
m_error code = 0; m_status = 0
%finish
t_next block = -1
%end
%routine do close file(%record(fs message fm)%name m)
%record(file token fm)%name t
validate file token(m, -2); %return %if m_error code < 0
t == record(m_file token)
%if t_Xno > 0 %start
m_textual response = send command(t_filestore, t_Xno, FC close, "")
%if m_textual response # "" %and charno(m_textual response, 1) = '-' %start
m_error code = -1; m_status = -1
%else
m_error code = 0; m_status = 0
%finish
%else {%if t_Xno = -2
!! printstring("Close root directory"); newline
root directory size = 0
%finish
t = 0
%end
!%routine do truncate file(%record(fs message fm)%name m)
! m_error code = -1; m_status = -3
! m_textual response = "Subrequest (truncate file) not implemented yet"
!%end
!
!%routine do make accessible(%record(fs message fm)%name m)
! m_error code = -1; m_status = -3
! m_textual response = "Subrequest (make accessible) not implemented yet"
!%end
!
!%routine do obtain attributes(%record(fs message fm)%name m, %integer type)
! m_error code = -1; m_status = -3
! m_textual response = "Subrequest (obtain attributes) not implemented yet"
!%end
%routine do short form attributes(%record(fs message fm)%name m)
%string(255) filename
%integer pos
determine filename(m, filename)
!! printstring("Short form attributes: "); printstring(filename); newline
m_textual response = send command(m_fsys work, -1, FC ninfo, filename)
!! printstring("response: "); xprintstring(m_textual response); newline
%if m_textual response = "" %or charno(m_textual response, 1) = '-' %start
m_error code = -1; m_status = -1
%return
%finish
pos = 1
! Lose filename, then spaces...
pos = pos + 1 %while pos < length(m_textual response) %c
%and charno(m_textual response, pos) # ' '
pos = pos + 1 %while pos < length(m_textual response) %c
%and charno(m_textual response, pos) = ' '
m_textual data = sub string(m_textual response, pos, length(m_textual response))
m_status = 0; m_error code = 0
%end
!%routine do modify attributes(%record(fs message fm)%name m, %integer type)
! m_error code = -1; m_status = -3
! m_textual response = "Subrequest (modify attributes) not implemented yet"
!%end
%routine do create new directory(%record(fs message fm)%name m)
%string(255) filename
determine filename(m, filename)
m_textual response = send command(m_fsys work, -1, FC credir, filename)
%if m_textual response # "" %start
m_error code = -1; m_status = -1
%else
m_error code = 0; m_status = 0
%finish
%end
%routine do rename file(%record(fs message fm)%name m)
! We have to make sure here that we aren't being asked to rename
! from one filestore to another....
%string(255) from, to
%integer second filestore
determine filename(m, from)
determine second filename(m, to, second filestore)
%if m_fsys work # second filestore %start
m_error code = -1; m_status = -1
m_textual response = "-- Inter-filestore rename not allowed"
%return
%finish
m_textual response = send command(m_fsys work, -1, FC rename,
from . "," . to)
%if m_textual response # "" %start
m_error code = -1; m_status = -1
%else
m_error code = 0; m_status = 0
%finish
%end
%routine do permit file(%record(fs message fm)%name m)
%string(255) filename
determine filename(m, filename)
m_textual response = send command(m_fsys work, -1, FC permit,
filename . "," . m_textual data)
%if m_textual response # "" %start
m_error code = -1; m_status = -1
%else
m_error code = 0; m_status = 0
%finish
%end
%routine do copy file(%record(fs message fm)%name m)
! We have to make sure here that we aren't being asked to copy
! from one filestore to another (that should be done by our caller)....
%string(255) from, to
%integer second filestore
determine filename(m, from)
determine second filename(m, to, second filestore)
%if m_fsys work # second filestore %start
m_error code = -1; m_status = -1
m_textual response = "-- Inter-filestore copy not allowed"
%return
%finish
m_textual response = send command(m_fsys work, -1, FC copyfile,
from . "," . to)
%if m_textual response # "" %start
m_error code = -1; m_status = -1
%else
m_error code = 0; m_status = 0
%finish
%end
%routine do delete file(%record(fs message fm)%name m)
%string(255) filename
determine filename(m, filename)
m_textual response = send command(m_fsys work, -1, FC delete, filename)
%if m_textual response # "" %start
m_error code = -1; m_status = -1
%else
m_error code = 0; m_status = 0
%finish
%end
!%routine do generate unique name(%record(fs message fm)%name m)
! m_error code = -1; m_status = -3
! m_textual response = "Subrequest (unique name) not implemented yet"
!%end
!
!%routine do timestamp enquiry(%record(fs message fm)%name m)
! m_error code = -1; m_status = -3
! m_textual response = "Subrequest (timestamp enquiry) not implemented yet"
!%end
%routine do filestore logon(%record(fs message fm)%name m)
%record(path fm)%name p
p == m_filename
m_textual response = send command(m_request specific, -1, FC logon,
p_key . "," . m_textual data)
%if m_textual response # "" %and charno(m_textual response, 1) = '-' %start
m_error code = -1; m_status = -1
%else
m_error code = 0; m_status = 0
%finish
%end
%routine do filestore logoff(%record(fs message fm)%name m)
m_textual response = send command(m_request specific, -1, FC logoff, "")
break connection(m_request specific)
%if m_textual response # "" %and charno(m_textual response, 1) = '-' %start
m_error code = -1; m_status = -1
%else
m_error code = 0; m_status = 0
%finish
%end
%routine do filestore quote(%record(fs message fm)%name m)
%record(path fm)%name p
p == m_filename
m_textual response = send command(m_request specific, -1, FC quote, p_key)
%if m_textual response # "" %and charno(m_textual response, 1) = '-' %start
m_error code = -1; m_status = -1
%else
m_error code = 0; m_status = 0
%finish
%end
%routine do set pass(%record(fs message fm)%name m)
%string(255) param
%if m_request specific = 'B' %or m_request specific = 'C' %c
%or m_request specific = 'M' %start
! Old filestore: only new password required (P2 is username)
param = m_textual data
%else
! Must be new filestore: old password required in P2 as verifier
param = m_textual data . "," . m_textual data2
%finish
m_textual response = send command(m_request specific, -1, FC pass, param)
%if m_textual response # "" %and charno(m_textual response, 1) = '-' %start
m_error code = -1; m_status = -1
%else
m_error code = 0; m_status = 0
%finish
%end
! Main code of local file system process. Loop, reading the mailbox and
! calling a code-demultiplexing routine to interpret the subcodes as
! appropriate.
%owninteger which = 0
%ownrecord(semaphore fm) which sem = 0
%routine local filesystem process
%record(fs message fm)%name m
%ownrecord(semaphore fm) disaster = 0
%record(poa fm)%name P
%switch standard(-1 : last standard request)
%switch specific(-1 : last old request)
%integer i, L set, L clear
!%on 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 %start
! ! Last-chance disaster-trap
! P == POA
! printstring("X_H2: unexpected event "); write(P_event, 0)
! space; write(P_event sub, 0); space; phex(P_event extra)
! space; printstring(P_event message)
! printstring(" at or about PC "); phex(P_event PC)
! newline
! %for i = 0, 1, 15 %cycle
! phex(P_event r(i)); space
! newline %if i & 7 = 7
! %repeat
! semaphore wait(disaster)
!%finish
open input(2, ":N"); select input(2)
open output(2, ":T"); select output(2)
setup semaphore(disaster)
semaphore wait(which sem)
L set = 16_100 << which
which = which + 1
signal semaphore(which sem)
L clear = \ L set
%cycle
!! printstring("Waiting for message to "); phex(addr(request mailbox))
!! newline
m == receive message(request mailbox)
!L! lights set B(L set)
!! printstring("H2 filesystem request: code "); phex(m_request)
!! printstring(", reply box "); phex(addr(m_system header_reply))
!! printstring(", sema "); phex(addr(m_system header_reply_semaphore))
!! newline
%if m_request & filesystem mask = 0 %start
i = m_request & request mask
-> standard(i) %if 0 <= i <= last standard request
%else %if m_request & filesystem mask = old style request
i = m_request & request mask
-> specific(i) %if 0 <= i <= last old request
%finish
dud request:
m_error code= -1; m_status = -1
m_textual response = "Unknown request code"
-> send reply
standard(interpret filename request & request mask):
! We don't know how to do this yet, so we just kid on that there
! were no redirectors along the way...
m_error code = 0; m_status = 0; m_textual response = ""
m_components translated = 0; ! This, at least, is true
-> send reply
standard(open file request & request mask):
do open file(m)
-> send reply
standard(close file request & request mask):
do close file(m)
-> send reply
standard(read data request & request mask):
do read data(m)
-> send reply
standard(write data request & request mask):
do write data(m)
-> send reply
!standard(truncate file request & request mask):
! do truncate file(m)
! -> send reply
!
!standard(make accessible request & request mask):
! do make accessible(m)
! -> send reply
standard(create directory request & request mask):
do create new directory(m)
-> send reply
standard(remove file request & request mask):
do delete file(m)
-> send reply
standard(rename file request & request mask):
do rename file(m)
-> send reply
standard(textual file attributes request & request mask):
do short form attributes(m)
-> send reply
standard(textual permit file request & request mask):
do permit file(m)
-> send reply
specific(old logon request & request mask):
do filestore logon(m)
-> send reply
specific(old logoff request & request mask):
do filestore logoff(m)
-> send reply
specific(old quote request & request mask):
do filestore quote(m)
-> send reply
specific(old copy file request & request mask):
do copy file(m)
-> send reply
specific(old set pass request & request mask):
do set pass(m)
-> send reply
standard(*):
specific(*):
unimplemented request:
m_error code= -1; m_status = -1
m_textual response = "Unimplemented request code"
send reply:
!! printstring("Replying to "); phex(addr(m_system header_reply))
!! printstring(", sema "); phex(addr(m_system header_reply_semaphore))
!! printstring(", status "); write(m_status, 0)
!! printstring(", error code "); write(m_error code, 0)
!! printstring(", text """); printstring(m_textual response)
!! print symbol('"'); newline
m_followup mailbox == request mailbox
send message(m, m_system header_reply, nil)
!L! lights and B(L clear)
%repeat
%end
%begin
%record(process fm)%name p
%integer i
%label x
open input(3, ":T"); select input(3)
open output(3, ":T"); select output(3)
setup semaphore(request semaphore)
setup mailbox(request mailbox, request semaphore)
setup semaphore(file token semaphore)
signal semaphore(file token semaphore)
setup semaphore(which sem)
signal semaphore(which sem)
%for i = first filestore, 1, last filestore %cycle
setup semaphore(filestore(i)_semaphore)
signal semaphore(filestore(i)_semaphore)
%repeat
FS insert(H2 file system mailbox, addr(request mailbox))
!! printstring("Starting "); write(processes, 0)
!! printstring(" remote (H2) file system processes"); newline
p == create process(10240, addr(x), priority, nil) %for i = 1, 1, processes - 1
set priority(nil, priority)
{} printstring("F_H2: "); write(free store, 0)
{} printstring(" free"); newline
! Fall through to form one of the processes....
x: local filesystem process
! Never returns...
%end %of %program