! Some utility stuff for the new filestores

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

%option "-Low-NonStandard-NoCheck-NoDiag-NoLine-NoStack"

%include "Moose:Mouse.Inc"
%include "GDMR_H:IO_F.Inc"

%systemroutinespec phex(%integer i)

! Dictionary manipulation

%conststring(15) FS dictionary name = "FS_DICTIONARY"

%systemintegerfnspec global heap get(%integer amount)

%record(dict fm)%map master master
   %record(dict fm)%name m
   %integer i, j
      m == poa_master dict
      m == m_alt %while m_alt ## nil
      !! printstring("Master master: top alt at ")
      !! phex(addr(m));  newline
      i = find entry(FS dictionary name, m)
      %if i = 0 %start
         !! printstring("Master master: creating...");  newline
         i = make entry(FS dictionary name, m)
         %result == nil %if i = 0
         integer(i) = global heap get(48)
         integer(integer(i) + j) = 0 %for j = 0, 4, 44
      %finish
      !! printstring("Master master: found dictionary at ")
      !! phex(integer(i));  newline
      %result == record(integer(i))
%end

%externalroutine FS insert(%string(31) name, %integer value)
   %record(dict fm)%name master
   %integer i, old SR
      !! printstring("Insert ");  printstring(name)
      !! printstring(" with value ");  write(value, 0)
      !! printstring(" (");  phex(value);  print symbol(')')
      !! newline
      old SR = or to SR(16_0100)
      master == master master
      %if master == nil %start
         old SR = set SR(old SR)
         %signal 10, 0, 0, "Can't find FS dictionary?"
      %finish
      i = make entry(name, master)
      old SR = set SR(old SR)
      %signal 10, 0, 0, "FS insert" %if i = 0
      integer(i) = value
%end

%externalpredicate FS lookup(%string(31) name, %integername value)
   %record(dict fm)%name master
   %integer i, old SR
      !! printstring("Look up ");  printstring(name)
      !! newline
      old SR = or to SR(16_0100)
      master == master master
      %if master == nil %start
         old SR = set SR(old SR)
         %signal 10, 0, 0, "Can't find FS dictionary?"
      %finish
      i = find entry(name, master)
      old SR = set SR(old SR)
      %false %if i = 0
      value = integer(i)
      %true
%end


