/** FifoBBS.rexx
*
*   Alpha 0.4 by W.G.J. Langeveld, 30 January 1991:
*   ---------------------------------------------------
*
*   Test of fifo-handler. A small BBS. Really small...
*
*   This requires VLT or VLTjr version 5.028 or later, and
*   Matt Dillon's Fifo.library and fifo-handler. Please
*   install these files and mount fifo: before running this.
*
*   Usage: FifoBBS [local | remote]
*
*   FifoBBS, when invoked without arguments will run a fake BBS
*   in the current CLI. When invoked with the "local" argument,
*   it will run with a local VLT, bypassing the serial port.
*   In neither of these cases will "UPLOAD" or "DOWNLOAD" work.
*   When invoked with the "remote" argument, it will run as a
*   real BBS, through the serial port.
*
*   The BBS installs itself almost completely. All you have to
*   do is assign FifoBBS: or change the BBSdevice string later on
*   to the location you want. You will also need to set up VLT
*   for running with its pipes on. After starting the BBS for
*   for the first time, you can log on as Sysop, password
*   SYSOP. It will ask you to change your password. From that
*   moment on, you're in business. People can register, the
*   sysop can validate them. Once on the system, type help to
*   find a list of commands.
*
*   Alpha 0.5 by W.G.J. Langeveld, 22 January 1992:
*   ---------------------------------------------------
*
*   Fixed a security problem.
*
*   Alpha 0.6 by W.G.J. Langeveld, 26 February 1994:
*   ---------------------------------------------------
*
*   Added modem initialization so echoes etc. don't cause so much
*   trouble. Also, set the modem to auto-answer.
*   Here are the modem strings I use:
*/
   modem.reset  = "ATZ"
   modem.init   = "ATC1E0Q1S0=1" /* Follow CD, no echo/progress msgs, answer at 1 ring */
   modem.ppp    = "+++"
   modem.hangup = "ATH"
/*
*   This assumes a Hayes modem! Also added hangup after logoff using +++
*   sequence, and ATZ upon exit.
*
*   Alpha 0.7 by W.G.J. Langeveld, 26 March 1994:
*   ---------------------------------------------------
*
*   Tried adding carrier detect (See Carrier.vlt). Unfortunately,
*   my modem seems to not assert CD when answering the phone, despite
*   the "C1" in the modem init string. See also RunBBS.rexx.
*
**/
   parse arg action
/*
*   Allow no interruptions for secure operation
*/
   SIGNAL ON BREAK_C
   SIGNAL ON BREAK_D
   SIGNAL ON BREAK_E
   SIGNAL ON BREAK_F
   SIGNAL ON ERROR
   SIGNAL ON FAILURE
   SIGNAL ON HALT
   SIGNAL ON SYNTAX
/*
*   This one is really for debugging purposes:
*/
   SIGNAL ON NOVALUE
/*
*   Don't allow system requesters
*/
   call pragma('W', 'NULL')

   Options failat 300
   SignalLabel = "Start"
/*
*   Trick: here are all the global variables we want accessible to all
*   routines. Watch the way interpret is used in the Procedure definitions
*/
   GLOBAL = "GLOBAL SignalLabel BBSdevice BBSusers BBSlistings"
   GLOBAL = GLOBAL || " BBSgeneral BBSmail BBSadmin BBSsysmsg BBSprompt"
   GLOBAL = GLOBAL || " Protocols. CurrentUser."
/*
*   Get the support library.
*/
   check = addlib('rexxsupport.library', 0, -30, 0)
/*
*   BBS definitions
*/
   BBSdevice   = "FifoBBS:"
   BBSusers    = BBSdevice"users"
   BBSlistings = BBSdevice"listings"
   BBSgeneral  = BBSdevice"general"
   BBSmail     = BBSdevice"mail"
   BBSadmin    = BBSdevice"admin"
   BBSsysmsg   = BBSdevice"admin/system.msg"
   BBSwelcome  = BBSdevice"admin/welcome.msg"
   BBSprompt   = "FifoBBS> "
/*
*   Check if the sections exist, or else make them
*/
   if ~exists(BBSdevice) then do
      say "You must set up an assignment called "BBSdevice
      exit 0
   end
   if ~exists(BBSusers)    then call Makedir(BBSusers)
   if ~exists(BBSlistings) then call Makedir(BBSlistings)
   if ~exists(BBSgeneral)  then call Makedir(BBSgeneral)
   if ~exists(BBSmail)     then call Makedir(BBSmail)
   if ~exists(BBSadmin)    then call Makedir(BBSadmin)
   if ~exists(BBSsysmsg)   then address command "echo >"BBSsysmsg' "No news"'
