! I/O module for local/remote file system, with redirection interpretation.
! This version constructed by merging local and remote client modules.

%externalstring(47) copyright %alias "GDMR_(C)_IO_F" = %c
   "Copyright (C) 1987 George D.M. Ross"

%option "-low-nonstandard-nocheck-nodiag-noline"

%constinteger redirect limit = 32

%constinteger separator = ':'
%constinteger device marker = ':'

%constinteger redirect character = 1
%constinteger interactive redirect character = '>'

%constinteger external textual equivalent = 1
%constinteger internal textual equivalent = 2

%externalinteger F external redirect off = 0
! Set to non-zero to inhibit external redirect processing

%externalinteger F old style handling = 0
! Set to non-zero to enable "Directory", etc

%externalinteger F no explicit device = 0
! Set to non-zero to inhibit explicit device-name stripping

%externalinteger F validate pathnames = 0
! Set to non-zero to inhibit pathname component checking

%externalinteger F enable dot dot = 0
! Set to non-zero to enable ".." in pathnames

%constinteger block shift = 9
%constinteger block size = 512
%constinteger buffer size = 512

%include "Moose:Mouse.Inc"
%include "GDMR_H:FSysAcc.Inc"
%include "GDMR_H:FSys.Inc"
%include "GDMR_H:FACMess.Inc"

%systemroutinespec phex(%integer i)
%externalstring(127)%fnspec itos(%integer i, j)

%constinteger directory flag = 16_40000000

%constinteger NUL = 0

%ownrecord(mailbox fm)%name request mailbox == nil
%externalpredicatespec FS lookup(%string(31) name, %integername value)

%conststring(31) local authority name = "FS_LOCAL_AUTHORITY_RECORD"

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

%recordformat path fm(%record(path fm)%name next, 
                      %integer version, %string(*)%name key,
                      %string(255) text)
%constinteger path size = 12;  ! Excluding string

!! %routine show path(%record(path fm)%name p)
!!    %while p ## nil %cycle
!!       print symbol('@');  phex(addr(p))
!!       printstring(" -> ");  phex(addr(p_next))
!!       printstring(", version ");  write(p_version, 0)
!!       printstring(", key ");  xprintstring(p_key)
!!       newline
!!       p == p_next
!!    %repeat
!! %end

%routine dispose path(%record(path fm)%name p)
   %record(path fm)%name n
      %while p ## nil %cycle
         !! printstring("Disposing (path) ");  phex(addr(p));  newline
         n == p_next
         dispose(p)
         p == n
      %repeat
%end

%predicate valid version(%record(path fm)%name p, %integername v)
   %integer i, ch, x
      %false %if length(p_key) < 2 %or charno(p_key, 1) # '-'
      x = 0
      %for i = 2, 1, length(p_key) %cycle
         ch = charno(p_key, i)
         %false %unless '0' <= ch <= '9'
         x = 10 * x - ch + '0'
      %repeat
      v = x
      %true
%end

%routine supply metacharacters(%integer start, finish)
   %bytename ch
      %while start < finish %cycle
         ch == byteinteger(start)
         %if ch = NUL %start
            ch = separator
         %else %if ch = 1
            ch = interactive redirect character
         %finish
         start = start + 1
      %repeat
%end

%predicate equal(%string(255) a, b)
   %integer i, aa, bb
      %false %unless length(a) = length(b)
      %true %if a = ""
      %for i = 1, 1, length(a) %cycle
         aa = charno(a, i);  bb = charno(b, i)
         aa = aa - 'a' + 'A' %if 'a' <= aa <= 'z'
         bb = bb - 'a' + 'A' %if 'a' <= bb <= 'z'
         %false %unless aa = bb
      %repeat
      %true
%end

%record(path fm)%map split path(%string(255) path, %integer separator,
                                %record(path fm)%name append)
   %record(path fm)%name head == nil, last, current
   %integer ch, n, first = 1
   %string(255) s = "", xx
      !! put string("Split path: """);  put string(path)
      !! put sym('"');  put sym(NL)
      %if path = "" %start
root:    head == record(heap get(path size + 2))
         head_text = ""
         head_key == head_text
         head_version = 0
         head_next == append
         %result == head
      %finish
      %if separator = NUL %or F no explicit device # 0 %start
         first = 1
      %else
         %if charno(path, 1) = device marker %start
            ! Device specified explicitly.  Junk it.
            first = 3
            %cycle
               -> root %if first > length(path)
               %exit %if charno(path, first) = device marker
               first = first + 1
            %repeat
            -> root %if first = length(path)
            first = first + 1
         %finish
      %finish
      %for n = first, 1, length(path) %cycle
         ch = charno(path, n)
         ch = ch & 127 %if F validate pathnames = 0
         %if ch = separator %start
            %if s = "" %start
               dispose path(head)
               %result == nil
            %finish
            ! End of component
            current == record(heap get(length(s) + path size + 1))
            !! printstring("Component ");  printstring(s)
            !! printstring(" at ");  phex(addr(current));  newline
            current_text = s
            current_key == current_text
            current_version = 0
            current_next == nil
            %if head == nil %start
               head == current
               last == current
            %else
               last_next == current
               last == current
            %finish
            s = ""
         %else
            %if separator = NUL %or F validate pathnames # 0 %c
                  %or ' ' <= ch <= '~' %start
               ! Allow "silly" characters only in redirections
               s = s . to string(ch) %if ch # ' '
            %else
               dispose path(head)
               %result == nil
            %finish
         %finish
      %repeat
      ! End of last component
      %if F old style handling # 0 %start
         !! printstring("Old-style handling for ")
         !! xprintstring(s);  newline
         %if equal(s, "DIRECTORY") %or equal(s, ".") %start
            s = ""
         %else %if s # "" %and charno(s, length(s)) = interactive redirect character
            length(s) = length(s) - 1
         %finish
      %finish
      current == record(heap get(length(s) + path size + 1))
      !! printstring("Component ");  printstring(s)
      !! printstring(" at ");  phex(addr(current));  newline
      current_text = s
      current_key == current_text
      current_version = 0
      current_next == append
      %if head == nil %start
         head == current
      %else
         last_next == current
         %if valid version(current, last_version) %start
            dispose(current)
            last_next == nil
         %finish
      %finish
      %result == head