!! Lights module.
!
!@16_FDC000 %writeonly %integer A lights
!@16_FD4000 %writeonly %integer B lights
!
!
!! Shadows & initialisation
!
!%ownintegername A, B
!%ownrecord(semaphore fm)%name S
!%owninteger initialised = 0
!
!%externalroutine initialise lights
!   %recordformat real fm(%integer A, B, %record(semaphore fm) sem)
!   %ownrecord(real fm) real = 0 
!   %integer i
!      %on 0 %start
!         ! Lights board not responding....
!         initialised = -1
!         !! printstring("No lights board");  newline
!         %return
!      %finish
!      %if FS lookup("LIGHTS", i) %start
!         A == integer(i)
!         B == integer(i + 4)
!         S == record(i + 8)
!      %else
!         setup semaphore(real_sem)
!         FS insert("LIGHTS_A", addr(real))
!         A == real_A
!         B == real_B
!         S == real_sem
!         signal semaphore(real_sem)
!         ! Probe for & reset the board....
!         A lights = 0
!         B lights = 0
!         !! printstring("Lights at ");  phex(addr(A lights))
!         !! printstring(" and ");  phex(addr(B lights))
!         !! printstring(", shadows at ");  phex(addr(real));  newline
!      %finish
!      initialised = 1
!%end
!
!! A lights
!
!%externalroutine lights set A(%integer what)
!   %on 0 %start
!      signal semaphore(S)
!      printstring("Lights set A: event 0 ");  write(event_sub, 0)
!      space;  write(event_extra, 0);  space
!      printstring(event_message)
!      newline
!      %return
!   %finish
!   initialise lights %if initialised = 0
!   semaphore wait(S)
!   A = what
!   A lights = A %if initialised > 0
!   signal semaphore(S)
!%end
!
!%externalroutine lights and A(%integer what)
!   %on 0 %start
!      signal semaphore(S)
!      printstring("Lights and A: event 0 ");  write(event_sub, 0)
!      space;  write(event_extra, 0);  space
!      printstring(event_message)
!      newline
!      %return
!   %finish
!   initialise lights %if initialised = 0
!   semaphore wait(S)
!   A = A & what
!   A lights = A %if initialised > 0
!   signal semaphore(S)
!%end
!
!%externalroutine lights or A(%integer what)
!   %on 0 %start
!      signal semaphore(S)
!      printstring("Lights or A: event 0 ");  write(event_sub, 0)
!      space;  write(event_extra, 0);  space
!      printstring(event_message)
!      newline
!      %return
!   %finish
!   initialise lights %if initialised = 0
!   semaphore wait(S)
!   A = A ! what
!   A lights = A %if initialised > 0
!   signal semaphore(S)
!%end
!
!%externalroutine lights xor A(%integer what)
!   %on 0 %start
!      signal semaphore(S)
!      printstring("Lights xor A: event 0 ");  write(event_sub, 0)
!      space;  write(event_extra, 0);  space
!      printstring(event_message)
!      newline
!      %return
!   %finish
!   initialise lights %if initialised = 0
!   semaphore wait(S)
!   A = A !! what
!   A lights = A %if initialised > 0
!   signal semaphore(S)
!%end
!
!! B lights
!
!%externalroutine lights set B(%integer what)
!   %on 0 %start
!      signal semaphore(S)
!      printstring("Lights set B: event 0 ");  write(event_sub, 0)
!      space;  write(event_extra, 0);  space
!      printstring(event_message)
!      newline
!      %return
!   %finish
!   initialise lights %if initialised = 0
!   semaphore wait(S)
!   B = what
!   B lights = B %if initialised > 0
!   signal semaphore(S)
!%end
!
!%externalroutine lights and B(%integer what)
!   %on 0 %start
!      signal semaphore(S)
!      printstring("Lights and B: event 0 ");  write(event_sub, 0)
!      space;  write(event_extra, 0);  space
!      printstring(event_message)
!      newline
!      %return
!   %finish
!   initialise lights %if initialised = 0
!   semaphore wait(S)
!   B = B & what
!   B lights = B %if initialised > 0
!   signal semaphore(S)
!%end
!
!%externalroutine lights or B(%integer what)
!   %on 0 %start
!      signal semaphore(S)
!      printstring("Lights or B: event 0 ");  write(event_sub, 0)
!      space;  write(event_extra, 0);  space
!      printstring(event_message)
!      newline
!      %return
!   %finish
!   initialise lights %if initialised = 0
!   semaphore wait(S)
!   B = B ! what
!   B lights = B %if initialised > 0
!   signal semaphore(S)
!%end
!
!%externalroutine lights xor B(%integer what)
!   %on 0 %start
!      signal semaphore(S)
!      printstring("Lights xor B: event 0 ");  write(event_sub, 0)
!      space;  write(event_extra, 0);  space
!      printstring(event_message)
!      newline
!      %return
!   %finish
!   initialise lights %if initialised = 0
!   semaphore wait(S)
!   B = B !! what
!   B lights = B %if initialised > 0
!   signal semaphore(S)
!%end


! Naive DES en/decryption, GDMR, Nov 1988
! This implementation (more or less) follows the recipe in 40FR12134.
! Although things could probably be made quicker, it has to be able to
! do BSD-style passwd encryption, which requires somewhat non-standard
! modifications to the tables.

%option "-NonStandard-NoCheck-NoTrace-NoDiag-NoStack-NoLine"

!%systemroutinespec phex(%integer x)
%systemroutinespec phex2(%integer x)

! Initial permutation

%constbytearray IP(1 : 64) =
      58, 50, 42, 34, 26, 18, 10,  2,
      60, 52, 44, 36, 28, 20, 12,  4,
      62, 54, 46, 38, 30, 22, 14,  6,
      64, 56, 48, 40, 32, 24, 16,  8,

      57, 49, 41, 33, 25, 17,  9,  1,
      59, 51, 43, 35, 27, 19, 11,  3,
      61, 53, 45, 37, 29, 21, 13,  5,
      63, 55, 47, 39, 31, 23, 15,  7