/*
*   If there's no sysop account, make one
*/
   if ~exists(BBSmail"/Sysop") then do
      Tmp. = ""
      Tmp.Account   = "Sysop"
      Tmp.Password  = "SYSOP"
      Tmp.Access    = 5
      Tmp.Name      = "Sysop"
      Tmp.MsgCount  = 0
      Tmp.MailCount = 0
      Tmp.Protocol  = 1
      call SetRecord()
      call Makedir(BBSmail"/Sysop")
   end
/*
*   Transfer Protocols
*/
   Protocols.0 = 5
   Protocols.1.nam = "XMODEM"
   Protocols.1.lib = "xprxmodem.library"
   Protocols.1.set = "C1,K1"
   Protocols.2.nam = "ZMODEM"
   Protocols.2.lib = "xprzmodem.library"
   Protocols.2.set = "T?,OS,B1,AN,DN,KN,SN,RN"
   Protocols.3.nam = "Kermit"
   Protocols.3.lib = "xprkermit.library"
   Protocols.3.set = "OCY,GN,TN,P1500,B3"
   Protocols.4.nam = "CIS QuickB"
   Protocols.4.lib = "xprquickb.library"
   Protocols.4.set = "TC,OS,B1,AN,DN,KN"
   Protocols.5.nam = "ASCII"
   Protocols.5.lib = "xprascii.library"
   Protocols.5.set = "50"
/*
*   Redirect I/O to VLT's pipes
*   For use as a BBS, use VLTR (remote). For local tests
*   use VLTL (local).
*/
   if action = "remote" then pip = "VLTR"
   else                      pip = "VLTL"
/*
*   When action is not either "local" or "remote", you will run in
*   the CLI (and you will see some echoes not otherwise present).
*/
   if action ~= "" then do
      call close("STDIN")
      call close("STDOUT")
/*
*   First open fifo for read/write and assign to stdin
*/
      if ~open("STDIN", "fifo:"pip"/rws") then do
         say "Can't open read pipe"
         exit 0
      end
/*
*   Identify stdin with the "current console"
*/
      call pragma('*', "STDIN")
/*
*   Open stdout to the current console for write.
*/
      if ~open("STDOUT", '*', "W") then do
         say "Can't open write pipe"
         exit 0
      end
   end

/*
*   Initialize the modem
*/
   if action = "remote" then do
      say modem.reset || '0d'x
/*
*   Get anything it might have typed back
*/
      call Delay(200)
      s = GetCommand("", 0)
/*
*   Set modem to no echo, no progress messages, and answer after one ring.
*/
      say modem.init || '0d'x
/*
*   Get anything it might have typed back
*/
      call delay(200)
      s = GetCommand("", 0)
   end


   quitflag = 0
/*
*   Wait for <cr>. Here's where we go on severe problems.
*/
Start:
/*
*   Fix the annoying RING echo problem
*/
   do i = 1
      s = GetCommand("", 0)
      if s = "" then leave i
   end
   call delay(30)
/*
*   Welcome message.
*/
   if action = "remote" then do
      call writech("STDOUT", '1b'x||"[20h")     /* Set up "newline mode" */
   end

   if exists(BBSwelcome) then do
      address command "type "BBSwelcome
   end
   else do
      say "+--------------------------------------------------+"
      say "|  FifoBBS  -  Only authorized users are welcome!  +"
      say "+--------------------------------------------------+"
   end
/*
*   Log in. Don't let users without sufficient privilege get past here.
*/
   CurrentUser. = ""

   call Login()

   if CurrentUser.Access > 2 then do
/*
*   If user is Sysop, make sure the password is changed first time
*/
      if upper(CurrentUser.Account) = "SYSOP" then do
         do while upper(CurrentUser.Password) = "SYSOP"
            say "You MUST change the Sysop password now!"
            call ChangePassword()
         end
      end
/*
*   System message
*/
      if exists(BBSsysmsg) then address command "type "BBSsysmsg
/*
*   Unread mail
*/
      n = GetMsgLeft(BBSmail"/"CurrentUser.Account, CurrentUser.MailCount)
      if n ~= 0 then say "You have "n" unread mail message"Esses(n)
/*
*   Unread regular messages
*/
      n = GetMsgLeft(BBSgeneral, CurrentUser.MsgCount)
      if n ~= 0 then say "You have "n" unread general message"Esses(n)
