home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / archives / tiexplorer.zip / kermit.lsp < prev    next >
Text File  |  1986-09-22  |  108KB  |  2,628 lines
  1.  
  2. ;;; -*- Mode:COMMON-LISP; Package:KERMIT; Base:10 -*-
  3.  
  4. ;;; Copyright (c) 1981, 1982, 1983, 1984 Trustees of Columbia University, New York
  5. ;;; Copyright (c) 1986 Sperry Corporation
  6. ;;; Copyright (c) 1986 Texas Instruments Incorporated
  7.  
  8. ;;; Permission is granted to any individual or institution to copy or use this
  9. ;;;  software but not to resell it for a price in excess of its media cost.
  10.  
  11. ;;; K e r m i t  File Transfer Utility
  12. ;;;
  13. ;;; Release 1.0 9/22/86
  14.  
  15. ;;; Remember @@TTY W,132 for 1100
  16.  
  17. ;;; Global constants
  18.  
  19. (DEFCONSTANT  *ASCII-NUL*         0    "ASCII NUL")
  20. (DEFCONSTANT  *ASCII-SOH*         1    "ASCII Start of Header")
  21. (DEFCONSTANT  *ASCII-BS*          8    "ASCII back space")
  22. (DEFCONSTANT  *ASCII-TAB*         9    "ASCII tab")
  23. (DEFCONSTANT  *ASCII-LF*         10    "ASCII line feed")
  24. (DEFCONSTANT  *ASCII-FF*         12    "ASCII form feed")
  25. (DEFCONSTANT  *ASCII-CR*         13    "ASCII carriage return")
  26. (DEFCONSTANT  *ASCII-SP*         32    "ASCII space")
  27. (DEFCONSTANT  *ASCII-NS*         35    "ASCII quote")
  28. (DEFCONSTANT  *ASCII-AMP*        38    "ASCII ampersand - for 8-bit quoting")
  29. (DEFCONSTANT  *ASCII-1*          49    "ASCII 1")
  30. (DEFCONSTANT  *ASCII-N*          78    "ASCII N")
  31. (DEFCONSTANT  *ASCII-Y*          89    "ASCII Y")
  32. (DEFCONSTANT  *ASCII-TILDE*     126    "ASCII tilde - for repeat count prefixing")
  33. (DEFCONSTANT  *ASCII-DEL*       127    "ASCII delete - rubout")
  34.  
  35. (DEFCONSTANT  *LISPM-RUBOUT*    135    "LISPM rubout")
  36. (DEFCONSTANT  *LISPM-BS*        136    "LISPM backspace")
  37. (DEFCONSTANT  *LISPM-TAB*       137    "LISPM tab")
  38. (DEFCONSTANT  *LISPM-LF*        138    "LISPM linefeed")
  39. (DEFCONSTANT  *LISPM-DEL*       139    "LISPM delete")
  40. (DEFCONSTANT  *LISPM-PAGE*      140    "LISPM page")
  41. (DEFCONSTANT  *LISPM-NEWLINE*   141    "LISPM version of CRLF")
  42.  
  43. ;;; States - The letter doesn't matter as long as all are unique.
  44.  
  45. (DEFCONSTANT  *ABORT-STATE*       #\A)
  46. (DEFCONSTANT  *SBREAK-STATE*      #\B)
  47. (DEFCONSTANT  *COMPLETE-STATE*    #\C)
  48. (DEFCONSTANT  *SDATA-STATE*       #\D)
  49. (DEFCONSTANT  *EXIT-STATE*        #\E)
  50. (DEFCONSTANT  *SFILE-STATE*       #\F)
  51. (DEFCONSTANT  *SGENERIC-STATE*    #\G)
  52. (DEFCONSTANT  *RSERVER-STATE*     #\I)
  53. (DEFCONSTANT  *RCANCEL-STATE*     #\K)
  54. (DEFCONSTANT  *RFILE-STATE*       #\L)
  55. (DEFCONSTANT  *RDATA-STATE*       #\M)
  56. (DEFCONSTANT  *LOGOUT-STATE*      #\Q)
  57. (DEFCONSTANT  *RINIT-STATE*       #\R)
  58. (DEFCONSTANT  *SINIT-STATE*       #\S)
  59. (DEFCONSTANT  *SSERVER-STATE*     #\V)
  60. (DEFCONSTANT  *SEOF-STATE*        #\Z)
  61.  
  62. (DEFCONSTANT  *KERMIT-NAME*       "Explorer Kermit")
  63.  
  64. ;;; Window variables.
  65.  
  66. (DEFFLAVOR KERMIT-FRAME ()
  67.        (TV:INFERIORS-NOT-IN-SELECT-MENU-MIXIN
  68.         TV:ALIAS-FOR-INFERIORS-MIXIN
  69.         TV:BORDERED-CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER
  70.         TV:LABEL-MIXIN))
  71.  
  72. (DEFMETHOD (KERMIT-FRAME :NAME-FOR-SELECTION) ()
  73.   (SEND SELF :NAME))
  74.  
  75. (DEFVAR *KERMIT-FRAME*            ; Define the KERMIT frame
  76.      (MAKE-INSTANCE 'KERMIT-FRAME
  77.             :EDGES '(44 107 980 478)    ; left,top,right,bottom
  78.             :SAVE-BITS T
  79.             :BORDERS 2
  80.             :LABEL '(:TOP
  81.                   :CENTERED
  82.                   :STRING "Explorer Kermit - Release 1.0"
  83.                   :FONT FONTS:HIGHER-MEDFNB)
  84.             :SELECTION-SUBSTITUTE 'INFO-PANE
  85.             :PANES
  86.             '((STATUS-PANE
  87.                 TV:WINDOW
  88.                 :LABEL NIL
  89.                 :BORDERS (0 2 0 1)
  90.                 :DEEXPOSED-TYPEOUT-ACTION :PERMIT)
  91.               (INFO-PANE
  92.                 TV:WINDOW
  93.                 :LABEL NIL
  94.                 :BORDERS (0 1 0 1)
  95.                 :DEEXPOSED-TYPEOUT-ACTION :PERMIT)
  96.               (MENU-PANE
  97.                 TV:COMMAND-MENU
  98.                 :BORDERS (0 1 0 0)
  99.                 :ROWS 1
  100.                 :COLUMNS 3
  101.                 :ITEM-LIST
  102.                 (("Abort"
  103.                   :VALUE "Z"
  104.                   :DOCUMENTATION "Abort the current operation.")
  105.                  ("Abort-Save"
  106.                   :VALUE "S"
  107.                   :DOCUMENTATION "Abort the current operation but save the file.")
  108.                  ("End"
  109.                   :VALUE "E"
  110.                   :DOCUMENTATION "Exit Kermit (valid only if an operation is complete)."))))
  111.             :CONSTRAINTS
  112.             '((MAIN . ((STATUS-PANE INFO-PANE MENU-PANE)
  113.                    ((STATUS-PANE 5 :LINES))
  114.                    ((MENU-PANE 3 :LINES))
  115.                    ((INFO-PANE :EVEN)))))))
  116.  
  117. (DEFVAR *STATUS-WINDOW* (SEND *KERMIT-FRAME* :GET-PANE 'STATUS-PANE))
  118. (DEFVAR  *INFO-WINDOW* (SEND *KERMIT-FRAME* :GET-PANE 'INFO-PANE))
  119.  
  120. ;;; Global variables - If values of these are changed, change in CHANGE-KERMIT-PARAMETERS function also
  121.  
  122. (DEFVAR  *RARG1*          ""             "Receive argument for interactive KERMIT CVV")
  123. (DEFVAR  *RARG2*          ""             "Receive argument for interactive KERMIT CVV")
  124. (DEFVAR  *SARG1*          ""             "Send argument for interactive KERMIT CVV")
  125. (DEFVAR  *SARG2*          ""             "Send argument for interactive KERMIT CVV")
  126. (DEFVAR  *CARG1*          ""             "Command argument for interactive KERMIT CVV")
  127. (DEFVAR  *CARG2*          ""             "Command argument for interactive KERMIT CVV")
  128.  
  129. (DEFVAR  *IMAGE*          NIL            "T means 8-bit mode - NIL means 7-bit mode")
  130. (DEFVAR  *DEBUG*          NIL            "T means print debugging information")
  131. (DEFVAR  *MORE*           NIL            "T means enable **MORE** in kermit window")
  132. (DEFVAR  *LOGFILE*        NIL            "If a filename specified, log info to a file")
  133. (DEFVAR  *FILNAMCNV*      T              "T means convert filename to name.type - NIL means don't convert file names")
  134. (DEFVAR  *SAVEFILES*      NIL            "T means save partially received file if xfer interrupted - NIL means delete")
  135. (DEFVAR  *MYMAXTRY*       10             "Times to retry a packet")
  136. (DEFVAR  *MYMAXPACSIZ*    94             "Maximum packet size")
  137. (DEFVAR  *MYTIME*         10             "Seconds after which I should be timed out")
  138. (DEFVAR  *MYPAD*          0              "Number of padding characters I will need - I don't need any!")
  139. (DEFVAR  *MYPADCHAR*      0              "Padding character I need - none")
  140. (DEFVAR  *MYEOL*          *ASCII-CR*     "End-Of-Line character")
  141. (DEFVAR  *MYQUOTE*        *ASCII-NS*     "Quote character I will use")
  142.  
  143. ;;; Macro Definitions:
  144.  
  145. (DEFSUBST TOCHAR (ch)
  146.   "converts a control character to a printable one by adding a space"
  147.   (+ ch *ASCII-SP*))
  148.  
  149. (DEFSUBST UNCHAR (ch)
  150.   "undoes TOCHAR by subtracting a space"
  151.   (- ch *ASCII-SP*))
  152.  
  153. (DEFSUBST CTL (ch)
  154.   "converts between control characters and printable characters by toggling
  155. the control bit (ie. ^A becomes A and A becomes ^A). #b1000000 is #o100."
  156.   (LOGXOR ch #b1000000))
  157.  
  158. (DEFSUBST COMPUTE-FINAL-CHECKSUM (NUM)
  159.   "Compute final checksum by folding in bits 7 and 8.  #b11000000 is #o300, #b111111 is #o077."
  160.   (LOGAND (+ (LSH (LOGAND NUM #b11000000) -6) NUM) #b111111))
  161.  
  162. (DEFSUBST CONVERT-FROM-ASCII (ch)
  163.   "Function to convert some characters from ASCII to Lisp."
  164.   (COND
  165.      ((OR
  166.        (AND (> ch *ASCII-CR*) (< ch  *ASCII-DEL*))
  167.        (AND (> ch *ASCII-DEL*) (< ch 256)))
  168.        ch)
  169.     ((= ch *ASCII-CR*)   *LISPM-NEWLINE*)
  170.     ((= ch *ASCII-TAB*)  *LISPM-TAB*)
  171.     ((= ch *ASCII-LF*)   *LISPM-LF*)
  172.     ((= ch *ASCII-FF*)   *LISPM-PAGE*)
  173.     ((= ch *ASCII-DEL*)  *LISPM-RUBOUT*)
  174.     ((= ch *ASCII-BS*)   *LISPM-BS*)
  175.     (T (IF (OR (< ch 0) (> ch 255))
  176.        NIL ch))))
  177.  
  178. (DEFSUBST CONVERT-TO-ASCII (ch)
  179.   "Function to convert characters from Lisp to ASCII.  Converts any appropriate
  180. control characters but maps the unimportant control chars to NIL."
  181.   (COND
  182.      ((<= ch *ASCII-DEL*)        ch)
  183.     ((= ch *LISPM-BS*)          *ASCII-BS*)
  184.     ((= ch *LISPM-TAB*)         *ASCII-TAB*)
  185.     ((= ch *LISPM-LF*)          *ASCII-LF*)
  186.     ((= ch *LISPM-PAGE*)        *ASCII-FF*)
  187.     ((= ch *LISPM-NEWLINE*)     *ASCII-CR*)
  188.     ((= ch *LISPM-RUBOUT*)      *ASCII-DEL*)
  189.     (T                          NIL)))
  190.  
  191.  
  192.  
  193. (DEFUN INTERACTIVE-KERMIT (&OPTIONAL STREAM (EXECUTE T))
  194.   "Produce a selection menu.  If EXECUTE is non-nil, call KERMIT;
  195. otherwise, return a form that can be EVALed to call KERMIT."
  196.   (LET*
  197.     ((SELECTION
  198.         (TV:MENU-CHOOSE
  199.      '(
  200.        ("Get File(s)     "
  201.         :VALUE (:GET "Get File(s)"
  202.              ((*RARG1* "Remote File Name   "
  203.                    :DOCUMENTATION "File(s) to transfer from the remote Kermit server." :STRING)
  204.               (*RARG2* "New Local File Name"
  205.                    :DOCUMENTATION "Name to give to the transferred file(s)." :STRING)))
  206.         :DOCUMENTATION "Transfer file(s) from a remote Kermit in server mode.")
  207.        ("Receive File(s) "
  208.         :VALUE (:RECEIVE "Receive File(s)"
  209.                  ((*RARG1* "New Local File Name"
  210.                        :DOCUMENTATION "Local name to give to the received file(s)." :STRING)))
  211.         :DOCUMENTATION "Wait for the arrival of file(s) transferred by a remote Kermit executing a Send command.")
  212.        ("Send File(s)    "
  213.         :VALUE (:SEND "Send File(s)"
  214.               ((*SARG1* "Local File Name     "
  215.                     :DOCUMENTATION "Local file(s) to transfer to the remote Kermit." :STRING)
  216.                (*SARG2* "New Remote File Name"
  217.                     :DOCUMENTATION "Name to give to the transferred file(s) on the remote host." :STRING)))
  218.         :DOCUMENTATION "Transfer file(s) to a remote Kermit in Server mode or executing a Receive command.")
  219.        (""
  220.         :NO-SELECT nil)
  221.        ("Bye             "
  222.         :VALUE (:BYE)
  223.         :DOCUMENTATION "Shut down and logout a remote Kermit server.")
  224.        ("Finish          "
  225.         :VALUE (:FINISH)
  226.         :DOCUMENTATION "Shut down a remote Kermit server without logging out the remote job.")
  227.        (""
  228.         :NO-SELECT nil)
  229.        ("Set Parameters  "
  230.         :VALUE (:SET)
  231.         :DOCUMENTATION "Modify local Kermit operating parameters.")
  232.        (""
  233.         :NO-SELECT nil)
  234.        ("Begin Logging   "
  235.         :VALUE (:LOG-BEGIN "Begin Logging to File"
  236.                      ((*CARG1* "Log File Pathname"
  237.                            :DOCUMENTATION "Pathname used to write logging information." :STRING)))
  238.         :DOCUMENTATION "Begin logging local Kermit actions to a file.")
  239.        ("End Logging     "
  240.         :VALUE (:LOG-END)
  241.         :DOCUMENTATION "End logging local Kermit actions to a file.")
  242.        (""
  243.         :NO-SELECT nil)
  244.        ("Server Mode     "
  245.         :VALUE (:SERVER)
  246.         :DOCUMENTATION "Place local Kermit in server mode.")
  247.        (""
  248.         :NO-SELECT nil)
  249.        ("Remote Copy     "
  250.         :VALUE (:REMOTE-COPY "Remote Copy"
  251.                  ((*CARG1* "File Name     "
  252.                        :DOCUMENTATION "File to copy on the remote KERMIT server." :STRING)
  253.                   (*CARG2* "File Copy Name"
  254.                        :DOCUMENTATION "Name to give to the copy file." :STRING)))
  255.         :DOCUMENTATION "Copy the specified file to another location on a remote KERMIT server.")
  256.        ("Remote CWD      "
  257.         :VALUE (:REMOTE-CWD "Remote Change Working Directory"
  258.                 ((*CARG1* "New Remote Directory"
  259.                       :DOCUMENTATION "New working directory pathname for the remote Kermit server."
  260.                       :STRING)))
  261.         :DOCUMENTATION "Change the working directory of a remote Kermit server.")
  262.        ("Remote Delete   "
  263.         :VALUE (:REMOTE-DELETE "Remote Delete File"
  264.                    ((*CARG1* "Remote File Name"
  265.                          :DOCUMENTATION "Name of file to delete on remote Kermit server." :STRING)))
  266.         :DOCUMENTATION "Delete a file on a remote Kermit server.")
  267.        ("Remote Directory"
  268.         :VALUE (:REMOTE-DIRECTORY "Remote Directory"
  269.                       ((*CARG1* "Remote Directory"
  270.                         :DOCUMENTATION "Directory pathname for remote Kermit server." :STRING)))
  271.         :DOCUMENTATION "Display names of files in directory on remote Kermit server.")
  272.        ("Remote Help     "
  273.         :VALUE (:REMOTE-HELP "Remote Help"
  274.                  ((*CARG1* "Help Topic"
  275.                        :DOCUMENTATION "Optional topic on which to obtain help." :STRING)))
  276.         :DOCUMENTATION "Display a list of remote KERMIT server help commands.")
  277.        ("Remote Host     "
  278.         :VALUE (:REMOTE-HOST "Remote Host"
  279.                  ((*CARG1* "Host Command"
  280.                        :DOCUMENTATION "Command to pass to the remote host." :STRING)))
  281.         :DOCUMENTATION "Pass the given command to the remote KERMIT server host for processing.
  282. The command must be in the remote KERMIT server host's own command level syntax.")
  283.        ("Remote Kermit   "
  284.         :VALUE (:REMOTE-KERMIT "Remote Kermit"
  285.                    ((*CARG1* "Kermit Command"
  286.                          :DOCUMENTATION "Command to pass to the remote KERMIT server." :STRING)))
  287.         :DOCUMENTATION "Pass the given command to the remote KERMIT server for execution.
  288. The command must be in the remote KERMIT server's own interactive mode syntax.")
  289.        ("Remote Rename   "
  290.         :VALUE (:REMOTE-RENAME "Remote Rename File"
  291.                    ((*CARG1* "File Name    "
  292.                          :DOCUMENTATION "File to rename on the remote KERMIT server." :STRING)
  293.                     (*CARG2* "New File Name"
  294.                          :DOCUMENTATION "New name to give to the file." :STRING)))
  295.         :DOCUMENTATION "Rename the specified file on a remote KERMIT server.")
  296.        ("Remote Set      "
  297.         :VALUE (:REMOTE-SET "Remote Set Parameter"
  298.                 ((*CARG1* "Parameter"
  299.                       :DOCUMENTATION "Name of parameter to set on remote KERMIT server." :STRING)
  300.                  (*CARG2* "Value    "
  301.                       :DOCUMENTATION "New value to give to the parameter." :STRING)))
  302.         :DOCUMENTATION "Set a parameter to a given value on a remote KERMIT server.")
  303.        ("Remote Show     "
  304.         :VALUE (:REMOTE-SHOW "Remote Show Parameter"
  305.                   ((*CARG1* "Parameter"
  306.                         :DOCUMENTATION "Name of parameter to query on remote KERMIT server." :STRING)))
  307.         :DOCUMENTATION "Obtain the value of a parameter on a remote KERMIT server.")
  308.        ("Remote Space    "
  309.         :VALUE (:REMOTE-SPACE "Remote Disk Space"
  310.                   ((*CARG1* "Remote Directory"
  311.                         :DOCUMENTATION "Remote directory pathname." :STRING)))
  312.         :DOCUMENTATION "Display information about disk usage for a directory on remote Kermit server.")
  313.        ("Remote Type     "
  314.         :VALUE (:REMOTE-TYPE "Remote File Type"
  315.                  ((*CARG1* "File Name"
  316.                        :DOCUMENTATION "Name of file to list." :STRING)))
  317.         :DOCUMENTATION "Display the specified filename from a remote KERMIT server."))
  318.      "KERMIT OPERATIONS"
  319.      '(:POINT 500 400)))
  320.      (OPERATION (FIRST SELECTION))
  321.      (LABEL (SECOND SELECTION))
  322.      (CVV-LIST (THIRD SELECTION)))
  323.  
  324.     (WHEN CVV-LIST                ; If a cvv is required, display it
  325.       (WHEN
  326.     (*CATCH 'END-CVV            ; Setup catch - if true, we used it
  327.       (TV:CHOOSE-VARIABLE-VALUES
  328.         CVV-LIST
  329.         :NEAR-MODE '(:POINT 500 400)
  330.         :WIDTH 50
  331.         :LABEL LABEL
  332.         :MARGIN-CHOICES '("Do It" ("Quit" (*THROW 'END-CVV T))))
  333.       NIL)                    ; Return nil from entire block
  334.     (SETQ OPERATION NIL)))            ; If we returned with T, the throw was used.
  335.  
  336.     (WHEN OPERATION
  337.       (LET
  338.     ((FORM `(KERMIT ,OPERATION
  339.             :ARG1 ,(EVAL (FIRST (FIRST CVV-LIST)))
  340.             :ARG2 ,(EVAL (FIRST (SECOND CVV-LIST)))
  341.             :STREAM ,STREAM
  342.             :VERBOSEP T)))
  343.     (IF EXECUTE
  344.         (EVAL FORM)
  345.         FORM)))))
  346.  
  347.  
  348.  
  349. (DEFUN KERMIT (OPERATION &KEY ARG1 ARG2 STREAM VERBOSEP)
  350.   "Transfers files using the KERMIT protocol.
  351.  
  352. OPERATION - :GET               Transfer file(s) from a remote Kermit in server mode
  353.             :RECEIVE           Wait for the arrival of file(s) transferred by a remote Kermit executing a Send command
  354.             :SEND              Transfer file(s) to a remote KERMIT in server mode or executing a Receive command
  355.             :BYE               Shut down and logout a remote KERMIT server
  356.             :FINISH            Shut down a remote KERMIT server without logging out the remote job
  357.             :SET               Modify the local KERMIT operating parameters
  358.             :LOG-BEGIN         Begin logging local KERMIT actions to a file
  359.             :LOG-END           End logging local KERMIT actions to a file
  360.             :SERVER            Place local KERMIT in server mode
  361.             :REMOTE-COPY       Copy the specified file to another location on a remote KERMIT server
  362.             :REMOTE-CWD        Change the working directory of a remote KERMIT server
  363.             :REMOTE-DELETE     Delete a file on a remote KERMIT server
  364.             :REMOTE-DIRECTORY  Display names of files in a directory on remote KERMIT server
  365.             :REMOTE-HELP       Display a list of remote KERMIT server help commands
  366.             :REMOTE-HOST       Pass the given command to the remote KERMIT server host for processing
  367.                                (the command must be in the remote KERMIT host's own command level syntax)
  368.             :REMOTE-KERMIT     Pass the given command to the remote KERMIT server for execution
  369.                                (the command must be in the remote KERMIT's own interactive mode syntax)
  370.             :REMOTE-RENAME     Rename the specified file on a remote KERMIT server
  371.             :REMOTE-SET        Set a parameter to a given value on a remote KERMIT server
  372.             :REMOTE-SHOW       Obtain the value of a parameter on a remote KERMIT serve
  373.             :REMOTE-SPACE      Display information about disk usage for a directory on remote KERMIT server
  374.             :REMOTE-TYPE       Display the specified filename from a remote KERMIT server
  375.  
  376. :ARG1     -  Filename, directory, command or parameter
  377. :ARG2     -  New filename, destination name or parameter
  378. :STREAM   -  Serial stream to use
  379. :VERBOSEP -  T means verbose output."
  380.  
  381.   ;;; All Kermit variables that are passed between functions (but not global via DEFVAR)
  382.   ;;; are defined here and prefixed with K*
  383.  
  384.   (LET ((K*OPERATION OPERATION)            ; Action to be taken
  385.     (K*TTYFD STREAM)            ; Serial stream for I/O
  386.     (K*TTYFD-BITS NIL)            ; Number of data bits in serial stream
  387.     (K*VERBOSEP VERBOSEP)            ; T means print things on the screen
  388.     (K*STATE NIL)                ; Represents the present state of RECSW or SENDSW
  389.     (K*PCKT-NUM 0)                ; Packet number
  390.     (K*NUMTRY 0)                ; Times this packet retried
  391.     (K*SIZE 0)                ; Size of data in the buffer
  392.     (K*FILE-CHARS 0)                        ; Total number of file chars read or written
  393.     
  394.     (K*YOURMAXPACSIZ *MYMAXPACSIZ*)        ; Maximum send packet size - default to my size
  395.     (K*YOURTIME (+ 5 *MYTIME*))        ; Timeout on sends - default to longer
  396.     (K*YOURPAD 0)                ; Padding to send - assume none
  397.     (K*YOURPADCHAR 0)            ; Padding character to send - none
  398.     (K*YOUREOL *ASCII-CR*)            ; End-Of-Line character to send
  399.     (K*YOURQUOTE *ASCII-NS*)        ; Quote character in incoming data
  400.     
  401.     (K*BINQUOTE *ASCII-N*)            ; 8-bit quoting character
  402.     (K*REPEAT *ASCII-TILDE*)        ; Repeat character
  403.     
  404.     (K*SPACKET                ; Send packet buffer
  405.       (MAKE-ARRAY (* 2 *MYMAXPACSIZ*)
  406.               :TYPE 'ART-STRING
  407.               :FILL-POINTER 0))
  408.     (K*RPACKET                ; Receive packet buffer
  409.       (MAKE-ARRAY (* 2 *MYMAXPACSIZ*)
  410.               :TYPE 'ART-STRING
  411.               :FILL-POINTER 0))
  412.     (K*BUFFER                ; Local packet buffer
  413.       (MAKE-ARRAY (* 2 *MYMAXPACSIZ*)
  414.               :TYPE 'ART-STRING
  415.               :FILL-POINTER 0))
  416.     (K*ARG1LIST
  417.       (IF (LISTP ARG1)            ; Make sure ARG1 is a list
  418.           ARG1 (LIST ARG1)))
  419.     (K*ARG2LIST
  420.       (IF (LISTP ARG2)            ; Make sure ARG2 is a list
  421.           ARG2 (LIST ARG2)))
  422.     (K*FILNAM NIL)                ; Current file name
  423.     (K*RECFILNAM NIL)            ; Default pathname into which to place the received file
  424.     (K*EMPTY-PATHNAME (MAKE-PATHNAME))      ; Empty pathname used for merging
  425.     
  426.     (K*FP NIL)                ; File pointer to currently opened disk file
  427.     
  428.     (K*BUFILLPTR 0)                ; Pointer to current location in K*BUFILLBUF
  429.     (K*BUFILLBUF                ; Temporary file buffer for BUFILL to handle file input
  430.       (MAKE-ARRAY 2048                      ; Buffer size is 2 blocks
  431.               :TYPE 'ART-STRING
  432.               :FILL-POINTER 0))
  433.     
  434.     (K*IGNORE-NEXT-LINEFEED NIL)        ; Flag for ASCII conversion
  435.     (K*SEND-TO-TTY NIL)            ; Flag indicating whether to send data to TTY or file
  436.     (K*FILES-TRANSFERRED NIL)        ; List of files successfully sent or received
  437.     (K*CANCEL NIL)                ; Used to poll the keyboard to see if we should cancel xfer
  438.     (K*ABORT-REASON NIL)            ; Contains string with error
  439.     (K*PACKETS-TRANSFERRED 0)        ; Total number of packets transferred
  440.     (K*PACKETS-RETRIED 0)            ; Total number of packets retried
  441.     (K*BYTES-TRANSFERRED 0)            ; Total number of bytes transferred
  442.     (K*START-TIME 0))            ; Time at which transfer began
  443.  
  444.     (DECLARE (SPECIAL K*OPERATION K*TTYFD K*VERBOSEP K*STATE K*PCKT-NUM K*NUMTRY K*SIZE K*FILE-CHARS K*START-TIME
  445.               K*YOURMAXPACSIZ K*YOURTIME K*YOURPAD K*YOURPADCHAR K*YOUREOL K*YOURQUOTE K*EMPTY-PATHNAME
  446.               K*BINQUOTE K*REPEAT K*SPACKET K*RPACKET K*BUFFER K*ARG1LIST K*ARG2LIST K*FILNAM K*RECFILNAM
  447.               K*FP K*BUFILLBUF K*BUFILLPTR K*IGNORE-NEXT-LINEFEED K*SEND-TO-TTY K*BYTES-TRANSFERRED
  448.               K*FILES-TRANSFERRED K*CANCEL K*ABORT-REASON K*PACKETS-TRANSFERRED K*PACKETS-RETRIED))
  449.  
  450.                     ;  (CONDITION-CASE (K-ERROR)                           ; Setup error trap
  451.     (PROGN                    ; First form is the body...
  452.  
  453.       (WHEN K*VERBOSEP                    ; Setup the KERMIT output window
  454.     (INITIALIZE-STATUS-WINDOW)        ; Initialize the status window
  455.     (SEND *INFO-WINDOW* :CLEAR-WINDOW)    ; Clear the Interactive window
  456.     (SEND *KERMIT-FRAME* :SELECT))        ; Select and expose the entire frame
  457.  
  458.       (WHEN (EQL OPERATION :SET)            ; If the SET operation was specified,
  459.      (SETQ K*VERBOSEP NIL))            ; force quiet mode!
  460.  
  461.       (WHEN (NOT K*TTYFD)            ; If no stream was supplied, make one.
  462.     (SETQ K*TTYFD (SI:MAKE-SERIAL-STREAM))) ; Could use SI:*SERIAL-PORT-OWNER* ;; BAC
  463.       (SEND K*TTYFD :CLEAR-INPUT)
  464.       (SEND K*TTYFD :CLEAR-OUTPUT)
  465.       (SETQ K*TTYFD-BITS            ; Determine the number of data bits in the stream
  466.         (SEND K*TTYFD :GET :NUMBER-OF-DATA-BITS))
  467.       (SETQ K*BINQUOTE                ; Set the initial value for the 8-bit quote char
  468.         (IF *IMAGE*                ; Image mode?
  469.         (IF (= K*TTYFD-BITS 8)          ; - Yes, 8-bit?
  470.             *ASCII-Y*                   ; -- Yes, set to Y
  471.             *ASCII-AMP*)            ; -- No,  set to &
  472.         *ASCII-N*))            ; - No, set to N
  473.  
  474.       (WHEN ARG1                ; If a filename was specified,
  475.     (GET-NEXT-FILE))            ; Set K*FILNAM to the first in the list
  476.  
  477.       (UNWIND-PROTECT                ; Surround entire selection in unwind-protect
  478.       (SELECTQ OPERATION
  479.         (:SEND                    ; Send command
  480.          (IF K*FILNAM            ; Required filename specified?
  481.          (LET                           ; - Yes
  482.            ((HOST-SPECIFIED? (STRING-SEARCH ":" K*RECFILNAM))
  483.             (PATH-RECFILNAM (FS:PARSE-PATHNAME K*RECFILNAM NIL K*EMPTY-PATHNAME)))
  484.            (SETQ K*ARG1LIST
  485.              (EXPAND-WILDS K*FILNAM))    ; Expand any wildcards in the filename
  486.            (SETQ K*ARG2LIST        ; expand the transfer name list
  487.              (MAPCAR                ; Map over each of the send files
  488.                (FUNCTION            ; replacing any wildcard components
  489.                  (LAMBDA (x)
  490.                    (LET
  491.                  ((EXPANDED-PATH (DEFAULT-ONLY-WILD-PATHNAME-COMPONENTS PATH-RECFILNAM x)))
  492.                  (IF HOST-SPECIFIED?
  493.                      EXPANDED-PATH
  494.                      (SEND EXPANDED-PATH :STRING-FOR-HOST)))))
  495.                K*ARG1LIST))
  496.            (GET-NEXT-FILE)        ; Get the file to process
  497.            (SW *SINIT-STATE*))        ; - Yes, start with SINIT as initial state
  498.          (PRINTMSG "~%~A"        ; - No, setup error
  499.                (SETQ K*ABORT-REASON "No file(s) specified"))))
  500.         (:GET
  501.          (IF K*FILNAM            ; Required filename specified?
  502.          (PROGN                ; - Yes
  503.            (SETQ K*FILNAM
  504.              (CREATE-KERMIT-FILENAME K*FILNAM))    ; Make a suitable packet filename
  505.            (SW *SGENERIC-STATE* #\R K*FILNAM))    ; SGENERIC is the initial state
  506.          (PRINTMSG "~%~A"        ; - No, setup error
  507.                (SETQ K*ABORT-REASON "No file(s) specified"))))
  508.         (:RECEIVE
  509.          (SW *RINIT-STATE*))        ; Start with RINIT as initial state
  510.         (:BYE
  511.          (SW *SGENERIC-STATE* #\G "L"))    ; SGENERIC is initial state
  512.         (:FINISH
  513.          (SW *SGENERIC-STATE* #\G "F"))    ; SGENERIC is initial state
  514.         (:SET
  515.          (CHANGE-KERMIT-PARAMETERS))
  516.         (:LOG-BEGIN
  517.          (IF K*FILNAM            ; Required filename specified?
  518.          (CONDITION-CASE (ERR)        ; - Yes, try to open the logfile
  519.              (PROGN
  520.               (SETQ K*FILNAM        ; Merge the filename with the home directory
  521.                 (SEND
  522.                   (FS:MERGE-PATHNAME-DEFAULTS
  523.                 K*FILNAM
  524.                 (USER-HOMEDIR-PATHNAME))
  525.                   :STRING-FOR-PRINTING))
  526.               (SETQ *LOGFILE*        ; Try to open the file
  527.                 (OPEN K*FILNAM
  528.                   :DIRECTION :OUTPUT
  529.                   :IF-EXISTS ':NEW-VERSION
  530.                   :IF-DOES-NOT-EXIST ':CREATE)))
  531.            (ERROR            ; If unable to merge the filename or open the file
  532.             (PRINTMSG "~%~A"
  533.                   (SETQ K*ABORT-REASON
  534.                     (FORMAT NIL "~A: Error <~A> opening log file ~A"
  535.                         *KERMIT-NAME* (SEND ERR :REPORT-STRING) K*FILNAM))))
  536.            (:NO-ERROR
  537.             (MULTIPLE-VALUE-BIND (SS MM HH DY MN YR) (GET-DECODED-TIME)
  538.               (PRINTMSG "~%Begin logging at ~A:~A:~A  ~A/~A/~A  to file ~A"
  539.                 HH MM SS MN DY YR K*FILNAM))))
  540.          (PRINTMSG "~%~A"        ; - No, filename not specified
  541.                (SETQ K*ABORT-REASON "No log file name specified"))))
  542.         (:LOG-END
  543.          (IF *LOGFILE*              ; Is there an open logfile?
  544.          (PROGN                ; - Yes
  545.            (MULTIPLE-VALUE-BIND (SS MM HH DY MN YR) (GET-DECODED-TIME)
  546.              (PRINTMSG "~%End logging to file ~A at ~A:~A:~A  ~A/~A/~A~%"
  547.                    (SEND (SEND *LOGFILE* :TRUENAME) :STRING-FOR-PRINTING) HH MM SS MN DY YR))
  548.            (SEND *LOGFILE* :CLOSE)    ; Close the file
  549.            (SETQ *LOGFILE* NIL))
  550.          (PRINTMSG "~%~A"        ; - No
  551.                (SETQ K*ABORT-REASON
  552.                  (FORMAT NIL "~A: No log file was opened" *KERMIT-NAME*)))))
  553.         (:SERVER
  554.          (SW *RSERVER-STATE*))        ; RSERVER is initial state
  555.         (:REMOTE-COPY
  556.          (IF (AND K*FILNAM K*RECFILNAM)    ; Required filenames specified?
  557.          (SW *SGENERIC-STATE*        ; - Yes, SGENERIC is initial state
  558.              #\G            ; Start with G packet
  559.              (FORMAT NIL "K~C~A~C~A"    ; Setup data packet
  560.                  (TOCHAR (LENGTH K*FILNAM)) K*FILNAM
  561.                  (TOCHAR (LENGTH K*RECFILNAM)) K*RECFILNAM))
  562.          (PRINTMSG "~%~A"        ; - No, setup error
  563.                (SETQ K*ABORT-REASON "Both files must be specified"))))
  564.         (:REMOTE-CWD
  565.          (SW *SGENERIC-STATE*        ; SGENERIC is initial state
  566.          #\G                ; Start with G packet
  567.          (FORMAT NIL "C~C~A"        ; Setup data packet
  568.              (TOCHAR (LENGTH K*FILNAM)) K*FILNAM)))
  569.         (:REMOTE-DELETE
  570.          (IF K*FILNAM            ; Required filename specified?
  571.          (SW *SGENERIC-STATE*        ; - Yes, SGENERIC is initial state
  572.              #\G            ; Start with G packet
  573.              (FORMAT NIL "E~C~A"    ; Setup data packet
  574.                  (TOCHAR (LENGTH K*FILNAM)) K*FILNAM))
  575.          (PRINTMSG "~%~A"        ; - No, setup error
  576.                (SETQ K*ABORT-REASON "No file(s) specified"))))
  577.         (:REMOTE-DIRECTORY
  578.          (IF K*FILNAM            ; Required filename specified?
  579.          (SW *SGENERIC-STATE*        ; - Yes, SGENERIC is initial state
  580.              #\G            ; Start with G packet
  581.              (FORMAT NIL "D~C~A"    ; Setup data packet
  582.                  (TOCHAR (LENGTH K*FILNAM)) K*FILNAM))
  583.          (PRINTMSG "~%~A"        ; - No, setup error
  584.                (SETQ K*ABORT-REASON "No file(s) specified"))))
  585.         (:REMOTE-HELP
  586.          (SW *SGENERIC-STATE*        ; SGENERIC is initial state
  587.          #\G                ; Start with G packet
  588.          (FORMAT NIL "H~C~A"        ; Setup data packet
  589.              (TOCHAR (LENGTH K*FILNAM)) K*FILNAM)))
  590.         (:REMOTE-HOST
  591.          (IF K*FILNAM            ; Required command specified?
  592.          (SW *SGENERIC-STATE*        ; - Yes, SGENERIC is initial state
  593.              #\C            ; Start with C packet
  594.              (FORMAT NIL "~A"        ; Setup data packet
  595.                  K*FILNAM))
  596.          (PRINTMSG "~%~A"        ; - No, setup error
  597.                (SETQ K*ABORT-REASON "No command specified"))))
  598.         (:REMOTE-KERMIT
  599.          (IF K*FILNAM            ; Required command specified?
  600.          (SW *SGENERIC-STATE*        ; - Yes, SGENERIC is initial state
  601.              #\K            ; Start with K packet
  602.              (FORMAT NIL "~A"        ; Setup data packet
  603.                  K*FILNAM))
  604.          (PRINTMSG "~%~A"        ; - No, setup error
  605.                (SETQ K*ABORT-REASON "No command specified"))))
  606.         (:REMOTE-RENAME
  607.          (IF (AND K*FILNAM K*RECFILNAM)    ; Required filenames specified?
  608.          (SW *SGENERIC-STATE*        ; - Yes, SGENERIC is initial state
  609.              #\G            ; Start with G packet
  610.              (FORMAT NIL "R~C~A~C~A"    ; Setup data packet
  611.                  (TOCHAR (LENGTH K*FILNAM)) K*FILNAM
  612.                  (TOCHAR (LENGTH K*RECFILNAM)) K*RECFILNAM))
  613.          (PRINTMSG "~%~A"        ; - No, setup error
  614.                (SETQ K*ABORT-REASON "Both files must be specified"))))
  615.         (:REMOTE-SET
  616.          (IF (AND K*FILNAM K*RECFILNAM)    ; Required parameters specified?
  617.          (SW *SGENERIC-STATE*        ; - Yes, SGENERIC is initial state
  618.              #\G            ; Start with G packet
  619.              (FORMAT NIL "V~CS~C~A~C~A"    ; Setup data packet
  620.                  (TOCHAR 1)
  621.                  (TOCHAR (LENGTH K*FILNAM)) K*FILNAM
  622.                  (TOCHAR (LENGTH K*RECFILNAM)) K*RECFILNAM))
  623.          (PRINTMSG "~%~A"        ; - No, setup error
  624.                (SETQ K*ABORT-REASON "Both variable and value must be specified"))))
  625.         (:REMOTE-SHOW
  626.          (IF K*FILNAM            ; Required parameter specified?
  627.          (SW *SGENERIC-STATE*        ; - Yes, SGENERIC is initial state
  628.              #\G            ; Start with G packet
  629.              (FORMAT NIL "V~CQ~C~A"    ; Setup data packet
  630.                  (TOCHAR 1)
  631.                  (TOCHAR (LENGTH K*FILNAM)) K*FILNAM))
  632.          (PRINTMSG "~%~A"        ; - No, setup error
  633.                (SETQ K*ABORT-REASON "Variable must be specified"))))
  634.         (:REMOTE-SPACE
  635.          (SW *SGENERIC-STATE*        ; SGENERIC is initial state
  636.          #\G
  637.          (FORMAT NIL "U~C~A"
  638.              (TOCHAR (LENGTH K*FILNAM)) K*FILNAM)))
  639.         (:REMOTE-TYPE
  640.          (IF K*FILNAM            ; Required filename specified?
  641.          (SW *SGENERIC-STATE*        ; - Yes, SGENERIC is initial state
  642.              #\G            ; Start with G packet
  643.              (FORMAT NIL "T~C~A"    ; Setup data packet
  644.                  (TOCHAR (LENGTH K*FILNAM)) K*FILNAM))
  645.          (PRINTMSG "~%~A"        ; - No, setup error
  646.                (SETQ K*ABORT-REASON "No file(s) specified"))))
  647.         (:OTHERWISE                ; Unknown command
  648.          (PRINTMSG "~%~A"
  649.                (SETQ K*ABORT-REASON "Invalid operation specified"))))
  650.     
  651.     (IF K*FP (SEND K*FP :CLOSE)))        ; No matter what happened, close any opened file
  652.  
  653.       (WHEN K*VERBOSEP                    ; When not in quiet mode
  654.     (PRINTMSG "~%KERMIT operation ~A ~A."
  655.           OPERATION
  656.           (IF K*ABORT-REASON "failed" "succeeded"))
  657.     (WHEN K*FILES-TRANSFERRED
  658.       (PRINTMSG "~%Files transferred: ~A." K*FILES-TRANSFERRED))
  659.     (PRINTMSG "~%Press any key or click on END to continue.")
  660.     (SEND *INFO-WINDOW* :CLEAR-INPUT)    ; Clear the input buffer
  661.     (SEND *INFO-WINDOW* :ANY-TYI)           ; Wait for a keypress or mouse blip
  662.     (SEND *KERMIT-FRAME* :BURY))            ; Bury the Interactive window
  663.  
  664.       (IF K*ABORT-REASON
  665.       (VALUES NIL K*FILES-TRANSFERRED K*ABORT-REASON)
  666.       (VALUES T   K*FILES-TRANSFERRED NIL)))
  667.  
  668.                         ; (ERROR
  669.                         ;  (PRINTMSG "~%~%ERROR: ~A" (SEND K-ERROR :REPORT-STRING))
  670.                         ;  (SIGNAL-CONDITION K-ERROR)))
  671.     ))
  672.  
  673.  
  674.  
  675. (DEFUN SW (STATE &OPTIONAL SPACK-TYPE SPACK-DATA)
  676.   "This is the state table switcher for transferring files.  It loops until
  677. either it finishes, or an error is encountered.  The routines called by
  678. this function are responsible for returning a new state."
  679.  
  680.   (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*NUMTRY K*OPERATION K*VERBOSEP K*CANCEL
  681.             K*FP K*ABORT-REASON))
  682.  
  683.   (SETQ K*STATE STATE)                ; Initialize the start state
  684.   (SETQ K*CANCEL NIL)
  685.   (SETQ K*PCKT-NUM 0)                ; Initialize the packet number
  686.   (SETQ K*NUMTRY 0)                ; Say no tries yet
  687.  
  688.   (LOOP
  689.     UNTIL (NOT K*STATE)
  690.     DO
  691.  
  692.     (WHEN *DEBUG*
  693.       (PRINTMSG "~%Function SW in state ~C" K*STATE))
  694.  
  695.     (WHEN (>= K*NUMTRY *MYMAXTRY*)
  696.       (PRINTMSG "~%~A"
  697.         (SETQ K*ABORT-REASON        ; Save the error
  698.               (FORMAT NIL "~A: No valid packet received after ~A retries." *KERMIT-NAME* K*NUMTRY)))
  699.       (SETQ K*STATE *ABORT-STATE*)
  700.       (SETQ K*NUMTRY 0))
  701.  
  702.     (WHEN (AND K*VERBOSEP (NOT K*CANCEL))    ; When verbose and not already cancelled
  703.       (SETQ K*CANCEL
  704.         (SEND *INFO-WINDOW* :ANY-TYI-NO-HANG))    ; Get a char from the io buffer
  705.       (IF                    ; Command menu blip?
  706.     (AND
  707.       (CONSP K*CANCEL)
  708.       (EQ (FIRST K*CANCEL) :MENU))
  709.     (PROGN                    ; - Yes
  710.       (SETQ K*CANCEL
  711.         (GET (SECOND K*CANCEL) :VALUE))    ; Set the value of K*CANCEL
  712.       (IF (STRING-EQUAL K*CANCEL "E")       ; End requsted?
  713.           (PROGN                            ; -- Yes
  714.         (SETQ K*CANCEL NIL)             ; Reset K*CANCEL
  715.         (PRINTMSG "~%~A: END not valid here; ABORT or ABORT-SAVE first." *KERMIT-NAME*))
  716.           (PRINTMSG "~%~A"                  ; -- No,
  717.               (SETQ K*ABORT-REASON    ; Save the error
  718.                 (FORMAT NIL "~A: User requested cancellation." *KERMIT-NAME*)))))
  719.     (SETQ K*CANCEL NIL)))            ; - No
  720.  
  721.     (SETQ K*STATE
  722.       (SELECT K*STATE
  723.         (*RDATA-STATE*        (RDATA))
  724.         (*SDATA-STATE*        (SDATA))
  725.         (*RINIT-STATE*        (RINIT))
  726.         (*SINIT-STATE*        (SINIT))
  727.         (*RFILE-STATE*        (RFILE))
  728.         (*SFILE-STATE*        (SFILE))
  729.         (*SEOF-STATE*         (SEOF))
  730.         (*SBREAK-STATE*       (SBREAK))
  731.         (*SGENERIC-STATE*     (SGENERIC SPACK-TYPE SPACK-DATA))
  732.         (*SSERVER-STATE*      (SSERVER))
  733.         (*RSERVER-STATE*      (RSERVER))
  734.         (*COMPLETE-STATE*     (IF (EQL K*OPERATION :SERVER) *RSERVER-STATE* NIL))
  735.         (*RCANCEL-STATE*      (RCANCEL))
  736.         (*ABORT-STATE*        (IF K*FP (SEND K*FP :CLOSE))
  737.                   (IF (AND (EQL K*OPERATION :SERVER) (NOT K*CANCEL))
  738.                       *RSERVER-STATE*
  739.                       NIL))
  740.         (:OTHERWISE           NIL)))))
  741.  
  742.  
  743.  
  744. (DEFUN SINIT ()
  745.   "Send-Initiate function to send this host's parameters and get other side's back."
  746.   (DECLARE (SPECIAL K*YOUREOL K*STATE K*CANCEL K*PCKT-NUM K*YOURQUOTE K*ABORT-REASON K*SPACKET))
  747.   (SETQ K*PCKT-NUM 0)                ; Initialize the packet number
  748.  
  749.   (IF K*CANCEL                    ; Cancelled?
  750.       *ABORT-STATE*                ; - Yes, abort
  751.       (PROGN                    ; - No
  752.     (SETQ K*SPACKET (SPAR K*SPACKET))    ; Fill up init info packet
  753.     (SPACK #\S K*PCKT-NUM (LENGTH K*SPACKET) K*SPACKET)    ; Send an S packet with type,number,length,packet
  754.     
  755.     (MULTIPLE-VALUE-BIND (TYPE LEN NUM PACKET)
  756.         (RPACK)                ; What was the reply?
  757.       (SELECTQ TYPE                ;
  758.     
  759.         (#\Y                ; ACK...
  760.          (IF (= K*PCKT-NUM NUM)        ; Correct ACK?
  761.          (PROGN                ; - Yes
  762.            (RPAR PACKET LEN)        ; Get other side's init info
  763.            (INCREMENT-PACKET-NUMBER)    ; Bump packet count
  764.            *SFILE-STATE*)        ; OK, switch to SFILE-STATE
  765.          K*STATE))            ; - No, stay in same K*STATE
  766.     
  767.         (#\N                ; NAK
  768.          (INCREMENT-RETRIES)        ; Increment the retries
  769.          K*STATE)                ; stay in same state and try again
  770.     
  771.         (#\E                ; Error packet received
  772.          (PRINTMSG "~%~A"
  773.                (SETQ K*ABORT-REASON    ; Save the error
  774.                  (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET)))
  775.          *ABORT-STATE*)
  776.     
  777.         (NIL                ; No packet received - timeout
  778.          (INCREMENT-RETRIES)        ; Increment the retries
  779.          K*STATE)                ; and try again
  780.     
  781.         (:OTHERWISE                ; Received unknown packet - abort
  782.          (PRINTMSG "~%~A"
  783.                (SETQ K*ABORT-REASON    ; Save the error
  784.                  (FORMAT NIL "~A: Received unknown packet type <~A>." *KERMIT-NAME* TYPE)))
  785.          *ABORT-STATE*))))))
  786.  
  787.  
  788.  
  789. (DEFUN SFILE ()
  790.   "Send File Header."
  791.   (DECLARE (SPECIAL K*FP K*FILNAM K*RECFILNAM K*SPACKET K*STATE K*PCKT-NUM
  792.             K*CANCEL K*SIZE K*SEND-TO-TTY K*ABORT-REASON))
  793.  
  794.   (IF K*CANCEL                    ; Cancelled?
  795.       *ABORT-STATE*                ; - Yes
  796.  
  797.       (PROGN                    ; - No
  798.     (WHEN (NOT K*FP)            ; If file is not already open,
  799.       (LET ((FILNAM                ; Merge the filename with the home directory
  800.           (SEND (FS:MERGE-PATHNAME-DEFAULTS
  801.               K*FILNAM
  802.               (USER-HOMEDIR-PATHNAME))
  803.             :STRING-FOR-PRINTING)))
  804.         (WHEN *DEBUG*            ; Print debugging info
  805.           (PRINTMSG "~%Opening ~A for sending." FILNAM))
  806.     
  807.         (CONDITION-CASE (ERR)
  808.         (SETQ K*FP            ; Try to open the file
  809.               (OPEN FILNAM))
  810.           (ERROR                ; Error in opening?
  811.            (PRINTMSG "~%~A"            ; Print error
  812.              (SETQ K*ABORT-REASON
  813.                    (FORMAT NIL "~A: Error <~A> opening file ~A."
  814.                        *KERMIT-NAME* (SEND ERR :REPORT-STRING) FILNAM)))
  815.            (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)    ; Send E packet
  816.            (SETQ K*FP NIL)))))        ; Be sure the pointer is not set
  817.     
  818.     (IF (NOT K*FP)                ; Did we get an error opening the file?
  819.         *ABORT-STATE*            ; - Yes, abort
  820.         (PROGN                        ; - No, setup the filename to send
  821.           (SETQ K*RECFILNAM
  822.             (IF K*SEND-TO-TTY           ; Send to the other KERMIT'S tty?
  823.             ""                      ; - Yes, don't worry about any transfer name
  824.             (CREATE-KERMIT-FILENAME ; - No, convert the transfer name
  825.               (IF K*RECFILNAM    ; Was a transfer filename specified?
  826.                   K*RECFILNAM    ; -- Yes, use it
  827.                   (SEND               ; -- No, use the true open file name
  828.                 (SEND K*FP :TRUENAME)
  829.                 :STRING-FOR-PRINTING)))))
  830.           (SETQ K*SIZE (ENCODE-PREFIXED-DATA K*RECFILNAM K*SPACKET))
  831.           (INITIALIZE-STATUS-COUNTS)    ; Reset the timing info
  832.           (PRINT-STATUS-FILE-INFO)        ; update the filenames on the screen
  833.           (PRINTMSG "~%Sending data...")
  834.           (IF K*SEND-TO-TTY            ; Are we sending to other KERMIT's TTY?
  835.           (SPACK #\X K*PCKT-NUM K*SIZE K*SPACKET)    ; - Yes, send an X packet
  836.           (SPACK #\F K*PCKT-NUM K*SIZE K*SPACKET))    ; - No, send an F packet
  837.     
  838.           (MULTIPLE-VALUE-BIND (TYPE IGNORE NUM PACKET)
  839.           (RPACK)            ; What was the reply?
  840.         (SELECTQ TYPE
  841.         
  842.           (#\Y                ; ACK
  843.            (IF (= NUM K*PCKT-NUM)    ; See if it's correct ACK
  844.                (PROGN            ; - Yes,
  845.              (INCREMENT-PACKET-NUMBER)    ; Increment the packet count
  846.              (SETQ K*SIZE
  847.                    (BUFILL K*SPACKET K*FP))    ; Get first data from file
  848.              *SDATA-STATE*)        ; Switch to DATA-STATE
  849.                K*STATE))        ; - No, stay in same K*STATE
  850.         
  851.           (#\N                ; NAK
  852.            (IF (= (IF (> NUM 0 ) (1- NUM) 63)    ; See if this is a NAK for the previous packet
  853.               K*PCKT-NUM)
  854.                (PROGN            ; - Yes, so treat it as an ACK
  855.              (INCREMENT-PACKET-NUMBER)    ; Increment the packet count
  856.              (SETQ K*SIZE
  857.                    (BUFILL K*SPACKET K*FP))    ; Get first data from file
  858.              *SDATA-STATE*)        ; Switch to SDATA-STATE
  859.                (PROGN            ; - No,
  860.              (INCREMENT-RETRIES)    ; increment the retries
  861.              K*STATE)))        ; Remain in same K*STATE
  862.         
  863.           (#\E                ; Error packet received
  864.            (SETQ K*ABORT-REASON        ; Save the error
  865.              (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET))
  866.            (PRINTMSG "~%~A" K*ABORT-REASON)
  867.            *ABORT-STATE*)
  868.         
  869.           (NIL                ; Timeout
  870.            (INCREMENT-RETRIES)        ; Increment the retries
  871.            K*STATE)            ; Remain in same K*STATE
  872.         
  873.           (:OTHERWISE            ; Unknown packet - abort
  874.            (PRINTMSG "~%~A"
  875.                  (SETQ K*ABORT-REASON    ; Save the error
  876.                    (FORMAT NIL "~A: Received unknown packet type <~A>." *KERMIT-NAME* TYPE)))
  877.            *ABORT-STATE*))))))))
  878.  
  879.  
  880.  
  881. (DEFUN SDATA ()
  882.   "Send File Data."
  883.   (DECLARE (SPECIAL K*FP K*STATE K*PCKT-NUM K*SIZE K*CANCEL K*SPACKET K*ABORT-REASON))
  884.   (SPACK #\D K*PCKT-NUM K*SIZE K*SPACKET)    ; Send a D packet
  885.   (COUNT-AND-PRINT-PACKETS K*SIZE)            ; Keep track of packet totals
  886.  
  887.   (MULTIPLE-VALUE-BIND (TYPE IGNORE NUM PACKET)
  888.       (RPACK)                    ; What was the reply?
  889.     (SELECTQ TYPE
  890.  
  891.       (#\Y                    ; ACK
  892.        (IF (= NUM K*PCKT-NUM)            ; See if it's correct ACK
  893.        (PROGN                ; - Yes,
  894.          (INCREMENT-PACKET-NUMBER)        ; Increment the packet count
  895.          (SETQ K*SIZE
  896.            (BUFILL K*SPACKET K*FP))          ; Get more data from the file
  897.          (IF (OR (ZEROP K*SIZE) K*CANCEL)    ; EOF or cancel flag?
  898.          *SEOF-STATE*            ; -- Yes, switch to SEOF-STATE
  899.          *SDATA-STATE*))        ; -- No, stay in SDATA-STATE
  900.        (PROGN                ; - No
  901.          (INCREMENT-RETRIES)        ; Increment the retries
  902.          K*STATE)))                ; Stay in same K*STATE
  903.  
  904.       (#\N                    ; NAK
  905.        (IF (= (IF (> NUM 0 ) (1- NUM) 63)    ; See if it's a NAK for last packet
  906.           K*PCKT-NUM)
  907.        (PROGN                ; - Yes, treat as ACK
  908.          (INCREMENT-PACKET-NUMBER)        ; Increment the packet count
  909.          (SETQ K*SIZE
  910.            (BUFILL K*SPACKET K*FP))            ; Get more date from the file
  911.          (IF (OR (ZEROP K*SIZE) K*CANCEL)    ; EOF or cancel flag?
  912.          *SEOF-STATE*            ; -- Yes, switch to SEOF-STATE
  913.          *SDATA-STATE*))        ; -- No, stay in SDATA-STATE
  914.        (PROGN                ; - No
  915.          (INCREMENT-RETRIES)        ; Increment the retries
  916.          K*STATE)))                ; Stay in same K*STATE
  917.  
  918.       (#\E                    ; Error packet received
  919.        (PRINTMSG "~%~A"
  920.          (SETQ K*ABORT-REASON        ; Save the error
  921.                (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET)))
  922.        *ABORT-STATE*)
  923.  
  924.       (NIL                    ; Timeout
  925.        (INCREMENT-RETRIES)            ; Increment the retries
  926.        K*STATE)                    ; Remain in same K*STATE
  927.  
  928.       (:OTHERWISE                ; Unknown packet - abort
  929.        (PRINTMSG "~%~A"
  930.          (SETQ K*ABORT-REASON        ; Save the error
  931.                (FORMAT NIL "~A: Received unknown packet type <~A>." *KERMIT-NAME* TYPE)))
  932.        *ABORT-STATE*))))
  933.  
  934.  
  935.  
  936. (DEFUN SEOF ()
  937.   "Send End-Of-File."
  938.   (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*FP K*FILNAM
  939.             K*CANCEL K*ABORT-REASON))
  940.   (IF K*CANCEL                                ; Has cancellation been requested?
  941.       (SPACK #\Z K*PCKT-NUM 1 "D")        ; - Yes, send a Z packet with a D for Discard!
  942.       (SPACK #\Z K*PCKT-NUM 0 NIL))        ; - No, send a Z packet to close
  943.  
  944.   (MULTIPLE-VALUE-BIND (TYPE IGNORE NUM PACKET)
  945.       (RPACK)                    ; What was the reply?
  946.     (SELECTQ TYPE
  947.  
  948.       (#\Y                    ; ACK
  949.        (IF (= NUM K*PCKT-NUM)            ; See if it's correct ACK
  950.        (PROGN                ; - Yes
  951.          (INCREMENT-PACKET-NUMBER)        ; Increment the packet count
  952.          (PRINTMSG "~%Sending completed.")
  953.          (SEND K*FP :CLOSE)            ; Close the input file
  954.          (SETQ K*FP NIL)            ; Set flag indicating no file open
  955.          (IF (GET-NEXT-FILE)        ; Any more files?
  956.          (PROGN                ; -- Yes
  957.            (IF *DEBUG*            ; Print debugging info
  958.                (PRINTMSG "~%New file is ~A." K*FILNAM))
  959.            *SFILE-STATE*)        ; Switch to SFILE-STATE
  960.          *SBREAK-STATE*))        ; -- No, Break (EOT) and all done
  961.        (PROGN                ; - No
  962.          (INCREMENT-RETRIES)        ; Increment the retries
  963.          K*STATE)))                ; Stay in same K*STATE
  964.  
  965.       (#\N                    ; NAK
  966.        (IF (= (IF (> NUM 0 ) (1- NUM) 63)    ; See if it's a NAK for last packet
  967.           K*PCKT-NUM)
  968.        (PROGN                ; - Yes, treat as ACK
  969.          (INCREMENT-PACKET-NUMBER)        ; Increment the packet count
  970.          (PRINTMSG "~%Sending completed.")
  971.          (SEND K*FP :CLOSE)            ; Close the input file
  972.          (SETQ K*FP NIL)            ; Set flag indicating no file open
  973.          (IF (GET-NEXT-FILE)        ; Any more files?
  974.          (PROGN                ; -- Yes,
  975.            (IF *DEBUG*            ; Print debugging info
  976.                (PRINTMSG "~%New file is ~A." K*FILNAM))
  977.            *SFILE-STATE*)        ; Switch to SFILE-STATE
  978.          *SBREAK-STATE*))        ; -- No, Break (EOT) and all done
  979.        (PROGN                ; - No,
  980.          (INCREMENT-RETRIES)        ; Increment the retries
  981.          K*STATE)))                ; Stay in same K*STATE
  982.  
  983.       (#\E                    ; Error packet received
  984.        (PRINTMSG "~%~A"
  985.          (SETQ K*ABORT-REASON        ; Save the error
  986.                (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET)))
  987.        *ABORT-STATE*)
  988.  
  989.       (NIL                    ; Timeout
  990.        (INCREMENT-RETRIES)            ; Increment the retries
  991.        K*STATE)                    ; Remain in same K*STATE
  992.  
  993.       (:OTHERWISE                ; Unknown packet - abort
  994.        (PRINTMSG "~%~A"
  995.          (SETQ K*ABORT-REASON        ; Save the error
  996.                (FORMAT NIL "~A: Received unknown packet type <~A>." *KERMIT-NAME* TYPE)))
  997.        *ABORT-STATE*))))
  998.  
  999.  
  1000.  
  1001. (DEFUN SBREAK ()
  1002.   "Send Break (EOT)."
  1003.   (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*ABORT-REASON))
  1004.   (SPACK #\B K*PCKT-NUM 0 NIL)            ; Send a B packet
  1005.  
  1006.   (MULTIPLE-VALUE-BIND (TYPE IGNORE NUM PACKET)
  1007.       (RPACK)                    ; What was the reply?
  1008.     (SELECTQ TYPE
  1009.  
  1010.       (#\Y                    ; ACK
  1011.        (IF (= NUM K*PCKT-NUM)            ; See if it's correct ACK
  1012.        (PROGN                ; - Yes
  1013.          (INCREMENT-PACKET-NUMBER)        ; Increment the packet count
  1014.          *COMPLETE-STATE*)            ; Switch to COMPLETE-STATE
  1015.        (PROGN                ; - No
  1016.          (INCREMENT-RETRIES)        ; Increment the retries
  1017.          K*STATE)))                ; Stay in same K*STATE
  1018.  
  1019.       (#\N                    ; NAK
  1020.        (IF (= (IF (> NUM 0 ) (1- NUM) 63)    ; See if it's a NAK for last packet
  1021.           K*PCKT-NUM)
  1022.        (PROGN                ; - Yes, treat as ACK
  1023.          (INCREMENT-PACKET-NUMBER)        ; Increment the packet count
  1024.          *COMPLETE-STATE*)            ; Switch to COMPLETE-STATE
  1025.        (PROGN                ; - No,
  1026.          (INCREMENT-RETRIES)        ; Increment the retries
  1027.          K*STATE)))                ; Stay in same K*STATE
  1028.  
  1029.       (#\E                    ; Error packet received
  1030.        (PRINTMSG "~%~A"
  1031.          (SETQ K*ABORT-REASON        ; Save the error
  1032.                (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET)))
  1033.        *ABORT-STATE*)
  1034.  
  1035.       (NIL                    ; Timeout
  1036.        (INCREMENT-RETRIES)            ; Increment the retries
  1037.        K*STATE)                    ; Remain in same K*STATE
  1038.  
  1039.       (:OTHERWISE                ; Unknown packet - abort
  1040.        (PRINTMSG "~%~A"
  1041.          (SETQ K*ABORT-REASON        ; Save the error
  1042.                (FORMAT NIL "~A: Received unknown packet type <~A>." *KERMIT-NAME* TYPE)))
  1043.        *ABORT-STATE*))))
  1044.  
  1045.  
  1046.  
  1047. (DEFUN RINIT ()
  1048.   "Receive-Initiate function to receive other side's host's parameters and send ours back."
  1049.   (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*CANCEL K*ABORT-REASON))
  1050.   (SETQ K*PCKT-NUM 0)                ; Initialize the packet number
  1051.  
  1052.   (IF K*CANCEL                    ; Cancel?
  1053.       *ABORT-STATE*                ; - Yes, abort
  1054.       (MULTIPLE-VALUE-BIND (TYPE LEN IGNORE PACKET)    ; - No, get a packet
  1055.       (RPACK)
  1056.     (SELECTQ TYPE                ; What type was it?
  1057.     
  1058.       (#\S                    ; Send-Init
  1059.        (RPAR PACKET LEN)            ; Get other side's init info
  1060.        (SETQ PACKET (SPAR PACKET))        ; Fill up my init info packet
  1061.        (SPACK #\Y K*PCKT-NUM (LENGTH PACKET) PACKET)    ; ACK with my parameters
  1062.        (INCREMENT-PACKET-NUMBER)        ; Bump packet number
  1063.        *RFILE-STATE*)            ; OK, enter File-Receive state
  1064.     
  1065.       (#\E                    ; Error packet received
  1066.        (PRINTMSG "~%~A"
  1067.              (SETQ K*ABORT-REASON    ; Save the error
  1068.                (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET)))
  1069.        *ABORT-STATE*)
  1070.     
  1071.       (NIL                    ; Didn't get a packet
  1072.        (SPACK #\N 0 0 NIL)            ; Return a NAK
  1073.        (INCREMENT-RETRIES)            ; Increment the retries
  1074.        K*STATE)                ; and keep trying
  1075.     
  1076.       (:OTHERWISE                ; Unknown packet
  1077.        (SPACK #\N K*PCKT-NUM 0 NIL)        ; Return a NAK
  1078.        (PRINTMSG "~%~A"
  1079.              (SETQ K*ABORT-REASON    ; Save the error
  1080.                (FORMAT NIL "~A: Received unknown packet type <~A>." *KERMIT-NAME* TYPE)))
  1081.        *ABORT-STATE*)))))            ; and abort
  1082.  
  1083.  
  1084.  
  1085. (DEFUN RFILE ()
  1086.   "Receive File Header."
  1087.   (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*FP K*RECFILNAM K*CANCEL
  1088.             K*VERBOSEP K*ABORT-REASON K*EMPTY-PATHNAME))
  1089.  
  1090.   (IF K*CANCEL                    ; Cancel?
  1091.       *ABORT-STATE*                ; - Yes, abort
  1092.       (MULTIPLE-VALUE-BIND (TYPE LEN NUM PACKET)    ; - No...
  1093.       (RPACK)                ; Get a packet
  1094.     (SELECTQ TYPE                ; What was the type?
  1095.     
  1096.       (#\S                    ; Send-Init
  1097.        (IF (= NUM (IF (= K*PCKT-NUM 0)
  1098.               63
  1099.               (1- K*PCKT-NUM)))    ; See if it's previous packet
  1100.            (PROGN                ; - Yes
  1101.          (SETQ PACKET (SPAR PACKET))    ; Load in our Send-Init parameters
  1102.          (SPACK #\Y K*PCKT-NUM (LENGTH PACKET) PACKET)    ; Send the ACK packet
  1103.          (INCREMENT-RETRIES)        ; Increment the retries
  1104.          K*STATE)            ; Stay in same state
  1105.            (PROGN                ; - No,
  1106.          (PRINTMSG "~%~A"
  1107.                (SETQ K*ABORT-REASON    ; Otherwise set up error
  1108.                  (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM)))
  1109.          *ABORT-STATE*)))        ; abort
  1110.     
  1111.       (#\Z                    ; End-Of-File
  1112.        (IF (= NUM (IF (= K*PCKT-NUM 0)
  1113.               63
  1114.               (1- K*PCKT-NUM)))    ; See if it's previous packet
  1115.            (PROGN                ; - Yes
  1116.          (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Send the ACK packet
  1117.          (INCREMENT-RETRIES)        ; Increment the retries
  1118.          K*STATE)            ; Finally, stay in this K*STATE
  1119.            (PROGN                ; - No
  1120.          (PRINTMSG "~%~A"
  1121.                (SETQ K*ABORT-REASON    ; Set up error
  1122.                  (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM)))
  1123.          *ABORT-STATE*)))        ; abort
  1124.     
  1125.       (#\F                    ; File Header (just what we want)
  1126.        (IF (= NUM K*PCKT-NUM)        ; Correct packet number?
  1127.            (LET                ; - Yes
  1128.          ((FILNAM (DECODE-PREFIXED-DATA PACKET LEN))    ; Decode the packet to get the filename
  1129.           (NEWFILNAM NIL))    
  1130.          (CONDITION-CASE (ERR)
  1131.              (PROGN
  1132.               (SETQ NEWFILNAM        ; Determine the filename to use
  1133.                 (SEND
  1134.                   (FS:MERGE-PATHNAMES
  1135.                 (FS:DEFAULT-WILD-PATHNAME-COMPONENTS
  1136.                   (FS:PARSE-PATHNAME    ; Make a pathname from the transfer name
  1137.                     (IF K*RECFILNAM    ; Transfer name specified?
  1138.                     K*RECFILNAM    ; -- Yes, use it
  1139.                     "")    ; -- No, use empty-string
  1140.                     NIL
  1141.                     K*EMPTY-PATHNAME)    ; Merge with empty pathname
  1142.                   (FS:PARSE-PATHNAME
  1143.                     (CREATE-KERMIT-FILENAME FILNAM)    ; Create a suitible filename from FILNAM
  1144.                     NIL
  1145.                     K*EMPTY-PATHNAME))
  1146.                 (USER-HOMEDIR-PATHNAME))
  1147.                   :STRING-FOR-PRINTING))
  1148.               (SETQ K*FP        ; Try to open the file
  1149.                 (OPEN NEWFILNAM
  1150.                   :DIRECTION :OUTPUT
  1151.                   :IF-EXISTS ':NEW-VERSION
  1152.                   :IF-DOES-NOT-EXIST ':CREATE)))
  1153.            (ERROR
  1154.             (PRINTMSG "~%~A"        ; Print error
  1155.                   (SETQ K*ABORT-REASON
  1156.                     (FORMAT NIL "~A: Error <~A> while creating file."
  1157.                         *KERMIT-NAME* (SEND ERR :REPORT-STRING))))
  1158.             (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)
  1159.             *ABORT-STATE*)        ; abort
  1160.            (:NO-ERROR
  1161.             (INITIALIZE-STATUS-COUNTS)    ; Reset the timing info
  1162.             (PRINT-STATUS-FILE-INFO)    ; update the filenames on the screen
  1163.             (PRINTMSG "~%Receiving ~A as ~A." FILNAM NEWFILNAM)
  1164.             (SPACK #\Y K*PCKT-NUM (LENGTH NEWFILNAM) NEWFILNAM)    ; ACKnowledge the file header
  1165.             (INCREMENT-PACKET-NUMBER)    ; Bump packet count
  1166.             *RDATA-STATE*)))        ; Switch to RDATA-STATE
  1167.            (PROGN                ; - No, incorrect packet number
  1168.          (PRINTMSG "~%~A"
  1169.                (SETQ K*ABORT-REASON    ; Set up error
  1170.                  (FORMAT NIL "~A: Received incorrect S packet number <~A>." *KERMIT-NAME* NUM)))
  1171.          *ABORT-STATE*)))        ; abort
  1172.     
  1173.       (#\X                                  ; Print to TTY
  1174.        (IF (= NUM K*PCKT-NUM)        ; Correct packet number?
  1175.            (PROGN                ; - Yes
  1176.          (SETQ K*FP            ; Direct the output to the TTY
  1177.                (IF K*VERBOSEP
  1178.                *INFO-WINDOW*
  1179.                (MAKE-STRING-OUTPUT-STREAM)))
  1180.          (INITIALIZE-STATUS-COUNTS)    ; Reset the timing info
  1181.          (PRINT-STATUS-FILE-INFO)    ; update the filenames on the screen
  1182.          (PRINTMSG "~%Receiving ~A on screen.~%" PACKET)
  1183.          (SPACK #\Y K*PCKT-NUM 0 NIL)    ; ACKnowledge the file header
  1184.          (INCREMENT-PACKET-NUMBER)    ; Bump packet count
  1185.          *RDATA-STATE*)            ; Switch to RDATA-STATE
  1186.            (PROGN                ; - No
  1187.          (PRINTMSG "~%~A"
  1188.                (SETQ K*ABORT-REASON    ; Set up error
  1189.                  (FORMAT NIL "~A: Received incorrect S packet number <~A>." *KERMIT-NAME* NUM)))
  1190.          *ABORT-STATE*)))        ; abort
  1191.     
  1192.       (#\B                    ; Break transmission (EOT)
  1193.        (IF (= NUM K*PCKT-NUM)        ; Correct packet number?
  1194.            (PROGN                ; - Yes
  1195.          (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Say OK
  1196.          *COMPLETE-STATE*)        ; Switch to COMPLETE-STATE
  1197.            (PROGN                ; - No
  1198.          (PRINTMSG "~%~A"
  1199.                (SETQ K*ABORT-REASON    ; Set up error
  1200.                  (FORMAT NIL "~A: Received incorrect S packet number <~A>." *KERMIT-NAME* NUM)))
  1201.          *ABORT-STATE*)))        ; abort
  1202.     
  1203.       (#\E                    ; Error packet received
  1204.        (PRINTMSG "~%~A"
  1205.              (SETQ K*ABORT-REASON    ; Save the error
  1206.                (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET)))
  1207.        *ABORT-STATE*)
  1208.     
  1209.       (NIL                    ; Didn't get packet - timeout
  1210.        (SPACK #\N K*PCKT-NUM 0 NIL)        ; Return a NAK
  1211.        (INCREMENT-RETRIES)            ; Increment the retries
  1212.        K*STATE)                ; Stay in same K*STATE and keep trying
  1213.     
  1214.       (:OTHERWISE                ; Unknown packet - abort
  1215.        (SPACK #\N K*PCKT-NUM 0 NIL)        ; Return a NAK
  1216.        (PRINTMSG "~%~A"
  1217.              (SETQ K*ABORT-REASON    ; Save the error
  1218.                (FORMAT NIL "~A: Received unknown packet type <~A>." *KERMIT-NAME* TYPE)))
  1219.        *ABORT-STATE*)))))
  1220.  
  1221.  
  1222.  
  1223. (DEFUN RDATA ()
  1224.   "Receive Data."
  1225.   (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*CANCEL K*ABORT-REASON K*FILE-CHARS K*FP))
  1226.  
  1227.   (MULTIPLE-VALUE-BIND (TYPE LEN NUM PACKET)
  1228.       (RPACK)                    ; Get a packet
  1229.     (SELECTQ TYPE                ; What was the type?
  1230.  
  1231.       (#\D                    ; Data packet
  1232.        (IF (= NUM K*PCKT-NUM)            ; Correct packet number?
  1233.        (PROGN                ; - Yes,
  1234.          (COUNT-AND-PRINT-PACKETS LEN)    ; Keep track of packet totals
  1235.          (INCF K*FILE-CHARS (BUFEMP PACKET LEN K*FP)) ; Write the data to the file and increment total chars
  1236.          (IF K*CANCEL            ; Should the transfer be interrupted?
  1237.          (PROGN                ; -- Yes
  1238.            (SPACK #\Y K*PCKT-NUM 1 "Z")    ; Send the ACK with cancel
  1239.            (INCREMENT-PACKET-NUMBER)    ; Bump packet count
  1240.            *RCANCEL-STATE*)        ; Switch to RCANCEL-STATE
  1241.          (PROGN                ; -- No
  1242.            (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Send regular ACK
  1243.            (INCREMENT-PACKET-NUMBER)    ; Bump packet count
  1244.            *RDATA-STATE*)))        ; Remain in RDATA-STATE
  1245.        (PROGN                ; - No, wrong packet number
  1246.          (IF (= NUM (IF (= K*PCKT-NUM 0)
  1247.                 63
  1248.                 (1- K*PCKT-NUM)))    ; See if it's previous packet
  1249.          (PROGN                ; -- Yes
  1250.            (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Send an ACK
  1251.            (INCREMENT-RETRIES)        ; Increment the retries
  1252.            K*STATE)            ; Finally, stay in this K*STATE so no data will be written
  1253.          (PROGN                ; -- No
  1254.            (PRINTMSG "~%~A"
  1255.                  (SETQ K*ABORT-REASON    ; Otherwise, set up error
  1256.                    (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM)))
  1257.            *ABORT-STATE*)))))        ; abort
  1258.  
  1259.       (#\F                    ; File header
  1260.        (IF (= NUM (IF (= K*PCKT-NUM 0)
  1261.               63
  1262.               (1- K*PCKT-NUM)))        ; See if it's previous packet
  1263.        (PROGN                ; - Yes
  1264.          (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Send ACK
  1265.          (INCREMENT-RETRIES)        ; Increment the retries
  1266.          K*STATE)                ; Finally, stay in this K*STATE
  1267.        (PROGN                ; - No
  1268.          (PRINTMSG "~%~A"
  1269.                (SETQ K*ABORT-REASON    ; Otherwise, set up error
  1270.                  (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM)))
  1271.          *ABORT-STATE*)))            ; abort
  1272.  
  1273.       (#\X                    ; File header
  1274.        (IF (= NUM (IF (= K*PCKT-NUM 0)
  1275.               63
  1276.               (1- K*PCKT-NUM)))        ; See if it's previous packet
  1277.        (PROGN                ; - Yes
  1278.          (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Send ACK
  1279.          (INCREMENT-RETRIES)        ; Increment the retries
  1280.          K*STATE)                ; Finally, stay in this K*STATE
  1281.        (PROGN                ; - No
  1282.          (PRINTMSG "~%~A"
  1283.                (SETQ K*ABORT-REASON    ; Set up error
  1284.                  (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM)))
  1285.          *ABORT-STATE*)))            ; abort
  1286.  
  1287.       (#\Z                    ; End-Of-File
  1288.        (IF (= NUM K*PCKT-NUM)            ; Correct packet number?
  1289.        (PROGN                ; - Yes
  1290.          (IF (AND (> LEN 0)            ;
  1291.               (EQUAL (SUBSEQ PACKET 0 1) "D")) ; Is D specified?
  1292.          (PROGN                    ; -- Yes
  1293.            (IF (OR *SAVEFILES*          ; Should the file be saved?  e.g., is *SAVEFILES* true
  1294.                 (STRING-EQUAL K*CANCEL "S")) ; or K*CANCEL save?
  1295.                (PROGN                   ; --- Yes
  1296.              (SEND K*FP :CLOSE)    ; Close but save the file
  1297.              (PRINTMSG "~%Receive aborted - file saved."))
  1298.                (PROGN                   ; --- No
  1299.              (SEND K*FP :CLOSE T)    ; Close with abort (discard)
  1300.              (PRINTMSG "~%Receive aborted - file discarded."))))
  1301.          (PROGN                ; -- No
  1302.            (SEND K*FP :CLOSE)        ; Close the file [NOTE IF SEND-TO-TTY must save stream BAC]
  1303.            (PRINTMSG "~%Receive completed - file closed.")))
  1304.          (SETQ K*FP NIL)            ; Clear the file pointer
  1305.          (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Say OK
  1306.          (INCREMENT-PACKET-NUMBER)        ; Bump packet count
  1307.          *RFILE-STATE*)            ; Go back to Receive File K*STATE
  1308.        (PROGN                ; - No
  1309.          (PRINTMSG "~%~A"
  1310.                (SETQ K*ABORT-REASON    ; Set up error
  1311.                  (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM)))
  1312.          *ABORT-STATE*)))            ; abort
  1313.  
  1314.       (#\E                    ; Error packet received
  1315.        (PRINTMSG "~%~A"
  1316.          (SETQ K*ABORT-REASON        ; Save the error
  1317.                (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET)))
  1318.        *ABORT-STATE*)
  1319.  
  1320.       (NIL                    ; Didn't get packet - timeout
  1321.        (SPACK #\N K*PCKT-NUM 0 NIL)        ; Return a NAK
  1322.        (INCREMENT-RETRIES)            ; Increment the retries
  1323.        K*STATE)                    ; Stay in same K*STATE and keep trying
  1324.  
  1325.       (:OTHERWISE                ; Unknown packet - abort
  1326.        (PRINTMSG "~%~A"
  1327.          (SETQ K*ABORT-REASON        ; Save the error
  1328.                (FORMAT NIL "~A: Received unknown packet type <~A>." TYPE)))
  1329.        (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)    ; Send an error packet
  1330.        *ABORT-STATE*))))
  1331.  
  1332.  
  1333.  
  1334. (DEFUN RCANCEL ()
  1335.   "We cancelled receive - now send an ERROR packet when we get a DATA packet."
  1336.   (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*CANCEL K*ABORT-REASON K*FP))
  1337.  
  1338.   (MULTIPLE-VALUE-BIND (TYPE LEN NUM PACKET)
  1339.       (RPACK)                    ; Get a packet
  1340.     (SELECTQ TYPE                ; What was the type?
  1341.  
  1342.       (#\D                    ; Data packet
  1343.        (IF (= NUM K*PCKT-NUM)            ; Correct packet number?
  1344.        (PROGN                ; - Yes
  1345.          (SEND K*FP :CLOSE T)        ; Close with abort (discard)
  1346.          (PRINTMSG "~%Receive aborted - file discarded")
  1347.          (SETQ K*FP NIL)            ; Clear the file pointer
  1348.          (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)    ; Send an error packet
  1349.          (INCREMENT-PACKET-NUMBER)        ; Bump packet count
  1350.          (IF K*CANCEL                 ; Cancel all further transfers? (really not valid, since only Z supported)
  1351.          *ABORT-STATE*            ; -- Yes, abort
  1352.          (PROGN                ; -- No
  1353.            (SETQ K*CANCEL NIL)        ; Reset K*CANCEL and
  1354.            *RFILE-STATE*)))        ; switch to RFILE-STATE
  1355.        (PROGN                ; - No, wrong packet number
  1356.          (IF (= NUM (IF (= K*PCKT-NUM 0)
  1357.                 63
  1358.                 (1- K*PCKT-NUM)))    ; See if it's previous packet
  1359.          (PROGN                ; -- Yes
  1360.            (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Send an ACK
  1361.            (INCREMENT-RETRIES)        ; Increment the retries
  1362.            K*STATE)            ; Finally, stay in this K*STATE so no data will be written
  1363.          (PROGN                ; -- No
  1364.            (PRINTMSG "~%~A"
  1365.                  (SETQ K*ABORT-REASON    ; Set up error
  1366.                    (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM)))
  1367.            *ABORT-STATE*)))))        ; abort
  1368.  
  1369.       (#\F                    ; File header
  1370.        (IF (= NUM (IF (= K*PCKT-NUM 0)
  1371.               63
  1372.               (1- K*PCKT-NUM)))        ; See if it's previous packet
  1373.        (PROGN                ; - Yes
  1374.          (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Send ACK
  1375.          (INCREMENT-RETRIES)        ; Increment the retries
  1376.          K*STATE)                ; Finally, stay in this K*STATE
  1377.        (PROGN                ; - No
  1378.          (PRINTMSG "~%~A"
  1379.                (SETQ K*ABORT-REASON    ; set up error
  1380.                  (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM)))
  1381.          *ABORT-STATE*)))            ; abort
  1382.  
  1383.       (#\X                    ; TTY
  1384.        (IF (= NUM (IF (= K*PCKT-NUM 0)
  1385.               63
  1386.               (1- K*PCKT-NUM)))        ; See if it's previous packet
  1387.        (PROGN                ; - Yes
  1388.          (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Send ACK
  1389.          (INCREMENT-RETRIES)        ; Increment the retries
  1390.          K*STATE)                ; Finally, stay in this K*STATE
  1391.        (PROGN                ; - No
  1392.          (PRINTMSG "~%~A"
  1393.                (SETQ K*ABORT-REASON    ; Set up error
  1394.                  (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM)))
  1395.          *ABORT-STATE*)))            ; abort
  1396.  
  1397.       (#\Z                    ; End-Of-File
  1398.        (IF (= NUM K*PCKT-NUM)            ; Correct packet number?
  1399.        (PROGN                ; - Yes
  1400.          (IF (AND (> LEN 0)            ; D specified to discard file?
  1401.               (EQUAL (SUBSEQ PACKET 0 1) "D"))
  1402.          (PROGN                    ; -- Yes
  1403.            (IF (OR *SAVEFILES*          ; Should the file be saved?  e.g., is *SAVEFILES* true
  1404.                 (STRING-EQUAL K*CANCEL "S")) ; or K*CANCEL save?
  1405.                (PROGN                   ; --- Yes
  1406.              (SEND K*FP :CLOSE)    ; Close but save the file
  1407.              (PRINTMSG "~%Receive aborted - file saved."))
  1408.                (PROGN                   ; --- No
  1409.              (SEND K*FP :CLOSE T)    ; Close with abort (discard)
  1410.              (PRINTMSG "~%Receive aborted - file discarded."))))
  1411.          (PROGN                ; -- No
  1412.            (SEND K*FP :CLOSE)        ; Close the file [NOTE IF SEND-TO-TTY must save stream BAC]
  1413.            (PRINTMSG "~%Receive aborted - file ~A closed")))
  1414.          (SETQ K*FP NIL)            ; Clear the file pointer
  1415.          (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Say OK
  1416.          (INCREMENT-PACKET-NUMBER)        ; Bump packet count
  1417.          (IF K*CANCEL                ; Cancel all further transfers? (not needed, since only Z supported)
  1418.          *ABORT-STATE*            ; -- Yes, abort
  1419.          (PROGN                ; -- No
  1420.            (SETQ K*CANCEL NIL)        ; reset K*CANCEL and
  1421.            *RFILE-STATE*)))        ; switch to RFILE-STATE
  1422.        (PROGN                ; - No, incorrect packet number
  1423.          (PRINTMSG "~%~A"
  1424.                (SETQ K*ABORT-REASON    ; Set up error
  1425.                  (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM)))
  1426.          *ABORT-STATE*)))            ; abort
  1427.  
  1428.       (#\E                    ; Error packet received
  1429.        (PRINTMSG "~%~A"
  1430.          (SETQ K*ABORT-REASON        ; Save the error
  1431.                (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET)))
  1432.        *ABORT-STATE*)
  1433.  
  1434.       (NIL                    ; Didn't get packet
  1435.        (SPACK #\N K*PCKT-NUM 0 NIL)        ; Return a NAK
  1436.        (INCREMENT-RETRIES)            ; Increment the retries
  1437.        K*STATE)                    ; Stay in same K*STATE and keep trying
  1438.  
  1439.       (:OTHERWISE                ; Unknown packet - abort
  1440.        (PRINTMSG "~%~A"
  1441.          (SETQ K*ABORT-REASON        ; Save the error
  1442.                (FORMAT NIL "~A: Received unknown packet type <~A>." TYPE)))
  1443.        (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)    ; Send an error packet
  1444.        *ABORT-STATE*))))
  1445.  
  1446.  
  1447.  
  1448. (DEFUN SGENERIC (SPACK-TYPE &OPTIONAL SPACK-DATA)
  1449.   "Used for server commands expecting short response such as ACK.
  1450. SPACK-TYPE should be a G, R or C packet type."
  1451.   (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*NUMTRY K*SPACKET K*VERBOSEP
  1452.             K*CANCEL K*SERVER-PACK-TYPE K*FP K*PACKETS-RETRIED K*ABORT-REASON))
  1453.  
  1454.   (IF K*CANCEL                    ; Cancel?
  1455.       *ABORT-STATE*                ; - Yes
  1456.       (PROGN                    ; - No
  1457.     (INITIALIZE-STATUS-COUNTS)        ; Initialize the packet counts and timing
  1458.         (WHEN (EQL SPACK-TYPE #\G)              ; When processing a Generic server command
  1459.       (ENCODE-PREFIXED-DATA SPACK-DATA K*SPACKET)           ; Prefix encode the data
  1460.       (SETQ SPACK-DATA K*SPACKET))
  1461.     (SPACK SPACK-TYPE 0 (LENGTH SPACK-DATA) SPACK-DATA)    ; Send a G, R or C packet
  1462.     
  1463.     (MULTIPLE-VALUE-BIND (TYPE LEN NUM PACKET)
  1464.         (RPACK)                ; What was the reply?
  1465.       (SELECTQ TYPE
  1466.     
  1467.         (#\S                ; Send-Init
  1468.          (IF (ZEROP NUM)            ; Packet number 0?
  1469.          (PROGN                ; - Yes,
  1470.            (RPAR PACKET LEN)        ; Get other side's init info
  1471.            (SETQ PACKET (SPAR PACKET))    ; Fill up my init info packet
  1472.            (SPACK #\Y K*PCKT-NUM (LENGTH PACKET) PACKET)    ; ACK with my parameters
  1473.            (INCREMENT-PACKET-NUMBER)    ; Bump packet number
  1474.            *RFILE-STATE*)        ; OK, enter File-Receive state
  1475.          (PROGN                ; - No
  1476.            (PRINTMSG "~%~A"        ; setup error
  1477.                  (SETQ K*ABORT-REASON
  1478.                    (FORMAT NIL "~A: Received non-zero packet number <~A>." *KERMIT-NAME* NUM)))
  1479.            *ABORT-STATE*)))        ; abort
  1480.     
  1481.         (#\X                ; Text header
  1482.          (IF (ZEROP NUM)            ; Correct packet number? ; maybe K*PCKT-NUM instead? ; BAC
  1483.          (PROGN                ; - Yes
  1484.            (SETQ K*FP            ; set the file pointer to
  1485.              (IF K*VERBOSEP        ; either the info window or a string stream
  1486.                  *INFO-WINDOW*
  1487.                  (MAKE-STRING-OUTPUT-STREAM)))
  1488.            (PRINTMSG "~%Receiving ~A on the screen.~%" PACKET)
  1489.            (SPACK #\Y K*PCKT-NUM 0 NIL)    ; ACKnowledge the file header
  1490.            (INCREMENT-PACKET-NUMBER)    ; Bump packet count
  1491.            *RDATA-STATE*)        ; switch to RDATA-STATE
  1492.          (PROGN                ; - No
  1493.            (PRINTMSG "~%~A"        ; setup error
  1494.                  (SETQ K*ABORT-REASON
  1495.                    (FORMAT NIL "~A: Received non-zero packet number <~A>." *KERMIT-NAME* NUM)))
  1496.            *ABORT-STATE*)))        ; abort
  1497.     
  1498.         (#\N                ; NAK
  1499.          (INCREMENT-RETRIES)        ; Increment the retries
  1500.          K*STATE)                ; Stay in same K*STATE
  1501.     
  1502.         (#\Y                ; ACK
  1503.          (IF (ZEROP NUM)            ; See if it's correct ACK
  1504.          (PROGN                ; - Yes
  1505.            (PRINTMSG "~%~A" PACKET)    ; print data on tty
  1506.            *COMPLETE-STATE*)        ; Switch to COMPLETE-STATE
  1507.          (PROGN                ; - No
  1508.            (PRINTMSG "~%~A"        ; setup error
  1509.                  (SETQ K*ABORT-REASON
  1510.                    (FORMAT NIL "~A: Received non-zero packet number <~A>." *KERMIT-NAME* NUM)))
  1511.            *ABORT-STATE*)))        ; abort
  1512.     
  1513.         (#\E                ; Error packet received
  1514.          (PRINTMSG "~%~A"
  1515.                (SETQ K*ABORT-REASON    ; Save the error
  1516.                  (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET)))
  1517.          *ABORT-STATE*)
  1518.     
  1519.         (NIL                ; Timeout
  1520.          (IF (AND (= SPACK-TYPE #\G)    ; Did we just request
  1521.               (OR (EQUAL (SUBSEQ SPACK-DATA 0 1) "L")    ; a remote logout
  1522.               (EQUAL (SUBSEQ SPACK-DATA 0 1) "F")))    ; or a remote finish?
  1523.          *COMPLETE-STATE*        ; - Yes, the remote KERMIT will never respond so we're finished
  1524.          (PROGN                ; - No
  1525.            (INCREMENT-RETRIES)        ; Increment the retries
  1526.            K*STATE)))            ; remain in same K*STATE
  1527.     
  1528.         (:OTHERWISE                ; Unknown packet - abort
  1529.          (PRINTMSG "~%~A"
  1530.                (SETQ K*ABORT-REASON    ; Save the error
  1531.                  (FORMAT NIL "~A: Received unknown packet type <~A>." TYPE)))
  1532.          *ABORT-STATE*))))))
  1533.  
  1534.  
  1535.  
  1536. (DEFUN SSERVER ()
  1537.   "Used for server commands expecting large responses."
  1538.   (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*SPACKET K*CANCEL
  1539.             K*YOUREOL K*YOURQUOTE K*VERBOSEP K*FP K*ABORT-REASON))
  1540.  
  1541.   (IF K*CANCEL                    ; Cancel?
  1542.       *ABORT-STATE*                ; - Yes, so abort
  1543.       (PROGN                    ; - No
  1544.     (SETQ K*SPACKET (SPAR K*SPACKET))    ; Fill up init info packet
  1545.     (SPACK #\I K*PCKT-NUM (LENGTH K*SPACKET) K*SPACKET)    ; Send an I packet with type,number,length,packet
  1546.     
  1547.     (MULTIPLE-VALUE-BIND (TYPE LEN NUM PACKET)
  1548.         (RPACK)                ; What was the reply?
  1549.       (SELECTQ TYPE
  1550.     
  1551.         (#\Y                ; ACK
  1552.          (IF (ZEROP NUM)            ; Correct packet number (0)?
  1553.          (PROGN                ; -- Yes
  1554.            (RPAR PACKET LEN)        ; Get other side's init info
  1555.            *SGENERIC-STATE*)        ; Move to SGENERIC-STATE
  1556.          (PROGN                ; -- No
  1557.            (PRINTMSG "~%~A"        ; setup error
  1558.                  (SETQ K*ABORT-REASON
  1559.                    (FORMAT NIL "~A: Received non-zero packet number <~A>." *KERMIT-NAME* NUM)))
  1560.            *ABORT-STATE*)))        ; abort
  1561.     
  1562.         (#\N                ; NAK
  1563.          (INCREMENT-RETRIES)        ; Increment the retries
  1564.          K*STATE)                ; Stay in same K*STATE
  1565.     
  1566.         (#\E                ; Error packet received - use defaults - but how? ;; BAC
  1567.          *SGENERIC-STATE*)            ; Switch to SGENERIC-STATE
  1568.     
  1569.         (NIL                ; Timeout
  1570.          (INCREMENT-RETRIES)        ; Increment the retries
  1571.          K*STATE)                ; remain in same K*STATE
  1572.     
  1573.         (:OTHERWISE                ; Unknown packet - abort
  1574.          (PRINTMSG "~%~A"
  1575.                (SETQ K*ABORT-REASON    ; Save the error
  1576.                  (FORMAT NIL "~A: Received unknown packet type <~A>." TYPE)))
  1577.          *ABORT-STATE*))))))
  1578.  
  1579.  
  1580.  
  1581. (DEFUN RSERVER ()
  1582.   "Receive Server - This KERMIT in server mode, idle and waiting for a message."
  1583.   (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*NUMTRY K*FILNAM K*SPACKET K*ABORT-REASON
  1584.             K*PACKETS-RETRIED K*CANCEL K*YOURMAXPACSIZ K*FP K*SEND-TO-TTY
  1585.             K*ARG1LIST))
  1586.  
  1587.   (SETQ K*PCKT-NUM 0)                ; Initialize the packet number
  1588.   (SETQ K*NUMTRY 0)                ; Zero the number of tries - can't exceed maxtry in this state
  1589.   (SETQ K*ABORT-REASON "")            ; Reset the abort reason string
  1590.   (INITIALIZE-STATUS-COUNTS)            ; Initialize the packet counts and timing info
  1591.  
  1592.   (IF K*CANCEL                    ; Cancel?
  1593.       *ABORT-STATE*                ; - Yes
  1594.       (MULTIPLE-VALUE-BIND (TYPE LEN NUM PACKET)    ; - No
  1595.       (RPACK 900)                ; Get a packet - wait 15 seconds (60 * 15) for it
  1596.     (SELECTQ TYPE
  1597.     
  1598.       (#\I                    ; INIT
  1599.        (IF (ZEROP NUM)            ; Correct packet number (0)?
  1600.            (PROGN                ; -- Yes
  1601.          (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Send ACK
  1602.          K*STATE)            ; Stay in same K*STATE
  1603.            (PROGN                ; -- No
  1604.          (PRINTMSG "~%~A"        ; setup error
  1605.                (SETQ K*ABORT-REASON
  1606.                  (FORMAT NIL "~A: Server received non-zero packet number <~A>." *KERMIT-NAME* NUM)))
  1607.          (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)    ; Send E packet
  1608.          K*STATE)))            ; Stay in same K*STATE
  1609.     
  1610.       (#\S                    ; SEND-INIT
  1611.        (IF (ZEROP NUM)            ; Correct packet number (0)?
  1612.            (PROGN                ; -- Yes
  1613.          (RPAR PACKET LEN)        ; Get other side's init info
  1614.          (SETQ PACKET (SPAR PACKET))    ; Fill up my init info packet
  1615.          (SPACK #\Y K*PCKT-NUM (LENGTH PACKET) PACKET)    ; ACK with my parameters
  1616.          (INCREMENT-PACKET-NUMBER)    ; Bump packet number
  1617.          *RFILE-STATE*)            ; OK, enter File-Receive state
  1618.            (PROGN                ; -- No
  1619.          (PRINTMSG "~%~A"        ; setup error
  1620.                (SETQ K*ABORT-REASON
  1621.                  (FORMAT NIL "~A: Server received non-zero packet number <~A>." *KERMIT-NAME* NUM)))
  1622.          (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)
  1623.          K*STATE)))            ; and stay in same K*STATE
  1624.     
  1625.       (#\R                    ; RECEIVE-INIT
  1626.        (IF (ZEROP NUM)            ; Correct packet number (0)?
  1627.            (PROGN                ; -- Yes
  1628.          (SETQ K*ARG1LIST
  1629.                (EXPAND-WILDS        ; Expand any wildcards in the filename
  1630.              (DECODE-PREFIXED-DATA PACKET LEN)))    ; Decode the packet to get the requested filename
  1631.          (GET-NEXT-FILE)        ; Get the file to process
  1632.          *SINIT-STATE*)            ; Proceed to SINIT-STATE
  1633.            (PROGN                ; -- No
  1634.          (PRINTMSG "~%~A"        ; setup error
  1635.                (SETQ K*ABORT-REASON
  1636.                  (FORMAT NIL "~A: Server received non-zero packet number <~A>." *KERMIT-NAME* NUM)))
  1637.          (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)
  1638.          K*STATE)))            ; and stay in same K*STATE
  1639.     
  1640.       (#\K                    ; KERMIT command
  1641.        (IF (ZEROP NUM)            ; Correct packet number (0)?
  1642.            (LET
  1643.          ((RESULT (PROCESS-KERMIT-COMMAND PACKET LEN)))
  1644.          (IF (OR
  1645.                K*FILNAM                 ; Filename specified for transfer?
  1646.                (> (LENGTH RESULT)       ; or long reply?
  1647.               (FLOOR K*YOURMAXPACSIZ 1.5)))
  1648.              (PROGN                     ; - Yes
  1649.                (SETQ K*SEND-TO-TTY T)   ; Set tty flag
  1650.                (WHEN (NOT K*FILNAM)
  1651.              (SETQ K*FP
  1652.                    (MAKE-STRING-INPUT-STREAM RESULT)))
  1653.                *SINIT-STATE*)           ; Go to SINIT-STATE
  1654.              (PROGN                     ; - No
  1655.                (SPACK #\Y K*PCKT-NUM (LENGTH RESULT) RESULT)    ; ACK with the requested info
  1656.                K*STATE)))                ; Stay in same state
  1657.            (PROGN                ; -- No
  1658.          (PRINTMSG "~%~A"        ; setup error
  1659.                (SETQ K*ABORT-REASON
  1660.                  (FORMAT NIL "~A: Server received non-zero packet number <~A>." *KERMIT-NAME* NUM)))
  1661.          (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)
  1662.          K*STATE)))            ; Stay in same state
  1663.     
  1664.       (#\C                    ; HOST command
  1665.        (IF (ZEROP NUM)            ; Correct packet number (0)?
  1666.            (LET
  1667.          ((RESULT (PROCESS-HOST-COMMAND PACKET LEN)))
  1668.          (IF (OR
  1669.                K*FILNAM                 ; Filename specified for tranfer?
  1670.                (> (LENGTH RESULT)       ; or long reply?
  1671.               (FLOOR K*YOURMAXPACSIZ 1.5)))
  1672.              (PROGN                     ; - Yes
  1673.                (SETQ K*SEND-TO-TTY T)   ; Set tty flag
  1674.                (WHEN (NOT K*FILNAM)
  1675.              (SETQ K*FP
  1676.                    (MAKE-STRING-INPUT-STREAM RESULT)))
  1677.                *SINIT-STATE*)           ; Go to SINIT-STATE
  1678.              (PROGN                     ; - No
  1679.                (SPACK #\Y K*PCKT-NUM (LENGTH RESULT) RESULT)    ; ACK with the requested info
  1680.                K*STATE)))                ; Stay in same state
  1681.            (PROGN                ; -- No
  1682.          (PRINTMSG "~%~A"        ; setup error
  1683.                (SETQ K*ABORT-REASON
  1684.                  (FORMAT NIL "~A: Server received non-zero packet number <~A>." *KERMIT-NAME* NUM)))
  1685.          (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)
  1686.          K*STATE)))            ; Stay in same state
  1687.     
  1688.       (#\G                    ; GENERIC command
  1689.        (IF (ZEROP NUM)            ; Correct packet number (0)?
  1690.            (LET
  1691.          ((RESULT (PROCESS-GENERIC-COMMAND PACKET LEN)))
  1692.          (IF (OR
  1693.                K*FILNAM                 ; Filename specified for tranfer?
  1694.                (> (LENGTH RESULT)       ; or long reply?
  1695.               (FLOOR K*YOURMAXPACSIZ 1.5)))
  1696.              (PROGN                     ; - Yes
  1697.                (SETQ K*SEND-TO-TTY T)   ; Set tty flag
  1698.                (WHEN (NOT K*FILNAM)
  1699.              (SETQ K*FP
  1700.                    (MAKE-STRING-INPUT-STREAM RESULT)))
  1701.                *SINIT-STATE*)           ; Go to SINIT-STATE
  1702.              (PROGN                     ; - No
  1703.                (SPACK #\Y K*PCKT-NUM (LENGTH RESULT) RESULT)    ; ACK with the requested info
  1704.                K*STATE)))                ; Stay in same state
  1705.            (PROGN                ; -- No
  1706.          (PRINTMSG "~%~A"        ; setup error
  1707.                (SETQ K*ABORT-REASON
  1708.                  (FORMAT NIL "~A: Server received non-zero packet number <~A>." *KERMIT-NAME* NUM)))
  1709.          (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)
  1710.          K*STATE)))            ; Stay in same state
  1711.     
  1712.       (#\E                    ; Error packet received
  1713.        (PRINTMSG "~%~A"
  1714.              (SETQ K*ABORT-REASON (FORMAT NIL "~%~A: Received error packet <~A>." *KERMIT-NAME* PACKET)))
  1715.        K*STATE)                ; Stay in same K*STATE
  1716.     
  1717.       (NIL                    ; Timeout
  1718.        (SPACK #\N 0 0 NIL)            ; Return a NAK
  1719.        K*STATE)                ; and keep trying
  1720.     
  1721.       (:OTHERWISE                ; Unknown packet
  1722.        (PRINTMSG "~%~A"
  1723.              (SETQ K*ABORT-REASON
  1724.                (FORMAT NIL "~A: Server received unknown packet type <~A>." *KERMIT-NAME* TYPE)))
  1725.        (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)    ; Send E packet with an error message
  1726.        K*STATE)))))
  1727.  
  1728.  
  1729.  
  1730. ;;; KERMIT utilities.
  1731.  
  1732. (DEFUN SPACK (TYPE NUM LEN DATA)
  1733.   "Send a packet.  Returns T."
  1734.   (DECLARE (SPECIAL K*BUFFER K*YOURPAD K*YOURPADCHAR K*YOUREOL K*TTYFD))
  1735.   (SEND K*TTYFD :CLEAR-INPUT)            ; clear the input buffer
  1736.  
  1737.   (LET ((IND 0)
  1738.     (CHECKSUM 0))
  1739.  
  1740.     (DOTIMES (i K*YOURPAD)
  1741.       (SETF (AREF K*BUFFER i) K*YOURPADCHAR)    ; Issue any padding
  1742.       (INCF IND))
  1743.  
  1744.     (SETF (AREF K*BUFFER IND) *ASCII-SOH*)    ; Packet marker, ASCII 1 SOH
  1745.     (INCF IND)                    ; Increment
  1746.  
  1747.     (SETF (AREF K*BUFFER IND) (TOCHAR (+ LEN 3)))    ; Character count
  1748.     (INCF IND)                    ; Increment
  1749.     (SETQ CHECKSUM (TOCHAR (+ LEN 3)))        ; Initialize the checksum
  1750.  
  1751.     (SETF (AREF K*BUFFER IND) (TOCHAR NUM))    ; Packet number
  1752.     (INCF IND)                    ; Increment
  1753.     (SETQ CHECKSUM (+ CHECKSUM (TOCHAR NUM)))    ; Update checksum to include NUM
  1754.  
  1755.     (SETF (AREF K*BUFFER IND) TYPE)        ; Packet type
  1756.     (INCF IND)                    ; Increment
  1757.     (SETQ CHECKSUM (+ CHECKSUM TYPE))        ; Update checksum to include TYPE
  1758.  
  1759.     (DOTIMES (i LEN)                ; Loop for all data characters
  1760.       (SETF (AREF K*BUFFER IND) (AREF DATA i))    ; Get a character
  1761.       (INCF IND)                ; Increment
  1762.       (SETQ CHECKSUM (+ CHECKSUM (AREF DATA i))))    ; Update checksum to include character
  1763.  
  1764.     (SETQ CHECKSUM (COMPUTE-FINAL-CHECKSUM CHECKSUM))    ; Compute final checksum
  1765.     (SETF (AREF K*BUFFER IND) (TOCHAR CHECKSUM))    ; Put it in the packet
  1766.     (INCF IND)                    ; Increment
  1767.  
  1768.     (SETF (AREF K*BUFFER IND) K*YOUREOL)        ; Extra-packet line terminator
  1769.     (INCF IND)                    ; Increment
  1770.  
  1771.     (SETF (FILL-POINTER K*BUFFER) IND)        ; Setup the length of the buffer
  1772.     (SEND K*TTYFD :STRING-OUT K*BUFFER 0 IND)    ; Send the packet
  1773.  
  1774.     (WHEN *DEBUG*                ; For Debugging display outgoing packet
  1775.       (PRINTMSG
  1776.     "~%SPACK:  type=~A  num=~D  len=~D  data=~S  buffer=~S" type num len data K*BUFFER)))
  1777.  
  1778.   T)                        ; Finally, return T
  1779.  
  1780.  
  1781.  
  1782. (DEFUN RPACK (&OPTIONAL (TIMEOUT (* *MYTIME* 60)))
  1783.   "Read a packet from the K*TTYFD stream.  Returns values TYPE, LEN, NUM and DATA.
  1784. :TYI-WITH-TIMEOUT added to Explorer serial stream.  Optional timeout supplied to
  1785. allow server mode to have longer timeouts."
  1786.   (DECLARE (SPECIAL K*TTYFD K*YOURMAXPACSIZ K*RPACKET))
  1787.  
  1788.   (LET ((CCHECKSUM 0) (RCHECKSUM 0) (DATA-COUNT 0)
  1789.     (TYPE NIL) (LEN 0) (NUM 0) (READ-STATE 0))
  1790.  
  1791.     (SETF (FILL-POINTER K*RPACKET) 0)        ; Say no data in array yet
  1792.     (LOOP
  1793.       UNTIL (> READ-STATE 7)
  1794.       FOR T-CHAR = (SEND K*TTYFD :TYI-WITH-TIMEOUT TIMEOUT)
  1795.       WHEN (NULL T-CHAR)
  1796.       DO
  1797.       (SETQ READ-STATE 99)
  1798.       ELSE
  1799.       DO
  1800.  
  1801.       (WHEN (NOT *IMAGE*)            ; If not in *IMAGE* mode,
  1802.     (SETQ T-CHAR (LOGAND T-CHAR #b1111111)))    ; handle the parity - #b1111111 is #o177
  1803.  
  1804.       (WHEN (= T-CHAR *ASCII-SOH*)        ; If *ASCII-SOH*
  1805.     (SETQ READ-STATE 1))            ; resynchronize!
  1806.  
  1807.       (SELECTQ READ-STATE
  1808.     (0                    ; Never had a Start Header
  1809.      NIL)                    ; Do nothing
  1810.     (1                    ; Start Header
  1811.      (INCF READ-STATE))            ; ... on to next state
  1812.     (2                    ; Length
  1813.      (SETQ CCHECKSUM T-CHAR)        ; Start the checksum
  1814.      (SETQ LEN (- (UNCHAR T-CHAR) 3))    ; Character count
  1815.      (SETQ LEN (ABS LEN))            ; temp - must handle this BAC
  1816.      (WHEN (OR (> LEN K*YOURMAXPACSIZ) (< LEN 0))    ; BAC - carefull
  1817.        (SETQ TYPE NIL)            ; Error in packet length
  1818.        (SETQ READ-STATE 99)            ; Get out of loop!
  1819.        (PRINTMSG "~%RPACK:  Error reading length <~A>~%" LEN))
  1820.      (INCF READ-STATE))            ; ... on to the next state
  1821.     (3                    ; Packet number
  1822.      (SETQ CCHECKSUM (+ CCHECKSUM T-CHAR))    ; Update checksum
  1823.      (SETQ NUM (UNCHAR T-CHAR))        ; Packet number
  1824.      (INCF READ-STATE))            ; ... on to the next state
  1825.     (4                    ; Packet type
  1826.      (SETQ CCHECKSUM (+ CCHECKSUM T-CHAR))    ; Update checksum
  1827.      (SETQ TYPE (CODE-CHAR T-CHAR))        ; Packet type - make number into a character
  1828.      (IF (ZEROP LEN)            ; Check for any data
  1829.          (SETQ READ-STATE 6)        ; If no data, skip to checksum state
  1830.          (PROGN                ; data ...
  1831.            (SETQ DATA-COUNT 0)        ; set up DATA-COUNT for next state
  1832.            (INCF READ-STATE))))        ; ... on to the next state
  1833.     (5                    ; Data characters
  1834.      (SETQ CCHECKSUM (+ CCHECKSUM T-CHAR))    ; Update checksum
  1835.      (SETF (AREF K*RPACKET DATA-COUNT) T-CHAR)    ; Get a character
  1836.      (INCF DATA-COUNT)            ; Increment the data count
  1837.      (WHEN (= DATA-COUNT LEN)        ; If no more data characters
  1838.        (INCF READ-STATE)))            ; ... on to the next state
  1839.     (6                    ; Checksum
  1840.      (SETQ RCHECKSUM (UNCHAR T-CHAR))    ; Convert to numeric
  1841.      (SETQ CCHECKSUM (COMPUTE-FINAL-CHECKSUM CCHECKSUM))    ; Compute the checksum
  1842.      (WHEN (NOT (= CCHECKSUM RCHECKSUM))    ; If checksum is not ok,
  1843.        (SETQ TYPE NIL)            ; indicate an error so that we'll loop again
  1844.        (WHEN *DEBUG*            ; For debugging, print checksum errors
  1845.          (PRINTMSG
  1846.            "~%RPACK:  Error comparing received checksum <~A> to computed checksum <~A> in packet number <~A>~%"
  1847.            RCHECKSUM CCHECKSUM NUM)))
  1848.      (SETF (AREF K*RPACKET LEN) 0)        ; Mark the end of the data
  1849.      (SETF (FILL-POINTER K*RPACKET) LEN)    ;
  1850.      (INCF READ-STATE))            ; ... on to the next state
  1851.     (7                    ; EOL character - throw it away!
  1852.      (INCF READ-STATE))))            ; ... on to the next state DONE!!!
  1853.  
  1854.     (WHEN *DEBUG*                ; For Debugging display incoming packet
  1855.       (PRINTMSG
  1856.     "~%RPACK:  type=~A  num=~D  len=~D  data=~A" TYPE NUM LEN K*RPACKET))
  1857.  
  1858.     (VALUES TYPE LEN NUM K*RPACKET)))        ; Return values
  1859.  
  1860.  
  1861.  
  1862. (DEFUN BUFILL (BUFFER FILEPOINTER)
  1863.   "Fill a packet buffer with data from a file.
  1864.    Input parameters are the buffer in which to place the file data,
  1865.    and a file pointer from which to read the data.  As a result of
  1866.    processing, BUFFER is filled and the position in FILEPOINTER is
  1867.    advanced.  Returned value is the length of the buffer.
  1868.    K*BUFILLPTR and K*BUFILLBUF are used to buffer the file data
  1869.    for look-ahead processing."
  1870.  
  1871.   (DECLARE (SPECIAL K*BUFILLBUF K*BUFILLPTR K*YOURMAXPACSIZ K*YOURQUOTE
  1872.             K*REPEAT K*BINQUOTE K*FILE-CHARS))
  1873.   (LET
  1874.     ((7-CHAR NIL)
  1875.      (8-CHAR NIL)
  1876.      (EOF NIL)
  1877.      (INDEX 0)
  1878.      (TMPBUFILLPTR NIL)
  1879.      (LENBUFILLBUF (LENGTH K*BUFILLBUF))
  1880.      (ACTUALMAXPACSIZ (- K*YOURMAXPACSIZ 8))
  1881.      (QUOTABLES (LIST K*YOURQUOTE
  1882.               (WHEN (NOT (= K*BINQUOTE *ASCII-N*)) K*BINQUOTE)
  1883.               (WHEN (NOT (= K*REPEAT *ASCII-SP*)) K*REPEAT))))
  1884.  
  1885.     (LOOP
  1886.       UNTIL (OR (>= INDEX  ACTUALMAXPACSIZ) EOF)    ; Until we exceed length of the packet or are at EOF
  1887.  
  1888.       WHEN (= K*BUFILLPTR LENBUFILLBUF)        ; When we run out of data in the buffer
  1889.       DO
  1890.       (SETQ K*BUFILLPTR 0)                ; Reset the pointer
  1891.       (WHEN (ZEROP (SEND FILEPOINTER :STRING-IN NIL K*BUFILLBUF))    ; and get more
  1892.     (SETQ EOF T))                ; If no more, set EOF
  1893.       (SETQ LENBUFILLBUF (LENGTH K*BUFILLBUF))    ; Newly filled buffer so get the length
  1894.       ELSE
  1895.       DO
  1896.       (SETQ 8-CHAR (AREF K*BUFILLBUF K*BUFILLPTR))    ; Get the next character from the file buffer
  1897.       (INCF K*BUFILLPTR)                ; Increment the pointer
  1898.       (INCF K*FILE-CHARS)                       ; Increment the total number of file chars read
  1899.  
  1900.       (WHEN (NOT (= K*REPEAT *ASCII-SP*))    ; If we have agreed to do repeat processing,
  1901.     (SETQ TMPBUFILLPTR K*BUFILLPTR)            ; handle the repeat characters
  1902.     (LOOP                    ; Loop until
  1903.       UNTIL (OR (= TMPBUFILLPTR LENBUFILLBUF)       ; either we run out of chars from the buffer
  1904.             (NOT (= 8-CHAR (AREF K*BUFILLBUF TMPBUFILLPTR)))) ; or we get one that's not equal to 8-char
  1905.       DO (INCF TMPBUFILLPTR))
  1906.     (SETQ TMPBUFILLPTR (1+ (- TMPBUFILLPTR K*BUFILLPTR)))    ; We repeat the char TMPBUFILLPTR times
  1907.     (WHEN (> TMPBUFILLPTR 3)            ; If this is more than 3, do repeat prefixing!
  1908.       (WHEN (> TMPBUFILLPTR 94) (SETQ TMPBUFILLPTR 94))    ; Also, truncate the number of repeats to 94
  1909.       (SETF (AREF BUFFER INDEX) K*REPEAT)    ; Put repeat character in the packet
  1910.       (INCF INDEX)                ; Increment
  1911.       (SETF (AREF BUFFER INDEX) (TOCHAR TMPBUFILLPTR))    ; Put my repeat count in the packet
  1912.       (INCF INDEX)                ; Increment
  1913.       (SETQ K*BUFILLPTR (+ K*BUFILLPTR TMPBUFILLPTR -1))    ; adjust the buffer index for the next character
  1914.       (SETQ K*FILE-CHARS (+ K*FILE-CHARS TMPBUFILLPTR -1)))) ; Adjust the total file chars read
  1915.  
  1916.       (WHEN (AND (NOT (= K*BINQUOTE *ASCII-N*))    ; Handle 8-bit quoting
  1917.          (> 8-CHAR *ASCII-DEL*))    ; If the 8-bit char is > 127
  1918.     (SETF (AREF BUFFER INDEX) K*BINQUOTE)    ; Put K*BINQUOTE in buffer
  1919.     (INCF INDEX))                ; Increment
  1920.  
  1921.       (WHEN (NOT *IMAGE*)            ; As long as we're not in image mode
  1922.     (SETQ 8-CHAR (CONVERT-TO-ASCII 8-CHAR)))    ; force characters to ASCII
  1923.  
  1924.       (SETQ 7-CHAR (LOGAND 8-CHAR #b1111111))    ; Get low order 7 bits - #b1111111 is #o177
  1925.  
  1926.       (WHEN (OR (< 7-CHAR *ASCII-SP*)        ; Does char require special handling?
  1927.         (MEMBER 7-CHAR QUOTABLES)
  1928.         (= 7-CHAR *ASCII-DEL*))
  1929.     
  1930.     (WHEN (AND (= 7-CHAR *ASCII-CR*)    ; Map CR->CRLF when
  1931.            (NOT *IMAGE*))        ; not in image mode
  1932.       (SETF (AREF BUFFER INDEX) K*YOURQUOTE)    ; Put K*YOURQUOTE in buffer
  1933.       (INCF INDEX)                ; Increment
  1934.       (SETF (AREF BUFFER INDEX) (CTL *ASCII-CR*))    ; Put the character in buffer
  1935.       (INCF INDEX)                ; Increment
  1936.       (SETQ 8-CHAR *ASCII-LF*)        ; Replace the char with a linefeed
  1937.       (SETQ 7-CHAR (LOGAND 8-CHAR #b1111111)))    ; Get low order 7 bits - #b1111111 is #o177
  1938.     
  1939.     (SETF (AREF BUFFER INDEX) K*YOURQUOTE)    ; Put K*YOURQUOTE in buffer
  1940.     (INCF INDEX)                ; Increment
  1941.     
  1942.     (WHEN                    ; Make printable characters
  1943.       (NOT(MEMBER 7-CHAR QUOTABLES))        ; As long as it's not the active quote, binquote or repeat
  1944.       (SETQ 7-CHAR (CTL 7-CHAR))
  1945.       (SETQ 8-CHAR (CTL 8-CHAR))))
  1946.  
  1947.       (IF *IMAGE*
  1948.       (SETF (AREF BUFFER INDEX) 8-CHAR)
  1949.       (SETF (AREF BUFFER INDEX) 7-CHAR))
  1950.       (INCF INDEX))
  1951.  
  1952.     (SETF (FILL-POINTER BUFFER) INDEX)
  1953.     INDEX))                    ; Return the index
  1954.  
  1955.  
  1956.  
  1957. (DEFUN BUFEMP (BUFFER LEN FILEPOINTER)
  1958.   "Put data from an incoming packet buffer into a file.
  1959.    Input parameters are the packet, it's length, and a
  1960.    pointer to the file in which to store the data.  As a
  1961.    result of processing, data is written to the file.
  1962.    This function returns the total number of characters
  1963.    written to the file."
  1964.  
  1965.   (DECLARE (SPECIAL K*IGNORE-NEXT-LINEFEED K*REPEAT K*BINQUOTE))
  1966.  
  1967.   (LET (T-CHAR 7-CHAR REPEAT BINQUOTED
  1968.     (FILE-CHARS 0)
  1969.     (QUOTABLES (LIST *MYQUOTE*
  1970.               (WHEN (NOT (= K*BINQUOTE *ASCII-N*)) K*BINQUOTE)
  1971.               (WHEN (NOT (= K*REPEAT *ASCII-SP*)) K*REPEAT))))
  1972.     (LOOP
  1973.       WITH IND = 0
  1974.       UNTIL (= IND LEN)
  1975.       DO
  1976.       (SETQ T-CHAR (AREF BUFFER IND))        ; Get a character
  1977.  
  1978.       (SETQ REPEAT 1)
  1979.       (SETQ BINQUOTED NIL)
  1980.  
  1981.       (WHEN (AND (NOT (= K*REPEAT *ASCII-SP*)) (= T-CHAR K*REPEAT))    ; Is it the repeat prefix?
  1982.     (INCF IND)
  1983.     (SETQ REPEAT (UNCHAR (LOGAND (AREF BUFFER IND) #b1111111)))    ; Get the repeat count
  1984.     (INCF IND)                ; Increment
  1985.     (SETQ T-CHAR (AREF BUFFER IND)))    ; Get next char
  1986.  
  1987.       (WHEN (AND (NOT (= K*BINQUOTE *ASCII-N*)) (= T-CHAR K*BINQUOTE))    ; Is it the binary quote prefix?
  1988.     (SETQ BINQUOTED T)            ; flag it
  1989.     (INCF IND)
  1990.     (SETQ T-CHAR (AREF BUFFER IND)))    ; Get next char
  1991.  
  1992.       (WHEN (= T-CHAR *MYQUOTE*)        ; Control quote?
  1993.     (INCF IND)                ; Increment
  1994.     (SETQ T-CHAR (AREF BUFFER IND))        ; Get the quoted character
  1995.     (SETQ 7-CHAR (LOGAND T-CHAR #b1111111))    ; and strip off the parity bit
  1996.     (WHEN (NOT (MEMBER 7-CHAR QUOTABLES))    ; Low order bits match active quote, binquote or repeat char?
  1997.       (SETQ T-CHAR (CTL T-CHAR))))        ; - No, uncontrollify it
  1998.  
  1999.       (WHEN BINQUOTED                ; If the binary prefix was set
  2000.     (SETQ T-CHAR (LOGXOR T-CHAR #b10000000)))    ; set the 8th bit
  2001.  
  2002.       (LOOP
  2003.     FOR I FROM 1 TO REPEAT            ; Now do the repeat count processing
  2004.     DO
  2005.     (IF *IMAGE*                ; Image mode?
  2006.         (PROGN                              ; - Yes
  2007.           (SEND FILEPOINTER :TYO T-CHAR)        ; send the character
  2008.           (INCF FILE-CHARS))                ; Increment the total file chars written
  2009.         (PROGN                ; - No,
  2010.           (SETQ T-CHAR (LOGAND T-CHAR #b1111111))    ; Strip off the parity bit
  2011.           (IF (AND (= T-CHAR *ASCII-LF*)    ; Is it a linefeed
  2012.                K*IGNORE-NEXT-LINEFEED)    ; after a CR?
  2013.           (SETQ K*IGNORE-NEXT-LINEFEED NIL)    ; -- Yes, ignore the LF and clear the flag
  2014.           (PROGN            ; -- No,
  2015.             (SETQ K*IGNORE-NEXT-LINEFEED    ; setup the flag
  2016.               (IF (= T-CHAR *ASCII-CR*) T NIL))    ; T If it's a CR; otherwise NIL
  2017.             (SETQ T-CHAR (CONVERT-FROM-ASCII T-CHAR))    ; Convert the character
  2018.             (WHEN T-CHAR        ; If it has an appropriate conversion,
  2019.               (SEND FILEPOINTER :TYO T-CHAR)   ; Write char to the file
  2020.               (INCF FILE-CHARS)))))))    ; Increment the total file chars written
  2021.  
  2022.       (INCF IND))                ; Increment the index
  2023.     FILE-CHARS))                                ; Return the total number of chars written
  2024.  
  2025.  
  2026.  
  2027. (DEFUN GET-NEXT-FILE ()
  2028.   "Get next file in a file group.  Returns NIL if no more files."
  2029.   (DECLARE (SPECIAL K*FILNAM K*RECFILNAM K*ARG1LIST K*ARG2LIST))
  2030.  
  2031.   (SETQ K*FILNAM (CAR K*ARG1LIST))        ; Get the next file
  2032.   (SETQ K*ARG1LIST (CDR K*ARG1LIST))        ; Shorten the list
  2033.   (SETQ K*RECFILNAM (CAR K*ARG2LIST))        ; Get the next recfile
  2034.   (SETQ K*ARG2LIST (CDR K*ARG2LIST))        ; Shorten the list
  2035.   (WHEN (AND (STRINGP K*FILNAM)
  2036.          (ZEROP (LENGTH K*FILNAM)))        ; If its an empty string, make it nil
  2037.     (SETQ K*FILNAM NIL))
  2038.   (WHEN (AND (STRINGP K*RECFILNAM)
  2039.          (ZEROP (LENGTH K*RECFILNAM)))    ; If its an empty string, make it nil
  2040.     (SETQ K*RECFILNAM NIL))
  2041.   (WHEN *DEBUG*                    ; Print debugging info
  2042.     (PRINTMSG
  2043.       "~%Function GET-NEXT-FILE:  k*filnam=~A  k*recfilnam=~A  k*arg1list=~A  k*arg2list=~A"
  2044.       K*FILNAM K*RECFILNAM K*ARG1LIST K*ARG2LIST))
  2045.   (IF K*FILNAM                    ; More files?
  2046.       T
  2047.       NIL))
  2048.  
  2049.  
  2050.  
  2051. (DEFUN SPAR (DATA)
  2052.   "Fill the data array with my send-init parameters.
  2053. Returns the data array."
  2054.   (DECLARE (SPECIAL K*BINQUOTE K*REPEAT))
  2055.   (SETF (FILL-POINTER DATA) 9)            ; Set array length to 9
  2056.   (SETF (AREF DATA 0) (TOCHAR *MYMAXPACSIZ*))    ; Biggest packet I can receive
  2057.   (SETF (AREF DATA 1) (TOCHAR *MYTIME*))    ; When I will time out
  2058.   (SETF (AREF DATA 2) (TOCHAR *MYPAD*))        ; How much padding I need
  2059.   (SETF (AREF DATA 3) (CTL *MYPADCHAR*))    ; Padding character I want
  2060.   (SETF (AREF DATA 4) (TOCHAR *MYEOL*))        ; End-Of-Line character I want
  2061.   (SETF (AREF DATA 5) *MYQUOTE*)        ; Quote character I use
  2062.   (SETF (AREF DATA 6) K*BINQUOTE)        ; 8-bit quote character I use
  2063.   (SETF (AREF DATA 7) *ASCII-1*)        ; Only know how to do 1 char checksum
  2064.   (SETF (AREF DATA 8) K*REPEAT)            ; Repeat count character I use
  2065.   DATA)
  2066.  
  2067.  
  2068.  
  2069. (DEFUN RPAR (DATA LEN)
  2070.   "Read the data array to get the other host's send-init parameters.
  2071. Returns the data array."
  2072.   (DECLARE (SPECIAL K*YOURMAXPACSIZ K*YOURTIME K*YOURPAD K*YOURPADCHAR
  2073.             K*YOUREOL K*YOURQUOTE K*BINQUOTE K*REPEAT K*STATE K*TTYFD-BITS))
  2074.   (LET
  2075.     ((REPEAT 0)
  2076.      (BINQUOTE 0))
  2077.  
  2078.     (WHEN (> LEN 0)
  2079.       (SETQ K*YOURMAXPACSIZ
  2080.         (UNCHAR (AREF DATA 0))))    ; Maximum send packet size
  2081.     (WHEN (> LEN 1)
  2082.       (SETQ K*YOURTIME
  2083.         (UNCHAR (AREF DATA 1))))    ; When you will time out
  2084.     (WHEN (> LEN 2)
  2085.       (SETQ K*YOURPAD
  2086.         (UNCHAR (AREF DATA 2))))    ; Number of pads to send
  2087.     (WHEN (> LEN 3)
  2088.       (SETQ K*YOURPADCHAR
  2089.         (CTL (AREF DATA 3))))    ; Padding character to send
  2090.     (WHEN (> LEN 4)
  2091.       (SETQ K*YOUREOL
  2092.         (UNCHAR (AREF DATA 4))))    ; EOL character to send
  2093.     (WHEN (> LEN 5)
  2094.       (SETQ K*YOURQUOTE
  2095.         (CHAR-CODE (AREF DATA 5))))    ; quote character to send
  2096.     (WHEN (> LEN 6)
  2097.       (SETQ K*BINQUOTE
  2098.         (CHAR-CODE (AREF DATA 6))))    ; 8-bit quote character to send
  2099.     (WHEN (> LEN 8)
  2100.       (SETQ REPEAT
  2101.         (CHAR-CODE (AREF DATA 8))))    ; Repeat character to send
  2102.     (WHEN *DEBUG*
  2103.       (PRINTMSG
  2104.     "~%RPAR (unadjusted):  pacsiz=~A/~A  time=~A/~A  pad=~A/~A  padchar=~A/~A  eol=~A/~A  quote=~A/~A  binquote=~A  repeat=~A" *MYMAXPACSIZ* K*YOURMAXPACSIZ *MYTIME* K*YOURTIME *MYPAD* K*YOURPAD *MYPADCHAR* K*YOURPADCHAR *MYEOL* K*YOUREOL *MYQUOTE* K*YOURQUOTE K*BINQUOTE K*REPEAT))
  2105.  
  2106.     (IF (ZEROP K*YOURMAXPACSIZ)            ; Is other KERMIT packet size unspecified?
  2107.     (SETQ K*YOURMAXPACSIZ *MYMAXPACSIZ*)    ; - Yes, use our size
  2108.     (IF (< K*YOURMAXPACSIZ *MYMAXPACSIZ*)    ; - No, is other KERMIT's smaller?
  2109.         (SETQ *MYMAXPACSIZ* K*YOURMAXPACSIZ)))    ; -- Yes - we'll both use other KERMIT's
  2110.  
  2111.     (WHEN (ZEROP K*YOUREOL)            ; Is other KERMIT EOL character unspecified?
  2112.       (SETQ K*YOUREOL *MYEOL*))            ; - Yes, use *MYEOL*
  2113.  
  2114.     (WHEN (ZEROP K*YOURQUOTE)            ; Is other KERMIT quote character unspecified?
  2115.       (SETQ K*YOURQUOTE *MYQUOTE*))        ; - Yes, use *MYQUOTE*
  2116.  
  2117.     (IF (AND (= K*STATE *RINIT-STATE*)        ; If we have never sent our parameters
  2118.          (= K*STATE *SGENERIC-STATE*)    ; and are processing the other
  2119.          (= K*STATE *RSERVER-STATE*))    ; KERMIT's parameters first (e.g., he did the init)
  2120.     (PROGN                    ; - Yes, we never sent
  2121.       (COND                    ; Process the 8-bit quoting char
  2122.         ((AND                ; If the other KERMIT has a valid 8-bit quote char...
  2123.            (OR (AND (> BINQUOTE 32) (< BINQUOTE 63))
  2124.            (AND (> BINQUOTE 95) (< BINQUOTE 127)))
  2125.            (NOT (= BINQUOTE K*YOURQUOTE)))
  2126.          (SETQ K*BINQUOTE BINQUOTE))    ; use it
  2127.     
  2128.         ((= BINQUOTE *ASCII-Y*)        ; If 8-bit quote char is a Y
  2129.          (IF *IMAGE*            ; Are we in image mode?
  2130.          (IF (= K*TTYFD-BITS 8)        ; -- Yes, do we have an 8-bit stream?
  2131.              (SETQ K*BINQUOTE *ASCII-N*)    ; -- Yes, say no quoting
  2132.              (SETQ K*BINQUOTE *ASCII-AMP*))    ; -- No, say we'll quote with &
  2133.          (SETQ K*BINQUOTE *ASCII-N*)))    ; -- No, not in image mode so don't do 8-bit
  2134.     
  2135.         (T                    ; Otherwise...say no 8-bit quoting
  2136.          (SETQ K*BINQUOTE *ASCII-N*)))
  2137.       (IF                    ; Process the repeat char
  2138.         (AND (OR (AND (> REPEAT 32) (< REPEAT 63))    ; Is it valid?
  2139.              (AND (> REPEAT 95) (< REPEAT 127)))
  2140.          (NOT (= REPEAT K*YOURQUOTE))
  2141.          (NOT (= REPEAT K*BINQUOTE)))
  2142.         (SETQ K*REPEAT REPEAT)        ; -- Yes, setup the repeat char
  2143.         (SETQ K*REPEAT *ASCII-SP*)))    ; -- No...say no repeating
  2144.     
  2145.     (PROGN                    ; - No, our parameters have been sent (we did the init)
  2146.     
  2147.       (WHEN (AND (NOT (= BINQUOTE K*BINQUOTE))    ; Process the 8-bit quote char
  2148.              (NOT (= BINQUOTE *ASCII-Y*))    ; If it's not what we sent, and its not a Y
  2149.              (SETQ K*BINQUOTE *ASCII-N*)))    ; say no 8-bit quoting
  2150.     
  2151.       (WHEN (NOT (= REPEAT K*REPEAT))    ; Process the repeat char - If it's not what we sent,
  2152.         (SETQ K*REPEAT *ASCII-SP*))))    ; say no repeating
  2153.  
  2154.     (WHEN *DEBUG*
  2155.       (PRINTMSG
  2156.     "~%RPAR   (adjusted):  pacsiz=~A/~A  time=~A/~A  pad=~A/~A  padchar=~A/~A  eol=~A/~A  quote=~A/~A  binquote=~A  repeat=~A" *MYMAXPACSIZ* K*YOURMAXPACSIZ *MYTIME* K*YOURTIME *MYPAD* K*YOURPAD *MYPADCHAR* K*YOURPADCHAR *MYEOL* K*YOUREOL *MYQUOTE* K*YOURQUOTE K*BINQUOTE K*REPEAT)))
  2157.  
  2158.   DATA)                        ; Finally, return DATA as the value of the function
  2159.  
  2160.  
  2161.  
  2162. ;;; Support functions
  2163.  
  2164. (DEFUN PROCESS-KERMIT-COMMAND (PACKET IGNORE)
  2165.   "Given a packet containing the command, try to process it.
  2166. Return a flag indicating success or failure, and the response."
  2167.   (FORMAT NIL "~A: Unimplemented KERMIT server command <~A>." *KERMIT-NAME* PACKET))
  2168.  
  2169. (DEFUN PROCESS-HOST-COMMAND (PACKET IGNORE)
  2170.   "Process a host command.  If an error is encountered, returns an error string."
  2171.   (LET
  2172.     ((RESULT NIL)
  2173.      (RESPONSE NIL))
  2174.  
  2175.     (CONDITION-CASE (ERR)
  2176.     (SETQ RESPONSE
  2177.           (WITH-OUTPUT-TO-STRING (STANDARD-OUTPUT)    ; Force the output to go to the string
  2178.         (SETQ RESULT (EVAL (READ-FROM-STRING PACKET)))))    ; Evaluate the command
  2179.       (ERROR
  2180.        (SETQ RESPONSE
  2181.          (FORMAT NIL "~A: Error <~A> while processing HOST command <~A>."
  2182.              *KERMIT-NAME* (SEND ERR :REPORT-STRING) PACKET)))
  2183.       (:NO-ERROR
  2184.        (FORMAT NIL "~A~A" RESPONSE RESULT)))))    ; Just return the response
  2185.  
  2186. (DEFUN PROCESS-GENERIC-COMMAND (PACKET LEN)
  2187.   "Generic Kermit Command.  Single character in data field (possibly followed
  2188. by operands, shown in {braces}, optional fields  in  [brackets]):
  2189.     I   Login [{*user[*password[*account]]}]
  2190.     C   CWD, Change Working Directory [{*directory[*password]}]
  2191.     L   Bye (Logout)
  2192.   * F   Finish (Shut down the server, but don't logout).
  2193.   * D   Directory [{*filespec}]
  2194.   * U   Disk Space Query (Usage) [{*area}]
  2195.   * E   Delete (Erase) {*filespec}
  2196.   * T   Type {*filespec}
  2197.   * R   Rename {*oldname*newname}
  2198.   * K   Copy {*source*destination}
  2199.   * W   Who's logged in? (Finger) [{*user ID or network host[*options]}]
  2200.     M   Send a short Message {*destination*text}
  2201.     H   Help [{*topic}]
  2202.   * Q   Server Status Query
  2203.     P   Program {*[program-filespec][*program-commands]}
  2204.     J   Journal {*command[*argument]}
  2205.     V   Variable {*command[*argument[*argument]]}"
  2206.  
  2207.   (DECLARE (SPECIAL K*FILNAM K*CANCEL))
  2208.   (LET
  2209.     ((COMD NIL)
  2210.      (ARGS (DECODE-PREFIXED-DATA PACKET LEN))        ; Decode the data
  2211.      (ARG1 NIL)
  2212.      (ARG2 NIL)
  2213.      (ARG3 NIL)
  2214.      (LNTH 0)
  2215.      (INDX 0)
  2216.      (DIR NIL))
  2217.  
  2218.     (SETQ COMD (SUBSEQ ARGS 0 1))
  2219.     (INCF INDX)
  2220.  
  2221.     (WHEN (< INDX (LENGTH ARGS))                     ; Get the first argument
  2222.       (SETQ LNTH (UNCHAR (COERCE (SUBSEQ ARGS INDX (1+ INDX)) 'CHARACTER)))
  2223.       (INCF INDX)
  2224.       (SETQ ARG1 (SUBSEQ ARGS INDX (+ INDX LNTH)))
  2225.       (INCF INDX LNTH)
  2226.  
  2227.       (WHEN (< INDX (LENGTH ARGS))                   ; Get the second argument
  2228.     (SETQ LNTH (UNCHAR (COERCE (SUBSEQ ARGS INDX (1+ INDX)) 'CHARACTER)))
  2229.     (INCF INDX)
  2230.     (SETQ ARG2 (SUBSEQ ARGS INDX (+ INDX LNTH)))
  2231.     (INCF INDX LNTH)
  2232.  
  2233.     (WHEN (< INDX (LENGTH ARGS))                 ; Get the third argument
  2234.       (SETQ LNTH (UNCHAR (COERCE (SUBSEQ ARGS INDX (1+ INDX)) 'CHARACTER)))
  2235.       (INCF INDX)
  2236.       (SETQ ARG3 (SUBSEQ ARGS INDX (+ INDX LNTH)))
  2237.       (INCF INDX LNTH))))
  2238.  
  2239.     (COND
  2240.       ((EQUAL COMD "D")
  2241.        (GENERIC-DIRECTORY ARG1))
  2242.       ((EQUAL COMD "E")
  2243.        (GENERIC-DELETE ARG1))
  2244.       ((EQUAL COMD "F")
  2245.        (SETQ K*CANCEL "Z"))
  2246.       ((EQUAL COMD "K")
  2247.        (GENERIC-COPY ARG1 ARG2))
  2248.       ((EQUAL COMD "Q")
  2249.        (GENERIC-STATUS))
  2250.       ((EQUAL COMD "R")
  2251.        (GENERIC-RENAME ARG1 ARG2))
  2252.       ((EQUAL COMD "T")
  2253.        (SETQ K*FILNAM ARG1))
  2254.       ((EQUAL COMD "U")
  2255.        (GENERIC-DISK-USAGE ARG1))
  2256.       ((EQUAL COMD "W")
  2257.        (GENERIC-WHO))
  2258.       (T
  2259.        (FORMAT NIL "~A: Unimplemented server GENERIC command <~A>" *KERMIT-NAME* COMD)))))
  2260.  
  2261.  
  2262.  
  2263. (DEFUN GENERIC-COPY (FILE1 FILE2)
  2264.   "Copies FILE1 to FILE2.  If an error is encountered, returns an error string."
  2265.   (LET
  2266.     ((F1 (MERGE-PATHNAMES FILE1 (USER-HOMEDIR-PATHNAME)))
  2267.      (F2 (MERGE-PATHNAMES FILE2 (USER-HOMEDIR-PATHNAME)))    
  2268.      (RESPONSE NIL))
  2269.  
  2270.     (CONDITION-CASE (ERR)
  2271.     (COPY-FILE F1 F2 :CREATE-DIRECTORIES T)
  2272.       (ERROR
  2273.        (SETQ RESPONSE
  2274.          (FORMAT NIL "~A: Error <~A> while processing GENERIC COPY command."
  2275.              *KERMIT-NAME* (SEND ERR :REPORT-STRING))))
  2276.       (:NO-ERROR
  2277.        (SETQ RESPONSE (FORMAT NIL "FIle ~A copied to ~A." F1 F2))))))
  2278.  
  2279. (DEFUN GENERIC-RENAME (FILE1 FILE2)
  2280.   "Renames FILE1 to FILE2.  If an error is encountered, returns an error string."
  2281.   (LET
  2282.     ((F1 (MERGE-PATHNAMES FILE1 (USER-HOMEDIR-PATHNAME)))
  2283.      (F2 (MERGE-PATHNAMES FILE2 (USER-HOMEDIR-PATHNAME)))    
  2284.      (RESPONSE NIL))
  2285.  
  2286.     (CONDITION-CASE (ERR)
  2287.     (RENAME-FILE F1 F2)
  2288.       (ERROR
  2289.        (SETQ RESPONSE
  2290.          (FORMAT NIL "~A: Error <~A> while processing GENERIC RENAME command."
  2291.              *KERMIT-NAME* (SEND ERR :REPORT-STRING))))
  2292.       (:NO-ERROR
  2293.        (SETQ RESPONSE (FORMAT NIL "FIle ~A renamed to ~A." F1 F2))))))
  2294.  
  2295. (DEFUN GENERIC-DELETE (FILE1)
  2296.   "Deletes FILE1.  If an error is encountered, returns an error string."
  2297.   (LET
  2298.     ((F1 (MERGE-PATHNAMES FILE1 (USER-HOMEDIR-PATHNAME)))
  2299.      (RESPONSE NIL))
  2300.  
  2301.     (CONDITION-CASE (ERR)
  2302.     (DELETE-FILE F1)
  2303.       (ERROR
  2304.        (SETQ RESPONSE
  2305.          (FORMAT NIL "~A: Error <~A> while processing GENERIC DELETE command."
  2306.              *KERMIT-NAME* (SEND ERR :REPORT-STRING))))
  2307.       (:NO-ERROR
  2308.        (SETQ RESPONSE (FORMAT NIL "FIle ~A deleted." F1))))))
  2309.  
  2310. (DEFUN GENERIC-DIRECTORY (&OPTIONAL DIRECTORY-NAME)
  2311.   "Returns a string containing the contents of current directory or directory-name.
  2312. If an error is encountered, returns an error string."
  2313.   (LET
  2314.     ((DIR NIL)
  2315.      (RESPONSE NIL))
  2316.  
  2317.     (CONDITION-CASE (ERR)
  2318.     (SETQ DIR
  2319.           (FS:DIRECTORY-LIST
  2320.         (MERGE-PATHNAMES
  2321.           (IF DIRECTORY-NAME
  2322.               DIRECTORY-NAME
  2323.               (USER-HOMEDIR-PATHNAME))
  2324.           "*.*#*")))
  2325.       (ERROR                ; If unable to get the directory-list
  2326.        (SETQ RESPONSE
  2327.          (FORMAT NIL "~A: Error <~A> while processing GENERIC DIRECTORY command."
  2328.              *KERMIT-NAME* (SEND ERR :REPORT-STRING))))
  2329.       (:NO-ERROR
  2330.        (SETQ RESPONSE
  2331.          (FORMAT NIL "Directory listing for ~A~%~A~%~:{~A~35T~@8A (~A)~51T~A~73T~A~%~}"
  2332.              (SEND (GET (CAR DIR) :PATHNAME) :STRING-FOR-PRINTING)
  2333.              (GET (CAR DIR) :DISK-SPACE-DESCRIPTION)
  2334.              (MAPCAR
  2335.                (FUNCTION
  2336.              (LAMBDA (flist)
  2337.                (LIST
  2338.                  (SEND (CAR flist) :STRING-FOR-DIRED)
  2339.                  (GET flist :LENGTH-IN-BYTES)
  2340.                  (GET flist :BYTE-SIZE)
  2341.                  (MULTIPLE-VALUE-BIND (SS MM HH DY MN YEAR)
  2342.                  (DECODE-UNIVERSAL-TIME
  2343.                    (GET flist :CREATION-DATE))
  2344.                    (FORMAT NIL "~A/~A/~A~11T~A:~A:~A"
  2345.                        MN DY YEAR HH MM SS))
  2346.                  (GET flist :AUTHOR))))
  2347.                (CDR DIR))))))))
  2348.  
  2349. (DEFUN GENERIC-DISK-USAGE (&OPTIONAL DIRECTORY-NAME)
  2350.   "Returns a string containing the disk-usage of current directory or directory-name.
  2351. If an error is encountered, returns an error string."
  2352.   (LET
  2353.     ((DIR NIL)
  2354.      (RESPONSE NIL))
  2355.  
  2356.     (CONDITION-CASE (ERR)
  2357.     (SETQ DIR
  2358.           (FS:DIRECTORY-LIST
  2359.         (MERGE-PATHNAMES
  2360.           (IF DIRECTORY-NAME
  2361.               DIRECTORY-NAME
  2362.               (USER-HOMEDIR-PATHNAME))
  2363.           "*.*#*")))
  2364.       (ERROR                ; If unable to get the directory-list
  2365.        (SETQ RESPONSE
  2366.          (FORMAT NIL "~A: Error <~A> while processing GENERIC DISK-USAGE command."
  2367.              *KERMIT-NAME* (SEND ERR :REPORT-STRING))))
  2368.       (:NO-ERROR
  2369.        (SETQ RESPONSE (GET (CAR DIR) :DISK-SPACE-DESCRIPTION))))))
  2370.  
  2371. (DEFUN GENERIC-STATUS ()
  2372.   "Returns a string containing the status of the current Kermit environment."
  2373.   (FORMAT NIL "Status of the current ~A environment:~%Image Mode:~26T~A~%Debug Mode:~26T~A~%More Processing:~26T~A~%Maximum Tries:~26T~A~%Maximum packet size:~26T~A~%Timeout seconds:~26T~A~%Number of pad characters:~26T~A~%Padding character:~26T~A~%EOL character:~26T~A~%Quote character:~26T~A~%Filename conversion:~26T~A~%Save partial files:~26T~A" *KERMIT-NAME* *IMAGE* *DEBUG* *MORE* *MYMAXTRY* *MYMAXPACSIZ* *MYTIME* *MYPAD* *MYPADCHAR* *MYEOL* *MYQUOTE* *FILNAMCNV* *SAVEFILES*))
  2374.  
  2375. (DEFUN GENERIC-WHO ()
  2376.   "Returns a string describing who's logged on each machine on the network."
  2377.   (LET
  2378.     ((STREAM (MAKE-STRING-OUTPUT-STREAM)))      ; make an output stream for FINGER-LISPMS to write to
  2379.     (CHAOS:FINGER-LISPMS STREAM)
  2380.     (GET-OUTPUT-STREAM-STRING STREAM)))
  2381.  
  2382.  
  2383.  
  2384.         
  2385. (DEFUN CHANGE-KERMIT-PARAMETERS ()
  2386.   "Change local operating parameters"
  2387.   (LET ((IMAGE *IMAGE*) (DEBUG *DEBUG*) (MORE *MORE*) (MYMAXTRY *MYMAXTRY*)
  2388.     (MYMAXPACSIZ *MYMAXPACSIZ*) (MYTIME *MYTIME*) (MYPAD *MYPAD*)
  2389.     (MYPADCHAR *MYPADCHAR*) (MYEOL *MYEOL*) (MYQUOTE *MYQUOTE*)
  2390.     (FILNAMCNV *FILNAMCNV*) (SAVEFILES *SAVEFILES*) (RESET NIL))
  2391.  
  2392.     (DECLARE (SPECIAL IMAGE DEBUG MORE MYMAXTRY MYMAXPACSIZ MYTIME
  2393.               MYPAD MYPADCHAR MYEOL MYQUOTE FILNAMCNV SAVEFILES RESET))
  2394.  
  2395.     (*CATCH 'QUIT-CVV
  2396.       (TV:CHOOSE-VARIABLE-VALUES
  2397.     '((IMAGE "Image Mode      "
  2398.          :DOCUMENTATION "YES: Send file as 8-bit data.  NO: Send file as ASCII characters."
  2399.          :BOOLEAN)
  2400.       (DEBUG "Debug Mode      "
  2401.          :DOCUMENTATION "YES: Print debugging information.  NO: Do not print debugging information."
  2402.          :BOOLEAN)
  2403.       (MORE  "More Processing "
  2404.          :DOCUMENTATION "YES: Enable **MORE** in the KERMIT window.  NO: Do not use **MORE**."
  2405.          :BOOLEAN)
  2406.       ""
  2407.       (MYMAXTRY    "Maximum tries            "
  2408.                :DOCUMENTATION "Maximum number of times to retry a packet"
  2409.                :NUMBER)
  2410.       (MYMAXPACSIZ "Maximum packet size      "
  2411.                :DOCUMENTATION "Maximum packet size - must not be greater than 94"
  2412.                :NUMBER)
  2413.       (MYTIME      "Timeout seconds          "
  2414.                :DOCUMENTATION "Number of seconds after which I should be timed out"
  2415.                :NUMBER)
  2416.       (MYPAD       "Number of pad characters "
  2417.                :DOCUMENTATION "Number of padding characters to use"
  2418.                :NUMBER)
  2419.       (MYPADCHAR   "Padding character        "
  2420.                :DOCUMENTATION "Padding character to use - enter the character number"
  2421.                :NUMBER)
  2422.       (MYEOL       "EOL character            "
  2423.                :DOCUMENTATION "End-Of-Line character to use - enter the character number"
  2424.                :NUMBER)
  2425.       (MYQUOTE     "Quote character          "
  2426.                :DOCUMENTATION "Quote character to use - enter the character number"
  2427.                :NUMBER)
  2428.       ""
  2429.       (FILNAMCNV "Filename conversion "
  2430.              :DOCUMENTATION "YES: Convert filenames to name.type format.  NO: Do not convert filenames."
  2431.              :BOOLEAN)
  2432.       (SAVEFILES "Save partial files  "
  2433.              :DOCUMENTATION "YES: Save partially received file if transfer is interrupted.  NO: Delete the file."
  2434.              :BOOLEAN)
  2435.       ""
  2436.       (RESET "Reset parameters "
  2437.          :DOCUMENTATION "YES: Immediately reset parameters to default values.  NO: Use current parameter values."
  2438.          :BOOLEAN))
  2439.     :NEAR-MODE '(:POINT 500 400)
  2440.     :WIDTH 50
  2441.     :LABEL "Change Parameters"
  2442.     :MARGIN-CHOICES '("Do It" ("Quit" (*THROW 'QUIT-CVV T))))
  2443.       (SETQ *IMAGE* IMAGE)
  2444.       (SETQ *DEBUG* DEBUG)
  2445.       (SETQ *MORE* MORE)
  2446.       (SETQ *MYMAXTRY* MYMAXTRY)
  2447.       (SETQ *MYMAXPACSIZ* MYMAXPACSIZ)
  2448.       (SETQ *MYTIME* MYTIME)
  2449.       (SETQ *MYPAD* MYPAD)
  2450.       (SETQ *MYPADCHAR* MYPADCHAR)
  2451.       (SETQ *MYEOL* MYEOL)
  2452.       (SETQ *MYQUOTE* MYQUOTE)
  2453.       (SETQ *FILNAMCNV* FILNAMCNV)
  2454.       (SETQ *SAVEFILES* SAVEFILES))
  2455.     (WHEN RESET                    ; If these values are changed, change in DEFVAR as well
  2456.       (SETQ *IMAGE* NIL)
  2457.       (SETQ *DEBUG* NIL)
  2458.       (SETQ *MORE* NIL)
  2459.       (SETQ *MYMAXTRY* 10)
  2460.       (SETQ *MYMAXPACSIZ* 94)
  2461.       (SETQ *MYTIME* 10)
  2462.       (SETQ *MYPAD* 0)
  2463.       (SETQ *MYPADCHAR* 0)
  2464.       (SETQ *MYEOL* *ASCII-CR*)
  2465.       (SETQ *MYQUOTE* *ASCII-NS*)
  2466.       (SETQ *FILNAMCNV* T)
  2467.       (SETQ *SAVEFILES* NIL))
  2468.     (SEND *INFO-WINDOW* :SET-MORE-P *MORE*)))    ; Set in window
  2469.  
  2470.  
  2471.  
  2472. ;;; Kermit printing routines:
  2473.  
  2474. (DEFUN PRINTMSG (MSG-CTL-STRING &OPTIONAL &REST ARGS)
  2475.   "Print message on standard output if in verbose mode."
  2476.   (DECLARE (SPECIAL K*VERBOSEP K*ERROR-MESSAGE))
  2477.   (WHEN K*VERBOSEP                ; When verbose,
  2478.     (APPLY 'FORMAT *INFO-WINDOW* MSG-CTL-STRING ARGS))    ; print to the window.
  2479.   (WHEN *LOGFILE*                ; If a logfile has been specified,
  2480.     (APPLY 'FORMAT *LOGFILE* MSG-CTL-STRING ARGS)))    ; write to the file.
  2481.  
  2482. (DEFUN INCREMENT-PACKET-NUMBER ()
  2483.   "Increments packet number by +1 but resets after 63.  Also zeros K*NUMTRY."
  2484.   (DECLARE (SPECIAL K*PCKT-NUM K*NUMTRY))
  2485.   (SETQ K*PCKT-NUM (IF (< K*PCKT-NUM 63) (1+ K*PCKT-NUM) 0))
  2486.   (SETQ K*NUMTRY 0))
  2487.  
  2488. (DEFUN INCREMENT-RETRIES ()
  2489.   "Increments the number of retries."
  2490.   (DECLARE (SPECIAL K*NUMTRY K*PACKETS-RETRIED))
  2491.   (INCF K*NUMTRY)                ; Increment the retries
  2492.   (INCF K*PACKETS-RETRIED))            ; Increment the total retries
  2493.  
  2494. (DEFUN INITIALIZE-STATUS-COUNTS ()
  2495.   "Initialize the status counting for packet numbers and transfer times."
  2496.   (DECLARE (SPECIAL K*PACKETS-TRANSFERRED K*PACKETS-RETRIED
  2497.             K*BYTES-TRANSFERRED K*FILE-CHARS K*START-TIME))
  2498.   (SETQ K*PACKETS-TRANSFERRED 0)        ; Initialize total packet count
  2499.   (SETQ K*PACKETS-RETRIED 0)            ; Initialize total retry count
  2500.   (SETQ K*BYTES-TRANSFERRED 0)            ; Reset the bytes transferred counter
  2501.   (SETQ K*FILE-CHARS 0)                         ; Reset the total file chars
  2502.   (SETQ K*START-TIME (TIME)))            ; Save the current internal time in 60ths of a second
  2503.  
  2504. (DEFUN COUNT-AND-PRINT-PACKETS (PACKET-LENGTH)    ; called in RDATA and SDATA
  2505.   "Increment total packet count and print totals."
  2506.   (DECLARE (SPECIAL K*PACKETS-TRANSFERRED K*BYTES-TRANSFERRED K*VERBOSEP))
  2507.   (INCF K*PACKETS-TRANSFERRED)
  2508.   (INCF K*BYTES-TRANSFERRED PACKET-LENGTH)
  2509.   (WHEN K*VERBOSEP
  2510.     (PRINT-STATUS-PACKET-INFO)))
  2511.  
  2512. (DEFUN INITIALIZE-STATUS-WINDOW ()
  2513.   (DECLARE (SPECIAL K*OPERATION))
  2514.   (SEND *STATUS-WINDOW* :CLEAR-WINDOW)
  2515.   (FORMAT *STATUS-WINDOW* "~%~10,1TOperation ~25,1T: ~A~60,1TRate (packet/file) ~80,1T:~%~10,1TFile Name ~25,1T:~60,1TNumber of Packets ~80,1T:~%~10,1TTransfer name ~25,1T:~60,1TNumber of Retries ~80,1T:" K*OPERATION)
  2516.   (TV:TURN-OFF-SHEET-BLINKERS *STATUS-WINDOW*))
  2517.  
  2518. (DEFUN PRINT-STATUS-PACKET-INFO ()
  2519.   (DECLARE (SPECIAL K*OPERATION K*FILNAM K*RECFILNAM K*PACKETS-TRANSFERRED
  2520.             K*BYTES-TRANSFERRED K*FILE-CHARS K*START-TIME K*PACKETS-RETRIED))
  2521.   (LET
  2522.     ((TIME-DIFF (MAX 1 (FLOOR (TIME-DIFFERENCE (TIME) K*START-TIME) 60))))
  2523.  
  2524.     (SEND *STATUS-WINDOW* :SET-CURSORPOS 82 1 :CHARACTER)
  2525.     (SEND *STATUS-WINDOW* :CLEAR-STRING "            ")
  2526.     (FORMAT *STATUS-WINDOW* "~5A/~@5A"
  2527.         (FLOOR K*BYTES-TRANSFERRED TIME-DIFF)
  2528.         (FLOOR K*FILE-CHARS TIME-DIFF))
  2529.     (SEND *STATUS-WINDOW* :SET-CURSORPOS 82 2 :CHARACTER)
  2530.     (SEND *STATUS-WINDOW* :CLEAR-STRING "       ")
  2531.     (FORMAT *STATUS-WINDOW* "~A" K*PACKETS-TRANSFERRED)
  2532.     (SEND *STATUS-WINDOW* :SET-CURSORPOS 82 3 :CHARACTER)
  2533.     (SEND *STATUS-WINDOW* :CLEAR-STRING "       ")
  2534.     (FORMAT *STATUS-WINDOW* "~A" K*PACKETS-RETRIED)))
  2535.  
  2536.  
  2537. (DEFUN PRINT-STATUS-FILE-INFO ()
  2538.   (DECLARE (SPECIAL K*VERBOSEP K*FILNAM K*RECFILNAM))
  2539.   (WHEN K*VERBOSEP
  2540.     (SEND *STATUS-WINDOW* :SET-CURSORPOS 27 2 :CHARACTER)
  2541.     (SEND *STATUS-WINDOW* :CLEAR-STRING "                               ")
  2542.     (FORMAT *STATUS-WINDOW* "~A" (IF K*FILNAM K*FILNAM ""))
  2543.     (SEND *STATUS-WINDOW* :SET-CURSORPOS 27 3 :CHARACTER)
  2544.     (SEND *STATUS-WINDOW* :CLEAR-STRING "                               ")
  2545.     (FORMAT *STATUS-WINDOW* "~A" (IF K*RECFILNAM K*RECFILNAM ""))))
  2546.  
  2547.  
  2548.  
  2549. (DEFUN CREATE-KERMIT-FILENAME (FILENAME)
  2550.   "Create a filename sutable for sending to another machine. Return file.type"
  2551.   (IF *FILNAMCNV*
  2552.       (LET* ((PATHNAME (FS:PARSE-PATHNAME FILENAME))
  2553.          (NAME (SEND PATHNAME :NAME))
  2554.          (TYPE (SEND PATHNAME :TYPE)))
  2555.     (IF (EQ NAME ':WILD)
  2556.         (SETQ NAME "*")
  2557.         (IF (EQ NAME ':UNSPECIFIC)
  2558.         (SETQ NAME "")
  2559.         (UNLESS (STRINGP NAME)
  2560.           (SETQ NAME ""))))
  2561.     (IF (EQ TYPE ':WILD)
  2562.         (SETQ TYPE "*")
  2563.         (IF (EQ TYPE ':UNSPECIFIC)
  2564.         (SETQ TYPE "")
  2565.         (UNLESS (STRINGP TYPE)
  2566.           (SETQ TYPE ""))))
  2567.     (FORMAT NIL "~A.~A" NAME TYPE))
  2568.       FILENAME))
  2569.  
  2570.  
  2571. (DEFUN ENCODE-PREFIXED-DATA (DATA BUFFER)
  2572.   "Decode string of data by passing it through BUFILL.
  2573.    Inputs are a string of data and a buffer to fill.
  2574.    Returned value is the size of the buffer."
  2575.   (DECLARE (SPECIAL K*BUFILLBUF K*BUFILLPTR))
  2576.   (LET
  2577.     ((SIZE 0))
  2578.     (WHEN                                       ; As long as noone is using BUFILL already...
  2579.       (AND (ZEROP (FILL-POINTER K*BUFILLBUF))
  2580.        (ZEROP K*BUFILLPTR))
  2581.       (SETQ SIZE
  2582.         (BUFILL BUFFER (MAKE-STRING-INPUT-STREAM DATA)))    ; Use BUFILL to encode the data
  2583.       (SETQ K*BUFILLPTR 0)            ; Reset the BUFILL pointer
  2584.       (SETF (FILL-POINTER K*BUFILLBUF) 0)    ; Clear the BUFILL buffer
  2585.       SIZE)))                    ; Return the SIZE of the buffer
  2586.  
  2587.  
  2588. (DEFUN DECODE-PREFIXED-DATA (PACKET LEN)
  2589.   "Decode a packet of data by passing it through BUFEMP.
  2590.    Inputs are a packet and length.  Returned value is the
  2591.    decoded string."
  2592.   (LET
  2593.     ((FILE (MAKE-STRING-OUTPUT-STREAM)))             ; Make a temporary output stream for BUFEMP
  2594.     (BUFEMP PACKET LEN FILE)                         ; Use BUFEMP to decode the data
  2595.     (GET-OUTPUT-STREAM-STRING FILE)))                ; Get the decoded data
  2596.  
  2597.  
  2598. (DEFUN EXPAND-WILDS (FILE-NAME)
  2599.   "Expand wildcards in a filename.  Returns a list
  2600.    of expanded filenames."
  2601.   (LET
  2602.     ((DIR NIL)
  2603.      (RESPONSE NIL))
  2604.  
  2605.     (CONDITION-CASE (ERR)
  2606.     (SETQ DIR
  2607.           (FS:DIRECTORY
  2608.         (MERGE-PATHNAMES
  2609.           FILE-NAME
  2610.           "FOO.BAR#>")))
  2611.       (ERROR                    ; If unable to get the directory due to error
  2612.        (SETQ RESPONSE                ; such as invalid host, pass on the file-name
  2613.          (LIST FILE-NAME)))            ; so it will error again at open time!
  2614.       (:NO-ERROR
  2615.        (SETQ RESPONSE
  2616.          (MAPCAR 'NAMESTRING DIR))))
  2617.     RESPONSE))                    ; Return RESPONSE
  2618.  
  2619. (DEFUN DEFAULT-ONLY-WILD-PATHNAME-COMPONENTS (PATH1 PATH2)
  2620.   "Fill in only the wild parts of PATH1 with the corresponding parts of PATH2."
  2621.   (FS:FAST-NEW-PATHNAME PATH1
  2622.             (WHEN (EQ (PATHNAME-DEVICE PATH1) :WILD) (PATHNAME-DEVICE PATH2))
  2623.             (WHEN (EQ (PATHNAME-DIRECTORY PATH1) :WILD) (PATHNAME-DIRECTORY PATH2))
  2624.             (WHEN (EQ (PATHNAME-NAME PATH1) :WILD) (PATHNAME-NAME PATH2))
  2625.             (WHEN (EQ (PATHNAME-TYPE PATH1) :WILD) (PATHNAME-TYPE PATH2))
  2626.             (WHEN (EQ (PATHNAME-VERSION PATH1) :W                  (PATHNAME-VERSION PATH2))))
  2627.  
  2628.