! Final permutation.

%constbytearray FP(1 : 64) =
      40,  8, 48, 16, 56, 24, 64, 32,
      39,  7, 47, 15, 55, 23, 63, 31,
      38,  6, 46, 14, 54, 22, 62, 30,
      37,  5, 45, 13, 53, 21, 61, 29,

      36,  4, 44, 12, 52, 20, 60, 28,
      35,  3, 43, 11, 51, 19, 59, 27,
      34,  2, 42, 10, 50, 18, 58, 26,
      33,  1, 41,  9, 49, 17, 57, 25

! E bit-selection.  This is the standard version; the BSD salted algorithm
! uses a non-standard permuted E.

%constbytearray standard E(1 : 48) =
      32,  1,  2,  3,  4,  5,
       4,  5,  6,  7,  8,  9,
       8,  9, 10, 11, 12, 13,
      12, 13, 14, 15, 16, 17,

      16, 17, 18, 19, 20, 21,
      20, 21, 22, 23, 24, 25,
      24, 25, 26, 27, 28, 29,
      28, 29, 30, 31, 32,  1

! S tables.  Note that these aren't exactly according to the standard: we've
! rewritten them to make for more convenient indexing; and, we've run the
! eight together, so Sn starts at 64 * (n - 1).  The table runs from ZERO
! upwards, as we're indexing in directly rather than by bit-number.

%constbytearray S(0 : 8 * 64 - 1) =
       14,  0,  4, 15, 13,  7,  1,  4,  2, 14, 15,  2, 11, 13,  8,  1,
        3, 10, 10,  6,  6, 12, 12, 11,  5,  9,  9,  5,  0,  3,  7,  8,
        4, 15,  1, 12, 14,  8,  8,  2, 13,  4,  6,  9,  2,  1, 11,  7,
       15,  5, 12, 11,  9,  3,  7, 14,  3, 10, 10,  0,  5,  6,  0, 13,

       15,  3,  1, 13,  8,  4, 14,  7,  6, 15, 11,  2,  3,  8,  4, 14,
        9, 12,  7,  0,  2,  1, 13, 10, 12,  6,  0,  9,  5, 11, 10,  5,
        0, 13, 14,  8,  7, 10, 11,  1, 10,  3,  4, 15, 13,  4,  1,  2,
        5, 11,  8,  6, 12,  7,  6, 12,  9,  0,  3,  5,  2, 14, 15,  9,

       10, 13,  0,  7,  9,  0, 14,  9,  6,  3,  3,  4, 15,  6,  5, 10,
        1,  2, 13,  8, 12,  5,  7, 14, 11, 12,  4, 11,  2, 15,  8,  1,
       13,  1,  6, 10,  4, 13,  9,  0,  8,  6, 15,  9,  3,  8,  0,  7,
       11,  4,  1, 15,  2, 14, 12,  3,  5, 11, 10,  5, 14,  2,  7, 12,

        7, 13, 13,  8, 14, 11,  3,  5,  0,  6,  6, 15,  9,  0, 10,  3,
        1,  4,  2,  7,  8,  2,  5, 12, 11,  1, 12, 10,  4, 14, 15,  9,
       10,  3,  6, 15,  9,  0,  0,  6, 12, 10, 11,  1,  7, 13, 13,  8,
       15,  9,  1,  4,  3,  5, 14, 11,  5, 12,  2,  7,  8,  2,  4, 14,

        2, 14, 12, 11,  4,  2,  1, 12,  7,  4, 10,  7, 11, 13,  6,  1,
        8,  5,  5,  0,  3, 15, 15, 10, 13,  3,  0,  9, 14,  8,  9,  6,
        4, 11,  2,  8,  1, 12, 11,  7, 10,  1, 13, 14,  7,  2,  8, 13,
       15,  6,  9, 15, 12,  0,  5,  9,  6, 10,  3,  4,  0,  5, 14,  3,

       12, 10,  1, 15, 10,  4, 15,  2,  9,  7,  2, 12,  6,  9,  8,  5,
        0,  6, 13,  1,  3, 13,  4, 14, 14,  0,  7, 11,  5,  3, 11,  8,
        9,  4, 14,  3, 15,  2,  5, 12,  2,  9,  8,  5, 12, 15,  3, 10,
        7, 11,  0, 14,  4,  1, 10,  7,  1,  6, 13,  0, 11,  8,  6, 13,

        4, 13, 11,  0,  2, 11, 14,  7, 15,  4,  0,  9,  8,  1, 13, 10,
        3, 14, 12,  3,  9,  5,  7, 12,  5,  2, 10, 15,  6,  8,  1,  6,
        1,  6,  4, 11, 11, 13, 13,  8, 12,  1,  3,  4,  7, 10, 14,  7,
       10,  9, 15,  5,  6,  0,  8, 15,  0, 14,  5,  2,  9,  3,  2, 12,

       13,  1,  2, 15,  8, 13,  4,  8,  6, 10, 15,  3, 11,  7,  1,  4,
       10, 12,  9,  5,  3,  6, 14, 11,  5,  0,  0, 14, 12,  9,  7,  2,
        7,  2, 11,  1,  4, 14,  1,  7,  9,  4, 12, 10, 14,  8,  2, 13,
        0, 15,  6, 12, 10,  9, 13,  0, 15,  3,  3,  5,  5,  6,  8, 11