/*
*   Main loop. Not too many commands yet. But you get the
*   idea... Some commands are only available with level 5 clearance.
*/
      do i = 1
         s = GetCommand(BBSprompt, 1)
         parse var s cmd arg1 arg2 .
         cmd = upper(cmd)
         select
            when abbrev("DOWNLOAD", cmd, 2) then call Download(arg1)
            when abbrev("ENTER",    cmd, 3) then call EnterMsg("")
            when abbrev("EXIT",     cmd, 4) then do
               quitflag = ExitBBS(cmd)
               if quitflag = 1 then leave i
            end
            when abbrev("HELP",     cmd, 1) then call HelpList("")
            when abbrev("LIST",     cmd, 2) then call ListFiles()
            when abbrev("LOGOFF",   cmd, 2) then leave i
            when abbrev("MAIL",     cmd, 2) then call DoMail()
            when abbrev("PASSWORD", cmd, 3) then call ChangePassword()
            when abbrev("PROTOCOL", cmd, 3) then call ChangeProtocol(arg1)
            when abbrev("REGISTER", cmd, 3) then call Register(cmd)
            when abbrev("READ",     cmd, 2) then call ReadMsg(arg1)
            when abbrev("SHOW",     cmd, 2) then call ShowRecord(arg1)
            when abbrev("SYSTEM",   cmd, 2) then call DoSystem(cmd)
            when abbrev("UPLOAD",   cmd, 2) then call UpLoad(arg1)
            when abbrev("USERS",    cmd, 2) then call ShowUsers()
            when abbrev("VALIDATE", cmd, 1) then call Validate(cmd, arg1, arg2)
            otherwise                            call HelpList(cmd)
         end
      end
/*
*   Save message and mail count
*/
      n = CurrentUser.MsgCount
      m = CurrentUser.MailCount
      Tmp.Account = CurrentUser.Account
      call GetRecord()
      Tmp.MsgCount  = n
      Tmp.MailCount = m
      call SetRecord()
/*
*   Logout
*/
      say CurrentUser.Name" logged off at "time()
   end
/*
*   Hang up
*/
   if action = "remote" then do
      call writech("STDOUT", '1b'x||"[20l")   /* Terminate "newline mode" */
      call delay(100)
      call writech("STDOUT", modem.ppp)
      call delay(100)
      say modem.hangup || '0d'x
   end
/*
*   If we're exiting, reset the modem
*/
   if quitflag = 1 then do
      if action = "remote" then do
         call delay(100)
         say modem.reset || '0d'x
      end
      exit 0
   end

   interpret "SIGNAL" SignalLabel



/**************************************************************/
/**************** Functions ***********************************/
/**************************************************************/

/**
*
*   Change the password
*
**/
ChangePassword: interpret "Procedure Expose" GLOBAL
   Tmp.Account = CurrentUser.Account

   if GetRecord() = 1 then do
      t = upper(GetCommand("Old Password: ", 0))
      if t ~= Tmp.Password then do
         say "Invalid Password"
         return
      end
      t = upper(GetCommand("New Password: ", 0))
      u = upper(GetCommand("Verification: ", 0))
      if u ~= t then do
         say "Verification doesn't match new password, aborted"
         return
      end
      else if index(u, "|") ~= 0 then do
         say "Illegal characters in password"
         return
      end
      else do
         Tmp.Password         = u
         CurrentUser.Password = u
         call SetRecord()
      end
   end
   return



/**
*
*   Change the transfer protocol
*
**/
ChangeProtocol: interpret "Procedure Expose" GLOBAL
   arg s

   if s = "" then do
      say "Transfer Protocol:"

      do i = 1 to Protocols.0
         say i". "Protocols.i.nam
      end
      i = CurrentUser.Protocol + 0
      say "Your current protocol is "Protocols.i.nam
   end

   Tmp.Account = CurrentUser.Account

   if GetRecord() = 1 then do
      do i = 1
         if s = "" then t = upper(GetCommand("Enter new protocol (1 - 5): ", 1))
         else           t = s

         if (t ~= 1) & (t ~= 2) & (t ~= 3) & (t ~= 4) & (t ~= 5) then do
            say "A number from 1 through 5 was expected"
            s = ""
            iterate i
         end
         leave i
      end

      CurrentUser.Protocol = t
      if s = "" then do
         if GetYesNo("Save for next time? ") = 1 then do
            Tmp.Protocol = t
            call SetRecord()
         end
      end
   end
   return