%end


! File system selection & redirection

%ownrecord(mailbox fm)%name local mailbox == nil
%ownrecord(mailbox fm)%name special mailbox == nil
%ownrecord(mailbox fm)%name H2 mailbox == nil
%ownrecord(mailbox fm)%name default mailbox == nil

%record(mailbox fm)%map target mailbox(%record(fs message fm)%name m)
   %record(path fm)%name p
   %integer i
      %if default mailbox == nil %start
         local mailbox == record(i) %if FS lookup(local filesystem mailbox, i)
         H2 mailbox == record(i) %if FS lookup(H2 filesystem mailbox, i)
         !! printstring("Local mailbox at ");  phex(addr(local mailbox))
         !! printstring(", H2 mailbox at ");  phex(addr(H2 mailbox))
         !! newline
         %if local mailbox ## nil %start
            default mailbox == local mailbox
         %else %if H2 mailbox ## nil
            default mailbox == H2 mailbox
         %else
            %signal 3,,, "No filesystem available?"
         %finish
      %finish
      p == m_filename 
      !! printstring("Determine mailbox: ");  xprintstring(p_key)
      !! newline
      %result == default mailbox %if length(p_key) < 2
      %if charno(p_key, 1) = interactive redirect character %or %c
            charno(p_key, 1) = redirect character %start
         %if charno(p_key, 2) = 0 %or charno(p_key, 2) = '@' %start
            ! Redirect to local file system.  We'll have to remove the
            ! redirector, as F_Local won't understand it
            m_filename == p_next
            dispose(p)
            !! printstring("Path is now:");  newline
            !! show path(m_filename)
            %result == local mailbox
         %else %if charno(p_key, 2) = '$'
            %if special mailbox == nil %start
               special mailbox == record(i) %c
                  %if FS lookup(special filesystem mailbox, i)
            %finish
            %if special mailbox == nil %start
               printstring("Special file system absent?")
               newline
            %finish
            ! Remove the redirector, as above
            m_filename == p_next
            dispose(p)
            %result == special mailbox
         %else
            %result == H2 mailbox
         %finish
      %else
         ! No redirect, use default
         %result == default mailbox
      %finish
%end