! P permutation table

%constbytearray P(1 : 32) =
       16,  7, 20, 21,
       29, 12, 28, 17,
        1, 15, 23, 26,
        5, 18, 31, 10,

        2,  8, 24, 14,
       32, 27,  3,  9,
       19, 13, 30,  6,
       22, 11,  4, 25

! Permuted choice 1

%constbytearray PC1(1 : 56) =
       57, 49, 41, 33, 25, 17,  9,
        1, 58, 50, 42, 34, 26, 18,
       10,  2, 59, 51, 43, 35, 27,
       19, 11,  3, 60, 52, 44, 36,

       63, 55, 47, 39, 31, 23, 15,
        7, 62, 54, 46, 38, 30, 22,
       14,  6, 61, 53, 45, 37, 29,
       21, 13,  5, 28, 20, 12,  4

! Permuted choice 2

%constbytearray PC2(1 : 48) =
       14, 17, 11, 24,  1,  5,
        3, 28, 15,  6, 21, 10,
       23, 19, 12,  4, 26,  8,
       16,  7, 27, 20, 13,  2,

       41, 52, 31, 37, 47, 55,
       30, 40, 51, 45, 33, 48,
       44, 49, 39, 56, 34, 53,
       46, 42, 50, 36, 29, 32

! Iteration shifts.

%constbytearray shifts(1 : 16) =
      1, 1, 2, 2, 2, 2, 2, 2,
      1, 2, 2, 2, 2, 2, 2, 1


! The main body of the algorithm follows.  We're not out for speed.  Rather
! the idea is to make things as clear as possible....

!! %routine print block(%bytename b, %integer bits)
!!    %integer i
!!       phex2(b [i]) %for i = 0, 1, bits >> 3 - 1
!! %end

%routine permute(%bytename from, %bytearrayname P,
                 %bytename to, %integer bits)
   %integer byte, bit, mask, target bit = 0, source bit
      %for byte = 0, 1, bits >> 3 - 1 %cycle
         mask = 2_10000000
         to [byte] = 0
         %for bit = 0, 1, 7 %cycle
            target bit = target bit + 1
            source bit = P(target bit) - 1
            !! write(source bit, 3)
            to [byte] = to [byte] ! mask %c
               %if from [source bit >> 3] & (1 << (7 - (source bit & 7))) # 0
            mask = mask  >> 1
         %repeat
         !! newline
      %repeat
%end

%recordformat key fm(%byte k0, k1, k2, k3, k4, k5)
%recordformat key table fm(%record(key fm)%array k(1 : 16))