/**
*
*   Collect a message
*
**/
CollectMsg: interpret "Procedure Expose" GLOBAL "msg."
   arg comm

   say "Enter the message below."
   say "Enter a dot as the first character on a line to exit."

   if comm = "" then do
      msg.3 = "Title: " || GetCommand("Title: ", 1)
      ni = 4
   end
   else ni = 3

   do k = 1
      do n = ni
         msg.n = GetCommand(">", 1)
         if substr(msg.n, 1, 1) = "." then leave n
      end

      do i = 1
         s = upper(GetCommand("Quit, Continue, List, Post: ", 1))
         if      abbrev("QUIT",     s, 1) then return 0
         else if abbrev("LIST",     s, 1) then do
            do j = 3 to n - 1
               say msg.j
            end
         end
         else if abbrev("POST",     s, 1) then leave k
         else if abbrev("CONTINUE", s, 1) then do
            ni = n
            leave i
         end
      end
   end
   return n - 1


/**
*
*   Copy the user's record from Tmp.
*
**/
CopyRecord: interpret "Procedure Expose" GLOBAL "Tmp."
   CurrentUser.Account   = Tmp.Account
   CurrentUser.Password  = Tmp.Password
   CurrentUser.Access    = Tmp.Access
   CurrentUser.Name      = Tmp.Name
   CurrentUser.City      = Tmp.City
   CurrentUser.Country   = Tmp.Country
   CurrentUser.Telephone = Tmp.Telephone
   CurrentUser.MsgCount  = Tmp.MsgCount
   CurrentUser.MailCount = Tmp.MailCount
   CurrentUser.Protocol  = Tmp.Protocol

   return


/**
*
*   Mail subsystem. Two commands: read and enter. They use the same
*   basic functions as the main system, but with different paths.
*
**/
DoMail: interpret "Procedure Expose" GLOBAL
   do i = 1
      s = upper(GetCommand("Mail: ", 1))
      parse var s cmd arg1 .
      select
         when abbrev("TO",    cmd, 2) then call EnterMail("", arg1)
         when abbrev("HELP",  cmd, 1) then call HelpLMail("")
         when abbrev("QUIT",  cmd, 1) then leave i
         when abbrev("READ",  cmd, 2) then call ReadMail(arg1)
         when abbrev("SHOW",  cmd, 2) then call ShowRecord(arg1)
         when abbrev("USERS", cmd, 2) then call ShowUsers()
         otherwise                         call HelpLMail(cmd)
      end
   end
   return



/**
*
*   Download an existing file
*
**/
DownLoad : interpret "Procedure Expose" GLOBAL
   parse arg filnam

   if filnam = "" then filnam = GetCommand("File name? ", 1)
   if ~exists(BBSlistings"/"filnam) then do
      say "Can't find file "filnam
      return
   end

   say "Get ready to receive file "filnam

   proto = CurrentUser.Protocol + 0
   address VLT "transfer protocol external; transfer mode image"
   address VLT "xpr select "Protocols.proto.lib
   address VLT "CD "BBSlistings
   if Protocols.proto.set ~= "" then address VLT "xpr init "Protocols.proto.set
   address VLT "file send "BBSlistings"/"filnam
/*
*   Switch back to XMODEM protocol so that we can't automatically start
*   receiving stuff.
*/
   address VLT "transfer protocol XMODEM"
   return



/**
*
*   More or less direct access to the system
*
**/
DoSystem: interpret "Procedure Expose" GLOBAL
   parse arg s
   if CurrentUser.Access < 5 then do
      call HelpList(s)
      return
   end
/*
*   In case a command breaks, this is the label we want to get
*   back to.
*/
SysCall: SignalLabel = "SysCall"
   do i = 1
      s = GetCommand("$ ", 1)
      parse var s cmd rest
      cmd = upper(cmd)
      if abbrev("RETURN", cmd, 3) then do
         leave i
      end
      else if (cmd = "CD") & (rest ~= "") then do
         call pragma("Directory", strip(rest))
      end
      else do
         address command s
      end
   end
/*
*   Change the label back to what it was.
*/
   SignalLabel = "Start"
   return



/**
*
*   Enter a new mail message.
*
**/
EnterMail: interpret "Procedure Expose" GLOBAL
   parse arg comm, dest

   if dest = "" then dest = GetCommand("To: ", 1)
   Tmp.Account = dest
   if GetRecord() ~= 1 then do
      say "No such account"
      return
   end

   n = CollectMsg(comm)
   if n = 0 then return

   call MakeFile(comm, BBSmail"/"CurrentUser.Account, n)
   if Tmp.Account ~= CurrentUser.Account then do
      call MakeFile(comm, BBSmail"/"Tmp.Account, n)
   end
   return



/**
*
*   Enter a new message. Someone should build in an editor...
*
**/
EnterMsg : interpret "Procedure Expose" GLOBAL
   parse arg comm

   n = CollectMsg(comm)
   if n = 0 then return

   call MakeFile(comm, BBSgeneral, n)
   return