%routine transact(%record(fs message fm)%name m,
                  %record(mailbox fm)%name specified target)
   %record(mailbox fm) our reply mailbox = 0
   %record(semaphore fm) our reply semaphore = 0
   %record(path fm)%name p
   %record(mailbox fm)%name target
   %record(fs message fm)%name r
   %ownrecord(access fm) default access = 0
   %owninteger default initialised = 0
   %integer lives = redirect limit, i
      setup semaphore(our reply semaphore)
      setup mailbox(our reply mailbox, our reply semaphore)
      %if m_access == nil %start
         %if default initialised = 0 %start
            default access_local == record(i) %c
               %if FS lookup(local authority name, i)
            default initialised = 1
         %finish
         m_access == default access
      %finish
      %if specified target == nil %start
         ! Send it
         %cycle
            lives = lives - 1
            %if lives = 0 %start
               m_error text = "Too many redirections"
               m_error code = -1;  m_status = -1
               %return
            %finish
            !! printstring("Transacting with:");  newline
            !! show path(m_filename)
            target == target mailbox(m)
            %if target == nil %start
               ! Specified file system is missing
               m_error text = "Specified file system not present"
               m_error code = -1;  m_status = -1
               %return
            %finish
            send message(m, target, our reply mailbox)
            r == receive message(our reply mailbox)
            %signal 3,,, "Unexpected filesystem reply" %if r ## m
            ! Remove those path components which were successfully translated.
            %while m_components translated > 0 %cycle
               p == m_filename;  m_filename == p_next
               !! printstring("Removing ");  printstring(p_key)
               !! printstring(" leaving ");  phex(addr(m_filename));  newline
               dispose(p)
               m_components translated = m_components translated - 1
            %repeat
            %exit %if m_status <= 0
            ! +ve status, so it was an external textual equivalent.
            ! Split it apart and prepend it to the already-existing
            ! path (the part we didn't deal with last time).
            ! First we have to remove the path component which translated
            ! to the redirection, as the file system hasn't counted it as
            ! successfully translated.
            p == m_filename;  m_filename == p_next
            dispose(p)
            !! printstring("Redirector: ");  xprintstring(m_error text)
            !! newline
            %if F external redirect off # 0 %and %c
                  m_status = external textual equivalent %start
               ! We're only dealing with internal equivalents, so if it
               ! wasn't one of those we reassemble the full filename and
               ! return it to our caller
               %while m_filename ## nil %cycle
                  p == m_filename;  m_filename == p_next
                  m_error text = m_error text . to string(separator) . p_key
                  dispose(p)
               %repeat
               %if m_error text # "" %start
                  %for i = 1, 1, length(m_error text) %cycle
                     charno(m_error text, i) = separator %c
                        %if charno(m_error text, i) = NUL
                  %repeat
               %finish
               !! printstring("External redirect -> ")
               !! printstring(m_error text);  newline
               %return
            %finish
            m_filename == split path(m_error text, NUL, m_filename)
            ! And round again with the new path.....
         %repeat
      %else
         !! printstring("Sending to (specified) ");  phex(addr(specified target))
         !! printstring(", replies to ");  phex(addr(our reply mailbox))
         !! newline
         send message(m, specified target, our reply mailbox)
         r == receive message(our reply mailbox)
         %signal 3,,, "Unexpected filesystem reply" %if r ## m
      %finish
%end


%routine convert metacharacters(%string(*)%name s)
   %bytename ch
   %integer i
      %return %if s = ""
      %for i = 1, 1, length(s) %cycle
         ch == charno(s, i)
         ch = ':' %if ch = 0
      %repeat
%end


! External procedural interface.  This consists of a collection of %functions
! which return status values, and a collection of %routines which merely call
! the corresponding %functions and %signal if the status is non-zero.

%externalintegerfn F open file(%record(*)%name access,
                               %string(255) filename,
                               %integer mode, compatible,
                               %integer partition, request flags,
                               %integername token, size, flags,
                               %string(*)%name textual response)
   %record(path fm)%name p
   %record(fs message fm) m = 0
      p == split path(filename, separator, nil)
      textual response = "Bad filename" %and %result = -1 %if p == nil
      setup message(m, size of(m))
      m_access == access
      m_error text == textual response
      m_tag = 0
      m_code = data access code
      m_subcode = open file subcode
      m_access mode = mode
      m_compatible mode = compatible
      m_filename == p
      m_request flags = request flags
      m_partition = partition
      transact(m, nil)
      dispose path(m_filename)
      %if m_status # 0 %start
         convert metacharacters(textual response)
         %result = m_status
      %finish
      token = m_file token
      size = m_bytes
      flags = m_response flags
      %result = 0
%end

%externalroutine L open file(%record(*)%name access,
                             %string(255) filename,
                             %integer mode, compatible,
                             %integer partition, request flags,
                             %integername token, size, flags)
   %string(255) text = ""
   %integer status
      status = F open file(access, filename, mode, compatible, partition,
                           request flags, token, size, flags, text)
      %signal 3, 1, status, text %if status # 0
%end


%externalintegerfn F close file(%record(*)%name access,
                                %integer token, flags,
                                %string(*)%name textual response)
   %record(fs message fm) m = 0
      setup message(m, size of(m))
      m_access == access
      m_error text == textual response
      m_tag = 0
      m_code = data access code
      m_subcode = close file subcode
      m_file token = token
      m_request flags = flags
      m_filename == nil
      transact(m, record(integer(token)))
      convert metacharacters(textual response) %if m_status # 0
      %result = m_status
%end

%externalroutine L close file(%record(*)%name access,
                              %integer token, flags)
   %string(255) text = ""
   %integer status
      status = F close file(access, token, flags, text)
      %signal 3, 1, status, text %if status # 0
%end


%externalintegerfn F truncate file(%record(*)%name access,
                                   %integer token, bytes,
                                   %string(*)%name textual response)
   %record(fs message fm) m = 0
      setup message(m, size of(m))
      m_access == access
      m_error text == textual response
      m_tag = 0
      m_code = data access code
      m_subcode = truncate file subcode
      m_file token = token
      m_bytes = bytes
      m_filename == nil
      transact(m, record(integer(token)))
      convert metacharacters(textual response) %if m_status # 0
      %result = m_status
%end

%externalroutine L truncate file(%record(*)%name access,
                                 %integer token, bytes)
   %string(255) text = ""
   %integer status
      status = F truncate file(access, token, bytes, text)
      %signal 3, 1, status, text %if status # 0
%end


%externalintegerfn F read block(%record(*)%name access,
                                %integer token, block,
                                %integername bytes,
                                %record(*)%name buffer,
                                %string(*)%name textual response)
   %record(fs message fm) m = 0
      setup message(m, size of(m))
      m_access == access
      m_error text == textual response
      m_tag = 0
      m_code = data access code
      m_subcode = read data subcode
      m_file token = token
      m_block = block
      m_buffer == buffer
      m_bytes = 512
      m_filename == nil
      transact(m, record(integer(token)))
      %if m_status # 0 %start
         convert metacharacters(textual response)
         %result = m_status
      %finish
      bytes = m_bytes
      %result = 0
%end

%externalroutine L read block(%record(*)%name access,
                              %integer token, block,
                              %integername bytes,
                              %record(*)%name buffer)
   %string(255) text = ""
   %integer status
      status = F read block(access, token, block, bytes, buffer, text)
      %signal 3, 1, status, text %if status # 0
%end

%routine L read short block(%record(*)%name access,
                            %integer token, block,
                            %integer buffer size,
                            %integername bytes,
                            %record(*)%name buffer)
   %recordformat x fm(%bytearray x(0 : 511))
   %record(x fm) x
      L read block(access, token, block, bytes, x)
      %signal 3, 9,, "Buffer overrun" %if bytes > buffer size
      A0 = addr(x)
      A1 = addr(buffer)
      D0 = buffer size - 1
   L: *move.b (A0)+, (A1)+
      *dbra D0, L
%end


%externalintegerfn F write block(%record(*)%name access,
                                 %integer token, block, bytes,
                                 %record(*)%name buffer,
                                 %string(*)%name textual response)
   %record(fs message fm) m = 0
      setup message(m, size of(m))
      m_access == access
      m_error text == textual response
      m_tag = 0
      m_code = data access code
      m_subcode = write data subcode
      m_file token = token
      m_block = block
      m_buffer == buffer
      m_bytes = bytes
      m_filename == nil
      transact(m, record(integer(token)))
      convert metacharacters(textual response) %if m_status # 0
      %result = m_status
%end

%externalroutine L write block(%record(*)%name access,
                               %integer token, block, bytes,
                               %record(*)%name buffer)
   %string(255) text = ""
   %integer status
      status = F write block(access, token, block, bytes, buffer, text)
      %signal 3, 1, status, text %if status # 0
%end


! Directory manipulation stuff

%externalintegerfn F create directory P(%record(*)%name access,
                                        %string(255) filename,
                                        %integer partition, flags,
                                        %string(*)%name textual response)
   %record(path fm)%name p
   %record(fs message fm) m = 0
      p == split path(filename, separator, nil)
      textual response = "Bad filename" %and %result = -1 %if p == nil
      setup message(m, size of(m))
      m_access == access
      m_error text == textual response
      m_tag = 0
      m_code = directory access code
      m_subcode = create new directory subcode
      m_filename == p
      m_partition = partition
      m_request flags = flags
      transact(m, nil)
      dispose path(m_filename)
      convert metacharacters(textual response) %if m_status # 0
      %result = m_status
%end

%externalroutine L create directory P(%record(*)%name access,
                                      %string(255) filename,
                                      %integer partition)
   %string(255) text = ""
   %integer status
      status = F create directory P(access, filename, partition, 0, text)
      %signal 3, 1, status, text %if status # 0
%end

%externalroutine L create directory(%record(*)%name access,
                                    %string(255) filename)
   L create directory P(access, filename, -1)
%end


%externalintegerfn F remove entry(%record(*)%name access,
                                  %string(255) filename,
                                  %string(*)%name textual response)
   %record(path fm)%name p
   %record(fs message fm) m = 0
      p == split path(filename, separator, nil)
      textual response = "Bad filename" %and %result = -1 %if p == nil
      setup message(m, size of(m))
      m_access == access
      m_error text == textual response
      m_tag = 0
      m_code = directory access code
      m_subcode = remove directory entry subcode
      m_filename == p
      transact(m, nil)
      dispose path(m_filename)
      convert metacharacters(textual response) %if m_status # 0
      %result = m_status
%end

%externalroutine L remove entry(%record(*)%name access,
                                %string(255) filename)
   %string(255) text = ""
   %integer status
      status = F remove entry(access, filename, text)
      %signal 3, 1, status, text %if status # 0
%end


%externalintegerfn F rename file(%record(*)%name access,
                                 %string(255) from, to,
                                 %string(*)%name textual response)
   %record(path fm)%name pf, pt
   %record(fs message fm) m = 0
   %record(mailbox fm)%name from box, to box
      !! printstring("Rename: ");  printstring(from)
      !! space;  printstring(to);  newline
      pf == split path(from, separator, nil)
      textual response = "Bad (source) filename" %and %result = -1 %if pf == nil
      pt == split path(to, separator, nil)
      %if pt == nil %start
         dispose path(pf)
         textual response = "Bad (target) filename"
         %result = -1
      %finish
      setup message(m, size of(m))
      m_access == access
      m_error text == textual response
      m_tag = 0
      m_code = miscellaneous file operation code
      m_subcode = translate redirections subcode
      m_request flags = 0
      m_filename == pf
      transact(m, nil)
      %if m_status # 0 %start
         dispose path(m_filename)
         dispose path(pt)
         convert metacharacters(textual response)
         %result = m_status
      %finish
      pf == m_filename
      m_filename == pt
      m_request flags = 1
      transact(m, nil)
      %if m_status # 0 %start
         dispose path(m_filename)
         dispose path(pf)
         convert metacharacters(textual response)
         %result = m_status
      %finish
      to box == target mailbox(m)
      m_subcode = rename file subcode
      m_filename2 == m_filename
      m_filename == pf
      from box == target mailbox(m)
      %if from box ## to box %start
         dispose path(m_filename)
         dispose path(m_filename2)
         textual response = "Inter-filesystem renames not allowed"
         %result = -1
      %finish
      transact(m, from box)
      dispose path(m_filename)
      dispose path(m_filename2)
      convert metacharacters(textual response) %if m_status # 0
      %result = m_status
%end

%externalroutine L rename file(%record(*)%name access,
                               %string(255) from, to)
   %string(255) text = ""
   %integer status
      status = F rename file(access, from, to, text)
      %signal 3, 1, status, text %if status # 0
%end


%recordformat copy token fm(%record(*)%name access,
                            %record(mailbox fm)%name f mailbox,
                            %integer f token, f size, f flags,
                            %record(mailbox fm)%name t mailbox,
                            %integer t token)


%externalintegerfn F initiate copy(%record(*)%name access,
                                   %string(255) from, to,
                                   %integername copy token,
                                   %string(*)%name textual response)
   %record(copy token fm)%name c
   %record(path fm)%name pf, pt
   %record(fs message fm) m = 0
   %record(mailbox fm)%name from box, to box
   %integer status
      !! printstring("Copy: ");  printstring(from)
      !! space;  printstring(to);  newline
      pf == split path(from, separator, nil)
      textual response = "Bad (source) filename" %and %result = -1 %if pf == nil
      pt == split path(to, separator, nil)
      %if pt == nil %start
         dispose path(pf)
         textual response = "Bad (target) filename"
         %result = -1
      %finish
      setup message(m, size of(m))
      m_access == access
      m_error text == textual response
      m_tag = 0
      m_code = miscellaneous file operation code
      m_subcode = translate redirections subcode
      m_request flags = 0
      m_filename == pf
      transact(m, nil)
      %if m_status # 0 %start
         dispose path(m_filename)
         dispose path(pt)
         convert metacharacters(textual response)
         %result = m_status
      %finish
      pf == m_filename
      m_filename == pt
      m_request flags = 1
      transact(m, nil)
      %if m_status # 0 %start
         dispose path(m_filename)
         dispose path(pf)
         convert metacharacters(textual response)
         %result = m_status
      %finish
      pt == m_filename
      to box == target mailbox(m)
      m_filename == pf
      from box == target mailbox(m)
      !! printstring("From box at ");  phex(addr(from box))
      !! printstring(", to box at ");  phex(addr(to box));  newline
      %if from box == H2 mailbox %and from box == to box %c
            %and pf_key = pt_key %start
         ! Remote copy if both are the same (remote) filestore
         !! printstring("Remote copy at same filestore");  newline
         copy token = 0
         m_subcode = copy file subcode
         m_filename2 == pt
         transact(m, from box)
         dispose path(m_filename)
         dispose path(m_filename2)
         convert metacharacters(textual response) %if m_status # 0
         %result = m_status
      %finish
      ! Otherwise we'll have to do the copy ourselves
      !! printstring("Different or local file systems");  newline
      c == new(c);  c_access == access
      c_f mailbox == from box;  c_t mailbox == to box
      ! First, open the source file
      m_code = data access code
      m_subcode = open file subcode
      m_filename == pf
      m_access mode = read file mode
      m_compatible mode = read file mode
      m_request flags = 0
      m_partition = -1
      transact(m, from box)
      dispose path(m_filename)
      %if m_status # 0 %start
         !! printstring("Open source failed: ");  write(m_status, 0);  newline
         dispose(c)
         dispose path(pt)
         convert metacharacters(textual response)
         %result = m_status
      %finish
      c_f token = m_file token
      c_f size = m_bytes
      c_f flags= m_response flags
      !! printstring("Source opened as ");  phex(c_f token)
      !! printstring(", size ");  write(c_f size, 0);  newline
      ! Source was OK, open the destination file
      m_filename == pt
      m_access mode = modify file mode
      m_compatible mode = 0
      m_request flags = create flag
      transact(m, to box)
      dispose path(m_filename)
      %if m_status # 0 %start
         ! Error, preserve status and close the source file
         convert metacharacters(textual response)
         status = m_status
         !! printstring("Open destination failed: ")
         !! write(status, 0);  newline
         m_subcode = close file subcode
         m_request flags = 0
         m_access == nil
         m_file token = c_f token
         transact(m, from box)
         !! printstring("Close source status: ")
         !! write(m_status, 0);  newline
         dispose(c)
         %result = status
      %finish
      c_t token = m_file token
      !! printstring("Destination opened as ");  phex(c_t token);  newline
      copy token = addr(c)
      !! printstring("Copy token is ");  phex(copy token);  newline
      %result = 0
%end

%externalintegerfn F complete copy(%integer copy token,
                                   %string(*)%name textual response)
   %recordformat block fm(%bytearray x(0 : 511))
   %record(block fm) buffer
   %record(copy token fm)%name c
   %record(fs message fm) m = 0
   %integer block = 0
      !! printstring("Complete copy, token ");  phex(copy token);  newline
      %result = -1 %if copy token <= 0
      c == record(copy token)
      setup message(m, size of(m))
      m_access == c_access
      m_tag = 0
      m_error text == textual response
      m_code = data access code
      m_filename == nil
      ! Copy block by block, while there's something to do
      %while c_f size > 0 %cycle
         !! printstring("Reading block ");  write(block, 0);  newline
         m_subcode = read data subcode
         m_file token = c_f token
         m_block = block
         m_buffer == buffer
         m_bytes = 512
         transact(m, c_f mailbox)
         %if m_status # 0 %start
            printstring("Copy: read status ");  write(m_status, 0)
            newline
            %exit
         %finish
         !! printstring("Writing block ");  write(block, 0);  newline
         m_subcode = write data subcode
         m_file token = c_t token
         transact(m, c_t mailbox)
         %if m_status # 0 %start
            printstring("Copy: write status ");  write(m_status, 0)
            newline
            %exit
         %finish
         block = block + 1
         c_f size = c_f size - 512;  ! Even for the short block
      %repeat
      ! Now close the source and destination files
      m_subcode = close file subcode
      m_file token = c_f token
      m_request flags = 0
      transact(m, c_f mailbox)
      %if m_status # 0 %start
         printstring("Copy: close source status ");  write(m_status, 0)
         newline
      %finish
      m_file token = c_t token
      m_request flags = 1;  ! Auto-truncate
      transact(m, c_t mailbox)
      %if m_status # 0 %start
         printstring("Copy: close destination status ");  write(m_status, 0)
         newline
      %finish
      dispose(c)
      %result = 0
%end

%externalintegerfn F copy file(%record(*)%name access,
                               %string(255) from, to,
                               %string(*)%name textual response)
   %integer status, copy token
      status = F initiate copy(access, from, to, copy token, textual response)
      status = F complete copy(copy token, textual response) %c
         %if status = 0 %and copy token # 0
      %result = status
%end

%externalroutine L copy file(%record(*)%name access,
                             %string(255) from, to)
   %string(255) text = ""
   %integer status
      status = F copy file(access, from, to, text)
      %signal 3, 1, status, text %if status # 0
%end


%externalintegerfn F delete file(%record(*)%name access,
                                 %string(255) filename,
                                 %string(*)%name textual response)
   %record(path fm)%name p
   %record(fs message fm) m = 0
      p == split path(filename, separator, nil)
      textual response = "Bad filename" %and %result = -1 %if p == nil
      setup message(m, size of(m))
      m_access == access
      m_error text == textual response
      m_tag = 0
      m_code = miscellaneous file operation code
      m_subcode = delete file subcode
      m_filename == p
      transact(m, nil)
      dispose path(m_filename)
      convert metacharacters(textual response) %if m_status # 0
      %result = m_status
%end

%externalroutine L delete file(%record(*)%name access,
                               %string(255) filename)
   %string(255) text = ""
   %integer status
      status = F delete file(access, filename, text)
      %signal 3, 1, status, text %if status # 0
%end


%externalintegerfn F insert textual translation(%record(*)%name access,
                                                %string(255) filename,
                                                %string(255) translation,
                                                %integer type,
                                                %string(*)%name textual response)
   %record(path fm)%name p
   %record(fs message fm) m = 0
      p == split path(filename, separator, nil)
      textual response = "Bad filename" %and %result = -1 %if p == nil
      setup message(m, size of(m))
      m_access == access
      m_error text == textual response
      m_tag = 0
      m_code = directory access code
      %if type = 0 %then m_subcode = insert local translation subcode %c
                   %else m_subcode = insert external translation subcode
      m_filename == p
      m_translation string == translation
      transact(m, nil)
      dispose path(m_filename)
      convert metacharacters(textual response) %if m_status # 0
      %result = m_status
%end

%externalroutine L insert textual translation(%record(*)%name access,
                                              %string(255) filename,
                                              %string(255) translation,
                                              %integer type)
   %string(255) text = ""
   %integer status
      status = F insert textual translation(access, filename, translation,
                                            type, text)
      %signal 3, 1, status, text %if status # 0
%end


%externalintegerfn F get header(%record(*)%name access,
                                %string(255) filename,
                                %record(*)%name header,
                                %string(*)%name textual response)
   %record(path fm)%name p
   %record(fs message fm) m = 0
      p == split path(filename, separator, nil)
      textual response = "Bad filename" %and %result = -1 %if p == nil
      setup message(m, size of(m))
      m_access == access
      m_error text == textual response
      m_tag = 0
      m_code = file attributes access code
      m_subcode = file header subcode
      m_filename == p
      m_buffer == header
      transact(m, nil)
      dispose path(m_filename)
      convert metacharacters(textual response) %if m_status # 0
      %result = m_status
%end

%externalroutine L get header(%record(*)%name access, %string(255) filename,
                              %record(*)%name header)
   %string(255) text = ""
   %integer status
      status = F get header(access, filename, header, text)
      %signal 3, 1, status, text %if status # 0
%end


%externalintegerfn F short form attributes(%record(*)%name access,
                                           %string(255) filename,
                                           %string(*)%name information,
                                           %string(*)%name textual response)
   %record(path fm)%name p
   %record(fs message fm) m = 0
      p == split path(filename, separator, nil)
      textual response = "Bad filename" %and %result = -1 %if p == nil
      setup message(m, size of(m))
      m_access == access
      m_error text == textual response
      m_tag = 0
      m_code = file attributes access code
      m_subcode = short form attributes subcode
      m_filename == p
      m_textual info == information
      transact(m, nil)
      dispose path(m_filename)
      convert metacharacters(textual response) %if m_status # 0
      %result = m_status
%end

%externalroutine L short form attributes(%record(*)%name access,
                                         %string(255) filename,
                                         %string(*)%name information)
   %string(255) text = ""
   %integer status
      status = F short form attributes(access, filename, information, text)
      %signal 3, 1, status, text %if status # 0
%end

%externalintegerfn F obtain attributes(%record(*)%name access,
                                       %string(255) filename,
                                       %record(*)%name attributes,
                                       %string(*)%name textual response)
   %record(path fm)%name p
   %record(fs message fm) m = 0
      p == split path(filename, separator, nil)
      textual response = "Bad filename" %and %result = -1 %if p == nil
      setup message(m, size of(m))
      m_access == access
      m_error text == textual response
      m_tag = 0
      m_code = file attributes access code
      m_subcode = obtain attributes subcode
      m_filename == p
      m_attributes == attributes
      transact(m, nil)
      dispose path(m_filename)
      convert metacharacters(textual response) %if m_status # 0
      %result = m_status
%end

%externalroutine L obtain attributes(%record(*)%name access,
                                     %string(255) filename,
                                     %record(*)%name attributes)
   %string(255) text = ""
   %integer status
      status = F obtain attributes(access, filename, attributes, text)
      %signal 3, 1, status, text %if status # 0
%end

%externalintegerfn F modify attributes(%record(*)%name access,
                                       %string(255) filename,
                                       %record(*)%name attributes,
                                       %string(*)%name textual response)
   %record(path fm)%name p
   %record(fs message fm) m = 0
      p == split path(filename, separator, nil)
      textual response = "Bad filename" %and %result = -1 %if p == nil
      setup message(m, size of(m))
      m_access == access
      m_error text == textual response
      m_tag = 0
      m_code = file attributes access code
      m_subcode = modify attributes subcode
      m_filename == p
      m_attributes == attributes
      transact(m, nil)
      dispose path(m_filename)
      convert metacharacters(textual response) %if m_status # 0
      %result = m_status
%end

%externalroutine L modify attributes(%record(*)%name access,
                                     %string(255) filename,
                                     %record(*)%name attributes)
   %string(255) text = ""
   %integer status
      status = F modify attributes(access, filename, attributes, text)
      %signal 3, 1, status, text %if status # 0
%end

%externalintegerfn F enquire nth directory entry(%record(*)%name access,
                                                 %string(255) filename,
                                                 %integer which,
                                                 %string(*)%name information,
                                                 %string(*)%name textual response)
   %record(path fm)%name p
   %record(fs message fm) m = 0
      p == split path(filename, separator, nil)
      textual response = "Bad filename" %and %result = -1 %if p == nil
      setup message(m, size of(m))
      m_access == access
      m_error text == textual response
      m_tag = 0
      m_code = directory access code
      m_subcode = enquire nth directory entry subcode
      m_filename == p
      m_block = which
      m_textual info == information
      transact(m, nil)
      dispose path(m_filename)
      convert metacharacters(textual response) %if m_status # 0
      %result = m_status
%end

! No %routine form for the above -- it's only in for the benefit of the
! H2 protocol interpreter.

%externalintegerfn F translate path(%record(*)%name access,
                                    %string(255) filename,
                                    %integername translation,
                                    %string(*)%name textual response)
   %record(path fm)%name p
   %record(fs message fm) m = 0
      !! printstring("F translate path: ");  printstring(filename);  newline
      p == split path(filename, separator, nil)
      textual response = "Bad filename" %and %result = -1 %if p == nil
      setup message(m, size of(m))
      m_access == access
      m_error text == textual response
      m_tag = 0
      m_code = directory access code
      m_subcode = translate path subcode
      m_filename == p
      !! printstring("About to transact");  newline
      transact(m, nil)
      !! printstring("Done, disposing");  newline
      dispose path(m_filename)
      translation = m_file token
      !! printstring("Resulting translation is ");  phex(translation);  newline
      convert metacharacters(textual response) %if m_status # 0
      %result = m_status
%end

%externalroutine L translate path(%record(*)%name access,
                                  %string(255) filename,
                                  %integername translation)
   %string(255) text = ""
   %integer status
      status = F translate path(access, filename, translation, text)
      %signal 3, 1, status, text %if status # 0
%end


! Special I/O module for H2 file system

%externalroutine X logon(%integer filestore, %string(255) user, pass)
   %record(path fm) p user
   %record(fs message fm) m
   %record(fs message fm)%name x
   %record(semaphore fm) s
   %record(mailbox fm) r
   %string(255) text = ""
      setup semaphore(s)
      setup mailbox(r, s)
      setup message(m, size of(m))
      p user_text = user
      p user_key == p user_text
      m_access == nil
      m_error text == text
      m_tag = 0
      m_code = 128
      m_subcode = 0
      m_filename == p user
      m_translation string == pass
      m_partition = filestore
      transact(m, H2 mailbox)
      %signal 3, 8, 0, text %if m_status # 0
%end

%externalroutine X logoff(%integer filestore)
   %record(fs message fm) m
   %record(fs message fm)%name x
   %record(semaphore fm) s
   %record(mailbox fm) r
   %string(255) text = ""
      setup semaphore(s)
      setup mailbox(r, s)
      setup message(m, size of(m))
      m_access == nil
      m_error text == text
      m_tag = 0
      m_code = 128
      m_subcode = 1
      m_partition = filestore
      transact(m, H2 mailbox)
      %signal 3, 8, 0, text %if m_status # 0
%end


! SCB interface.  File access token is held in SCB_A, flags in SCB_B.

%externalrecord(scb fm)%map scb open %alias "l_open" %c
                                     (%integer mode, %string(255) filename)
   %record(scb fm)%name scb
   %integer x

   %routine refresh(%record(scb fm)%name scb)
      ! Beware RWT & connect file -- we may have had our buffer
      ! pointers fiddled with.
      %integer block, bytes, offset, blocks, i, b, expecting
         %signal 9,,, "End of file" %if scb_p >= scb_fl
         %signal 3, 9,, "Corrupt buffer (misaligned)" %c
            %unless (scb_fs - scb_bs) & (block size - 1) = 0
         blocks = (scb_bl - scb_bs) >> block shift - 1 {-1 for convenience}
         offset = scb_p - scb_fs;  block = offset >> block shift
         b = scb_bs
         %for i = 0, 1, blocks %cycle
            L read block(nil, scb_a, block + i, bytes, record(b))
            b = b + block size
         %repeat
         expecting = (scb_bl - scb_bs) & (block size - 1)
         %if expecting # 0 %start
            ! Read the remaining short block
            L read short block(nil, scb_a, block + blocks + 1, expecting,
                               bytes, record(b))
         %finish
         scb_fl = scb_bs - block << block shift + scb_fl - scb_fs
         scb_fs = scb_bs - block << block shift
         scb_p = scb_fs + offset
         scb_l = scb_bs + blocks << block shift + bytes
         supply metacharacters(scb_bs, scb_bl) %if scb_b & directory flag # 0
   %end

   %routine flush(%record(scb fm)%name scb, %integer sym)
      %integer block, bytes
         %signal 3, 9,, "Corrupt buffer (misaligned)" %c
            %unless (scb_fs - scb_bs) & (block size - 1) = 0
         %signal 3, 9,, "Corrupt buffer (size)" %c
            %unless scb_bl = scb_bs + buffer size
         scb_fl = scb_p %if scb_fl < scb_p;  ! Extended file
         block = (scb_bs - scb_fs) >> block shift
         bytes = scb_fl - scb_bs;  bytes = block size %if bytes > block size
         L write block(nil, scb_a, block, bytes, record(scb_bs))
         %if bytes = block size %start
            ! Written the whole block
            scb_fs = scb_fs - block size
            scb_fl = scb_fl - block size
            scb_p = scb_bs
         %finish
         ! Else only a part block, so don't move the window            
         %if sym >= 0 %start
            byteinteger(scb_p) = sym
            scb_p = scb_p + 1
         %finish
   %end

   %routine access file(%string(*)%name file,
                        %record(scb fm)%name scb,
                        %integer mode)
      %integer access mode, compatible mode, flags
         %if mode = input mode %start
            access mode = read access
            compatible mode = read access
            flags = 0
         %else
            access mode = read access ! modify access
            compatible mode = 0
            flags = create flag
         %finish
         L open file(nil, file, access mode, compatible mode, -1, flags,
                     scb_a, scb_fl, scb_b)
   %end

   %routine close(%record(scb fm)%name scb, %integer mode)
      flush(scb, -1) %if scb_mode # input mode
      L close file(nil, scb_a, auto truncate flag)
      heap put(scb_bs)
   %end

   %routine set in(%record(scb fm)%name scb, %integer pos)
      %signal 2,,, "Seeking off end of file" %unless 0 <= pos <= scb_fl - scb_fs
      scb_p = scb_fs + pos
      scb_l = scb_p %unless scb_bs <= scb_p <= scb_l
   %end

   %routine set out(%record(scb fm)%name scb, %integer pos)
      flush(scb, -1) %unless scb_p = scb_bs
      %signal 2,,, "Seeking off end of file" %unless 0 <= pos <= scb_fl - scb_fs
      scb_p = scb_fs + pos
      refresh(scb)
      scb_p = scb_fs + pos
      !? scb_l = scb_bl
      scb_l = scb_bl {AJS}
   %end

   %routine service(%record(scb fm)%name scb, %integer op, param)
      %switch do(ser closin : ser flush)
         %signal 3, 4, op, "Dud service code" %c
            %unless ser closin <= op <= ser flush
         -> do(op)

do(ser closin):   close(scb, 0);       %return
do(ser closout):  close(scb, 0);       %return
do(ser setin):    set in(scb, param);  %return
do(ser setout):   set out(scb, param); %return
do(ser prompt):                        %return
do(ser dropout):  close(scb, 1);       %return
do(ser refresh):  refresh(scb);        %return
do(ser flush):    flush(scb, param);   %return

   %end

      !! printstring("SCB open ");  printstring(filename)
      !! printstring(", mode ");  write(mode, 0);  newline
      scb == new scb(filename)
      scb_mode = mode
      scb_gla = A4
      *lea service, A0;  *move.l A0, x
      scb_serPC = x
      %if mode = input mode %start
         *lea refresh, A0;  *move.l A0, x
         scb_fastPC = x
         access file(filename, scb, mode)
         scb_bs = heap get(buffer size)
         scb_bl = scb_bs + buffer size
         scb_fs = scb_bs
         scb_fl = scb_bs + scb_fl
         scb_p = scb_bs
         scb_l = scb_bs
      %else
         *lea flush, A0;  *move.l A0, x
         scb_fastPC = x
         access file(filename, scb, mode)
         scb_bs = heap get(buffer size)
         scb_bl = scb_bs + buffer size
         scb_fs = scb_bs
         scb_fl = scb_bs
         scb_p = scb_bs
         scb_l = scb_bl
      %finish
      %result == scb
%end

%end %of %file