%routine calculate kn(%bytename key, %record(key table fm)%name out)
   %bytearray CD, link(0 : 6)
   %integer i, j, n
      permute(key, PC1, CD(0), 56)
      %for n = 1, 1, 16 %cycle
         !! printstring("CD:   ");  print block(CD(0), 56)
         %for i = 1, 1, shifts(n) %cycle
            %for j = 0, 1, 6 %cycle
               link(j) = CD(j) & 2_10000000
               CD(j) <- CD(j) << 1
            %repeat
            CD(0) = CD(0) ! 1 %if link(1) # 0
            CD(1) = CD(1) ! 1 %if link(2) # 0
            CD(2) = CD(2) ! 1 %if link(3) # 0
            CD(3) = CD(3) ! 1 %if link(4) # 0
            CD(4) = CD(4) ! 1 %if link(5) # 0
            CD(5) = CD(5) ! 1 %if link(6) # 0
            CD(6) = CD(6) ! 1 %if CD(3) & 2_00010000 # 0
            CD(3) = CD(3) & 2_11101111
            CD(3) = CD(3) ! 2_00010000 %if link(0) # 0
         %repeat
         !! printstring(" -> ");  print block(CD(0), 56);  newline
         permute(CD(0), PC2, out_k(n)_k0, 48)
         !! printstring("Key ");  write(n, 0)
         !! printstring(": ");  print block(out_k(n)_k0, 48);  newline
      %repeat
%end

%routine calculate f(%bytename R, key, %bytearrayname E(1 : 48), %bytename out)
   %bytearray x(0 : 5)
   %bytearray pre p(0 : 3)
   %integer i, n, h, l
      !! printstring("f(");  print block(R, 32);  printstring(", ")
      !! print block(key, 48);  printstring(") -> ")
      ! Expand R to 48 bits
      permute(R, E, x(0), 48)
      ! XOR in key
      x(i) = x(i) !! key [i] %for i = 0, 1, 5
      !! phex2(x(n)) %and space %for n = 0, 1, 5
      ! Apply Sn to get pre-P
{S1}  n = ((x(0) & 2_11111100) >> 2                           );  h = S(n + 0*64)
{S2}  n = ((x(0) & 2_00000011) << 4 ! (x(1) & 2_11110000) >> 4);  l = S(n + 1*64)
      pre p(0) <- h << 4 ! l
{S3}  n = ((x(1) & 2_00001111) << 2 ! (x(2) & 2_11000000) >> 6);  h = S(n + 2*64)
{S4}  n = ((x(2) & 2_00111111)                                );  l = S(n + 3*64)
      pre p(1) <- h << 4 ! l
{S5}  n = ((x(3) & 2_11111100) >> 2                           );  h = S(n + 4*64)
{S6}  n = ((x(3) & 2_00000011) << 4 ! (x(4) & 2_11110000) >> 4);  l = S(n + 5*64)
      pre p(2) <- h << 4 ! l
{S7}  n = ((x(4) & 2_00001111) << 2 ! (x(5) & 2_11000000) >> 6);  h = S(n + 6*64)
{S8}  n = ((x(5) & 2_00111111)                                );  l = S(n + 7*64)
      pre p(3) <- h << 4 ! l
      ! Apply P to give result
      permute(pre p(0), P, out, 32)
      !! phex2(pre p(n)) %and space %for n = 0, 1, 3
      !! print block(out, 32);  newline
%end

%routine compute(%bytename in, key, %bytearrayname E(1 : 48), %bytename out)
   ! Perform one "complex computation".  Note that the %array f
   ! starts at 4 for convenience in indexing.
   %bytearray f(4 : 7)
   %integer i
      calculate f(in [4], key, E, f(4))
      !! printstring("F -> ");  print block(f(4), 32);  newline
      ! L' = R
      out [i] = in [i + 4] %for i = 0, 1, 3
      ! R' = L !! f
      out [i] = in [i - 4] !! f(i) %for i = 4, 1, 7
%end