/**
*
*   An s or not an s
*
**/
Esses: interpret "Procedure Expose" GLOBAL
   arg n
   if n > 1 then return "s"
   return ""



/**
*
*   Exit the BBS program
*
**/
ExitBBS: interpret "Procedure Expose" GLOBAL
   parse arg s
   if CurrentUser.Access >= 5 then return 1
   else                            call HelpList(s)
   return 0



/**
*
*   This gets the command from stdin. We can't use "pull"
*   because it doesn't echo the way we open things (Fifo doesn't
*   have a console handler) so we have to do it all ourselves (including
*   echo and backspace). No command line editing yet.
*   The first argument is the prompt string, the second argument
*   specifies whether or not to echo what the user types.
*   This routine checks for the presence of a "NO CARRIER"
*   string at the end of the command line. If it is present, the
*   session is aborted immediately. For this to work, you must make sure
*   your modem detects carrier loss and sends this string.
*
**/
GetCommand: interpret "Procedure Expose" GLOBAL
   parse arg pr, echo
/*
*   Some constants
*/
   cr = '0d'x
   lf = '0a'x
   bs = '08'x
   crlf = cr||lf

   if pr ~= "" then call writech("STDOUT", pr)

   command = ""

   do forever
/*
*   Read a character from STDIN
*/
      s = readch("STDIN", 1)
/*
*   If we get an EOF condition, abort this session.
*/
      if eof("STDIN") then SIGNAL "Start"
/*
*   Echo the character. Watch out for backspaces.
*/
      if echo = 1 then do
         if (s ~= bs) & (s ~= lf) & (s ~= cr) then call writech("STDOUT", s)
         if (s = bs)  & (length(command) > 0) then call writech("STDOUT", bs" "bs)
      end
/*
*   We have a <cr> of <lf>. This is the end of a command line.
*   Echo a line feed to STDOUT. Check if the line ends in
*   NO CARRIER. If so, abort the session. Else, return the command.
*/
      if s = cr | s = lf then do
         call writech("STDOUT", lf)

         nc = index(command, "NO CARRIER")
         if nc ~= 0 then do
            if nc = length(command) - 9 then do
               say "NO CARRIER detected, aborting session"
               SIGNAL "Start"
            end
         end

         return command
      end
/*
*   It's a backspace. Take off the last character of the command.
*/
      else if s = bs then do
         l = length(command)
         if l > 0 then command = substr(command, 1, l - 1)
      end
/*
*   A regular character. Add it to the command
*/
      else command = command || s
   end
   return



/**
*
*   Get highest numbered message in the source directory
*
**/
GetHighMsg: interpret "Procedure Expose" GLOBAL
   parse arg source

   files = showdir(source, "FILES")
/*
*   Loop over the files, and get the highest unread  message number
*/
   high = 0
   do i = 1
      parse var files "msg."k files
      if k = "last" then iterate i
      if k > high then high = k
      if files = "" then leave
   end
   return high



/**
*
*   Get number of messages left to read.
*
**/
GetMsgLeft: interpret "Procedure Expose" GLOBAL
   parse arg source, last

   files = showdir(source, "FILES")
/*
*   Loop over the files, and extract number of messages left to read (n)
*/
   n = 0
   do i = 1
      parse var files "msg."k files
      if k = "last" then iterate i
      if k > last then n = n + 1
      if files = "" then leave
   end
   return n




/**
*
*   Retrieve a user's record
*
**/
GetRecord: interpret "Procedure Expose" GLOBAL "Tmp."
   succ = 0
   if open("fi", BBSusers"/"Tmp.Account) then do
      t = readln("fi")
      if t ~= "" then do
         parse var t Tmp.Password  '|' Tmp.Access   '|' ,
                     Tmp.Name      '|' Tmp.Address  '|' ,
                     Tmp.City      '|' Tmp.Country  '|' ,
                     Tmp.Telephone '|' Tmp.MsgCount '|' ,
                     Tmp.MailCount '|' Tmp.Protocol '|'
         succ = 1
      end
      call close("fi")
   end
   return succ



/**
*
*   This gets a yes/no decision from stdin
*   The single argument is used as the prompt.
*
**/
GetYesNo: interpret "Procedure Expose" GLOBAL
   parse arg prompt

   do i = 1
      ss = upper(GetCommand(prompt" [Yes/No]: ", 1))
      if      substr(ss, 1, 1) = 'Y' then return 1
      else if substr(ss, 1, 1) = 'N' then return 0
      else do
         say "A Yes or No was expected, retry"
      end
   end
   return