%routine do DES encryption(%bytename block, key, %bytearrayname E(1 : 48))
   %bytearray x, y(0 : 7)
   %record(key table fm) kn
   %integer stage, i
      !! printstring("Encrypt starting with ");  print block(block, 64);  newline
      ! Set up the keys
      calculate kn(key, kn)
      ! Initial permutation
      permute(block, IP, x(0), 64)
      !! printstring("IP -> ");  print block(x(0), 64);  newline
      ! Cycle round the inner loop
      %for stage = 1, 2, 15 %cycle
         compute(x(0), kn_k(stage)_k0, E, y(0))
         !! write(stage, -2);  printstring(" -> ")
         !! print block(y(0), 64);  newline
         compute(y(0), kn_k(stage + 1)_k0, E, x(0))
         !! write(stage + 1, -2);  printstring(" -> ")
         !! print block(x(0), 64);  newline
      %repeat
      ! Undo the final swap
      y(i) = x(i) %and x(i) = x(i + 4) %for i = 0, 1, 3
      x(i + 4) = y(i) %for i = 0, 1, 3
      ! Final permutation
      permute(x(0), FP, block, 64)
      !! printstring("FP -> ");  print block(block, 64);  newline
%end

%externalroutine DES encrypt(%bytename block, key)
   do DES encryption(block, key, standard E)
%end

%externalpredicate check BSD password(%string(31) pass, target)
   %bytearray block(0 : 8)
   %bytearray key(0 : 7)
   %bytearray E(1 : 48)
   %integer i, j, k, x, ch, mask
   %bytename byte
      ! OK if null pass or target
      %true %if pass = "" %or target = ""
      ! Set up tables
      E(i) = standard E(i) %for i = 1, 1, 48
      block(i) = 0 %for i = 0, 1, 8
      ! Set up key: upshift away from parity bit, zero anything
      ! which is off the end of the password
      i = 0
      %while i < length(pass) %and i <= 7 %cycle
         key(i) = charno(pass, i + 1) << 1
         i = i + 1
      %repeat
      key(i) = 0 %and i = i + 1 %while i <= 7
      !! printstring("Key is ");  print block(key(0), 64);  newline
      ! Determine salt, and permute E table accordingly
      %for i = 1, 1, 2 %cycle
         ch = charno(target, i)
         ch = ch - 6 %if ch > 'Z'
         ch = ch - 7 %if ch > '9'
         ch = ch - '.'
         %for j = 0, 1, 5 %cycle
            %if ch >> j & 1 # 0 %start
               k = 6 * (i - 1) + 1
               !! printstring("E: switching ");  write(k + j, 0)
               !! printstring(" and ");  write(k + j + 24, 0);  newline
               x = E(k + j)
               E(k + j) = E(k + j + 24)
               E(k + j + 24) = x
            %finish
         %repeat
      %repeat
      ! Do the encryption
      do DES encryption(block(0), key(0), E) %for i = 1, 1, 25
      !! printstring("Encryption yields ");  print block(block(0), 64);  newline
      ! Check the result
      mask = 2_10000000;  byte == block(0)
      %for i = 0, 1, 10 %cycle
         ch = 0
         %for j = 0, 1, 5 %cycle
            ch = ch << 1
            ch = ch ! 1 %if byte & mask # 0
            mask = mask >> 1
            %if mask = 0 %start
               mask = 2_10000000;  byte == byte [1]
            %finish
         %repeat
         ! End of a character, so check it
         ch = ch + '.'
         ch = ch + 7 %if ch > '9'
         ch = ch + 6 %if ch > 'Z'
         !! printstring("Comparing ");  print symbol(ch)
         !! printstring(" against ");  print symbol(charno(target, i + 3))
         !! printstring(" at ");  write(i + 3, 0);  newline
         %false %unless ch = charno(target, i + 3)
      %repeat
      ! If we get here it must be OK
      %true
%end

%routine do DES decryption(%bytename block, key, %bytearrayname E(1 : 48))
   %bytearray x, y(0 : 7)
   %record(key table fm) kn
   %integer stage, i
      !! printstring("Decrypt starting with ");  print block(block, 64);  newline
      ! Set up the keys
      calculate kn(key, kn)
      ! Initial permutation
      permute(block, IP, x(0), 64)
      !! printstring("IP -> ");  print block(x(0), 64);  newline
      ! Cycle round the inner loop
      %for stage = 15, -2, 1 %cycle
         compute(x(0), kn_k(stage + 1)_k0, E, y(0))
         !! write(stage + 1, -2);  printstring(" -> ")
         !! print block(y(0), 64);  newline
         compute(y(0), kn_k(stage)_k0, E, x(0))
         !! write(stage, -2);  printstring(" -> ")
         !! print block(x(0), 64);  newline
      %repeat
      ! Undo the final swap
      y(i) = x(i) %and x(i) = x(i + 4) %for i = 0, 1, 3
      x(i + 4) = y(i) %for i = 0, 1, 3
      ! Final permutation
      permute(x(0), FP, block, 64)
      !! printstring("FP -> ");  print block(block, 64);  newline
%end

%externalroutine DES decrypt(%bytename block, key)
   do DES decryption(block, key, standard E)
%end