/**
*
*   List supported commands. Can be as extensive as you want.
*
**/
HelpList: interpret "Procedure Expose" GLOBAL
   parse arg s

   if s ~= "" then say "Unknown command: "s

   Say "Supported commands are: "
   Say "-------------------------+-------------------------------------"
   Say "DOWNLOAD [filename]      | Download a file [called filename]"
   Say "ENTER                    | Enter a message"

   if CurrentUser.Access >= 5 then
   Say "*EXIT                    | Exit the BBS program"

   Say "HELP                     | Display this list"
   Say "LIST                     | List downloadable files"
   Say "LOGOFF                   | Logoff"
   Say "MAIL                     | Go to mail subsytem"
   Say "PASSWORD                 | Set new password"
   Say "PROTOCOL [n]             | Set new transfer protocol [to n]"
   Say "READ [message]           | Read messages [starting at message]"

   if CurrentUser.Access >= 5 then
   Say "*REGISTER                | Add a new user to the system"

   Say "SHOW [name]              | Show current record [of user ""name""]"

   if CurrentUser.Access >= 5 then
   Say "*SYSTEM                  | Change to system command level"

   Say "UPLOAD [filename]        | Upload a file [called filename]"
   Say "USERS                    | Show the user list"

   if CurrentUser.Access >= 5 then
   Say "*VALIDATE [user] [level] | Validate a new user"
   Say "-------------------------+-------------------------------------"
   return



/**
*
*   List supported commands in mail.
*
**/
HelpLMail: interpret "Procedure Expose" GLOBAL
   parse arg s

   if s ~= "" then say "Unknown command: "s

   Say "Supported commands while in mail are: "
   Say "----------------+-------------------------------------"
   Say "TO              | Enter a message"
   Say "HELP            | Display this list"
   Say "QUIT            | Quit from the mail subsystem"
   Say "READ [message]  | Read messages [starting at message]"
   Say "SHOW [name]     | Show current record [of user ""name""]"
   Say "USERS           | Show the user list"
   Say "----------------+-------------------------------------"
   return



/**
*
*   List downloadable files
*
**/
ListFiles: interpret "Procedure Expose" GLOBAL
   address command "list "BBSlistings" nohead"
   return



/**
*
*   Handle logins and new registrations.
*   Argument is a user account name, so we can log ourselves back in
*   if we as a sysop have added someone else using Register().
*
**/
Login: interpret "Procedure Expose" GLOBAL
   Tmp.               = ""
   Tmp.Access         = 0
   CurrentUser.Access = 0

   do tries = 1 to 3
      Tmp.Account = upper(GetCommand("Username: ", 1))
      if Tmp.Account = "NEW" then do
         call Register("")
         return
      end
      else if GetRecord() = 0 then do
         say "Not registered."
         say "To register, use the NEW account."
      end
      else do
         s = upper(GetCommand("Password: ", 0))
         if s ~= Tmp.Password then do
            if tries < 3 then  say "Error in name or password, try again..."
            else               say "Error in name or password, logging of."
            Tmp.Access = 0
         end
         else leave tries
      end
   end

   call CopyRecord()
   if CurrentUser.Access = 2 then say "You are not yet validated"
   return



/**
*
*   Make a file header, and add it in the destination directory
*
**/
MakeFile: interpret "Procedure Expose" GLOBAL "msg."
   parse arg comm, dest, nlins
/*
*   Get list of files.
*/
   if ~open("fi", dest"/msg.last", "R") then do
      address COMMAND "echo >"dest"/msg.last 1"
      high = 0
   end
   else do
      high = readln(fi)
      close(fi)
   end
   high = high + 1

   address COMMAND "echo >"dest"/msg.last "high
/*
*   Header
*/
   msg.0 = "=========="
   msg.1 = "# "high", "date()", "time()", from "CurrentUser.Account". "
   if comm ~= "" then msg.1 = msg.1 || "Comment to "comm"."
   msg.2 = "----------"

   if ~open("fo", dest"/msg."high, "W") then do
      say "Cannot add a message right now"
      return
   end

   do i = 0 to nlins
      call writeln("fo", msg.i)
   end

   call close("fo")
   return



/**
*
*   Read mail messages.
*   One argument: the message number to start reading. This resets the
*   message pointer. This also allows you to skip to the last.
*
**/
ReadMail: interpret "Procedure Expose" GLOBAL
   parse arg nm
/*
*   If we have a message number for argument set user's message pointer
*   to just before that.
*/
   if nm ~= "" then CurrentUser.MailCount = nm - 1
/*
*   Unread mail
*/
   source = BBSmail"/"CurrentUser.Account

   n = GetMsgLeft(source, CurrentUser.MailCount)
   if n ~= 0 then say "You have "n" unread mail message"Esses(n)
   else           CurrentUser.MailCount = GetHighMsg(source)