! Utility routines to obtain the information in the $UserData file.  This
! file is assumed to be sorted by username, so that a binary search can be
! used for speed (though it isn't).  For now we don't use the standard Imp RTL.
! If a domain is specified then a YP lookup is performed.

%recordformat YP request fm(%record(message fm) system part,
                            %integer flags,
                            %string(15) user, domain,
                            %string(*)%name data)

%routine get YP user data(%string(15) user, domain,
                          %string(*)%name home, full name)
   %record(semaphore fm) sem = 0
   %record(mailbox fm) box = 0
   %record(YP request fm) req = 0
   %record(YP request fm)%name rep
   %ownrecord(mailbox fm)%name YP box == nil
   %string(255) data
   %integer x
   %bytename ch, end
      !! printstring("Get YP user data: ");  printstring(user)
      !! printstring(" at ");  printstring(domain);  newline
      %if YP box == nil %start
         %if FS lookup("YP_PASSWD_REQUESTS", x) %start
            YP box == record(x)
         %else
            home = "";  full name = ""
            %return
         %finish
      %finish
      setup semaphore(sem)
      setup mailbox(box, sem)
      setup message(req, size of(req))
      req_user = user;  req_domain = domain
      req_data == data
      send message(req, YP box, box)
      rep == receive message(box)
      %if data = "" %start
         ! Error of some kind
dud:     home = "";  full name = ""
         !! printstring("Dud");  newline
         %return
      %finish
      !! printstring(data);  newline
      home = "fred";  full name = "jim"
      ch == charno(data, 1);  end == charno(data, length(data))
      ! Skip to the name
      ch == ch [1] %while ch ## end %and ch # ':';  -> dud %if ch == end
      ch == ch [1];  -> dud %if ch == end;  ! -> pass
      ch == ch [1] %while ch ## end %and ch # ':';  -> dud %if ch == end
      ch == ch [1];  -> dud %if ch == end;  ! -> UID
      ch == ch [1] %while ch ## end %and ch # ':';  -> dud %if ch == end
      ch == ch [1];  -> dud %if ch == end;  ! -> GID
      ch == ch [1] %while ch ## end %and ch # ':';  -> dud %if ch == end
      ch == ch [1];  -> dud %if ch == end;  ! -> name
      ! Extract the name
      full name = ""
      %while ch ## end %and ch # ',' %and ch # ':' %cycle
         full name = full name . to string(ch)
         ch == ch [1]
      %repeat
      -> dud %if ch == end
      !! printstring("Full name is ");  printstring(full name);  newline
      ! Skip to the home directory
      ch == ch [1] %while ch ## end %and ch # ':';  -> dud %if ch == end
      ch == ch [1];  -> dud %if ch == end;  ! -> home
      ! Extract the home directory
      home = ""
      ch == ch [1];  -> dud %if ch == end;  ! Skip leading '/'
      %while ch ## end %and ch # ':' %cycle
         %if ch = '/' %then home = home . ":" %c
                      %else home = home . to string(ch)
         ch == ch [1]
      %repeat
      -> dud %if ch == end
      !! printstring("Home directory is ");  printstring(home);  newline
%end


%owninteger token1 = 0, token2 = 0, size = 0, flags = 0

%ownbytearray buffer(0 : 511)
%owninteger pos = -1, buffer start = 0, buffer end = -1

%predicate open database
   %string(255) textual response
   %integer status
      %true %if token1 # 0;  ! Already open
      !! printstring("Open $UserData");  newline
      ! Database isn't open yet
      status = F open file(nil, "$UserData", read file mode, read file mode, 0,
                           token1, token2, size, flags, textual response)
      %if status # 0 %start
         printstring("Open $UserData fails: ");  printstring(textual response)
         newline
         %false
      %finish
      !! printstring("Opened: ");  phex(token1);  space
      !! phex(token2);  newline
      buffer start = 0;  buffer end = -1
      pos = 0
      %true
%end

%integerfn next sym
   %string(255) textual response
   %integer status, start, bytes, x
      %unless buffer start <= pos <= buffer end %start
         ! Wrong block, so we'll have to fetch it
         !! printstring("Fetch: ");  write(pos, 0);  space
         !! write(buffer start, 0);  space;  write(buffer end, 0)
         !! space;  write(size, 0);  newline
         %signal 9, 9, pos %if pos >= size;  ! EOF
         start = pos & (\ 511);  ! Lose offset
         status = F read block(nil, token1, token2, start, bytes, buffer(0),
                               textual response)
         %if status # 0 %start
            printstring("Read $UserData at ");  write(start, 0)
            printstring(" fails: ");  printstring(textual response);  newline
            %signal 9, 9, pos
         %finish
         buffer start = start
         buffer end = start + bytes - 1
      %finish
      x = buffer(pos - buffer start)
      !! write(pos, 0);  space;  print symbol(x);  newline
      pos = pos + 1
      %result = x
%end

%routine close database
   %string(255) textual response
   %integer status
      %return %if token1 = 0;  ! Not open
      !! printstring("Close $UserData");  newline
      status = F close file(nil, token1, token2, 0, textual response)
      %if status # 0 %start
         printstring("Close $UserData fails: ");  printstring(textual response)
         newline
      %finish
      token1 = 0;  token2 = 0
%end

%externalroutine get user data(%string(15) user, domain,
                               %string(*)%name home, full name)
   ! Eventually we'll use a binary search here....
   %string(255) current user, udomain
   %bytename x
   %integer sym, i, quoted = 0
      %on 9 %start
         close database
         %return
      %finish
      udomain = domain;  to upper(udomain)
      get YP user data(user, domain, home, full name) %and %return %c
         %if udomain # "LOCAL"
      !! printstring("Get for ");  printstring(user);  newline
      home = "";  full name = ""
      %return %if user = ""
      %return %unless open database
      %for i = 1, 1, length(user) %cycle
         x == charno(user, i)
         x = x - 'a' + 'A' %if 'a' <= x <= 'z'
      %repeat
      %cycle
         current user = ""
         sym = next sym %until sym > ' ';  ! Blank lines, leading white space
         %while sym = '!' %cycle
            ! Skip comments: first the rest of this line
            sym = next sym %while sym # NL
            ! Then the white space at the start of the next
            sym = next sym %until sym > ' '
         %repeat
         %while sym > ' ' %cycle
            sym = sym - 'a' + 'A' %if 'a' <= sym <= 'z'
            current user = current user . to string(sym)
            sym = next sym
         %repeat
         !! printstring("Current user: ");  printstring(current user);  newline
         %if current user = user %start
            sym = next sym %while sym <= ' '
            %while sym > ' ' %cycle
               home = home . to string(sym)
               sym = next sym
            %repeat
            !! printstring("Home: ");  printstring(home);  newline
            sym = next sym %while sym # '"'
            sym = next sym
            %while sym # '"' %cycle
               full name = full name . to string(sym)
               sym = next sym
            %repeat
            close database
            %return
         %else
            ! Not this one, so skip the rest of the line
            sym = next sym %while sym # NL
         %finish
      %repeat
%end

%end %of %file