/*
*   Message read loop
*/
   do i = 1 to n
      do k = CurrentUser.MailCount + 1
         if ~exists(source"/msg."k) then iterate k
         address command "type "source"/msg."k
         CurrentUser.MailCount = k

         do j = 1
            s = upper(GetCommand("[Quit, Again, Delete, Reply, Next = <cr>]: ", 1))
            if      abbrev("QUIT",   s, 1) then return
            else if abbrev("AGAIN",  s, 1) then do
               CurrentUser.MailCount = k - 1
               i = i - 1
            end
            else if abbrev("DELETE", s, 1) then do
               call Delete(source"/msg."k)
               say "Deleted"
               CurrentUser.MailCount = k - 1
            end
            else if abbrev("REPLY",  s, 1) then do
               if open("fi", source"/msg."k) then do
                  call readln("fi")
                  t = readln("fi")
                  parse var t dummy "from " owner ". " rest
                  call close("fi")
                  call EnterMail(k, owner)
               end
            end
            else if abbrev("NEXT",   s, 1) then nop
            else if s = ""                 then nop
            else iterate j
            iterate i
         end
      end
   end
   say "No more unread messages"
   return



/**
*
*   Read messages.
*   Two arguments: (1) the message number to start reading. This resets the
*   message pointer. This also allows you to skip to the last. (2) The
*   source directory to read from.
*
**/
ReadMsg : interpret "Procedure Expose" GLOBAL
   parse arg nm
/*
*   If we have a message number for argument set user's message pointer
*   to just before that.
*/
   if nm ~= "" then CurrentUser.MsgCount = nm - 1
/*
*   Unread regular messages
*/
   source = BBSgeneral

   n = GetMsgLeft(source, CurrentUser.MsgCount)
   if n ~= 0 then say "You have "n" unread general message"Esses(n)
   else           CurrentUser.MsgCount = GetHighMsg(source)
/*
*   Message read loop
*/
   do i = 1 to n
      do k = CurrentUser.MsgCount + 1
         if ~exists(source"/msg."k) then iterate k
         address command "type "source"/msg."k
         CurrentUser.MsgCount = k

         do j = 1
            s = upper(GetCommand("[Quit, Again, Delete, Comment, Next = <cr>]: ", 1))

            if      abbrev("QUIT",    s, 1) then return
            else if abbrev("AGAIN",   s, 1) then do
               CurrentUser.MsgCount = k - 1
               i = i - 1
            end
            else if abbrev("DELETE",  s, 1) then do
               if open("fi", source"/msg."k) then do
                  call readln("fi")
                  t = readln("fi")
                  parse var t dummy "from " owner ". " rest
                  call close("fi")
                  if owner = CurrentUser.Account then do
                     call Delete(source"/msg."k)
                     say "Deleted"
                  end
                  else do
                     say "You didn't write this message"
                     if CurrentUser.Access >= 5 then do
                        if GetYesNo("Withdraw anyway? ") = 1 then do
                           call Delete(source"/msg."k)
                           say "Deleted"
                        end
                     end
                  end
               end
            end
            else if abbrev("COMMENT", s, 1) then call EnterMsg(k, source)
            else if abbrev("NEXT",    s, 1) then nop
            else if s = ""                  then nop
            else                                 iterate j
            iterate i
         end
      end
   end
   say "No more unread messages"
   return



/**
*
*   Register a new user. The new user is immediately added to the
*   system, but his access code is 2 which doesn't allow her to
*   log in yet. The Sysop uses the Validate command to set the access
*   code to a higher level. 3 is suggested... 5 gives system privileges.
*
**/
Register: interpret "Procedure Expose" GLOBAL
   parse arg s
/*
*   If access = 0 this is a new user. If access = 5, this is called by
*   the Sysop.
*/
   if CurrentUser.Access = 0 then prefix = "Your "
   else if CurrentUser.Access < 5 then do
      call HelpList(s)
      return
   end
   else prefix = "New "
/*
*   Generate registration record
*/
   Tmp.Account   =       GetCommand(prefix"account name:         ", 1)
   if GetRecord() = 1 then do
      say "Account name already taken"
      return
   end
/*
*   Don't allow | characters in the password (security problem)
*/
   do i = 1
      u = upper(GetCommand(prefix"password:             ", 0))
      if index(u, "|") ~= 0 then say "Illegal characters in password"
      else leave i
   end

   Tmp.Password  = u
   Tmp.Name      =       GetCommand(prefix"full name:            ", 1)
   Tmp.Address   =       GetCommand(prefix"address:              ", 1)
   Tmp.City      =       GetCommand(prefix"city, zip:            ", 1)
   Tmp.Country   =       GetCommand(prefix"country and/or state: ", 1)
   Tmp.Telephone =       GetCommand(prefix"telephone number:     ", 1)
   Tmp.Protocol  = 1
   Tmp.Access    = 2
   Tmp.MsgCount  = 0
   Tmp.MailCount = 0

   say "You are:"
   say Tmp.Name
   say Tmp.Address
   say Tmp.City
   say Tmp.Country
   say Tmp.Telephone

   if GetYesNo("Correct? ") = 1 then do
      call SetRecord()

      if CurrentUser.Access = 0 then do
         say "Please give the Sysop a chance to validate you (usually < 24 hours)."
         say "Thank you for registering with this BBS."
      end
   end
   return



/**
*
*   Change a user's record
*
**/
SetRecord: interpret "Procedure Expose" GLOBAL "Tmp."
   if Tmp.Access ~= 0 then do
      t = Tmp.Password  || '|' || Tmp.Access   || '|' ||,
          Tmp.Name      || '|' || Tmp.Address  || '|' ||,
          Tmp.City      || '|' || Tmp.Country  || '|' ||,
          Tmp.Telephone || '|' || Tmp.MsgCount || '|' ||,
          Tmp.MailCount || '|' || Tmp.Protocol || '|'
      if open("fo", BBSusers"/"Tmp.Account, "W") then do
         call writeln("fo", t)
         call close("fo")
      end
   end
   else call Delete(BBSusers'/'Tmp.Account)
   return



/**
*
*   Show a user's stats.
*
**/
ShowRecord: interpret "Procedure Expose" GLOBAL
   arg username

   if username = "" then Tmp.Account = CurrentUser.Account
   else                  Tmp.Account = username
   if GetRecord() = 1 then do
      say "Account info for "Tmp.Account":"
      say Tmp.Name
      say Tmp.Address
      say Tmp.City
      say Tmp.Country
      say Tmp.Telephone
/*
*   If asking about another user, don't need to show protocol.
*   If asking about ourselves, then show current protocol, not "saved" one.
*/
      if username = "" then do
         i = CurrentUser.Protocol + 0
         say "Transfer protocol: "Protocols.i.nam
      end
   end
   else say "User "username" not found"
   return



/**
*
*   List files
*
**/
ShowUsers: interpret "Procedure Expose" GLOBAL
   address command "list "BBSusers" nohead quick"
   return



/**
*
*   Upload a new file
*
**/
UpLoad : interpret "Procedure Expose" GLOBAL
   parse arg filnam

   if filnam = "" then filnam = GetCommand("File name? ", 1)
   if exists(BBSlistings"/"filnam) then do
      say filnam" already exists!"
      return
   end

   say "Now send file "filnam

   proto = CurrentUser.Protocol + 0
   address VLT "transfer protocol external; transfer mode image"
   address VLT "xpr select "Protocols.proto.lib
   address VLT "CD "BBSlistings
   if Protocols.proto.set ~= "" then address VLT "xpr init "Protocols.proto.set
   address VLT "file receive "BBSlistings"/"filnam
/*
*   Switch back to XMODEM protocol so that we can't automatically start
*   receiving stuff.
*/
   address VLT "transfer protocol XMODEM"

   return



/**
*
*   Routine to validate FifoBBS users. Only callable by the Sysop.
*
**/
Validate: interpret "Procedure Expose" GLOBAL
   parse arg s, nam, acc .

   if CurrentUser.Access < 5 then do
      call HelpList(s)
      return
   end

   if nam = "" then Tmp.Account = GetCommand("Name: ", 1)
   else             Tmp.Account = nam

   if GetRecord() = 0 then do
      say "Unknown account"
      return
   end

   if ~exists(BBSmail"/"Tmp.Account) then call Makedir(BBSmail"/"Tmp.Account)

   if acc = "" then do
      say "Account info for "Tmp.Account":"
      say Tmp.Name
      say Tmp.Address
      say Tmp.City
      say Tmp.Country
      say Tmp.Telephone
      say "Transfer protocol: "Tmp.Protocol
      say "Access code:       "Tmp.Access

      if GetYesNo("Change access code? ") = 1 then do
         Tmp.Access = GetCommand("Enter new access code: ", 1)
         call SetRecord()
      end
   end
   else do
      Tmp.Access = acc
      call SetRecord()
   end
   return





BREAK_C:
BREAK_D:
BREAK_E:
BREAK_F:
ERROR:
FAILURE:
HALT:
IOERROR:
NOVALUE:
SYNTAX:
   say "Command returned with error"

   interpret "SIGNAL" SignalLabel

   exit 0