home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / archives / tiexplorer.zip / explre.lsp < prev    next >
Text File  |  1986-09-22  |  182KB  |  4,431 lines
  1. <<< DEFSYS.LSP >>>
  2.  
  3. ;-*- Mode:LISP; Package:USER; Base:10. -*-
  4.  
  5. ;;; See if packages KERMIT and IP exist - if not, create them!
  6. (PKG-FIND-PACKAGE "KERMIT" T)
  7. (PKG-FIND-PACKAGE "IP" T)
  8.  
  9. (defsystem KERMIT
  10.   (:name "KERMIT")
  11.   (:short-name "KERMIT")
  12.   (:pathname-default "KERMIT;")
  13.   (:patchable "KERMIT;")
  14.   (:initial-status :RELEASED)
  15.   (:compile-load ("KERMIT"))
  16.   (:compile-load ("SERIAL-CLOSE-FIX"))
  17. ;  (:compile-load ("VT100-CURSOR-FIX"))
  18.   (:compile-load ("VT100-CURSOR-KEY-FIX"))
  19.   (:compile-load ("SERIAL-TELNET")))
  20.  
  21. <<< KERMIT.LSP >>>
  22.  
  23. ;;; -*- Mode:COMMON-LISP; Package:KERMIT; Base:10 -*-
  24.  
  25. ;;; Copyright (c) 1981, 1982, 1983, 1984 Trustees of Columbia University, New York
  26. ;;; Copyright (c) 1986 Sperry Corporation
  27. ;;; Copyright (c) 1986 Texas Instruments Incorporated
  28.  
  29. ;;; Permission is granted to any individual or institution to copy or use this
  30. ;;;  software but not to resell it for a price in excess of its media cost.
  31.  
  32. ;;; K e r m i t  File Transfer Utility
  33. ;;;
  34. ;;; Release 1.0 9/22/86
  35.  
  36. ;;; Remember @@TTY W,132 for 1100
  37.  
  38. ;;; Global constants
  39.  
  40. (DEFCONSTANT  *ASCII-NUL*         0    "ASCII NUL")
  41. (DEFCONSTANT  *ASCII-SOH*         1    "ASCII Start of Header")
  42. (DEFCONSTANT  *ASCII-BS*          8    "ASCII back space")
  43. (DEFCONSTANT  *ASCII-TAB*         9    "ASCII tab")
  44. (DEFCONSTANT  *ASCII-LF*         10    "ASCII line feed")
  45. (DEFCONSTANT  *ASCII-FF*         12    "ASCII form feed")
  46. (DEFCONSTANT  *ASCII-CR*         13    "ASCII carriage return")
  47. (DEFCONSTANT  *ASCII-SP*         32    "ASCII space")
  48. (DEFCONSTANT  *ASCII-NS*         35    "ASCII quote")
  49. (DEFCONSTANT  *ASCII-AMP*        38    "ASCII ampersand - for 8-bit quoting")
  50. (DEFCONSTANT  *ASCII-1*          49    "ASCII 1")
  51. (DEFCONSTANT  *ASCII-N*          78    "ASCII N")
  52. (DEFCONSTANT  *ASCII-Y*          89    "ASCII Y")
  53. (DEFCONSTANT  *ASCII-TILDE*     126    "ASCII tilde - for repeat count prefixing")
  54. (DEFCONSTANT  *ASCII-DEL*       127    "ASCII delete - rubout")
  55.  
  56. (DEFCONSTANT  *LISPM-RUBOUT*    135    "LISPM rubout")
  57. (DEFCONSTANT  *LISPM-BS*        136    "LISPM backspace")
  58. (DEFCONSTANT  *LISPM-TAB*       137    "LISPM tab")
  59. (DEFCONSTANT  *LISPM-LF*        138    "LISPM linefeed")
  60. (DEFCONSTANT  *LISPM-DEL*       139    "LISPM delete")
  61. (DEFCONSTANT  *LISPM-PAGE*      140    "LISPM page")
  62. (DEFCONSTANT  *LISPM-NEWLINE*   141    "LISPM version of CRLF")
  63.  
  64. ;;; States - The letter doesn't matter as long as all are unique.
  65.  
  66. (DEFCONSTANT  *ABORT-STATE*       #\A)
  67. (DEFCONSTANT  *SBREAK-STATE*      #\B)
  68. (DEFCONSTANT  *COMPLETE-STATE*    #\C)
  69. (DEFCONSTANT  *SDATA-STATE*       #\D)
  70. (DEFCONSTANT  *EXIT-STATE*        #\E)
  71. (DEFCONSTANT  *SFILE-STATE*       #\F)
  72. (DEFCONSTANT  *SGENERIC-STATE*    #\G)
  73. (DEFCONSTANT  *RSERVER-STATE*     #\I)
  74. (DEFCONSTANT  *RCANCEL-STATE*     #\K)
  75. (DEFCONSTANT  *RFILE-STATE*       #\L)
  76. (DEFCONSTANT  *RDATA-STATE*       #\M)
  77. (DEFCONSTANT  *LOGOUT-STATE*      #\Q)
  78. (DEFCONSTANT  *RINIT-STATE*       #\R)
  79. (DEFCONSTANT  *SINIT-STATE*       #\S)
  80. (DEFCONSTANT  *SSERVER-STATE*     #\V)
  81. (DEFCONSTANT  *SEOF-STATE*        #\Z)
  82.  
  83. (DEFCONSTANT  *KERMIT-NAME*       "Explorer Kermit")
  84.  
  85. ;;; Window variables.
  86.  
  87. (DEFFLAVOR KERMIT-FRAME ()
  88.        (TV:INFERIORS-NOT-IN-SELECT-MENU-MIXIN
  89.         TV:ALIAS-FOR-INFERIORS-MIXIN
  90.         TV:BORDERED-CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER
  91.         TV:LABEL-MIXIN))
  92.  
  93. (DEFMETHOD (KERMIT-FRAME :NAME-FOR-SELECTION) ()
  94.   (SEND SELF :NAME))
  95.  
  96. (DEFVAR *KERMIT-FRAME*            ; Define the KERMIT frame
  97.      (MAKE-INSTANCE 'KERMIT-FRAME
  98.             :EDGES '(44 107 980 478)    ; left,top,right,bottom
  99.             :SAVE-BITS T
  100.             :BORDERS 2
  101.             :LABEL '(:TOP
  102.                   :CENTERED
  103.                   :STRING "Explorer Kermit - Release 1.0"
  104.                   :FONT FONTS:HIGHER-MEDFNB)
  105.             :SELECTION-SUBSTITUTE 'INFO-PANE
  106.             :PANES
  107.             '((STATUS-PANE
  108.                 TV:WINDOW
  109.                 :LABEL NIL
  110.                 :BORDERS (0 2 0 1)
  111.                 :DEEXPOSED-TYPEOUT-ACTION :PERMIT)
  112.               (INFO-PANE
  113.                 TV:WINDOW
  114.                 :LABEL NIL
  115.                 :BORDERS (0 1 0 1)
  116.                 :DEEXPOSED-TYPEOUT-ACTION :PERMIT)
  117.               (MENU-PANE
  118.                 TV:COMMAND-MENU
  119.                 :BORDERS (0 1 0 0)
  120.                 :ROWS 1
  121.                 :COLUMNS 3
  122.                 :ITEM-LIST
  123.                 (("Abort"
  124.                   :VALUE "Z"
  125.                   :DOCUMENTATION "Abort the current operation.")
  126.                  ("Abort-Save"
  127.                   :VALUE "S"
  128.                   :DOCUMENTATION "Abort the current operation but save the file.")
  129.                  ("End"
  130.                   :VALUE "E"
  131.                   :DOCUMENTATION "Exit Kermit (valid only if an operation is complete)."))))
  132.             :CONSTRAINTS
  133.             '((MAIN . ((STATUS-PANE INFO-PANE MENU-PANE)
  134.                    ((STATUS-PANE 5 :LINES))
  135.                    ((MENU-PANE 3 :LINES))
  136.                    ((INFO-PANE :EVEN)))))))
  137.  
  138. (DEFVAR *STATUS-WINDOW* (SEND *KERMIT-FRAME* :GET-PANE 'STATUS-PANE))
  139. (DEFVAR  *INFO-WINDOW* (SEND *KERMIT-FRAME* :GET-PANE 'INFO-PANE))
  140.  
  141. ;;; Global variables - If values of these are changed, change in CHANGE-KERMIT-PARAMETERS function also
  142.  
  143. (DEFVAR  *RARG1*          ""             "Receive argument for interactive KERMIT CVV")
  144. (DEFVAR  *RARG2*          ""             "Receive argument for interactive KERMIT CVV")
  145. (DEFVAR  *SARG1*          ""             "Send argument for interactive KERMIT CVV")
  146. (DEFVAR  *SARG2*          ""             "Send argument for interactive KERMIT CVV")
  147. (DEFVAR  *CARG1*          ""             "Command argument for interactive KERMIT CVV")
  148. (DEFVAR  *CARG2*          ""             "Command argument for interactive KERMIT CVV")
  149.  
  150. (DEFVAR  *IMAGE*          NIL            "T means 8-bit mode - NIL means 7-bit mode")
  151. (DEFVAR  *DEBUG*          NIL            "T means print debugging information")
  152. (DEFVAR  *MORE*           NIL            "T means enable **MORE** in kermit window")
  153. (DEFVAR  *LOGFILE*        NIL            "If a filename specified, log info to a file")
  154. (DEFVAR  *FILNAMCNV*      T              "T means convert filename to name.type - NIL means don't convert file names")
  155. (DEFVAR  *SAVEFILES*      NIL            "T means save partially received file if xfer interrupted - NIL means delete")
  156. (DEFVAR  *MYMAXTRY*       10             "Times to retry a packet")
  157. (DEFVAR  *MYMAXPACSIZ*    94             "Maximum packet size")
  158. (DEFVAR  *MYTIME*         10             "Seconds after which I should be timed out")
  159. (DEFVAR  *MYPAD*          0              "Number of padding characters I will need - I don't need any!")
  160. (DEFVAR  *MYPADCHAR*      0              "Padding character I need - none")
  161. (DEFVAR  *MYEOL*          *ASCII-CR*     "End-Of-Line character")
  162. (DEFVAR  *MYQUOTE*        *ASCII-NS*     "Quote character I will use")
  163.  
  164. ;;; Macro Definitions:
  165.  
  166. (DEFSUBST TOCHAR (ch)
  167.   "converts a control character to a printable one by adding a space"
  168.   (+ ch *ASCII-SP*))
  169.  
  170. (DEFSUBST UNCHAR (ch)
  171.   "undoes TOCHAR by subtracting a space"
  172.   (- ch *ASCII-SP*))
  173.  
  174. (DEFSUBST CTL (ch)
  175.   "converts between control characters and printable characters by toggling
  176. the control bit (ie. ^A becomes A and A becomes ^A). #b1000000 is #o100."
  177.   (LOGXOR ch #b1000000))
  178.  
  179. (DEFSUBST COMPUTE-FINAL-CHECKSUM (NUM)
  180.   "Compute final checksum by folding in bits 7 and 8.  #b11000000 is #o300, #b111111 is #o077."
  181.   (LOGAND (+ (LSH (LOGAND NUM #b11000000) -6) NUM) #b111111))
  182.  
  183. (DEFSUBST CONVERT-FROM-ASCII (ch)
  184.   "Function to convert some characters from ASCII to Lisp."
  185.   (COND
  186.      ((OR
  187.        (AND (> ch *ASCII-CR*) (< ch  *ASCII-DEL*))
  188.        (AND (> ch *ASCII-DEL*) (< ch 256)))
  189.        ch)
  190.     ((= ch *ASCII-CR*)   *LISPM-NEWLINE*)
  191.     ((= ch *ASCII-TAB*)  *LISPM-TAB*)
  192.     ((= ch *ASCII-LF*)   *LISPM-LF*) 
  193.     ((= ch *ASCII-FF*)   *LISPM-PAGE*)
  194.     ((= ch *ASCII-DEL*)  *LISPM-RUBOUT*)
  195.     ((= ch *ASCII-BS*)   *LISPM-BS*)
  196.     (T (IF (OR (< ch 0) (> ch 255))
  197.        NIL ch))))
  198.  
  199. (DEFSUBST CONVERT-TO-ASCII (ch)
  200.   "Function to convert characters from Lisp to ASCII.  Converts any appropriate
  201. control characters but maps the unimportant control chars to NIL."
  202.   (COND
  203.      ((<= ch *ASCII-DEL*)        ch)
  204.     ((= ch *LISPM-BS*)          *ASCII-BS*)
  205.     ((= ch *LISPM-TAB*)         *ASCII-TAB*)
  206.     ((= ch *LISPM-LF*)          *ASCII-LF*)  
  207.     ((= ch *LISPM-PAGE*)        *ASCII-FF*)
  208.     ((= ch *LISPM-NEWLINE*)     *ASCII-CR*)
  209.     ((= ch *LISPM-RUBOUT*)      *ASCII-DEL*)
  210.     (T                          NIL)))
  211.  
  212.  
  213.  
  214. (DEFUN INTERACTIVE-KERMIT (&OPTIONAL STREAM (EXECUTE T))
  215.   "Produce a selection menu.  If EXECUTE is non-nil, call KERMIT;
  216. otherwise, return a form that can be EVALed to call KERMIT."
  217.   (LET*
  218.     ((SELECTION
  219.         (TV:MENU-CHOOSE
  220.      '(
  221.        ("Get File(s)     "
  222.         :VALUE (:GET "Get File(s)"
  223.              ((*RARG1* "Remote File Name   "
  224.                    :DOCUMENTATION "File(s) to transfer from the remote Kermit server." :STRING)
  225.               (*RARG2* "New Local File Name"
  226.                    :DOCUMENTATION "Name to give to the transferred file(s)." :STRING)))
  227.         :DOCUMENTATION "Transfer file(s) from a remote Kermit in server mode.")
  228.        ("Receive File(s) "
  229.         :VALUE (:RECEIVE "Receive File(s)"
  230.                  ((*RARG1* "New Local File Name"
  231.                        :DOCUMENTATION "Local name to give to the received file(s)." :STRING)))
  232.         :DOCUMENTATION "Wait for the arrival of file(s) transferred by a remote Kermit executing a Send command.")
  233.        ("Send File(s)    "
  234.         :VALUE (:SEND "Send File(s)"
  235.               ((*SARG1* "Local File Name     "
  236.                     :DOCUMENTATION "Local file(s) to transfer to the remote Kermit." :STRING)
  237.                (*SARG2* "New Remote File Name"
  238.                     :DOCUMENTATION "Name to give to the transferred file(s) on the remote host." :STRING)))
  239.         :DOCUMENTATION "Transfer file(s) to a remote Kermit in Server mode or executing a Receive command.")
  240.        (""
  241.         :NO-SELECT nil)
  242.        ("Bye             "
  243.         :VALUE (:BYE)
  244.         :DOCUMENTATION "Shut down and logout a remote Kermit server.")
  245.        ("Finish          "
  246.         :VALUE (:FINISH)
  247.         :DOCUMENTATION "Shut down a remote Kermit server without logging out the remote job.")
  248.        (""
  249.         :NO-SELECT nil)
  250.        ("Set Parameters  "
  251.         :VALUE (:SET)
  252.         :DOCUMENTATION "Modify local Kermit operating parameters.")
  253.        (""
  254.         :NO-SELECT nil)
  255.        ("Begin Logging   "
  256.         :VALUE (:LOG-BEGIN "Begin Logging to File"
  257.                      ((*CARG1* "Log File Pathname"
  258.                            :DOCUMENTATION "Pathname used to write logging information." :STRING)))
  259.         :DOCUMENTATION "Begin logging local Kermit actions to a file.")
  260.        ("End Logging     "
  261.         :VALUE (:LOG-END)
  262.         :DOCUMENTATION "End logging local Kermit actions to a file.")
  263.        (""
  264.         :NO-SELECT nil)
  265.        ("Server Mode     "
  266.         :VALUE (:SERVER)
  267.         :DOCUMENTATION "Place local Kermit in server mode.")
  268.        (""
  269.         :NO-SELECT nil)
  270.        ("Remote Copy     "
  271.         :VALUE (:REMOTE-COPY "Remote Copy"
  272.                  ((*CARG1* "File Name     "
  273.                        :DOCUMENTATION "File to copy on the remote KERMIT server." :STRING)
  274.                   (*CARG2* "File Copy Name"
  275.                        :DOCUMENTATION "Name to give to the copy file." :STRING)))
  276.         :DOCUMENTATION "Copy the specified file to another location on a remote KERMIT server.")
  277.        ("Remote CWD      "
  278.         :VALUE (:REMOTE-CWD "Remote Change Working Directory"
  279.                 ((*CARG1* "New Remote Directory"
  280.                       :DOCUMENTATION "New working directory pathname for the remote Kermit server."
  281.                       :STRING)))
  282.         :DOCUMENTATION "Change the working directory of a remote Kermit server.")
  283.        ("Remote Delete   "
  284.         :VALUE (:REMOTE-DELETE "Remote Delete File"
  285.                    ((*CARG1* "Remote File Name"
  286.                          :DOCUMENTATION "Name of file to delete on remote Kermit server." :STRING)))
  287.         :DOCUMENTATION "Delete a file on a remote Kermit server.")
  288.        ("Remote Directory"
  289.         :VALUE (:REMOTE-DIRECTORY "Remote Directory"
  290.                       ((*CARG1* "Remote Directory"
  291.                         :DOCUMENTATION "Directory pathname for remote Kermit server." :STRING)))
  292.         :DOCUMENTATION "Display names of files in directory on remote Kermit server.")
  293.        ("Remote Help     "
  294.         :VALUE (:REMOTE-HELP "Remote Help"
  295.                  ((*CARG1* "Help Topic"
  296.                        :DOCUMENTATION "Optional topic on which to obtain help." :STRING)))
  297.         :DOCUMENTATION "Display a list of remote KERMIT server help commands.")
  298.        ("Remote Host     "
  299.         :VALUE (:REMOTE-HOST "Remote Host"
  300.                  ((*CARG1* "Host Command"
  301.                        :DOCUMENTATION "Command to pass to the remote host." :STRING)))
  302.         :DOCUMENTATION "Pass the given command to the remote KERMIT server host for processing.
  303. The command must be in the remote KERMIT server host's own command level syntax.")
  304.        ("Remote Kermit   "
  305.         :VALUE (:REMOTE-KERMIT "Remote Kermit"
  306.                    ((*CARG1* "Kermit Command"
  307.                          :DOCUMENTATION "Command to pass to the remote KERMIT server." :STRING)))
  308.         :DOCUMENTATION "Pass the given command to the remote KERMIT server for execution.
  309. The command must be in the remote KERMIT server's own interactive mode syntax.")
  310.        ("Remote Rename   "
  311.         :VALUE (:REMOTE-RENAME "Remote Rename File"
  312.                    ((*CARG1* "File Name    "
  313.                          :DOCUMENTATION "File to rename on the remote KERMIT server." :STRING)
  314.                     (*CARG2* "New File Name"
  315.                          :DOCUMENTATION "New name to give to the file." :STRING)))
  316.         :DOCUMENTATION "Rename the specified file on a remote KERMIT server.")
  317.        ("Remote Set      "
  318.         :VALUE (:REMOTE-SET "Remote Set Parameter" 
  319.                 ((*CARG1* "Parameter"
  320.                       :DOCUMENTATION "Name of parameter to set on remote KERMIT server." :STRING)
  321.                  (*CARG2* "Value    "
  322.                       :DOCUMENTATION "New value to give to the parameter." :STRING)))
  323.         :DOCUMENTATION "Set a parameter to a given value on a remote KERMIT server.")
  324.        ("Remote Show     "
  325.         :VALUE (:REMOTE-SHOW "Remote Show Parameter"
  326.                   ((*CARG1* "Parameter"
  327.                         :DOCUMENTATION "Name of parameter to query on remote KERMIT server." :STRING)))
  328.         :DOCUMENTATION "Obtain the value of a parameter on a remote KERMIT server.")
  329.        ("Remote Space    "
  330.         :VALUE (:REMOTE-SPACE "Remote Disk Space"
  331.                   ((*CARG1* "Remote Directory"
  332.                         :DOCUMENTATION "Remote directory pathname." :STRING)))
  333.         :DOCUMENTATION "Display information about disk usage for a directory on remote Kermit server.")
  334.        ("Remote Type     "
  335.         :VALUE (:REMOTE-TYPE "Remote File Type"
  336.                  ((*CARG1* "File Name"
  337.                        :DOCUMENTATION "Name of file to list." :STRING)))
  338.         :DOCUMENTATION "Display the specified filename from a remote KERMIT server."))
  339.      "KERMIT OPERATIONS"
  340.      '(:POINT 500 400)))
  341.      (OPERATION (FIRST SELECTION))
  342.      (LABEL (SECOND SELECTION))
  343.      (CVV-LIST (THIRD SELECTION)))
  344.     
  345.     (WHEN CVV-LIST                ; If a cvv is required, display it
  346.       (WHEN
  347.     (*CATCH 'END-CVV            ; Setup catch - if true, we used it
  348.       (TV:CHOOSE-VARIABLE-VALUES
  349.         CVV-LIST
  350.         :NEAR-MODE '(:POINT 500 400)
  351.         :WIDTH 50
  352.         :LABEL LABEL
  353.         :MARGIN-CHOICES '("Do It" ("Quit" (*THROW 'END-CVV T))))
  354.       NIL)                    ; Return nil from entire block
  355.     (SETQ OPERATION NIL)))            ; If we returned with T, the throw was used.
  356.     
  357.     (WHEN OPERATION
  358.       (LET
  359.     ((FORM `(KERMIT ,OPERATION  
  360.             :ARG1 ,(EVAL (FIRST (FIRST CVV-LIST)))
  361.             :ARG2 ,(EVAL (FIRST (SECOND CVV-LIST)))
  362.             :STREAM ,STREAM
  363.             :VERBOSEP T)))
  364.     (IF EXECUTE
  365.         (EVAL FORM)
  366.         FORM)))))
  367.  
  368.   
  369.  
  370. (DEFUN KERMIT (OPERATION &KEY ARG1 ARG2 STREAM VERBOSEP)
  371.   "Transfers files using the KERMIT protocol.
  372.  
  373. OPERATION - :GET               Transfer file(s) from a remote Kermit in server mode
  374.             :RECEIVE           Wait for the arrival of file(s) transferred by a remote Kermit executing a Send command
  375.             :SEND              Transfer file(s) to a remote KERMIT in server mode or executing a Receive command
  376.             :BYE               Shut down and logout a remote KERMIT server
  377.             :FINISH            Shut down a remote KERMIT server without logging out the remote job
  378.             :SET               Modify the local KERMIT operating parameters
  379.             :LOG-BEGIN         Begin logging local KERMIT actions to a file
  380.             :LOG-END           End logging local KERMIT actions to a file 
  381.             :SERVER            Place local KERMIT in server mode
  382.             :REMOTE-COPY       Copy the specified file to another location on a remote KERMIT server
  383.             :REMOTE-CWD        Change the working directory of a remote KERMIT server
  384.             :REMOTE-DELETE     Delete a file on a remote KERMIT server
  385.             :REMOTE-DIRECTORY  Display names of files in a directory on remote KERMIT server
  386.             :REMOTE-HELP       Display a list of remote KERMIT server help commands
  387.             :REMOTE-HOST       Pass the given command to the remote KERMIT server host for processing
  388.                                (the command must be in the remote KERMIT host's own command level syntax)
  389.             :REMOTE-KERMIT     Pass the given command to the remote KERMIT server for execution
  390.                                (the command must be in the remote KERMIT's own interactive mode syntax)
  391.             :REMOTE-RENAME     Rename the specified file on a remote KERMIT server
  392.             :REMOTE-SET        Set a parameter to a given value on a remote KERMIT server
  393.             :REMOTE-SHOW       Obtain the value of a parameter on a remote KERMIT serve
  394.             :REMOTE-SPACE      Display information about disk usage for a directory on remote KERMIT server
  395.             :REMOTE-TYPE       Display the specified filename from a remote KERMIT server
  396.  
  397. :ARG1     -  Filename, directory, command or parameter
  398. :ARG2     -  New filename, destination name or parameter
  399. :STREAM   -  Serial stream to use
  400. :VERBOSEP -  T means verbose output."
  401.   
  402.   ;;; All Kermit variables that are passed between functions (but not global via DEFVAR)
  403.   ;;; are defined here and prefixed with K*
  404.   
  405.   (LET ((K*OPERATION OPERATION)            ; Action to be taken
  406.     (K*TTYFD STREAM)            ; Serial stream for I/O
  407.     (K*TTYFD-BITS NIL)            ; Number of data bits in serial stream
  408.     (K*VERBOSEP VERBOSEP)            ; T means print things on the screen
  409.     (K*STATE NIL)                ; Represents the present state of RECSW or SENDSW
  410.     (K*PCKT-NUM 0)                ; Packet number
  411.     (K*NUMTRY 0)                ; Times this packet retried
  412.     (K*SIZE 0)                ; Size of data in the buffer
  413.     (K*FILE-CHARS 0)                        ; Total number of file chars read or written
  414.     
  415.     (K*YOURMAXPACSIZ *MYMAXPACSIZ*)        ; Maximum send packet size - default to my size
  416.     (K*YOURTIME (+ 5 *MYTIME*))        ; Timeout on sends - default to longer
  417.     (K*YOURPAD 0)                ; Padding to send - assume none
  418.     (K*YOURPADCHAR 0)            ; Padding character to send - none
  419.     (K*YOUREOL *ASCII-CR*)            ; End-Of-Line character to send
  420.     (K*YOURQUOTE *ASCII-NS*)        ; Quote character in incoming data
  421.     
  422.     (K*BINQUOTE *ASCII-N*)            ; 8-bit quoting character
  423.     (K*REPEAT *ASCII-TILDE*)        ; Repeat character
  424.     
  425.     (K*SPACKET                ; Send packet buffer
  426.       (MAKE-ARRAY (* 2 *MYMAXPACSIZ*)
  427.               :TYPE 'ART-STRING
  428.               :FILL-POINTER 0))
  429.     (K*RPACKET                ; Receive packet buffer
  430.       (MAKE-ARRAY (* 2 *MYMAXPACSIZ*)
  431.               :TYPE 'ART-STRING
  432.               :FILL-POINTER 0))
  433.     (K*BUFFER                ; Local packet buffer
  434.       (MAKE-ARRAY (* 2 *MYMAXPACSIZ*)
  435.               :TYPE 'ART-STRING
  436.               :FILL-POINTER 0))
  437.     (K*ARG1LIST
  438.       (IF (LISTP ARG1)            ; Make sure ARG1 is a list
  439.           ARG1 (LIST ARG1)))
  440.     (K*ARG2LIST
  441.       (IF (LISTP ARG2)            ; Make sure ARG2 is a list
  442.           ARG2 (LIST ARG2)))
  443.     (K*FILNAM NIL)                ; Current file name
  444.     (K*RECFILNAM NIL)            ; Default pathname into which to place the received file
  445.     (K*EMPTY-PATHNAME (MAKE-PATHNAME))      ; Empty pathname used for merging
  446.     
  447.     (K*FP NIL)                ; File pointer to currently opened disk file
  448.     
  449.     (K*BUFILLPTR 0)                ; Pointer to current location in K*BUFILLBUF
  450.     (K*BUFILLBUF                ; Temporary file buffer for BUFILL to handle file input
  451.       (MAKE-ARRAY 2048                      ; Buffer size is 2 blocks
  452.               :TYPE 'ART-STRING
  453.               :FILL-POINTER 0))
  454.     
  455.     (K*IGNORE-NEXT-LINEFEED NIL)        ; Flag for ASCII conversion
  456.     (K*SEND-TO-TTY NIL)            ; Flag indicating whether to send data to TTY or file
  457.     (K*FILES-TRANSFERRED NIL)        ; List of files successfully sent or received
  458.     (K*CANCEL NIL)                ; Used to poll the keyboard to see if we should cancel xfer
  459.     (K*ABORT-REASON NIL)            ; Contains string with error
  460.     (K*PACKETS-TRANSFERRED 0)        ; Total number of packets transferred
  461.     (K*PACKETS-RETRIED 0)            ; Total number of packets retried
  462.     (K*BYTES-TRANSFERRED 0)            ; Total number of bytes transferred
  463.     (K*START-TIME 0))            ; Time at which transfer began
  464.     
  465.     (DECLARE (SPECIAL K*OPERATION K*TTYFD K*VERBOSEP K*STATE K*PCKT-NUM K*NUMTRY K*SIZE K*FILE-CHARS K*START-TIME
  466.               K*YOURMAXPACSIZ K*YOURTIME K*YOURPAD K*YOURPADCHAR K*YOUREOL K*YOURQUOTE K*EMPTY-PATHNAME
  467.               K*BINQUOTE K*REPEAT K*SPACKET K*RPACKET K*BUFFER K*ARG1LIST K*ARG2LIST K*FILNAM K*RECFILNAM
  468.               K*FP K*BUFILLBUF K*BUFILLPTR K*IGNORE-NEXT-LINEFEED K*SEND-TO-TTY K*BYTES-TRANSFERRED
  469.               K*FILES-TRANSFERRED K*CANCEL K*ABORT-REASON K*PACKETS-TRANSFERRED K*PACKETS-RETRIED))
  470.     
  471.                     ;  (CONDITION-CASE (K-ERROR)                           ; Setup error trap
  472.     (PROGN                    ; First form is the body...
  473.       
  474.       (WHEN K*VERBOSEP                    ; Setup the KERMIT output window
  475.     (INITIALIZE-STATUS-WINDOW)        ; Initialize the status window
  476.     (SEND *INFO-WINDOW* :CLEAR-WINDOW)    ; Clear the Interactive window
  477.     (SEND *KERMIT-FRAME* :SELECT))        ; Select and expose the entire frame
  478.       
  479.       (WHEN (EQL OPERATION :SET)            ; If the SET operation was specified,
  480.      (SETQ K*VERBOSEP NIL))            ; force quiet mode!
  481.  
  482.       (WHEN (NOT K*TTYFD)            ; If no stream was supplied, make one.
  483.     (SETQ K*TTYFD (SI:MAKE-SERIAL-STREAM))) ; Could use SI:*SERIAL-PORT-OWNER* ;; BAC 
  484.       (SEND K*TTYFD :CLEAR-INPUT)
  485.       (SEND K*TTYFD :CLEAR-OUTPUT)
  486.       (SETQ K*TTYFD-BITS            ; Determine the number of data bits in the stream
  487.         (SEND K*TTYFD :GET :NUMBER-OF-DATA-BITS))
  488.       (SETQ K*BINQUOTE                ; Set the initial value for the 8-bit quote char
  489.         (IF *IMAGE*                ; Image mode?
  490.         (IF (= K*TTYFD-BITS 8)          ; - Yes, 8-bit?
  491.             *ASCII-Y*                   ; -- Yes, set to Y
  492.             *ASCII-AMP*)            ; -- No,  set to &
  493.         *ASCII-N*))            ; - No, set to N
  494.       
  495.       (WHEN ARG1                ; If a filename was specified,
  496.     (GET-NEXT-FILE))            ; Set K*FILNAM to the first in the list
  497.       
  498.       (UNWIND-PROTECT                ; Surround entire selection in unwind-protect
  499.       (SELECTQ OPERATION
  500.         (:SEND                    ; Send command
  501.          (IF K*FILNAM            ; Required filename specified?
  502.          (LET                           ; - Yes
  503.            ((HOST-SPECIFIED? (STRING-SEARCH ":" K*RECFILNAM))
  504.             (PATH-RECFILNAM (FS:PARSE-PATHNAME K*RECFILNAM NIL K*EMPTY-PATHNAME)))
  505.            (SETQ K*ARG1LIST
  506.              (EXPAND-WILDS K*FILNAM))    ; Expand any wildcards in the filename
  507.            (SETQ K*ARG2LIST        ; expand the transfer name list
  508.              (MAPCAR                ; Map over each of the send files 
  509.                (FUNCTION            ; replacing any wildcard components
  510.                  (LAMBDA (x)
  511.                    (LET 
  512.                  ((EXPANDED-PATH (DEFAULT-ONLY-WILD-PATHNAME-COMPONENTS PATH-RECFILNAM x)))
  513.                  (IF HOST-SPECIFIED?
  514.                      EXPANDED-PATH
  515.                      (SEND EXPANDED-PATH :STRING-FOR-HOST)))))
  516.                K*ARG1LIST))
  517.            (GET-NEXT-FILE)        ; Get the file to process
  518.            (SW *SINIT-STATE*))        ; - Yes, start with SINIT as initial state
  519.          (PRINTMSG "~%~A"        ; - No, setup error
  520.                (SETQ K*ABORT-REASON "No file(s) specified"))))
  521.         (:GET
  522.          (IF K*FILNAM            ; Required filename specified?
  523.          (PROGN                ; - Yes
  524.            (SETQ K*FILNAM
  525.              (CREATE-KERMIT-FILENAME K*FILNAM))    ; Make a suitable packet filename
  526.            (SW *SGENERIC-STATE* #\R K*FILNAM))    ; SGENERIC is the initial state
  527.          (PRINTMSG "~%~A"        ; - No, setup error
  528.                (SETQ K*ABORT-REASON "No file(s) specified"))))
  529.         (:RECEIVE
  530.          (SW *RINIT-STATE*))        ; Start with RINIT as initial state
  531.         (:BYE
  532.          (SW *SGENERIC-STATE* #\G "L"))    ; SGENERIC is initial state
  533.         (:FINISH
  534.          (SW *SGENERIC-STATE* #\G "F"))    ; SGENERIC is initial state
  535.         (:SET
  536.          (CHANGE-KERMIT-PARAMETERS))
  537.         (:LOG-BEGIN
  538.          (IF K*FILNAM            ; Required filename specified?
  539.          (CONDITION-CASE (ERR)        ; - Yes, try to open the logfile
  540.              (PROGN
  541.               (SETQ K*FILNAM        ; Merge the filename with the home directory
  542.                 (SEND
  543.                   (FS:MERGE-PATHNAME-DEFAULTS
  544.                 K*FILNAM
  545.                 (USER-HOMEDIR-PATHNAME))
  546.                   :STRING-FOR-PRINTING))
  547.               (SETQ *LOGFILE*        ; Try to open the file 
  548.                 (OPEN K*FILNAM
  549.                   :DIRECTION :OUTPUT
  550.                   :IF-EXISTS ':NEW-VERSION
  551.                   :IF-DOES-NOT-EXIST ':CREATE)))
  552.            (ERROR            ; If unable to merge the filename or open the file
  553.             (PRINTMSG "~%~A"
  554.                   (SETQ K*ABORT-REASON
  555.                     (FORMAT NIL "~A: Error <~A> opening log file ~A"
  556.                         *KERMIT-NAME* (SEND ERR :REPORT-STRING) K*FILNAM))))
  557.            (:NO-ERROR
  558.             (MULTIPLE-VALUE-BIND (SS MM HH DY MN YR) (GET-DECODED-TIME)
  559.               (PRINTMSG "~%Begin logging at ~A:~A:~A  ~A/~A/~A  to file ~A"
  560.                 HH MM SS MN DY YR K*FILNAM))))
  561.          (PRINTMSG "~%~A"        ; - No, filename not specified
  562.                (SETQ K*ABORT-REASON "No log file name specified"))))
  563.         (:LOG-END
  564.          (IF *LOGFILE*              ; Is there an open logfile?
  565.          (PROGN                ; - Yes
  566.            (MULTIPLE-VALUE-BIND (SS MM HH DY MN YR) (GET-DECODED-TIME)
  567.              (PRINTMSG "~%End logging to file ~A at ~A:~A:~A  ~A/~A/~A~%"
  568.                    (SEND (SEND *LOGFILE* :TRUENAME) :STRING-FOR-PRINTING) HH MM SS MN DY YR))
  569.            (SEND *LOGFILE* :CLOSE)    ; Close the file
  570.            (SETQ *LOGFILE* NIL))
  571.          (PRINTMSG "~%~A"        ; - No
  572.                (SETQ K*ABORT-REASON
  573.                  (FORMAT NIL "~A: No log file was opened" *KERMIT-NAME*)))))
  574.         (:SERVER
  575.          (SW *RSERVER-STATE*))        ; RSERVER is initial state
  576.         (:REMOTE-COPY
  577.          (IF (AND K*FILNAM K*RECFILNAM)    ; Required filenames specified?
  578.          (SW *SGENERIC-STATE*        ; - Yes, SGENERIC is initial state
  579.              #\G            ; Start with G packet
  580.              (FORMAT NIL "K~C~A~C~A"    ; Setup data packet                
  581.                  (TOCHAR (LENGTH K*FILNAM)) K*FILNAM
  582.                  (TOCHAR (LENGTH K*RECFILNAM)) K*RECFILNAM))
  583.          (PRINTMSG "~%~A"        ; - No, setup error
  584.                (SETQ K*ABORT-REASON "Both files must be specified"))))
  585.         (:REMOTE-CWD
  586.          (SW *SGENERIC-STATE*        ; SGENERIC is initial state
  587.          #\G                ; Start with G packet
  588.          (FORMAT NIL "C~C~A"        ; Setup data packet                
  589.              (TOCHAR (LENGTH K*FILNAM)) K*FILNAM)))
  590.         (:REMOTE-DELETE
  591.          (IF K*FILNAM            ; Required filename specified?
  592.          (SW *SGENERIC-STATE*        ; - Yes, SGENERIC is initial state
  593.              #\G            ; Start with G packet
  594.              (FORMAT NIL "E~C~A"    ; Setup data packet                
  595.                  (TOCHAR (LENGTH K*FILNAM)) K*FILNAM))
  596.          (PRINTMSG "~%~A"        ; - No, setup error
  597.                (SETQ K*ABORT-REASON "No file(s) specified"))))
  598.         (:REMOTE-DIRECTORY
  599.          (IF K*FILNAM            ; Required filename specified?
  600.          (SW *SGENERIC-STATE*        ; - Yes, SGENERIC is initial state
  601.              #\G            ; Start with G packet
  602.              (FORMAT NIL "D~C~A"    ; Setup data packet                
  603.                  (TOCHAR (LENGTH K*FILNAM)) K*FILNAM))
  604.          (PRINTMSG "~%~A"        ; - No, setup error
  605.                (SETQ K*ABORT-REASON "No file(s) specified"))))
  606.         (:REMOTE-HELP
  607.          (SW *SGENERIC-STATE*        ; SGENERIC is initial state
  608.          #\G                ; Start with G packet
  609.          (FORMAT NIL "H~C~A"        ; Setup data packet                
  610.              (TOCHAR (LENGTH K*FILNAM)) K*FILNAM)))
  611.         (:REMOTE-HOST
  612.          (IF K*FILNAM            ; Required command specified?
  613.          (SW *SGENERIC-STATE*        ; - Yes, SGENERIC is initial state
  614.              #\C            ; Start with C packet
  615.              (FORMAT NIL "~A"        ; Setup data packet                
  616.                  K*FILNAM))
  617.          (PRINTMSG "~%~A"        ; - No, setup error
  618.                (SETQ K*ABORT-REASON "No command specified"))))
  619.         (:REMOTE-KERMIT
  620.          (IF K*FILNAM            ; Required command specified?
  621.          (SW *SGENERIC-STATE*        ; - Yes, SGENERIC is initial state
  622.              #\K            ; Start with K packet
  623.              (FORMAT NIL "~A"        ; Setup data packet                
  624.                  K*FILNAM))
  625.          (PRINTMSG "~%~A"        ; - No, setup error
  626.                (SETQ K*ABORT-REASON "No command specified"))))
  627.         (:REMOTE-RENAME
  628.          (IF (AND K*FILNAM K*RECFILNAM)    ; Required filenames specified?
  629.          (SW *SGENERIC-STATE*        ; - Yes, SGENERIC is initial state
  630.              #\G            ; Start with G packet
  631.              (FORMAT NIL "R~C~A~C~A"    ; Setup data packet                
  632.                  (TOCHAR (LENGTH K*FILNAM)) K*FILNAM
  633.                  (TOCHAR (LENGTH K*RECFILNAM)) K*RECFILNAM))
  634.          (PRINTMSG "~%~A"        ; - No, setup error
  635.                (SETQ K*ABORT-REASON "Both files must be specified"))))
  636.         (:REMOTE-SET
  637.          (IF (AND K*FILNAM K*RECFILNAM)    ; Required parameters specified?
  638.          (SW *SGENERIC-STATE*        ; - Yes, SGENERIC is initial state
  639.              #\G            ; Start with G packet
  640.              (FORMAT NIL "V~CS~C~A~C~A"    ; Setup data packet
  641.                  (TOCHAR 1)
  642.                  (TOCHAR (LENGTH K*FILNAM)) K*FILNAM
  643.                  (TOCHAR (LENGTH K*RECFILNAM)) K*RECFILNAM))
  644.          (PRINTMSG "~%~A"        ; - No, setup error
  645.                (SETQ K*ABORT-REASON "Both variable and value must be specified"))))
  646.         (:REMOTE-SHOW
  647.          (IF K*FILNAM            ; Required parameter specified?
  648.          (SW *SGENERIC-STATE*        ; - Yes, SGENERIC is initial state
  649.              #\G            ; Start with G packet
  650.              (FORMAT NIL "V~CQ~C~A"    ; Setup data packet                
  651.                  (TOCHAR 1)
  652.                  (TOCHAR (LENGTH K*FILNAM)) K*FILNAM))
  653.          (PRINTMSG "~%~A"        ; - No, setup error
  654.                (SETQ K*ABORT-REASON "Variable must be specified"))))
  655.         (:REMOTE-SPACE
  656.          (SW *SGENERIC-STATE*        ; SGENERIC is initial state
  657.          #\G
  658.          (FORMAT NIL "U~C~A" 
  659.              (TOCHAR (LENGTH K*FILNAM)) K*FILNAM)))
  660.         (:REMOTE-TYPE
  661.          (IF K*FILNAM            ; Required filename specified?
  662.          (SW *SGENERIC-STATE*        ; - Yes, SGENERIC is initial state
  663.              #\G            ; Start with G packet
  664.              (FORMAT NIL "T~C~A"    ; Setup data packet                
  665.                  (TOCHAR (LENGTH K*FILNAM)) K*FILNAM))
  666.          (PRINTMSG "~%~A"        ; - No, setup error
  667.                (SETQ K*ABORT-REASON "No file(s) specified"))))
  668.         (:OTHERWISE                ; Unknown command
  669.          (PRINTMSG "~%~A"
  670.                (SETQ K*ABORT-REASON "Invalid operation specified"))))
  671.     
  672.     (IF K*FP (SEND K*FP :CLOSE)))        ; No matter what happened, close any opened file
  673.       
  674.       (WHEN K*VERBOSEP                    ; When not in quiet mode
  675.     (PRINTMSG "~%KERMIT operation ~A ~A."
  676.           OPERATION
  677.           (IF K*ABORT-REASON "failed" "succeeded"))
  678.     (WHEN K*FILES-TRANSFERRED
  679.       (PRINTMSG "~%Files transferred: ~A." K*FILES-TRANSFERRED))
  680.     (PRINTMSG "~%Press any key or click on END to continue.")
  681.     (SEND *INFO-WINDOW* :CLEAR-INPUT)    ; Clear the input buffer
  682.     (SEND *INFO-WINDOW* :ANY-TYI)           ; Wait for a keypress or mouse blip
  683.     (SEND *KERMIT-FRAME* :BURY))            ; Bury the Interactive window
  684.       
  685.       (IF K*ABORT-REASON
  686.       (VALUES NIL K*FILES-TRANSFERRED K*ABORT-REASON)
  687.       (VALUES T   K*FILES-TRANSFERRED NIL)))
  688.     
  689.                         ; (ERROR
  690.                         ;  (PRINTMSG "~%~%ERROR: ~A" (SEND K-ERROR :REPORT-STRING))
  691.                         ;  (SIGNAL-CONDITION K-ERROR)))
  692.     ))
  693.  
  694.  
  695.  
  696. (DEFUN SW (STATE &OPTIONAL SPACK-TYPE SPACK-DATA)
  697.   "This is the state table switcher for transferring files.  It loops until
  698. either it finishes, or an error is encountered.  The routines called by
  699. this function are responsible for returning a new state."
  700.   
  701.   (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*NUMTRY K*OPERATION K*VERBOSEP K*CANCEL
  702.             K*FP K*ABORT-REASON))
  703.   
  704.   (SETQ K*STATE STATE)                ; Initialize the start state
  705.   (SETQ K*CANCEL NIL)
  706.   (SETQ K*PCKT-NUM 0)                ; Initialize the packet number
  707.   (SETQ K*NUMTRY 0)                ; Say no tries yet
  708.   
  709.   (LOOP
  710.     UNTIL (NOT K*STATE)
  711.     DO
  712.     
  713.     (WHEN *DEBUG*
  714.       (PRINTMSG "~%Function SW in state ~C" K*STATE))
  715.     
  716.     (WHEN (>= K*NUMTRY *MYMAXTRY*)
  717.       (PRINTMSG "~%~A"
  718.         (SETQ K*ABORT-REASON        ; Save the error
  719.               (FORMAT NIL "~A: No valid packet received after ~A retries." *KERMIT-NAME* K*NUMTRY)))
  720.       (SETQ K*STATE *ABORT-STATE*)
  721.       (SETQ K*NUMTRY 0))
  722.    
  723.     (WHEN (AND K*VERBOSEP (NOT K*CANCEL))    ; When verbose and not already cancelled
  724.       (SETQ K*CANCEL
  725.         (SEND *INFO-WINDOW* :ANY-TYI-NO-HANG))    ; Get a char from the io buffer
  726.       (IF                    ; Command menu blip?
  727.     (AND
  728.       (CONSP K*CANCEL)
  729.       (EQ (FIRST K*CANCEL) :MENU))
  730.     (PROGN                    ; - Yes
  731.       (SETQ K*CANCEL
  732.         (GET (SECOND K*CANCEL) :VALUE))    ; Set the value of K*CANCEL
  733.       (IF (STRING-EQUAL K*CANCEL "E")       ; End requsted?
  734.           (PROGN                            ; -- Yes
  735.         (SETQ K*CANCEL NIL)             ; Reset K*CANCEL
  736.         (PRINTMSG "~%~A: END not valid here; ABORT or ABORT-SAVE first." *KERMIT-NAME*))
  737.           (PRINTMSG "~%~A"                  ; -- No, 
  738.               (SETQ K*ABORT-REASON    ; Save the error
  739.                 (FORMAT NIL "~A: User requested cancellation." *KERMIT-NAME*)))))
  740.     (SETQ K*CANCEL NIL)))            ; - No
  741.  
  742.     (SETQ K*STATE
  743.       (SELECT K*STATE
  744.         (*RDATA-STATE*        (RDATA))
  745.         (*SDATA-STATE*        (SDATA))
  746.         (*RINIT-STATE*        (RINIT))
  747.         (*SINIT-STATE*        (SINIT))
  748.         (*RFILE-STATE*        (RFILE))
  749.         (*SFILE-STATE*        (SFILE))
  750.         (*SEOF-STATE*         (SEOF))
  751.         (*SBREAK-STATE*       (SBREAK))
  752.         (*SGENERIC-STATE*     (SGENERIC SPACK-TYPE SPACK-DATA))
  753.         (*SSERVER-STATE*      (SSERVER))
  754.         (*RSERVER-STATE*      (RSERVER))
  755.         (*COMPLETE-STATE*     (IF (EQL K*OPERATION :SERVER) *RSERVER-STATE* NIL))
  756.         (*RCANCEL-STATE*      (RCANCEL))
  757.         (*ABORT-STATE*        (IF K*FP (SEND K*FP :CLOSE))
  758.                   (IF (AND (EQL K*OPERATION :SERVER) (NOT K*CANCEL))
  759.                       *RSERVER-STATE*
  760.                       NIL))
  761.         (:OTHERWISE           NIL)))))
  762.  
  763.  
  764.  
  765. (DEFUN SINIT ()
  766.   "Send-Initiate function to send this host's parameters and get other side's back."
  767.   (DECLARE (SPECIAL K*YOUREOL K*STATE K*CANCEL K*PCKT-NUM K*YOURQUOTE K*ABORT-REASON K*SPACKET))
  768.   (SETQ K*PCKT-NUM 0)                ; Initialize the packet number
  769.   
  770.   (IF K*CANCEL                    ; Cancelled?
  771.       *ABORT-STATE*                ; - Yes, abort
  772.       (PROGN                    ; - No
  773.     (SETQ K*SPACKET (SPAR K*SPACKET))    ; Fill up init info packet
  774.     (SPACK #\S K*PCKT-NUM (LENGTH K*SPACKET) K*SPACKET)    ; Send an S packet with type,number,length,packet
  775.     
  776.     (MULTIPLE-VALUE-BIND (TYPE LEN NUM PACKET)
  777.         (RPACK)                ; What was the reply?
  778.       (SELECTQ TYPE                ;
  779.         
  780.         (#\Y                ; ACK...
  781.          (IF (= K*PCKT-NUM NUM)        ; Correct ACK?
  782.          (PROGN                ; - Yes
  783.            (RPAR PACKET LEN)        ; Get other side's init info
  784.            (INCREMENT-PACKET-NUMBER)    ; Bump packet count
  785.            *SFILE-STATE*)        ; OK, switch to SFILE-STATE
  786.          K*STATE))            ; - No, stay in same K*STATE
  787.         
  788.         (#\N                ; NAK
  789.          (INCREMENT-RETRIES)        ; Increment the retries
  790.          K*STATE)                ; stay in same state and try again
  791.         
  792.         (#\E                ; Error packet received
  793.          (PRINTMSG "~%~A"
  794.                (SETQ K*ABORT-REASON    ; Save the error
  795.                  (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET)))
  796.          *ABORT-STATE*)
  797.         
  798.         (NIL                ; No packet received - timeout
  799.          (INCREMENT-RETRIES)        ; Increment the retries
  800.          K*STATE)                ; and try again
  801.         
  802.         (:OTHERWISE                ; Received unknown packet - abort
  803.          (PRINTMSG "~%~A"
  804.                (SETQ K*ABORT-REASON    ; Save the error
  805.                  (FORMAT NIL "~A: Received unknown packet type <~A>." *KERMIT-NAME* TYPE)))
  806.          *ABORT-STATE*))))))
  807.  
  808.  
  809.  
  810. (DEFUN SFILE ()
  811.   "Send File Header."
  812.   (DECLARE (SPECIAL K*FP K*FILNAM K*RECFILNAM K*SPACKET K*STATE K*PCKT-NUM
  813.             K*CANCEL K*SIZE K*SEND-TO-TTY K*ABORT-REASON))
  814.   
  815.   (IF K*CANCEL                    ; Cancelled?
  816.       *ABORT-STATE*                ; - Yes
  817.       
  818.       (PROGN                    ; - No     
  819.     (WHEN (NOT K*FP)            ; If file is not already open,   
  820.       (LET ((FILNAM                ; Merge the filename with the home directory
  821.           (SEND (FS:MERGE-PATHNAME-DEFAULTS
  822.               K*FILNAM
  823.               (USER-HOMEDIR-PATHNAME))
  824.             :STRING-FOR-PRINTING)))
  825.         (WHEN *DEBUG*            ; Print debugging info
  826.           (PRINTMSG "~%Opening ~A for sending." FILNAM))
  827.         
  828.         (CONDITION-CASE (ERR)
  829.         (SETQ K*FP            ; Try to open the file
  830.               (OPEN FILNAM)) 
  831.           (ERROR                ; Error in opening?
  832.            (PRINTMSG "~%~A"            ; Print error
  833.              (SETQ K*ABORT-REASON
  834.                    (FORMAT NIL "~A: Error <~A> opening file ~A."
  835.                        *KERMIT-NAME* (SEND ERR :REPORT-STRING) FILNAM))) 
  836.            (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)    ; Send E packet
  837.            (SETQ K*FP NIL)))))        ; Be sure the pointer is not set
  838.     
  839.     (IF (NOT K*FP)                ; Did we get an error opening the file?
  840.         *ABORT-STATE*            ; - Yes, abort
  841.         (PROGN                        ; - No, setup the filename to send
  842.           (SETQ K*RECFILNAM
  843.             (IF K*SEND-TO-TTY           ; Send to the other KERMIT'S tty?
  844.             ""                      ; - Yes, don't worry about any transfer name
  845.             (CREATE-KERMIT-FILENAME ; - No, convert the transfer name
  846.               (IF K*RECFILNAM    ; Was a transfer filename specified?
  847.                   K*RECFILNAM    ; -- Yes, use it
  848.                   (SEND               ; -- No, use the true open file name
  849.                 (SEND K*FP :TRUENAME)
  850.                 :STRING-FOR-PRINTING)))))
  851.           (SETQ K*SIZE (ENCODE-PREFIXED-DATA K*RECFILNAM K*SPACKET))
  852.           (INITIALIZE-STATUS-COUNTS)    ; Reset the timing info
  853.           (PRINT-STATUS-FILE-INFO)        ; update the filenames on the screen
  854.           (PRINTMSG "~%Sending data...")
  855.           (IF K*SEND-TO-TTY            ; Are we sending to other KERMIT's TTY?
  856.           (SPACK #\X K*PCKT-NUM K*SIZE K*SPACKET)    ; - Yes, send an X packet
  857.           (SPACK #\F K*PCKT-NUM K*SIZE K*SPACKET))    ; - No, send an F packet
  858.           
  859.           (MULTIPLE-VALUE-BIND (TYPE IGNORE NUM PACKET)
  860.           (RPACK)            ; What was the reply?
  861.         (SELECTQ TYPE
  862.           
  863.           (#\Y                ; ACK
  864.            (IF (= NUM K*PCKT-NUM)    ; See if it's correct ACK
  865.                (PROGN            ; - Yes,
  866.              (INCREMENT-PACKET-NUMBER)    ; Increment the packet count
  867.              (SETQ K*SIZE
  868.                    (BUFILL K*SPACKET K*FP))    ; Get first data from file
  869.              *SDATA-STATE*)        ; Switch to DATA-STATE
  870.                K*STATE))        ; - No, stay in same K*STATE
  871.           
  872.           (#\N                ; NAK
  873.            (IF (= (IF (> NUM 0 ) (1- NUM) 63)    ; See if this is a NAK for the previous packet
  874.               K*PCKT-NUM)
  875.                (PROGN            ; - Yes, so treat it as an ACK
  876.              (INCREMENT-PACKET-NUMBER)    ; Increment the packet count
  877.              (SETQ K*SIZE
  878.                    (BUFILL K*SPACKET K*FP))    ; Get first data from file
  879.              *SDATA-STATE*)        ; Switch to SDATA-STATE
  880.                (PROGN            ; - No,
  881.              (INCREMENT-RETRIES)    ; increment the retries
  882.              K*STATE)))        ; Remain in same K*STATE
  883.           
  884.           (#\E                ; Error packet received
  885.            (SETQ K*ABORT-REASON        ; Save the error
  886.              (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET))
  887.            (PRINTMSG "~%~A" K*ABORT-REASON)
  888.            *ABORT-STATE*)
  889.           
  890.           (NIL                ; Timeout
  891.            (INCREMENT-RETRIES)        ; Increment the retries
  892.            K*STATE)            ; Remain in same K*STATE
  893.           
  894.           (:OTHERWISE            ; Unknown packet - abort
  895.            (PRINTMSG "~%~A"
  896.                  (SETQ K*ABORT-REASON    ; Save the error
  897.                    (FORMAT NIL "~A: Received unknown packet type <~A>." *KERMIT-NAME* TYPE)))
  898.            *ABORT-STATE*))))))))
  899.  
  900.  
  901.  
  902. (DEFUN SDATA ()
  903.   "Send File Data."
  904.   (DECLARE (SPECIAL K*FP K*STATE K*PCKT-NUM K*SIZE K*CANCEL K*SPACKET K*ABORT-REASON))
  905.   (SPACK #\D K*PCKT-NUM K*SIZE K*SPACKET)    ; Send a D packet
  906.   (COUNT-AND-PRINT-PACKETS K*SIZE)            ; Keep track of packet totals
  907.   
  908.   (MULTIPLE-VALUE-BIND (TYPE IGNORE NUM PACKET)
  909.       (RPACK)                    ; What was the reply?
  910.     (SELECTQ TYPE
  911.       
  912.       (#\Y                    ; ACK
  913.        (IF (= NUM K*PCKT-NUM)            ; See if it's correct ACK
  914.        (PROGN                ; - Yes,
  915.          (INCREMENT-PACKET-NUMBER)        ; Increment the packet count
  916.          (SETQ K*SIZE
  917.            (BUFILL K*SPACKET K*FP))          ; Get more data from the file
  918.          (IF (OR (ZEROP K*SIZE) K*CANCEL)    ; EOF or cancel flag?
  919.          *SEOF-STATE*            ; -- Yes, switch to SEOF-STATE
  920.          *SDATA-STATE*))        ; -- No, stay in SDATA-STATE
  921.        (PROGN                ; - No
  922.          (INCREMENT-RETRIES)        ; Increment the retries
  923.          K*STATE)))                ; Stay in same K*STATE
  924.       
  925.       (#\N                    ; NAK
  926.        (IF (= (IF (> NUM 0 ) (1- NUM) 63)    ; See if it's a NAK for last packet
  927.           K*PCKT-NUM)
  928.        (PROGN                ; - Yes, treat as ACK
  929.          (INCREMENT-PACKET-NUMBER)        ; Increment the packet count
  930.          (SETQ K*SIZE
  931.            (BUFILL K*SPACKET K*FP))            ; Get more date from the file
  932.          (IF (OR (ZEROP K*SIZE) K*CANCEL)    ; EOF or cancel flag?
  933.          *SEOF-STATE*            ; -- Yes, switch to SEOF-STATE
  934.          *SDATA-STATE*))        ; -- No, stay in SDATA-STATE
  935.        (PROGN                ; - No
  936.          (INCREMENT-RETRIES)        ; Increment the retries
  937.          K*STATE)))                ; Stay in same K*STATE
  938.       
  939.       (#\E                    ; Error packet received
  940.        (PRINTMSG "~%~A"
  941.          (SETQ K*ABORT-REASON        ; Save the error
  942.                (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET)))
  943.        *ABORT-STATE*)
  944.       
  945.       (NIL                    ; Timeout
  946.        (INCREMENT-RETRIES)            ; Increment the retries
  947.        K*STATE)                    ; Remain in same K*STATE
  948.       
  949.       (:OTHERWISE                ; Unknown packet - abort
  950.        (PRINTMSG "~%~A"
  951.          (SETQ K*ABORT-REASON        ; Save the error
  952.                (FORMAT NIL "~A: Received unknown packet type <~A>." *KERMIT-NAME* TYPE)))
  953.        *ABORT-STATE*))))
  954.  
  955.  
  956.  
  957. (DEFUN SEOF ()
  958.   "Send End-Of-File."
  959.   (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*FP K*FILNAM
  960.             K*CANCEL K*ABORT-REASON))
  961.   (IF K*CANCEL                                ; Has cancellation been requested?
  962.       (SPACK #\Z K*PCKT-NUM 1 "D")        ; - Yes, send a Z packet with a D for Discard!
  963.       (SPACK #\Z K*PCKT-NUM 0 NIL))        ; - No, send a Z packet to close
  964.   
  965.   (MULTIPLE-VALUE-BIND (TYPE IGNORE NUM PACKET)
  966.       (RPACK)                    ; What was the reply?
  967.     (SELECTQ TYPE
  968.       
  969.       (#\Y                    ; ACK
  970.        (IF (= NUM K*PCKT-NUM)            ; See if it's correct ACK
  971.        (PROGN                ; - Yes
  972.          (INCREMENT-PACKET-NUMBER)        ; Increment the packet count
  973.          (PRINTMSG "~%Sending completed.")
  974.          (SEND K*FP :CLOSE)            ; Close the input file
  975.          (SETQ K*FP NIL)            ; Set flag indicating no file open
  976.          (IF (GET-NEXT-FILE)        ; Any more files?
  977.          (PROGN                ; -- Yes
  978.            (IF *DEBUG*            ; Print debugging info
  979.                (PRINTMSG "~%New file is ~A." K*FILNAM))
  980.            *SFILE-STATE*)        ; Switch to SFILE-STATE
  981.          *SBREAK-STATE*))        ; -- No, Break (EOT) and all done
  982.        (PROGN                ; - No
  983.          (INCREMENT-RETRIES)        ; Increment the retries
  984.          K*STATE)))                ; Stay in same K*STATE
  985.       
  986.       (#\N                    ; NAK
  987.        (IF (= (IF (> NUM 0 ) (1- NUM) 63)    ; See if it's a NAK for last packet
  988.           K*PCKT-NUM)
  989.        (PROGN                ; - Yes, treat as ACK
  990.          (INCREMENT-PACKET-NUMBER)        ; Increment the packet count
  991.          (PRINTMSG "~%Sending completed.")
  992.          (SEND K*FP :CLOSE)            ; Close the input file
  993.          (SETQ K*FP NIL)            ; Set flag indicating no file open
  994.          (IF (GET-NEXT-FILE)        ; Any more files?
  995.          (PROGN                ; -- Yes,
  996.            (IF *DEBUG*            ; Print debugging info
  997.                (PRINTMSG "~%New file is ~A." K*FILNAM))
  998.            *SFILE-STATE*)        ; Switch to SFILE-STATE
  999.          *SBREAK-STATE*))        ; -- No, Break (EOT) and all done
  1000.        (PROGN                ; - No,
  1001.          (INCREMENT-RETRIES)        ; Increment the retries
  1002.          K*STATE)))                ; Stay in same K*STATE
  1003.       
  1004.       (#\E                    ; Error packet received
  1005.        (PRINTMSG "~%~A"
  1006.          (SETQ K*ABORT-REASON        ; Save the error
  1007.                (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET)))
  1008.        *ABORT-STATE*)
  1009.       
  1010.       (NIL                    ; Timeout
  1011.        (INCREMENT-RETRIES)            ; Increment the retries
  1012.        K*STATE)                    ; Remain in same K*STATE
  1013.       
  1014.       (:OTHERWISE                ; Unknown packet - abort
  1015.        (PRINTMSG "~%~A"
  1016.          (SETQ K*ABORT-REASON        ; Save the error
  1017.                (FORMAT NIL "~A: Received unknown packet type <~A>." *KERMIT-NAME* TYPE)))
  1018.        *ABORT-STATE*))))
  1019.  
  1020.  
  1021.  
  1022. (DEFUN SBREAK ()
  1023.   "Send Break (EOT)."
  1024.   (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*ABORT-REASON))
  1025.   (SPACK #\B K*PCKT-NUM 0 NIL)            ; Send a B packet
  1026.   
  1027.   (MULTIPLE-VALUE-BIND (TYPE IGNORE NUM PACKET)
  1028.       (RPACK)                    ; What was the reply?
  1029.     (SELECTQ TYPE
  1030.       
  1031.       (#\Y                    ; ACK
  1032.        (IF (= NUM K*PCKT-NUM)            ; See if it's correct ACK
  1033.        (PROGN                ; - Yes
  1034.          (INCREMENT-PACKET-NUMBER)        ; Increment the packet count
  1035.          *COMPLETE-STATE*)            ; Switch to COMPLETE-STATE
  1036.        (PROGN                ; - No
  1037.          (INCREMENT-RETRIES)        ; Increment the retries
  1038.          K*STATE)))                ; Stay in same K*STATE
  1039.       
  1040.       (#\N                    ; NAK
  1041.        (IF (= (IF (> NUM 0 ) (1- NUM) 63)    ; See if it's a NAK for last packet
  1042.           K*PCKT-NUM)
  1043.        (PROGN                ; - Yes, treat as ACK
  1044.          (INCREMENT-PACKET-NUMBER)        ; Increment the packet count
  1045.          *COMPLETE-STATE*)            ; Switch to COMPLETE-STATE
  1046.        (PROGN                ; - No,
  1047.          (INCREMENT-RETRIES)        ; Increment the retries
  1048.          K*STATE)))                ; Stay in same K*STATE
  1049.       
  1050.       (#\E                    ; Error packet received
  1051.        (PRINTMSG "~%~A"
  1052.          (SETQ K*ABORT-REASON        ; Save the error
  1053.                (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET)))
  1054.        *ABORT-STATE*)
  1055.       
  1056.       (NIL                    ; Timeout
  1057.        (INCREMENT-RETRIES)            ; Increment the retries
  1058.        K*STATE)                    ; Remain in same K*STATE
  1059.       
  1060.       (:OTHERWISE                ; Unknown packet - abort
  1061.        (PRINTMSG "~%~A"
  1062.          (SETQ K*ABORT-REASON        ; Save the error
  1063.                (FORMAT NIL "~A: Received unknown packet type <~A>." *KERMIT-NAME* TYPE)))
  1064.        *ABORT-STATE*)))) 
  1065.  
  1066.  
  1067.  
  1068. (DEFUN RINIT ()
  1069.   "Receive-Initiate function to receive other side's host's parameters and send ours back."
  1070.   (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*CANCEL K*ABORT-REASON))
  1071.   (SETQ K*PCKT-NUM 0)                ; Initialize the packet number
  1072.   
  1073.   (IF K*CANCEL                    ; Cancel?
  1074.       *ABORT-STATE*                ; - Yes, abort
  1075.       (MULTIPLE-VALUE-BIND (TYPE LEN IGNORE PACKET)    ; - No, get a packet
  1076.       (RPACK)
  1077.     (SELECTQ TYPE                ; What type was it?
  1078.       
  1079.       (#\S                    ; Send-Init
  1080.        (RPAR PACKET LEN)            ; Get other side's init info
  1081.        (SETQ PACKET (SPAR PACKET))        ; Fill up my init info packet
  1082.        (SPACK #\Y K*PCKT-NUM (LENGTH PACKET) PACKET)    ; ACK with my parameters
  1083.        (INCREMENT-PACKET-NUMBER)        ; Bump packet number
  1084.        *RFILE-STATE*)            ; OK, enter File-Receive state
  1085.       
  1086.       (#\E                    ; Error packet received
  1087.        (PRINTMSG "~%~A"
  1088.              (SETQ K*ABORT-REASON    ; Save the error
  1089.                (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET)))
  1090.        *ABORT-STATE*)
  1091.       
  1092.       (NIL                    ; Didn't get a packet
  1093.        (SPACK #\N 0 0 NIL)            ; Return a NAK
  1094.        (INCREMENT-RETRIES)            ; Increment the retries
  1095.        K*STATE)                ; and keep trying
  1096.       
  1097.       (:OTHERWISE                ; Unknown packet
  1098.        (SPACK #\N K*PCKT-NUM 0 NIL)        ; Return a NAK
  1099.        (PRINTMSG "~%~A"
  1100.              (SETQ K*ABORT-REASON    ; Save the error
  1101.                (FORMAT NIL "~A: Received unknown packet type <~A>." *KERMIT-NAME* TYPE)))
  1102.        *ABORT-STATE*)))))            ; and abort 
  1103.  
  1104.  
  1105.  
  1106. (DEFUN RFILE ()
  1107.   "Receive File Header."
  1108.   (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*FP K*RECFILNAM K*CANCEL
  1109.             K*VERBOSEP K*ABORT-REASON K*EMPTY-PATHNAME))
  1110.   
  1111.   (IF K*CANCEL                    ; Cancel?
  1112.       *ABORT-STATE*                ; - Yes, abort
  1113.       (MULTIPLE-VALUE-BIND (TYPE LEN NUM PACKET)    ; - No...
  1114.       (RPACK)                ; Get a packet
  1115.     (SELECTQ TYPE                ; What was the type?
  1116.       
  1117.       (#\S                    ; Send-Init
  1118.        (IF (= NUM (IF (= K*PCKT-NUM 0)
  1119.               63
  1120.               (1- K*PCKT-NUM)))    ; See if it's previous packet
  1121.            (PROGN                ; - Yes
  1122.          (SETQ PACKET (SPAR PACKET))    ; Load in our Send-Init parameters
  1123.          (SPACK #\Y K*PCKT-NUM (LENGTH PACKET) PACKET)    ; Send the ACK packet
  1124.          (INCREMENT-RETRIES)        ; Increment the retries
  1125.          K*STATE)            ; Stay in same state
  1126.            (PROGN                ; - No,
  1127.          (PRINTMSG "~%~A"
  1128.                (SETQ K*ABORT-REASON    ; Otherwise set up error
  1129.                  (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM)))
  1130.          *ABORT-STATE*)))        ; abort
  1131.       
  1132.       (#\Z                    ; End-Of-File
  1133.        (IF (= NUM (IF (= K*PCKT-NUM 0)
  1134.               63
  1135.               (1- K*PCKT-NUM)))    ; See if it's previous packet
  1136.            (PROGN                ; - Yes
  1137.          (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Send the ACK packet
  1138.          (INCREMENT-RETRIES)        ; Increment the retries
  1139.          K*STATE)            ; Finally, stay in this K*STATE
  1140.            (PROGN                ; - No
  1141.          (PRINTMSG "~%~A"
  1142.                (SETQ K*ABORT-REASON    ; Set up error
  1143.                  (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM)))
  1144.          *ABORT-STATE*)))        ; abort
  1145.       
  1146.       (#\F                    ; File Header (just what we want)
  1147.        (IF (= NUM K*PCKT-NUM)        ; Correct packet number?
  1148.            (LET                ; - Yes
  1149.          ((FILNAM (DECODE-PREFIXED-DATA PACKET LEN))    ; Decode the packet to get the filename  
  1150.           (NEWFILNAM NIL))    
  1151.          (CONDITION-CASE (ERR)
  1152.              (PROGN
  1153.               (SETQ NEWFILNAM        ; Determine the filename to use
  1154.                 (SEND
  1155.                   (FS:MERGE-PATHNAMES
  1156.                 (FS:DEFAULT-WILD-PATHNAME-COMPONENTS
  1157.                   (FS:PARSE-PATHNAME    ; Make a pathname from the transfer name
  1158.                     (IF K*RECFILNAM    ; Transfer name specified?
  1159.                     K*RECFILNAM    ; -- Yes, use it
  1160.                     "")    ; -- No, use empty-string
  1161.                     NIL
  1162.                     K*EMPTY-PATHNAME)    ; Merge with empty pathname
  1163.                   (FS:PARSE-PATHNAME
  1164.                     (CREATE-KERMIT-FILENAME FILNAM)    ; Create a suitible filename from FILNAM
  1165.                     NIL
  1166.                     K*EMPTY-PATHNAME))
  1167.                 (USER-HOMEDIR-PATHNAME))
  1168.                   :STRING-FOR-PRINTING))
  1169.               (SETQ K*FP        ; Try to open the file 
  1170.                 (OPEN NEWFILNAM  
  1171.                   :DIRECTION :OUTPUT
  1172.                   :IF-EXISTS ':NEW-VERSION
  1173.                   :IF-DOES-NOT-EXIST ':CREATE)))
  1174.            (ERROR
  1175.             (PRINTMSG "~%~A"        ; Print error
  1176.                   (SETQ K*ABORT-REASON
  1177.                     (FORMAT NIL "~A: Error <~A> while creating file."
  1178.                         *KERMIT-NAME* (SEND ERR :REPORT-STRING))))
  1179.             (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)
  1180.             *ABORT-STATE*)        ; abort
  1181.            (:NO-ERROR
  1182.             (INITIALIZE-STATUS-COUNTS)    ; Reset the timing info
  1183.             (PRINT-STATUS-FILE-INFO)    ; update the filenames on the screen
  1184.             (PRINTMSG "~%Receiving ~A as ~A." FILNAM NEWFILNAM)
  1185.             (SPACK #\Y K*PCKT-NUM (LENGTH NEWFILNAM) NEWFILNAM)    ; ACKnowledge the file header
  1186.             (INCREMENT-PACKET-NUMBER)    ; Bump packet count
  1187.             *RDATA-STATE*)))        ; Switch to RDATA-STATE
  1188.            (PROGN                ; - No, incorrect packet number
  1189.          (PRINTMSG "~%~A"
  1190.                (SETQ K*ABORT-REASON    ; Set up error
  1191.                  (FORMAT NIL "~A: Received incorrect S packet number <~A>." *KERMIT-NAME* NUM)))
  1192.          *ABORT-STATE*)))        ; abort
  1193.       
  1194.       (#\X                                  ; Print to TTY
  1195.        (IF (= NUM K*PCKT-NUM)        ; Correct packet number?
  1196.            (PROGN                ; - Yes
  1197.          (SETQ K*FP            ; Direct the output to the TTY
  1198.                (IF K*VERBOSEP
  1199.                *INFO-WINDOW*
  1200.                (MAKE-STRING-OUTPUT-STREAM)))
  1201.          (INITIALIZE-STATUS-COUNTS)    ; Reset the timing info
  1202.          (PRINT-STATUS-FILE-INFO)    ; update the filenames on the screen
  1203.          (PRINTMSG "~%Receiving ~A on screen.~%" PACKET)
  1204.          (SPACK #\Y K*PCKT-NUM 0 NIL)    ; ACKnowledge the file header
  1205.          (INCREMENT-PACKET-NUMBER)    ; Bump packet count
  1206.          *RDATA-STATE*)            ; Switch to RDATA-STATE
  1207.            (PROGN                ; - No
  1208.          (PRINTMSG "~%~A"
  1209.                (SETQ K*ABORT-REASON    ; Set up error
  1210.                  (FORMAT NIL "~A: Received incorrect S packet number <~A>." *KERMIT-NAME* NUM)))
  1211.          *ABORT-STATE*)))        ; abort
  1212.       
  1213.       (#\B                    ; Break transmission (EOT)
  1214.        (IF (= NUM K*PCKT-NUM)        ; Correct packet number?
  1215.            (PROGN                ; - Yes
  1216.          (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Say OK
  1217.          *COMPLETE-STATE*)        ; Switch to COMPLETE-STATE
  1218.            (PROGN                ; - No
  1219.          (PRINTMSG "~%~A"
  1220.                (SETQ K*ABORT-REASON    ; Set up error
  1221.                  (FORMAT NIL "~A: Received incorrect S packet number <~A>." *KERMIT-NAME* NUM)))
  1222.          *ABORT-STATE*)))        ; abort
  1223.       
  1224.       (#\E                    ; Error packet received
  1225.        (PRINTMSG "~%~A"
  1226.              (SETQ K*ABORT-REASON    ; Save the error
  1227.                (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET)))
  1228.        *ABORT-STATE*)
  1229.       
  1230.       (NIL                    ; Didn't get packet - timeout
  1231.        (SPACK #\N K*PCKT-NUM 0 NIL)        ; Return a NAK
  1232.        (INCREMENT-RETRIES)            ; Increment the retries
  1233.        K*STATE)                ; Stay in same K*STATE and keep trying
  1234.       
  1235.       (:OTHERWISE                ; Unknown packet - abort
  1236.        (SPACK #\N K*PCKT-NUM 0 NIL)        ; Return a NAK
  1237.        (PRINTMSG "~%~A"
  1238.              (SETQ K*ABORT-REASON    ; Save the error
  1239.                (FORMAT NIL "~A: Received unknown packet type <~A>." *KERMIT-NAME* TYPE)))
  1240.        *ABORT-STATE*))))) 
  1241.  
  1242.  
  1243.  
  1244. (DEFUN RDATA ()
  1245.   "Receive Data."
  1246.   (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*CANCEL K*ABORT-REASON K*FILE-CHARS K*FP))
  1247.   
  1248.   (MULTIPLE-VALUE-BIND (TYPE LEN NUM PACKET)
  1249.       (RPACK)                    ; Get a packet
  1250.     (SELECTQ TYPE                ; What was the type?
  1251.       
  1252.       (#\D                    ; Data packet
  1253.        (IF (= NUM K*PCKT-NUM)            ; Correct packet number?
  1254.        (PROGN                ; - Yes,
  1255.          (COUNT-AND-PRINT-PACKETS LEN)    ; Keep track of packet totals
  1256.          (INCF K*FILE-CHARS (BUFEMP PACKET LEN K*FP)) ; Write the data to the file and increment total chars
  1257.          (IF K*CANCEL            ; Should the transfer be interrupted?
  1258.          (PROGN                ; -- Yes
  1259.            (SPACK #\Y K*PCKT-NUM 1 "Z")    ; Send the ACK with cancel
  1260.            (INCREMENT-PACKET-NUMBER)    ; Bump packet count
  1261.            *RCANCEL-STATE*)        ; Switch to RCANCEL-STATE
  1262.          (PROGN                ; -- No
  1263.            (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Send regular ACK
  1264.            (INCREMENT-PACKET-NUMBER)    ; Bump packet count
  1265.            *RDATA-STATE*)))        ; Remain in RDATA-STATE
  1266.        (PROGN                ; - No, wrong packet number
  1267.          (IF (= NUM (IF (= K*PCKT-NUM 0)
  1268.                 63
  1269.                 (1- K*PCKT-NUM)))    ; See if it's previous packet
  1270.          (PROGN                ; -- Yes
  1271.            (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Send an ACK
  1272.            (INCREMENT-RETRIES)        ; Increment the retries
  1273.            K*STATE)            ; Finally, stay in this K*STATE so no data will be written
  1274.          (PROGN                ; -- No
  1275.            (PRINTMSG "~%~A"
  1276.                  (SETQ K*ABORT-REASON    ; Otherwise, set up error
  1277.                    (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM)))
  1278.            *ABORT-STATE*)))))        ; abort
  1279.       
  1280.       (#\F                    ; File header
  1281.        (IF (= NUM (IF (= K*PCKT-NUM 0)
  1282.               63
  1283.               (1- K*PCKT-NUM)))        ; See if it's previous packet
  1284.        (PROGN                ; - Yes
  1285.          (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Send ACK
  1286.          (INCREMENT-RETRIES)        ; Increment the retries
  1287.          K*STATE)                ; Finally, stay in this K*STATE
  1288.        (PROGN                ; - No
  1289.          (PRINTMSG "~%~A"
  1290.                (SETQ K*ABORT-REASON    ; Otherwise, set up error
  1291.                  (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM)))
  1292.          *ABORT-STATE*)))            ; abort
  1293.       
  1294.       (#\X                    ; File header
  1295.        (IF (= NUM (IF (= K*PCKT-NUM 0)
  1296.               63
  1297.               (1- K*PCKT-NUM)))        ; See if it's previous packet
  1298.        (PROGN                ; - Yes
  1299.          (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Send ACK
  1300.          (INCREMENT-RETRIES)        ; Increment the retries
  1301.          K*STATE)                ; Finally, stay in this K*STATE
  1302.        (PROGN                ; - No
  1303.          (PRINTMSG "~%~A"
  1304.                (SETQ K*ABORT-REASON    ; Set up error
  1305.                  (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM)))
  1306.          *ABORT-STATE*)))            ; abort
  1307.       
  1308.       (#\Z                    ; End-Of-File
  1309.        (IF (= NUM K*PCKT-NUM)            ; Correct packet number?
  1310.        (PROGN                ; - Yes
  1311.          (IF (AND (> LEN 0)            ;
  1312.               (EQUAL (SUBSEQ PACKET 0 1) "D")) ; Is D specified?
  1313.          (PROGN                    ; -- Yes
  1314.            (IF (OR *SAVEFILES*          ; Should the file be saved?  e.g., is *SAVEFILES* true
  1315.                 (STRING-EQUAL K*CANCEL "S")) ; or K*CANCEL save?
  1316.                (PROGN                   ; --- Yes
  1317.              (SEND K*FP :CLOSE)    ; Close but save the file
  1318.              (PRINTMSG "~%Receive aborted - file saved."))
  1319.                (PROGN                   ; --- No
  1320.              (SEND K*FP :CLOSE T)    ; Close with abort (discard)
  1321.              (PRINTMSG "~%Receive aborted - file discarded."))))
  1322.          (PROGN                ; -- No
  1323.            (SEND K*FP :CLOSE)        ; Close the file [NOTE IF SEND-TO-TTY must save stream BAC]
  1324.            (PRINTMSG "~%Receive completed - file closed.")))
  1325.          (SETQ K*FP NIL)            ; Clear the file pointer
  1326.          (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Say OK
  1327.          (INCREMENT-PACKET-NUMBER)        ; Bump packet count
  1328.          *RFILE-STATE*)            ; Go back to Receive File K*STATE
  1329.        (PROGN                ; - No
  1330.          (PRINTMSG "~%~A"
  1331.                (SETQ K*ABORT-REASON    ; Set up error
  1332.                  (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM)))
  1333.          *ABORT-STATE*)))            ; abort
  1334.       
  1335.       (#\E                    ; Error packet received
  1336.        (PRINTMSG "~%~A"
  1337.          (SETQ K*ABORT-REASON        ; Save the error
  1338.                (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET)))
  1339.        *ABORT-STATE*)
  1340.       
  1341.       (NIL                    ; Didn't get packet - timeout
  1342.        (SPACK #\N K*PCKT-NUM 0 NIL)        ; Return a NAK
  1343.        (INCREMENT-RETRIES)            ; Increment the retries
  1344.        K*STATE)                    ; Stay in same K*STATE and keep trying
  1345.       
  1346.       (:OTHERWISE                ; Unknown packet - abort
  1347.        (PRINTMSG "~%~A"
  1348.          (SETQ K*ABORT-REASON        ; Save the error
  1349.                (FORMAT NIL "~A: Received unknown packet type <~A>." TYPE)))
  1350.        (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)    ; Send an error packet
  1351.        *ABORT-STATE*))))
  1352.  
  1353.  
  1354.  
  1355. (DEFUN RCANCEL ()
  1356.   "We cancelled receive - now send an ERROR packet when we get a DATA packet."
  1357.   (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*CANCEL K*ABORT-REASON K*FP))
  1358.   
  1359.   (MULTIPLE-VALUE-BIND (TYPE LEN NUM PACKET)
  1360.       (RPACK)                    ; Get a packet
  1361.     (SELECTQ TYPE                ; What was the type?
  1362.       
  1363.       (#\D                    ; Data packet
  1364.        (IF (= NUM K*PCKT-NUM)            ; Correct packet number?
  1365.        (PROGN                ; - Yes
  1366.          (SEND K*FP :CLOSE T)        ; Close with abort (discard)
  1367.          (PRINTMSG "~%Receive aborted - file discarded")
  1368.          (SETQ K*FP NIL)            ; Clear the file pointer
  1369.          (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)    ; Send an error packet
  1370.          (INCREMENT-PACKET-NUMBER)        ; Bump packet count
  1371.          (IF K*CANCEL                 ; Cancel all further transfers? (really not valid, since only Z supported)
  1372.          *ABORT-STATE*            ; -- Yes, abort
  1373.          (PROGN                ; -- No
  1374.            (SETQ K*CANCEL NIL)        ; Reset K*CANCEL and
  1375.            *RFILE-STATE*)))        ; switch to RFILE-STATE
  1376.        (PROGN                ; - No, wrong packet number
  1377.          (IF (= NUM (IF (= K*PCKT-NUM 0)
  1378.                 63
  1379.                 (1- K*PCKT-NUM)))    ; See if it's previous packet
  1380.          (PROGN                ; -- Yes
  1381.            (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Send an ACK
  1382.            (INCREMENT-RETRIES)        ; Increment the retries
  1383.            K*STATE)            ; Finally, stay in this K*STATE so no data will be written
  1384.          (PROGN                ; -- No
  1385.            (PRINTMSG "~%~A"
  1386.                  (SETQ K*ABORT-REASON    ; Set up error
  1387.                    (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM)))
  1388.            *ABORT-STATE*)))))        ; abort
  1389.       
  1390.       (#\F                    ; File header
  1391.        (IF (= NUM (IF (= K*PCKT-NUM 0)
  1392.               63
  1393.               (1- K*PCKT-NUM)))        ; See if it's previous packet
  1394.        (PROGN                ; - Yes
  1395.          (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Send ACK
  1396.          (INCREMENT-RETRIES)        ; Increment the retries
  1397.          K*STATE)                ; Finally, stay in this K*STATE
  1398.        (PROGN                ; - No
  1399.          (PRINTMSG "~%~A"
  1400.                (SETQ K*ABORT-REASON    ; set up error
  1401.                  (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM)))
  1402.          *ABORT-STATE*)))            ; abort
  1403.       
  1404.       (#\X                    ; TTY
  1405.        (IF (= NUM (IF (= K*PCKT-NUM 0)
  1406.               63
  1407.               (1- K*PCKT-NUM)))        ; See if it's previous packet
  1408.        (PROGN                ; - Yes
  1409.          (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Send ACK
  1410.          (INCREMENT-RETRIES)        ; Increment the retries
  1411.          K*STATE)                ; Finally, stay in this K*STATE
  1412.        (PROGN                ; - No
  1413.          (PRINTMSG "~%~A"
  1414.                (SETQ K*ABORT-REASON    ; Set up error
  1415.                  (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM)))
  1416.          *ABORT-STATE*)))            ; abort
  1417.       
  1418.       (#\Z                    ; End-Of-File
  1419.        (IF (= NUM K*PCKT-NUM)            ; Correct packet number?
  1420.        (PROGN                ; - Yes
  1421.          (IF (AND (> LEN 0)            ; D specified to discard file?
  1422.               (EQUAL (SUBSEQ PACKET 0 1) "D"))
  1423.          (PROGN                    ; -- Yes
  1424.            (IF (OR *SAVEFILES*          ; Should the file be saved?  e.g., is *SAVEFILES* true
  1425.                 (STRING-EQUAL K*CANCEL "S")) ; or K*CANCEL save?
  1426.                (PROGN                   ; --- Yes
  1427.              (SEND K*FP :CLOSE)    ; Close but save the file
  1428.              (PRINTMSG "~%Receive aborted - file saved."))
  1429.                (PROGN                   ; --- No
  1430.              (SEND K*FP :CLOSE T)    ; Close with abort (discard)
  1431.              (PRINTMSG "~%Receive aborted - file discarded."))))
  1432.          (PROGN                ; -- No
  1433.            (SEND K*FP :CLOSE)        ; Close the file [NOTE IF SEND-TO-TTY must save stream BAC]
  1434.            (PRINTMSG "~%Receive aborted - file ~A closed")))
  1435.          (SETQ K*FP NIL)            ; Clear the file pointer
  1436.          (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Say OK
  1437.          (INCREMENT-PACKET-NUMBER)        ; Bump packet count
  1438.          (IF K*CANCEL                ; Cancel all further transfers? (not needed, since only Z supported)
  1439.          *ABORT-STATE*            ; -- Yes, abort
  1440.          (PROGN                ; -- No
  1441.            (SETQ K*CANCEL NIL)        ; reset K*CANCEL and
  1442.            *RFILE-STATE*)))        ; switch to RFILE-STATE
  1443.        (PROGN                ; - No, incorrect packet number
  1444.          (PRINTMSG "~%~A"
  1445.                (SETQ K*ABORT-REASON    ; Set up error
  1446.                  (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM)))
  1447.          *ABORT-STATE*)))            ; abort
  1448.       
  1449.       (#\E                    ; Error packet received
  1450.        (PRINTMSG "~%~A"
  1451.          (SETQ K*ABORT-REASON        ; Save the error
  1452.                (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET)))
  1453.        *ABORT-STATE*)
  1454.       
  1455.       (NIL                    ; Didn't get packet
  1456.        (SPACK #\N K*PCKT-NUM 0 NIL)        ; Return a NAK
  1457.        (INCREMENT-RETRIES)            ; Increment the retries
  1458.        K*STATE)                    ; Stay in same K*STATE and keep trying
  1459.       
  1460.       (:OTHERWISE                ; Unknown packet - abort
  1461.        (PRINTMSG "~%~A"
  1462.          (SETQ K*ABORT-REASON        ; Save the error
  1463.                (FORMAT NIL "~A: Received unknown packet type <~A>." TYPE)))
  1464.        (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)    ; Send an error packet
  1465.        *ABORT-STATE*))))
  1466.  
  1467.  
  1468.  
  1469. (DEFUN SGENERIC (SPACK-TYPE &OPTIONAL SPACK-DATA)
  1470.   "Used for server commands expecting short response such as ACK.
  1471. SPACK-TYPE should be a G, R or C packet type."
  1472.   (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*NUMTRY K*SPACKET K*VERBOSEP
  1473.             K*CANCEL K*SERVER-PACK-TYPE K*FP K*PACKETS-RETRIED K*ABORT-REASON))
  1474.   
  1475.   (IF K*CANCEL                    ; Cancel?
  1476.       *ABORT-STATE*                ; - Yes
  1477.       (PROGN                    ; - No
  1478.     (INITIALIZE-STATUS-COUNTS)        ; Initialize the packet counts and timing
  1479.         (WHEN (EQL SPACK-TYPE #\G)              ; When processing a Generic server command
  1480.       (ENCODE-PREFIXED-DATA SPACK-DATA K*SPACKET)           ; Prefix encode the data
  1481.       (SETQ SPACK-DATA K*SPACKET))
  1482.     (SPACK SPACK-TYPE 0 (LENGTH SPACK-DATA) SPACK-DATA)    ; Send a G, R or C packet
  1483.     
  1484.     (MULTIPLE-VALUE-BIND (TYPE LEN NUM PACKET)
  1485.         (RPACK)                ; What was the reply?
  1486.       (SELECTQ TYPE
  1487.         
  1488.         (#\S                ; Send-Init
  1489.          (IF (ZEROP NUM)            ; Packet number 0?
  1490.          (PROGN                ; - Yes,      
  1491.            (RPAR PACKET LEN)        ; Get other side's init info
  1492.            (SETQ PACKET (SPAR PACKET))    ; Fill up my init info packet
  1493.            (SPACK #\Y K*PCKT-NUM (LENGTH PACKET) PACKET)    ; ACK with my parameters
  1494.            (INCREMENT-PACKET-NUMBER)    ; Bump packet number
  1495.            *RFILE-STATE*)        ; OK, enter File-Receive state
  1496.          (PROGN                ; - No
  1497.            (PRINTMSG "~%~A"        ; setup error
  1498.                  (SETQ K*ABORT-REASON
  1499.                    (FORMAT NIL "~A: Received non-zero packet number <~A>." *KERMIT-NAME* NUM)))
  1500.            *ABORT-STATE*)))        ; abort
  1501.         
  1502.         (#\X                ; Text header
  1503.          (IF (ZEROP NUM)            ; Correct packet number? ; maybe K*PCKT-NUM instead? ; BAC
  1504.          (PROGN                ; - Yes 
  1505.            (SETQ K*FP            ; set the file pointer to
  1506.              (IF K*VERBOSEP        ; either the info window or a string stream
  1507.                  *INFO-WINDOW*
  1508.                  (MAKE-STRING-OUTPUT-STREAM)))        
  1509.            (PRINTMSG "~%Receiving ~A on the screen.~%" PACKET)
  1510.            (SPACK #\Y K*PCKT-NUM 0 NIL)    ; ACKnowledge the file header
  1511.            (INCREMENT-PACKET-NUMBER)    ; Bump packet count
  1512.            *RDATA-STATE*)        ; switch to RDATA-STATE
  1513.          (PROGN                ; - No
  1514.            (PRINTMSG "~%~A"        ; setup error
  1515.                  (SETQ K*ABORT-REASON
  1516.                    (FORMAT NIL "~A: Received non-zero packet number <~A>." *KERMIT-NAME* NUM)))
  1517.            *ABORT-STATE*)))        ; abort
  1518.         
  1519.         (#\N                ; NAK
  1520.          (INCREMENT-RETRIES)        ; Increment the retries
  1521.          K*STATE)                ; Stay in same K*STATE
  1522.         
  1523.         (#\Y                ; ACK
  1524.          (IF (ZEROP NUM)            ; See if it's correct ACK
  1525.          (PROGN                ; - Yes     
  1526.            (PRINTMSG "~%~A" PACKET)    ; print data on tty
  1527.            *COMPLETE-STATE*)        ; Switch to COMPLETE-STATE
  1528.          (PROGN                ; - No
  1529.            (PRINTMSG "~%~A"        ; setup error
  1530.                  (SETQ K*ABORT-REASON
  1531.                    (FORMAT NIL "~A: Received non-zero packet number <~A>." *KERMIT-NAME* NUM)))
  1532.            *ABORT-STATE*)))        ; abort
  1533.         
  1534.         (#\E                ; Error packet received
  1535.          (PRINTMSG "~%~A"
  1536.                (SETQ K*ABORT-REASON    ; Save the error
  1537.                  (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET)))
  1538.          *ABORT-STATE*)
  1539.         
  1540.         (NIL                ; Timeout
  1541.          (IF (AND (= SPACK-TYPE #\G)    ; Did we just request
  1542.               (OR (EQUAL (SUBSEQ SPACK-DATA 0 1) "L")    ; a remote logout 
  1543.               (EQUAL (SUBSEQ SPACK-DATA 0 1) "F")))    ; or a remote finish?
  1544.          *COMPLETE-STATE*        ; - Yes, the remote KERMIT will never respond so we're finished
  1545.          (PROGN                ; - No
  1546.            (INCREMENT-RETRIES)        ; Increment the retries
  1547.            K*STATE)))            ; remain in same K*STATE
  1548.         
  1549.         (:OTHERWISE                ; Unknown packet - abort
  1550.          (PRINTMSG "~%~A"
  1551.                (SETQ K*ABORT-REASON    ; Save the error
  1552.                  (FORMAT NIL "~A: Received unknown packet type <~A>." TYPE)))
  1553.          *ABORT-STATE*))))))
  1554.  
  1555.  
  1556.  
  1557. (DEFUN SSERVER ()
  1558.   "Used for server commands expecting large responses."
  1559.   (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*SPACKET K*CANCEL
  1560.             K*YOUREOL K*YOURQUOTE K*VERBOSEP K*FP K*ABORT-REASON))
  1561.   
  1562.   (IF K*CANCEL                    ; Cancel?
  1563.       *ABORT-STATE*                ; - Yes, so abort
  1564.       (PROGN                    ; - No
  1565.     (SETQ K*SPACKET (SPAR K*SPACKET))    ; Fill up init info packet
  1566.     (SPACK #\I K*PCKT-NUM (LENGTH K*SPACKET) K*SPACKET)    ; Send an I packet with type,number,length,packet
  1567.     
  1568.     (MULTIPLE-VALUE-BIND (TYPE LEN NUM PACKET)
  1569.         (RPACK)                ; What was the reply?
  1570.       (SELECTQ TYPE
  1571.         
  1572.         (#\Y                ; ACK
  1573.          (IF (ZEROP NUM)            ; Correct packet number (0)?
  1574.          (PROGN                ; -- Yes
  1575.            (RPAR PACKET LEN)        ; Get other side's init info
  1576.            *SGENERIC-STATE*)        ; Move to SGENERIC-STATE
  1577.          (PROGN                ; -- No
  1578.            (PRINTMSG "~%~A"        ; setup error
  1579.                  (SETQ K*ABORT-REASON
  1580.                    (FORMAT NIL "~A: Received non-zero packet number <~A>." *KERMIT-NAME* NUM)))
  1581.            *ABORT-STATE*)))        ; abort
  1582.         
  1583.         (#\N                ; NAK
  1584.          (INCREMENT-RETRIES)        ; Increment the retries
  1585.          K*STATE)                ; Stay in same K*STATE
  1586.         
  1587.         (#\E                ; Error packet received - use defaults - but how? ;; BAC
  1588.          *SGENERIC-STATE*)            ; Switch to SGENERIC-STATE
  1589.         
  1590.         (NIL                ; Timeout
  1591.          (INCREMENT-RETRIES)        ; Increment the retries
  1592.          K*STATE)                ; remain in same K*STATE
  1593.         
  1594.         (:OTHERWISE                ; Unknown packet - abort
  1595.          (PRINTMSG "~%~A"
  1596.                (SETQ K*ABORT-REASON    ; Save the error
  1597.                  (FORMAT NIL "~A: Received unknown packet type <~A>." TYPE)))
  1598.          *ABORT-STATE*))))))
  1599.  
  1600.  
  1601.  
  1602. (DEFUN RSERVER ()
  1603.   "Receive Server - This KERMIT in server mode, idle and waiting for a message."
  1604.   (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*NUMTRY K*FILNAM K*SPACKET K*ABORT-REASON
  1605.             K*PACKETS-RETRIED K*CANCEL K*YOURMAXPACSIZ K*FP K*SEND-TO-TTY
  1606.             K*ARG1LIST))
  1607.   
  1608.   (SETQ K*PCKT-NUM 0)                ; Initialize the packet number
  1609.   (SETQ K*NUMTRY 0)                ; Zero the number of tries - can't exceed maxtry in this state
  1610.   (SETQ K*ABORT-REASON "")            ; Reset the abort reason string
  1611.   (INITIALIZE-STATUS-COUNTS)            ; Initialize the packet counts and timing info
  1612.   
  1613.   (IF K*CANCEL                    ; Cancel?
  1614.       *ABORT-STATE*                ; - Yes
  1615.       (MULTIPLE-VALUE-BIND (TYPE LEN NUM PACKET)    ; - No
  1616.       (RPACK 900)                ; Get a packet - wait 15 seconds (60 * 15) for it 
  1617.     (SELECTQ TYPE
  1618.       
  1619.       (#\I                    ; INIT
  1620.        (IF (ZEROP NUM)            ; Correct packet number (0)?
  1621.            (PROGN                ; -- Yes 
  1622.          (SPACK #\Y K*PCKT-NUM 0 NIL)    ; Send ACK
  1623.          K*STATE)            ; Stay in same K*STATE
  1624.            (PROGN                ; -- No
  1625.          (PRINTMSG "~%~A"        ; setup error
  1626.                (SETQ K*ABORT-REASON
  1627.                  (FORMAT NIL "~A: Server received non-zero packet number <~A>." *KERMIT-NAME* NUM)))
  1628.          (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)    ; Send E packet
  1629.          K*STATE)))            ; Stay in same K*STATE
  1630.       
  1631.       (#\S                    ; SEND-INIT
  1632.        (IF (ZEROP NUM)            ; Correct packet number (0)?
  1633.            (PROGN                ; -- Yes
  1634.          (RPAR PACKET LEN)        ; Get other side's init info
  1635.          (SETQ PACKET (SPAR PACKET))    ; Fill up my init info packet
  1636.          (SPACK #\Y K*PCKT-NUM (LENGTH PACKET) PACKET)    ; ACK with my parameters
  1637.          (INCREMENT-PACKET-NUMBER)    ; Bump packet number
  1638.          *RFILE-STATE*)            ; OK, enter File-Receive state
  1639.            (PROGN                ; -- No
  1640.          (PRINTMSG "~%~A"        ; setup error
  1641.                (SETQ K*ABORT-REASON
  1642.                  (FORMAT NIL "~A: Server received non-zero packet number <~A>." *KERMIT-NAME* NUM)))
  1643.          (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)
  1644.          K*STATE)))            ; and stay in same K*STATE
  1645.       
  1646.       (#\R                    ; RECEIVE-INIT
  1647.        (IF (ZEROP NUM)            ; Correct packet number (0)?
  1648.            (PROGN                ; -- Yes
  1649.          (SETQ K*ARG1LIST
  1650.                (EXPAND-WILDS        ; Expand any wildcards in the filename
  1651.              (DECODE-PREFIXED-DATA PACKET LEN)))    ; Decode the packet to get the requested filename
  1652.          (GET-NEXT-FILE)        ; Get the file to process
  1653.          *SINIT-STATE*)            ; Proceed to SINIT-STATE
  1654.            (PROGN                ; -- No
  1655.          (PRINTMSG "~%~A"        ; setup error
  1656.                (SETQ K*ABORT-REASON
  1657.                  (FORMAT NIL "~A: Server received non-zero packet number <~A>." *KERMIT-NAME* NUM)))
  1658.          (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)
  1659.          K*STATE)))            ; and stay in same K*STATE
  1660.       
  1661.       (#\K                    ; KERMIT command
  1662.        (IF (ZEROP NUM)            ; Correct packet number (0)?
  1663.            (LET
  1664.          ((RESULT (PROCESS-KERMIT-COMMAND PACKET LEN)))
  1665.          (IF (OR
  1666.                K*FILNAM                 ; Filename specified for transfer?
  1667.                (> (LENGTH RESULT)       ; or long reply?
  1668.               (FLOOR K*YOURMAXPACSIZ 1.5))) 
  1669.              (PROGN                     ; - Yes
  1670.                (SETQ K*SEND-TO-TTY T)   ; Set tty flag
  1671.                (WHEN (NOT K*FILNAM)
  1672.              (SETQ K*FP
  1673.                    (MAKE-STRING-INPUT-STREAM RESULT)))
  1674.                *SINIT-STATE*)           ; Go to SINIT-STATE
  1675.              (PROGN                     ; - No
  1676.                (SPACK #\Y K*PCKT-NUM (LENGTH RESULT) RESULT)    ; ACK with the requested info
  1677.                K*STATE)))                ; Stay in same state
  1678.            (PROGN                ; -- No
  1679.          (PRINTMSG "~%~A"        ; setup error
  1680.                (SETQ K*ABORT-REASON
  1681.                  (FORMAT NIL "~A: Server received non-zero packet number <~A>." *KERMIT-NAME* NUM)))
  1682.          (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)
  1683.          K*STATE)))            ; Stay in same state
  1684.       
  1685.       (#\C                    ; HOST command
  1686.        (IF (ZEROP NUM)            ; Correct packet number (0)?
  1687.            (LET
  1688.          ((RESULT (PROCESS-HOST-COMMAND PACKET LEN)))
  1689.          (IF (OR
  1690.                K*FILNAM                 ; Filename specified for tranfer?
  1691.                (> (LENGTH RESULT)       ; or long reply?
  1692.               (FLOOR K*YOURMAXPACSIZ 1.5))) 
  1693.              (PROGN                     ; - Yes
  1694.                (SETQ K*SEND-TO-TTY T)   ; Set tty flag
  1695.                (WHEN (NOT K*FILNAM)
  1696.              (SETQ K*FP
  1697.                    (MAKE-STRING-INPUT-STREAM RESULT)))
  1698.                *SINIT-STATE*)           ; Go to SINIT-STATE
  1699.              (PROGN                     ; - No
  1700.                (SPACK #\Y K*PCKT-NUM (LENGTH RESULT) RESULT)    ; ACK with the requested info
  1701.                K*STATE)))                ; Stay in same state
  1702.            (PROGN                ; -- No
  1703.          (PRINTMSG "~%~A"        ; setup error
  1704.                (SETQ K*ABORT-REASON
  1705.                  (FORMAT NIL "~A: Server received non-zero packet number <~A>." *KERMIT-NAME* NUM)))
  1706.          (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)
  1707.          K*STATE)))            ; Stay in same state
  1708.       
  1709.       (#\G                    ; GENERIC command
  1710.        (IF (ZEROP NUM)            ; Correct packet number (0)?
  1711.            (LET
  1712.          ((RESULT (PROCESS-GENERIC-COMMAND PACKET LEN)))
  1713.          (IF (OR
  1714.                K*FILNAM                 ; Filename specified for tranfer?
  1715.                (> (LENGTH RESULT)       ; or long reply?
  1716.               (FLOOR K*YOURMAXPACSIZ 1.5))) 
  1717.              (PROGN                     ; - Yes
  1718.                (SETQ K*SEND-TO-TTY T)   ; Set tty flag
  1719.                (WHEN (NOT K*FILNAM)
  1720.              (SETQ K*FP
  1721.                    (MAKE-STRING-INPUT-STREAM RESULT)))
  1722.                *SINIT-STATE*)           ; Go to SINIT-STATE
  1723.              (PROGN                     ; - No
  1724.                (SPACK #\Y K*PCKT-NUM (LENGTH RESULT) RESULT)    ; ACK with the requested info
  1725.                K*STATE)))                ; Stay in same state
  1726.            (PROGN                ; -- No
  1727.          (PRINTMSG "~%~A"        ; setup error
  1728.                (SETQ K*ABORT-REASON
  1729.                  (FORMAT NIL "~A: Server received non-zero packet number <~A>." *KERMIT-NAME* NUM)))
  1730.          (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)
  1731.          K*STATE)))            ; Stay in same state
  1732.       
  1733.       (#\E                    ; Error packet received
  1734.        (PRINTMSG "~%~A"
  1735.              (SETQ K*ABORT-REASON (FORMAT NIL "~%~A: Received error packet <~A>." *KERMIT-NAME* PACKET)))
  1736.        K*STATE)                ; Stay in same K*STATE
  1737.       
  1738.       (NIL                    ; Timeout
  1739.        (SPACK #\N 0 0 NIL)            ; Return a NAK
  1740.        K*STATE)                ; and keep trying
  1741.       
  1742.       (:OTHERWISE                ; Unknown packet
  1743.        (PRINTMSG "~%~A"
  1744.              (SETQ K*ABORT-REASON
  1745.                (FORMAT NIL "~A: Server received unknown packet type <~A>." *KERMIT-NAME* TYPE)))
  1746.        (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON)    ; Send E packet with an error message
  1747.        K*STATE)))))
  1748.  
  1749.  
  1750.  
  1751. ;;; KERMIT utilities.
  1752.  
  1753. (DEFUN SPACK (TYPE NUM LEN DATA)
  1754.   "Send a packet.  Returns T."
  1755.   (DECLARE (SPECIAL K*BUFFER K*YOURPAD K*YOURPADCHAR K*YOUREOL K*TTYFD))
  1756.   (SEND K*TTYFD :CLEAR-INPUT)            ; clear the input buffer
  1757.   
  1758.   (LET ((IND 0)
  1759.     (CHECKSUM 0))
  1760.  
  1761.     (DOTIMES (i K*YOURPAD)                    
  1762.       (SETF (AREF K*BUFFER i) K*YOURPADCHAR)    ; Issue any padding
  1763.       (INCF IND))
  1764.     
  1765.     (SETF (AREF K*BUFFER IND) *ASCII-SOH*)    ; Packet marker, ASCII 1 SOH
  1766.     (INCF IND)                    ; Increment
  1767.     
  1768.     (SETF (AREF K*BUFFER IND) (TOCHAR (+ LEN 3)))    ; Character count
  1769.     (INCF IND)                    ; Increment
  1770.     (SETQ CHECKSUM (TOCHAR (+ LEN 3)))        ; Initialize the checksum
  1771.     
  1772.     (SETF (AREF K*BUFFER IND) (TOCHAR NUM))    ; Packet number
  1773.     (INCF IND)                    ; Increment
  1774.     (SETQ CHECKSUM (+ CHECKSUM (TOCHAR NUM)))    ; Update checksum to include NUM
  1775.     
  1776.     (SETF (AREF K*BUFFER IND) TYPE)        ; Packet type
  1777.     (INCF IND)                    ; Increment
  1778.     (SETQ CHECKSUM (+ CHECKSUM TYPE))        ; Update checksum to include TYPE
  1779.     
  1780.     (DOTIMES (i LEN)                ; Loop for all data characters
  1781.       (SETF (AREF K*BUFFER IND) (AREF DATA i))    ; Get a character
  1782.       (INCF IND)                ; Increment
  1783.       (SETQ CHECKSUM (+ CHECKSUM (AREF DATA i))))    ; Update checksum to include character
  1784.     
  1785.     (SETQ CHECKSUM (COMPUTE-FINAL-CHECKSUM CHECKSUM))    ; Compute final checksum
  1786.     (SETF (AREF K*BUFFER IND) (TOCHAR CHECKSUM))    ; Put it in the packet
  1787.     (INCF IND)                    ; Increment
  1788.     
  1789.     (SETF (AREF K*BUFFER IND) K*YOUREOL)        ; Extra-packet line terminator
  1790.     (INCF IND)                    ; Increment
  1791.     
  1792.     (SETF (FILL-POINTER K*BUFFER) IND)        ; Setup the length of the buffer
  1793.     (SEND K*TTYFD :STRING-OUT K*BUFFER 0 IND)    ; Send the packet
  1794.     
  1795.     (WHEN *DEBUG*                ; For Debugging display outgoing packet
  1796.       (PRINTMSG
  1797.     "~%SPACK:  type=~A  num=~D  len=~D  data=~S  buffer=~S" type num len data K*BUFFER)))
  1798.     
  1799.   T)                        ; Finally, return T
  1800.  
  1801.  
  1802.  
  1803. (DEFUN RPACK (&OPTIONAL (TIMEOUT (* *MYTIME* 60)))
  1804.   "Read a packet from the K*TTYFD stream.  Returns values TYPE, LEN, NUM and DATA.
  1805. :TYI-WITH-TIMEOUT added to Explorer serial stream.  Optional timeout supplied to
  1806. allow server mode to have longer timeouts."
  1807.   (DECLARE (SPECIAL K*TTYFD K*YOURMAXPACSIZ K*RPACKET))
  1808.   
  1809.   (LET ((CCHECKSUM 0) (RCHECKSUM 0) (DATA-COUNT 0)
  1810.     (TYPE NIL) (LEN 0) (NUM 0) (READ-STATE 0))
  1811.     
  1812.     (SETF (FILL-POINTER K*RPACKET) 0)        ; Say no data in array yet
  1813.     (LOOP
  1814.       UNTIL (> READ-STATE 7)
  1815.       FOR T-CHAR = (SEND K*TTYFD :TYI-WITH-TIMEOUT TIMEOUT)
  1816.       WHEN (NULL T-CHAR)
  1817.       DO
  1818.       (SETQ READ-STATE 99)
  1819.       ELSE
  1820.       DO
  1821.       
  1822.       (WHEN (NOT *IMAGE*)            ; If not in *IMAGE* mode,
  1823.     (SETQ T-CHAR (LOGAND T-CHAR #b1111111)))    ; handle the parity - #b1111111 is #o177
  1824.       
  1825.       (WHEN (= T-CHAR *ASCII-SOH*)        ; If *ASCII-SOH*
  1826.     (SETQ READ-STATE 1))            ; resynchronize!
  1827.       
  1828.       (SELECTQ READ-STATE
  1829.     (0                    ; Never had a Start Header
  1830.      NIL)                    ; Do nothing
  1831.     (1                    ; Start Header
  1832.      (INCF READ-STATE))            ; ... on to next state
  1833.     (2                    ; Length
  1834.      (SETQ CCHECKSUM T-CHAR)        ; Start the checksum
  1835.      (SETQ LEN (- (UNCHAR T-CHAR) 3))    ; Character count
  1836.      (SETQ LEN (ABS LEN))            ; temp - must handle this BAC
  1837.      (WHEN (OR (> LEN K*YOURMAXPACSIZ) (< LEN 0))    ; BAC - carefull
  1838.        (SETQ TYPE NIL)            ; Error in packet length
  1839.        (SETQ READ-STATE 99)            ; Get out of loop!
  1840.        (PRINTMSG "~%RPACK:  Error reading length <~A>~%" LEN))
  1841.      (INCF READ-STATE))            ; ... on to the next state
  1842.     (3                    ; Packet number
  1843.      (SETQ CCHECKSUM (+ CCHECKSUM T-CHAR))    ; Update checksum
  1844.      (SETQ NUM (UNCHAR T-CHAR))        ; Packet number
  1845.      (INCF READ-STATE))            ; ... on to the next state
  1846.     (4                    ; Packet type
  1847.      (SETQ CCHECKSUM (+ CCHECKSUM T-CHAR))    ; Update checksum
  1848.      (SETQ TYPE (CODE-CHAR T-CHAR))        ; Packet type - make number into a character
  1849.      (IF (ZEROP LEN)            ; Check for any data
  1850.          (SETQ READ-STATE 6)        ; If no data, skip to checksum state
  1851.          (PROGN                ; data ...
  1852.            (SETQ DATA-COUNT 0)        ; set up DATA-COUNT for next state
  1853.            (INCF READ-STATE))))        ; ... on to the next state
  1854.     (5                    ; Data characters
  1855.      (SETQ CCHECKSUM (+ CCHECKSUM T-CHAR))    ; Update checksum
  1856.      (SETF (AREF K*RPACKET DATA-COUNT) T-CHAR)    ; Get a character
  1857.      (INCF DATA-COUNT)            ; Increment the data count
  1858.      (WHEN (= DATA-COUNT LEN)        ; If no more data characters
  1859.        (INCF READ-STATE)))            ; ... on to the next state
  1860.     (6                    ; Checksum
  1861.      (SETQ RCHECKSUM (UNCHAR T-CHAR))    ; Convert to numeric
  1862.      (SETQ CCHECKSUM (COMPUTE-FINAL-CHECKSUM CCHECKSUM))    ; Compute the checksum
  1863.      (WHEN (NOT (= CCHECKSUM RCHECKSUM))    ; If checksum is not ok,
  1864.        (SETQ TYPE NIL)            ; indicate an error so that we'll loop again
  1865.        (WHEN *DEBUG*            ; For debugging, print checksum errors
  1866.          (PRINTMSG
  1867.            "~%RPACK:  Error comparing received checksum <~A> to computed checksum <~A> in packet number <~A>~%"
  1868.            RCHECKSUM CCHECKSUM NUM)))
  1869.      (SETF (AREF K*RPACKET LEN) 0)        ; Mark the end of the data
  1870.      (SETF (FILL-POINTER K*RPACKET) LEN)    ;
  1871.      (INCF READ-STATE))            ; ... on to the next state
  1872.     (7                    ; EOL character - throw it away!
  1873.      (INCF READ-STATE))))            ; ... on to the next state DONE!!!
  1874.     
  1875.     (WHEN *DEBUG*                ; For Debugging display incoming packet
  1876.       (PRINTMSG
  1877.     "~%RPACK:  type=~A  num=~D  len=~D  data=~A" TYPE NUM LEN K*RPACKET))
  1878.     
  1879.     (VALUES TYPE LEN NUM K*RPACKET)))        ; Return values
  1880.  
  1881.  
  1882.  
  1883. (DEFUN BUFILL (BUFFER FILEPOINTER)
  1884.   "Fill a packet buffer with data from a file.
  1885.    Input parameters are the buffer in which to place the file data,
  1886.    and a file pointer from which to read the data.  As a result of
  1887.    processing, BUFFER is filled and the position in FILEPOINTER is
  1888.    advanced.  Returned value is the length of the buffer.
  1889.    K*BUFILLPTR and K*BUFILLBUF are used to buffer the file data
  1890.    for look-ahead processing."
  1891.   
  1892.   (DECLARE (SPECIAL K*BUFILLBUF K*BUFILLPTR K*YOURMAXPACSIZ K*YOURQUOTE
  1893.             K*REPEAT K*BINQUOTE K*FILE-CHARS))
  1894.   (LET
  1895.     ((7-CHAR NIL)
  1896.      (8-CHAR NIL)
  1897.      (EOF NIL)
  1898.      (INDEX 0)
  1899.      (TMPBUFILLPTR NIL)
  1900.      (LENBUFILLBUF (LENGTH K*BUFILLBUF))
  1901.      (ACTUALMAXPACSIZ (- K*YOURMAXPACSIZ 8))
  1902.      (QUOTABLES (LIST K*YOURQUOTE
  1903.               (WHEN (NOT (= K*BINQUOTE *ASCII-N*)) K*BINQUOTE)
  1904.               (WHEN (NOT (= K*REPEAT *ASCII-SP*)) K*REPEAT))))
  1905.     
  1906.     (LOOP
  1907.       UNTIL (OR (>= INDEX  ACTUALMAXPACSIZ) EOF)    ; Until we exceed length of the packet or are at EOF
  1908.       
  1909.       WHEN (= K*BUFILLPTR LENBUFILLBUF)        ; When we run out of data in the buffer
  1910.       DO
  1911.       (SETQ K*BUFILLPTR 0)                ; Reset the pointer
  1912.       (WHEN (ZEROP (SEND FILEPOINTER :STRING-IN NIL K*BUFILLBUF))    ; and get more
  1913.     (SETQ EOF T))                ; If no more, set EOF
  1914.       (SETQ LENBUFILLBUF (LENGTH K*BUFILLBUF))    ; Newly filled buffer so get the length
  1915.       ELSE
  1916.       DO
  1917.       (SETQ 8-CHAR (AREF K*BUFILLBUF K*BUFILLPTR))    ; Get the next character from the file buffer
  1918.       (INCF K*BUFILLPTR)                ; Increment the pointer
  1919.       (INCF K*FILE-CHARS)                       ; Increment the total number of file chars read
  1920.       
  1921.       (WHEN (NOT (= K*REPEAT *ASCII-SP*))    ; If we have agreed to do repeat processing,
  1922.     (SETQ TMPBUFILLPTR K*BUFILLPTR)            ; handle the repeat characters
  1923.     (LOOP                    ; Loop until
  1924.       UNTIL (OR (= TMPBUFILLPTR LENBUFILLBUF)       ; either we run out of chars from the buffer 
  1925.             (NOT (= 8-CHAR (AREF K*BUFILLBUF TMPBUFILLPTR)))) ; or we get one that's not equal to 8-char
  1926.       DO (INCF TMPBUFILLPTR))
  1927.     (SETQ TMPBUFILLPTR (1+ (- TMPBUFILLPTR K*BUFILLPTR)))    ; We repeat the char TMPBUFILLPTR times
  1928.     (WHEN (> TMPBUFILLPTR 3)            ; If this is more than 3, do repeat prefixing!
  1929.       (WHEN (> TMPBUFILLPTR 94) (SETQ TMPBUFILLPTR 94))    ; Also, truncate the number of repeats to 94
  1930.       (SETF (AREF BUFFER INDEX) K*REPEAT)    ; Put repeat character in the packet
  1931.       (INCF INDEX)                ; Increment
  1932.       (SETF (AREF BUFFER INDEX) (TOCHAR TMPBUFILLPTR))    ; Put my repeat count in the packet
  1933.       (INCF INDEX)                ; Increment
  1934.       (SETQ K*BUFILLPTR (+ K*BUFILLPTR TMPBUFILLPTR -1))    ; adjust the buffer index for the next character
  1935.       (SETQ K*FILE-CHARS (+ K*FILE-CHARS TMPBUFILLPTR -1)))) ; Adjust the total file chars read
  1936.      
  1937.       (WHEN (AND (NOT (= K*BINQUOTE *ASCII-N*))    ; Handle 8-bit quoting
  1938.          (> 8-CHAR *ASCII-DEL*))    ; If the 8-bit char is > 127
  1939.     (SETF (AREF BUFFER INDEX) K*BINQUOTE)    ; Put K*BINQUOTE in buffer
  1940.     (INCF INDEX))                ; Increment
  1941.        
  1942.       (WHEN (NOT *IMAGE*)            ; As long as we're not in image mode
  1943.     (SETQ 8-CHAR (CONVERT-TO-ASCII 8-CHAR)))    ; force characters to ASCII 
  1944.       
  1945.       (SETQ 7-CHAR (LOGAND 8-CHAR #b1111111))    ; Get low order 7 bits - #b1111111 is #o177
  1946.  
  1947.       (WHEN (OR (< 7-CHAR *ASCII-SP*)        ; Does char require special handling?
  1948.         (MEMBER 7-CHAR QUOTABLES)
  1949.         (= 7-CHAR *ASCII-DEL*))
  1950.     
  1951.     (WHEN (AND (= 7-CHAR *ASCII-CR*)    ; Map CR->CRLF when
  1952.            (NOT *IMAGE*))        ; not in image mode
  1953.       (SETF (AREF BUFFER INDEX) K*YOURQUOTE)    ; Put K*YOURQUOTE in buffer
  1954.       (INCF INDEX)                ; Increment
  1955.       (SETF (AREF BUFFER INDEX) (CTL *ASCII-CR*))    ; Put the character in buffer
  1956.       (INCF INDEX)                ; Increment
  1957.       (SETQ 8-CHAR *ASCII-LF*)        ; Replace the char with a linefeed
  1958.       (SETQ 7-CHAR (LOGAND 8-CHAR #b1111111)))    ; Get low order 7 bits - #b1111111 is #o177
  1959.     
  1960.     (SETF (AREF BUFFER INDEX) K*YOURQUOTE)    ; Put K*YOURQUOTE in buffer
  1961.     (INCF INDEX)                ; Increment
  1962.     
  1963.     (WHEN                    ; Make printable characters
  1964.       (NOT(MEMBER 7-CHAR QUOTABLES))        ; As long as it's not the active quote, binquote or repeat 
  1965.       (SETQ 7-CHAR (CTL 7-CHAR))
  1966.       (SETQ 8-CHAR (CTL 8-CHAR))))
  1967.       
  1968.       (IF *IMAGE*
  1969.       (SETF (AREF BUFFER INDEX) 8-CHAR)
  1970.       (SETF (AREF BUFFER INDEX) 7-CHAR))
  1971.       (INCF INDEX))
  1972.     
  1973.     (SETF (FILL-POINTER BUFFER) INDEX)
  1974.     INDEX))                    ; Return the index
  1975.  
  1976.  
  1977.  
  1978. (DEFUN BUFEMP (BUFFER LEN FILEPOINTER)
  1979.   "Put data from an incoming packet buffer into a file.
  1980.    Input parameters are the packet, it's length, and a
  1981.    pointer to the file in which to store the data.  As a
  1982.    result of processing, data is written to the file.
  1983.    This function returns the total number of characters
  1984.    written to the file."
  1985.   
  1986.   (DECLARE (SPECIAL K*IGNORE-NEXT-LINEFEED K*REPEAT K*BINQUOTE))
  1987.   
  1988.   (LET (T-CHAR 7-CHAR REPEAT BINQUOTED
  1989.     (FILE-CHARS 0)
  1990.     (QUOTABLES (LIST *MYQUOTE*
  1991.               (WHEN (NOT (= K*BINQUOTE *ASCII-N*)) K*BINQUOTE)
  1992.               (WHEN (NOT (= K*REPEAT *ASCII-SP*)) K*REPEAT))))
  1993.     (LOOP
  1994.       WITH IND = 0
  1995.       UNTIL (= IND LEN)
  1996.       DO
  1997.       (SETQ T-CHAR (AREF BUFFER IND))        ; Get a character
  1998.       
  1999.       (SETQ REPEAT 1)
  2000.       (SETQ BINQUOTED NIL)
  2001.       
  2002.       (WHEN (AND (NOT (= K*REPEAT *ASCII-SP*)) (= T-CHAR K*REPEAT))    ; Is it the repeat prefix?
  2003.     (INCF IND)
  2004.     (SETQ REPEAT (UNCHAR (LOGAND (AREF BUFFER IND) #b1111111)))    ; Get the repeat count
  2005.     (INCF IND)                ; Increment
  2006.     (SETQ T-CHAR (AREF BUFFER IND)))    ; Get next char
  2007.       
  2008.       (WHEN (AND (NOT (= K*BINQUOTE *ASCII-N*)) (= T-CHAR K*BINQUOTE))    ; Is it the binary quote prefix?
  2009.     (SETQ BINQUOTED T)            ; flag it
  2010.     (INCF IND)
  2011.     (SETQ T-CHAR (AREF BUFFER IND)))    ; Get next char
  2012.       
  2013.       (WHEN (= T-CHAR *MYQUOTE*)        ; Control quote?
  2014.     (INCF IND)                ; Increment
  2015.     (SETQ T-CHAR (AREF BUFFER IND))        ; Get the quoted character
  2016.     (SETQ 7-CHAR (LOGAND T-CHAR #b1111111))    ; and strip off the parity bit
  2017.     (WHEN (NOT (MEMBER 7-CHAR QUOTABLES))    ; Low order bits match active quote, binquote or repeat char?
  2018.       (SETQ T-CHAR (CTL T-CHAR))))        ; - No, uncontrollify it
  2019.       
  2020.       (WHEN BINQUOTED                ; If the binary prefix was set
  2021.     (SETQ T-CHAR (LOGXOR T-CHAR #b10000000)))    ; set the 8th bit
  2022.       
  2023.       (LOOP
  2024.     FOR I FROM 1 TO REPEAT            ; Now do the repeat count processing
  2025.     DO
  2026.     (IF *IMAGE*                ; Image mode?
  2027.         (PROGN                              ; - Yes
  2028.           (SEND FILEPOINTER :TYO T-CHAR)        ; send the character
  2029.           (INCF FILE-CHARS))                ; Increment the total file chars written
  2030.         (PROGN                ; - No, 
  2031.           (SETQ T-CHAR (LOGAND T-CHAR #b1111111))    ; Strip off the parity bit
  2032.           (IF (AND (= T-CHAR *ASCII-LF*)    ; Is it a linefeed
  2033.                K*IGNORE-NEXT-LINEFEED)    ; after a CR? 
  2034.           (SETQ K*IGNORE-NEXT-LINEFEED NIL)    ; -- Yes, ignore the LF and clear the flag
  2035.           (PROGN            ; -- No,
  2036.             (SETQ K*IGNORE-NEXT-LINEFEED    ; setup the flag
  2037.               (IF (= T-CHAR *ASCII-CR*) T NIL))    ; T If it's a CR; otherwise NIL
  2038.             (SETQ T-CHAR (CONVERT-FROM-ASCII T-CHAR))    ; Convert the character
  2039.             (WHEN T-CHAR        ; If it has an appropriate conversion,
  2040.               (SEND FILEPOINTER :TYO T-CHAR)   ; Write char to the file
  2041.               (INCF FILE-CHARS)))))))    ; Increment the total file chars written
  2042.       
  2043.       (INCF IND))                ; Increment the index
  2044.     FILE-CHARS))                                ; Return the total number of chars written
  2045.  
  2046.  
  2047.  
  2048. (DEFUN GET-NEXT-FILE ()
  2049.   "Get next file in a file group.  Returns NIL if no more files."
  2050.   (DECLARE (SPECIAL K*FILNAM K*RECFILNAM K*ARG1LIST K*ARG2LIST))
  2051.   
  2052.   (SETQ K*FILNAM (CAR K*ARG1LIST))        ; Get the next file
  2053.   (SETQ K*ARG1LIST (CDR K*ARG1LIST))        ; Shorten the list
  2054.   (SETQ K*RECFILNAM (CAR K*ARG2LIST))        ; Get the next recfile
  2055.   (SETQ K*ARG2LIST (CDR K*ARG2LIST))        ; Shorten the list
  2056.   (WHEN (AND (STRINGP K*FILNAM)
  2057.          (ZEROP (LENGTH K*FILNAM)))        ; If its an empty string, make it nil
  2058.     (SETQ K*FILNAM NIL))
  2059.   (WHEN (AND (STRINGP K*RECFILNAM)
  2060.          (ZEROP (LENGTH K*RECFILNAM)))    ; If its an empty string, make it nil
  2061.     (SETQ K*RECFILNAM NIL))
  2062.   (WHEN *DEBUG*                    ; Print debugging info
  2063.     (PRINTMSG
  2064.       "~%Function GET-NEXT-FILE:  k*filnam=~A  k*recfilnam=~A  k*arg1list=~A  k*arg2list=~A"
  2065.       K*FILNAM K*RECFILNAM K*ARG1LIST K*ARG2LIST))
  2066.   (IF K*FILNAM                    ; More files?
  2067.       T
  2068.       NIL))
  2069.  
  2070.  
  2071.  
  2072. (DEFUN SPAR (DATA)
  2073.   "Fill the data array with my send-init parameters.
  2074. Returns the data array."
  2075.   (DECLARE (SPECIAL K*BINQUOTE K*REPEAT))
  2076.   (SETF (FILL-POINTER DATA) 9)            ; Set array length to 9
  2077.   (SETF (AREF DATA 0) (TOCHAR *MYMAXPACSIZ*))    ; Biggest packet I can receive
  2078.   (SETF (AREF DATA 1) (TOCHAR *MYTIME*))    ; When I will time out
  2079.   (SETF (AREF DATA 2) (TOCHAR *MYPAD*))        ; How much padding I need
  2080.   (SETF (AREF DATA 3) (CTL *MYPADCHAR*))    ; Padding character I want
  2081.   (SETF (AREF DATA 4) (TOCHAR *MYEOL*))        ; End-Of-Line character I want
  2082.   (SETF (AREF DATA 5) *MYQUOTE*)        ; Quote character I use
  2083.   (SETF (AREF DATA 6) K*BINQUOTE)        ; 8-bit quote character I use
  2084.   (SETF (AREF DATA 7) *ASCII-1*)        ; Only know how to do 1 char checksum
  2085.   (SETF (AREF DATA 8) K*REPEAT)            ; Repeat count character I use
  2086.   DATA)
  2087.  
  2088.  
  2089.  
  2090. (DEFUN RPAR (DATA LEN)
  2091.   "Read the data array to get the other host's send-init parameters.
  2092. Returns the data array."
  2093.   (DECLARE (SPECIAL K*YOURMAXPACSIZ K*YOURTIME K*YOURPAD K*YOURPADCHAR
  2094.             K*YOUREOL K*YOURQUOTE K*BINQUOTE K*REPEAT K*STATE K*TTYFD-BITS))
  2095.   (LET
  2096.     ((REPEAT 0)
  2097.      (BINQUOTE 0))
  2098.     
  2099.     (WHEN (> LEN 0)
  2100.       (SETQ K*YOURMAXPACSIZ
  2101.         (UNCHAR (AREF DATA 0))))    ; Maximum send packet size
  2102.     (WHEN (> LEN 1)
  2103.       (SETQ K*YOURTIME
  2104.         (UNCHAR (AREF DATA 1))))    ; When you will time out
  2105.     (WHEN (> LEN 2)
  2106.       (SETQ K*YOURPAD
  2107.         (UNCHAR (AREF DATA 2))))    ; Number of pads to send
  2108.     (WHEN (> LEN 3)
  2109.       (SETQ K*YOURPADCHAR
  2110.         (CTL (AREF DATA 3))))    ; Padding character to send
  2111.     (WHEN (> LEN 4)
  2112.       (SETQ K*YOUREOL
  2113.         (UNCHAR (AREF DATA 4))))    ; EOL character to send
  2114.     (WHEN (> LEN 5)
  2115.       (SETQ K*YOURQUOTE
  2116.         (CHAR-CODE (AREF DATA 5))))    ; quote character to send
  2117.     (WHEN (> LEN 6)
  2118.       (SETQ K*BINQUOTE
  2119.         (CHAR-CODE (AREF DATA 6))))    ; 8-bit quote character to send
  2120.     (WHEN (> LEN 8)
  2121.       (SETQ REPEAT
  2122.         (CHAR-CODE (AREF DATA 8))))    ; Repeat character to send
  2123.     (WHEN *DEBUG*
  2124.       (PRINTMSG
  2125.     "~%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))
  2126.     
  2127.     (IF (ZEROP K*YOURMAXPACSIZ)            ; Is other KERMIT packet size unspecified?
  2128.     (SETQ K*YOURMAXPACSIZ *MYMAXPACSIZ*)    ; - Yes, use our size
  2129.     (IF (< K*YOURMAXPACSIZ *MYMAXPACSIZ*)    ; - No, is other KERMIT's smaller?
  2130.         (SETQ *MYMAXPACSIZ* K*YOURMAXPACSIZ)))    ; -- Yes - we'll both use other KERMIT's
  2131.     
  2132.     (WHEN (ZEROP K*YOUREOL)            ; Is other KERMIT EOL character unspecified?
  2133.       (SETQ K*YOUREOL *MYEOL*))            ; - Yes, use *MYEOL*
  2134.     
  2135.     (WHEN (ZEROP K*YOURQUOTE)            ; Is other KERMIT quote character unspecified?
  2136.       (SETQ K*YOURQUOTE *MYQUOTE*))        ; - Yes, use *MYQUOTE*
  2137.     
  2138.     (IF (AND (= K*STATE *RINIT-STATE*)        ; If we have never sent our parameters
  2139.          (= K*STATE *SGENERIC-STATE*)    ; and are processing the other
  2140.          (= K*STATE *RSERVER-STATE*))    ; KERMIT's parameters first (e.g., he did the init)
  2141.     (PROGN                    ; - Yes, we never sent
  2142.       (COND                    ; Process the 8-bit quoting char
  2143.         ((AND                ; If the other KERMIT has a valid 8-bit quote char...
  2144.            (OR (AND (> BINQUOTE 32) (< BINQUOTE 63))
  2145.            (AND (> BINQUOTE 95) (< BINQUOTE 127)))
  2146.            (NOT (= BINQUOTE K*YOURQUOTE)))
  2147.          (SETQ K*BINQUOTE BINQUOTE))    ; use it
  2148.         
  2149.         ((= BINQUOTE *ASCII-Y*)        ; If 8-bit quote char is a Y
  2150.          (IF *IMAGE*            ; Are we in image mode?
  2151.          (IF (= K*TTYFD-BITS 8)        ; -- Yes, do we have an 8-bit stream?
  2152.              (SETQ K*BINQUOTE *ASCII-N*)    ; -- Yes, say no quoting
  2153.              (SETQ K*BINQUOTE *ASCII-AMP*))    ; -- No, say we'll quote with &
  2154.          (SETQ K*BINQUOTE *ASCII-N*)))    ; -- No, not in image mode so don't do 8-bit
  2155.         
  2156.         (T                    ; Otherwise...say no 8-bit quoting
  2157.          (SETQ K*BINQUOTE *ASCII-N*)))
  2158.       (IF                    ; Process the repeat char
  2159.         (AND (OR (AND (> REPEAT 32) (< REPEAT 63))    ; Is it valid?
  2160.              (AND (> REPEAT 95) (< REPEAT 127)))
  2161.          (NOT (= REPEAT K*YOURQUOTE))
  2162.          (NOT (= REPEAT K*BINQUOTE)))
  2163.         (SETQ K*REPEAT REPEAT)        ; -- Yes, setup the repeat char
  2164.         (SETQ K*REPEAT *ASCII-SP*)))    ; -- No...say no repeating
  2165.     
  2166.     (PROGN                    ; - No, our parameters have been sent (we did the init)
  2167.       
  2168.       (WHEN (AND (NOT (= BINQUOTE K*BINQUOTE))    ; Process the 8-bit quote char
  2169.              (NOT (= BINQUOTE *ASCII-Y*))    ; If it's not what we sent, and its not a Y
  2170.              (SETQ K*BINQUOTE *ASCII-N*)))    ; say no 8-bit quoting
  2171.       
  2172.       (WHEN (NOT (= REPEAT K*REPEAT))    ; Process the repeat char - If it's not what we sent,
  2173.         (SETQ K*REPEAT *ASCII-SP*))))    ; say no repeating
  2174.     
  2175.     (WHEN *DEBUG*
  2176.       (PRINTMSG
  2177.     "~%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)))
  2178.   
  2179.   DATA)                        ; Finally, return DATA as the value of the function
  2180.  
  2181.  
  2182.  
  2183. ;;; Support functions
  2184.  
  2185. (DEFUN PROCESS-KERMIT-COMMAND (PACKET IGNORE)
  2186.   "Given a packet containing the command, try to process it.
  2187. Return a flag indicating success or failure, and the response."
  2188.   (FORMAT NIL "~A: Unimplemented KERMIT server command <~A>." *KERMIT-NAME* PACKET))
  2189.  
  2190. (DEFUN PROCESS-HOST-COMMAND (PACKET IGNORE)
  2191.   "Process a host command.  If an error is encountered, returns an error string."
  2192.   (LET
  2193.     ((RESULT NIL)
  2194.      (RESPONSE NIL))
  2195.     
  2196.     (CONDITION-CASE (ERR)
  2197.     (SETQ RESPONSE
  2198.           (WITH-OUTPUT-TO-STRING (STANDARD-OUTPUT)    ; Force the output to go to the string
  2199.         (SETQ RESULT (EVAL (READ-FROM-STRING PACKET)))))    ; Evaluate the command
  2200.       (ERROR
  2201.        (SETQ RESPONSE
  2202.          (FORMAT NIL "~A: Error <~A> while processing HOST command <~A>."
  2203.              *KERMIT-NAME* (SEND ERR :REPORT-STRING) PACKET)))
  2204.       (:NO-ERROR
  2205.        (FORMAT NIL "~A~A" RESPONSE RESULT)))))    ; Just return the response
  2206.  
  2207. (DEFUN PROCESS-GENERIC-COMMAND (PACKET LEN)
  2208.   "Generic Kermit Command.  Single character in data field (possibly followed
  2209. by operands, shown in {braces}, optional fields  in  [brackets]):
  2210.     I   Login [{*user[*password[*account]]}]
  2211.     C   CWD, Change Working Directory [{*directory[*password]}]
  2212.     L   Bye (Logout)
  2213.   * F   Finish (Shut down the server, but don't logout).
  2214.   * D   Directory [{*filespec}]
  2215.   * U   Disk Space Query (Usage) [{*area}]
  2216.   * E   Delete (Erase) {*filespec}
  2217.   * T   Type {*filespec}
  2218.   * R   Rename {*oldname*newname}
  2219.   * K   Copy {*source*destination}
  2220.   * W   Who's logged in? (Finger) [{*user ID or network host[*options]}]
  2221.     M   Send a short Message {*destination*text}
  2222.     H   Help [{*topic}]
  2223.   * Q   Server Status Query
  2224.     P   Program {*[program-filespec][*program-commands]}
  2225.     J   Journal {*command[*argument]}
  2226.     V   Variable {*command[*argument[*argument]]}"
  2227.   
  2228.   (DECLARE (SPECIAL K*FILNAM K*CANCEL))
  2229.   (LET
  2230.     ((COMD NIL)
  2231.      (ARGS (DECODE-PREFIXED-DATA PACKET LEN))        ; Decode the data
  2232.      (ARG1 NIL)
  2233.      (ARG2 NIL)
  2234.      (ARG3 NIL)
  2235.      (LNTH 0)
  2236.      (INDX 0)
  2237.      (DIR NIL))
  2238.     
  2239.     (SETQ COMD (SUBSEQ ARGS 0 1))
  2240.     (INCF INDX)
  2241.  
  2242.     (WHEN (< INDX (LENGTH ARGS))                     ; Get the first argument
  2243.       (SETQ LNTH (UNCHAR (COERCE (SUBSEQ ARGS INDX (1+ INDX)) 'CHARACTER)))
  2244.       (INCF INDX)
  2245.       (SETQ ARG1 (SUBSEQ ARGS INDX (+ INDX LNTH)))
  2246.       (INCF INDX LNTH)
  2247.     
  2248.       (WHEN (< INDX (LENGTH ARGS))                   ; Get the second argument
  2249.     (SETQ LNTH (UNCHAR (COERCE (SUBSEQ ARGS INDX (1+ INDX)) 'CHARACTER)))
  2250.     (INCF INDX)
  2251.     (SETQ ARG2 (SUBSEQ ARGS INDX (+ INDX LNTH)))
  2252.     (INCF INDX LNTH)
  2253.  
  2254.     (WHEN (< INDX (LENGTH ARGS))                 ; Get the third argument
  2255.       (SETQ LNTH (UNCHAR (COERCE (SUBSEQ ARGS INDX (1+ INDX)) 'CHARACTER)))
  2256.       (INCF INDX)
  2257.       (SETQ ARG3 (SUBSEQ ARGS INDX (+ INDX LNTH)))
  2258.       (INCF INDX LNTH))))
  2259.  
  2260.     (COND
  2261.       ((EQUAL COMD "D")
  2262.        (GENERIC-DIRECTORY ARG1))
  2263.       ((EQUAL COMD "E")
  2264.        (GENERIC-DELETE ARG1))
  2265.       ((EQUAL COMD "F")
  2266.        (SETQ K*CANCEL "Z"))
  2267.       ((EQUAL COMD "K")
  2268.        (GENERIC-COPY ARG1 ARG2))
  2269.       ((EQUAL COMD "Q")
  2270.        (GENERIC-STATUS))
  2271.       ((EQUAL COMD "R")
  2272.        (GENERIC-RENAME ARG1 ARG2))
  2273.       ((EQUAL COMD "T")
  2274.        (SETQ K*FILNAM ARG1))
  2275.       ((EQUAL COMD "U")
  2276.        (GENERIC-DISK-USAGE ARG1))
  2277.       ((EQUAL COMD "W")
  2278.        (GENERIC-WHO))
  2279.       (T
  2280.        (FORMAT NIL "~A: Unimplemented server GENERIC command <~A>" *KERMIT-NAME* COMD)))))
  2281.  
  2282.  
  2283.  
  2284. (DEFUN GENERIC-COPY (FILE1 FILE2)
  2285.   "Copies FILE1 to FILE2.  If an error is encountered, returns an error string."
  2286.   (LET
  2287.     ((F1 (MERGE-PATHNAMES FILE1 (USER-HOMEDIR-PATHNAME)))
  2288.      (F2 (MERGE-PATHNAMES FILE2 (USER-HOMEDIR-PATHNAME)))     
  2289.      (RESPONSE NIL))
  2290.     
  2291.     (CONDITION-CASE (ERR)
  2292.     (COPY-FILE F1 F2 :CREATE-DIRECTORIES T)
  2293.       (ERROR
  2294.        (SETQ RESPONSE
  2295.          (FORMAT NIL "~A: Error <~A> while processing GENERIC COPY command."
  2296.              *KERMIT-NAME* (SEND ERR :REPORT-STRING))))
  2297.       (:NO-ERROR
  2298.        (SETQ RESPONSE (FORMAT NIL "FIle ~A copied to ~A." F1 F2))))))
  2299.  
  2300. (DEFUN GENERIC-RENAME (FILE1 FILE2)
  2301.   "Renames FILE1 to FILE2.  If an error is encountered, returns an error string."
  2302.   (LET
  2303.     ((F1 (MERGE-PATHNAMES FILE1 (USER-HOMEDIR-PATHNAME)))
  2304.      (F2 (MERGE-PATHNAMES FILE2 (USER-HOMEDIR-PATHNAME)))     
  2305.      (RESPONSE NIL))
  2306.     
  2307.     (CONDITION-CASE (ERR)
  2308.     (RENAME-FILE F1 F2)
  2309.       (ERROR
  2310.        (SETQ RESPONSE
  2311.          (FORMAT NIL "~A: Error <~A> while processing GENERIC RENAME command."
  2312.              *KERMIT-NAME* (SEND ERR :REPORT-STRING))))
  2313.       (:NO-ERROR
  2314.        (SETQ RESPONSE (FORMAT NIL "FIle ~A renamed to ~A." F1 F2))))))
  2315.  
  2316. (DEFUN GENERIC-DELETE (FILE1)
  2317.   "Deletes FILE1.  If an error is encountered, returns an error string."
  2318.   (LET
  2319.     ((F1 (MERGE-PATHNAMES FILE1 (USER-HOMEDIR-PATHNAME)))
  2320.      (RESPONSE NIL))
  2321.     
  2322.     (CONDITION-CASE (ERR)
  2323.     (DELETE-FILE F1)
  2324.       (ERROR
  2325.        (SETQ RESPONSE
  2326.          (FORMAT NIL "~A: Error <~A> while processing GENERIC DELETE command."
  2327.              *KERMIT-NAME* (SEND ERR :REPORT-STRING))))
  2328.       (:NO-ERROR
  2329.        (SETQ RESPONSE (FORMAT NIL "FIle ~A deleted." F1))))))
  2330.  
  2331. (DEFUN GENERIC-DIRECTORY (&OPTIONAL DIRECTORY-NAME)
  2332.   "Returns a string containing the contents of current directory or directory-name.
  2333. If an error is encountered, returns an error string."
  2334.   (LET
  2335.     ((DIR NIL)
  2336.      (RESPONSE NIL))
  2337.     
  2338.     (CONDITION-CASE (ERR)
  2339.     (SETQ DIR
  2340.           (FS:DIRECTORY-LIST
  2341.         (MERGE-PATHNAMES
  2342.           (IF DIRECTORY-NAME
  2343.               DIRECTORY-NAME
  2344.               (USER-HOMEDIR-PATHNAME))
  2345.           "*.*#*")))
  2346.       (ERROR                ; If unable to get the directory-list
  2347.        (SETQ RESPONSE
  2348.          (FORMAT NIL "~A: Error <~A> while processing GENERIC DIRECTORY command."
  2349.              *KERMIT-NAME* (SEND ERR :REPORT-STRING))))
  2350.       (:NO-ERROR
  2351.        (SETQ RESPONSE
  2352.          (FORMAT NIL "Directory listing for ~A~%~A~%~:{~A~35T~@8A (~A)~51T~A~73T~A~%~}"
  2353.              (SEND (GET (CAR DIR) :PATHNAME) :STRING-FOR-PRINTING)
  2354.              (GET (CAR DIR) :DISK-SPACE-DESCRIPTION)
  2355.              (MAPCAR
  2356.                (FUNCTION
  2357.              (LAMBDA (flist)
  2358.                (LIST
  2359.                  (SEND (CAR flist) :STRING-FOR-DIRED)
  2360.                  (GET flist :LENGTH-IN-BYTES)
  2361.                  (GET flist :BYTE-SIZE)
  2362.                  (MULTIPLE-VALUE-BIND (SS MM HH DY MN YEAR)
  2363.                  (DECODE-UNIVERSAL-TIME
  2364.                    (GET flist :CREATION-DATE))
  2365.                    (FORMAT NIL "~A/~A/~A~11T~A:~A:~A"
  2366.                        MN DY YEAR HH MM SS))
  2367.                  (GET flist :AUTHOR))))
  2368.                (CDR DIR))))))))
  2369.  
  2370. (DEFUN GENERIC-DISK-USAGE (&OPTIONAL DIRECTORY-NAME)
  2371.   "Returns a string containing the disk-usage of current directory or directory-name.
  2372. If an error is encountered, returns an error string."
  2373.   (LET
  2374.     ((DIR NIL)
  2375.      (RESPONSE NIL))
  2376.     
  2377.     (CONDITION-CASE (ERR)
  2378.     (SETQ DIR
  2379.           (FS:DIRECTORY-LIST
  2380.         (MERGE-PATHNAMES
  2381.           (IF DIRECTORY-NAME
  2382.               DIRECTORY-NAME
  2383.               (USER-HOMEDIR-PATHNAME))
  2384.           "*.*#*")))
  2385.       (ERROR                ; If unable to get the directory-list
  2386.        (SETQ RESPONSE
  2387.          (FORMAT NIL "~A: Error <~A> while processing GENERIC DISK-USAGE command."
  2388.              *KERMIT-NAME* (SEND ERR :REPORT-STRING))))
  2389.       (:NO-ERROR
  2390.        (SETQ RESPONSE (GET (CAR DIR) :DISK-SPACE-DESCRIPTION))))))
  2391.  
  2392. (DEFUN GENERIC-STATUS ()
  2393.   "Returns a string containing the status of the current Kermit environment."
  2394.   (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*))
  2395.  
  2396. (DEFUN GENERIC-WHO ()
  2397.   "Returns a string describing who's logged on each machine on the network."
  2398.   (LET
  2399.     ((STREAM (MAKE-STRING-OUTPUT-STREAM)))      ; make an output stream for FINGER-LISPMS to write to
  2400.     (CHAOS:FINGER-LISPMS STREAM)
  2401.     (GET-OUTPUT-STREAM-STRING STREAM)))
  2402.  
  2403.  
  2404.  
  2405.              
  2406. (DEFUN CHANGE-KERMIT-PARAMETERS ()
  2407.   "Change local operating parameters"
  2408.   (LET ((IMAGE *IMAGE*) (DEBUG *DEBUG*) (MORE *MORE*) (MYMAXTRY *MYMAXTRY*)
  2409.     (MYMAXPACSIZ *MYMAXPACSIZ*) (MYTIME *MYTIME*) (MYPAD *MYPAD*)
  2410.     (MYPADCHAR *MYPADCHAR*) (MYEOL *MYEOL*) (MYQUOTE *MYQUOTE*)
  2411.     (FILNAMCNV *FILNAMCNV*) (SAVEFILES *SAVEFILES*) (RESET NIL))
  2412.     
  2413.     (DECLARE (SPECIAL IMAGE DEBUG MORE MYMAXTRY MYMAXPACSIZ MYTIME
  2414.               MYPAD MYPADCHAR MYEOL MYQUOTE FILNAMCNV SAVEFILES RESET))
  2415.     
  2416.     (*CATCH 'QUIT-CVV
  2417.       (TV:CHOOSE-VARIABLE-VALUES
  2418.     '((IMAGE "Image Mode      "
  2419.          :DOCUMENTATION "YES: Send file as 8-bit data.  NO: Send file as ASCII characters."
  2420.          :BOOLEAN)
  2421.       (DEBUG "Debug Mode      "
  2422.          :DOCUMENTATION "YES: Print debugging information.  NO: Do not print debugging information."
  2423.          :BOOLEAN)
  2424.       (MORE  "More Processing "
  2425.          :DOCUMENTATION "YES: Enable **MORE** in the KERMIT window.  NO: Do not use **MORE**."
  2426.          :BOOLEAN)
  2427.       ""
  2428.       (MYMAXTRY    "Maximum tries            "
  2429.                :DOCUMENTATION "Maximum number of times to retry a packet"
  2430.                :NUMBER)
  2431.       (MYMAXPACSIZ "Maximum packet size      "
  2432.                :DOCUMENTATION "Maximum packet size - must not be greater than 94"
  2433.                :NUMBER)
  2434.       (MYTIME      "Timeout seconds          "
  2435.                :DOCUMENTATION "Number of seconds after which I should be timed out"
  2436.                :NUMBER)
  2437.       (MYPAD       "Number of pad characters "
  2438.                :DOCUMENTATION "Number of padding characters to use"
  2439.                :NUMBER)
  2440.       (MYPADCHAR   "Padding character        "
  2441.                :DOCUMENTATION "Padding character to use - enter the character number"
  2442.                :NUMBER)
  2443.       (MYEOL       "EOL character            "
  2444.                :DOCUMENTATION "End-Of-Line character to use - enter the character number"
  2445.                :NUMBER)
  2446.       (MYQUOTE     "Quote character          "
  2447.                :DOCUMENTATION "Quote character to use - enter the character number"
  2448.                :NUMBER)
  2449.       ""
  2450.       (FILNAMCNV "Filename conversion "
  2451.              :DOCUMENTATION "YES: Convert filenames to name.type format.  NO: Do not convert filenames."
  2452.              :BOOLEAN)
  2453.       (SAVEFILES "Save partial files  "
  2454.              :DOCUMENTATION "YES: Save partially received file if transfer is interrupted.  NO: Delete the file."
  2455.              :BOOLEAN)
  2456.       ""
  2457.       (RESET "Reset parameters "
  2458.          :DOCUMENTATION "YES: Immediately reset parameters to default values.  NO: Use current parameter values."
  2459.          :BOOLEAN))
  2460.     :NEAR-MODE '(:POINT 500 400)
  2461.     :WIDTH 50
  2462.     :LABEL "Change Parameters"
  2463.     :MARGIN-CHOICES '("Do It" ("Quit" (*THROW 'QUIT-CVV T))))
  2464.       (SETQ *IMAGE* IMAGE)
  2465.       (SETQ *DEBUG* DEBUG)
  2466.       (SETQ *MORE* MORE)
  2467.       (SETQ *MYMAXTRY* MYMAXTRY)
  2468.       (SETQ *MYMAXPACSIZ* MYMAXPACSIZ)
  2469.       (SETQ *MYTIME* MYTIME)
  2470.       (SETQ *MYPAD* MYPAD)
  2471.       (SETQ *MYPADCHAR* MYPADCHAR)
  2472.       (SETQ *MYEOL* MYEOL)
  2473.       (SETQ *MYQUOTE* MYQUOTE)
  2474.       (SETQ *FILNAMCNV* FILNAMCNV)
  2475.       (SETQ *SAVEFILES* SAVEFILES))
  2476.     (WHEN RESET                    ; If these values are changed, change in DEFVAR as well
  2477.       (SETQ *IMAGE* NIL)
  2478.       (SETQ *DEBUG* NIL)
  2479.       (SETQ *MORE* NIL)
  2480.       (SETQ *MYMAXTRY* 10)
  2481.       (SETQ *MYMAXPACSIZ* 94)
  2482.       (SETQ *MYTIME* 10)
  2483.       (SETQ *MYPAD* 0)
  2484.       (SETQ *MYPADCHAR* 0)
  2485.       (SETQ *MYEOL* *ASCII-CR*)
  2486.       (SETQ *MYQUOTE* *ASCII-NS*)
  2487.       (SETQ *FILNAMCNV* T)
  2488.       (SETQ *SAVEFILES* NIL)) 
  2489.     (SEND *INFO-WINDOW* :SET-MORE-P *MORE*)))    ; Set in window
  2490.  
  2491.  
  2492.  
  2493. ;;; Kermit printing routines:
  2494.  
  2495. (DEFUN PRINTMSG (MSG-CTL-STRING &OPTIONAL &REST ARGS)
  2496.   "Print message on standard output if in verbose mode."
  2497.   (DECLARE (SPECIAL K*VERBOSEP K*ERROR-MESSAGE))
  2498.   (WHEN K*VERBOSEP                ; When verbose,
  2499.     (APPLY 'FORMAT *INFO-WINDOW* MSG-CTL-STRING ARGS))    ; print to the window.
  2500.   (WHEN *LOGFILE*                ; If a logfile has been specified,
  2501.     (APPLY 'FORMAT *LOGFILE* MSG-CTL-STRING ARGS)))    ; write to the file.
  2502.  
  2503. (DEFUN INCREMENT-PACKET-NUMBER ()
  2504.   "Increments packet number by +1 but resets after 63.  Also zeros K*NUMTRY."
  2505.   (DECLARE (SPECIAL K*PCKT-NUM K*NUMTRY))
  2506.   (SETQ K*PCKT-NUM (IF (< K*PCKT-NUM 63) (1+ K*PCKT-NUM) 0))
  2507.   (SETQ K*NUMTRY 0))
  2508.  
  2509. (DEFUN INCREMENT-RETRIES ()
  2510.   "Increments the number of retries."
  2511.   (DECLARE (SPECIAL K*NUMTRY K*PACKETS-RETRIED))
  2512.   (INCF K*NUMTRY)                ; Increment the retries
  2513.   (INCF K*PACKETS-RETRIED))            ; Increment the total retries
  2514.  
  2515. (DEFUN INITIALIZE-STATUS-COUNTS ()
  2516.   "Initialize the status counting for packet numbers and transfer times."
  2517.   (DECLARE (SPECIAL K*PACKETS-TRANSFERRED K*PACKETS-RETRIED
  2518.             K*BYTES-TRANSFERRED K*FILE-CHARS K*START-TIME))
  2519.   (SETQ K*PACKETS-TRANSFERRED 0)        ; Initialize total packet count
  2520.   (SETQ K*PACKETS-RETRIED 0)            ; Initialize total retry count
  2521.   (SETQ K*BYTES-TRANSFERRED 0)            ; Reset the bytes transferred counter
  2522.   (SETQ K*FILE-CHARS 0)                         ; Reset the total file chars
  2523.   (SETQ K*START-TIME (TIME)))            ; Save the current internal time in 60ths of a second
  2524.  
  2525. (DEFUN COUNT-AND-PRINT-PACKETS (PACKET-LENGTH)    ; called in RDATA and SDATA 
  2526.   "Increment total packet count and print totals."
  2527.   (DECLARE (SPECIAL K*PACKETS-TRANSFERRED K*BYTES-TRANSFERRED K*VERBOSEP))
  2528.   (INCF K*PACKETS-TRANSFERRED)
  2529.   (INCF K*BYTES-TRANSFERRED PACKET-LENGTH)
  2530.   (WHEN K*VERBOSEP
  2531.     (PRINT-STATUS-PACKET-INFO)))
  2532.  
  2533. (DEFUN INITIALIZE-STATUS-WINDOW ()
  2534.   (DECLARE (SPECIAL K*OPERATION))
  2535.   (SEND *STATUS-WINDOW* :CLEAR-WINDOW)
  2536.   (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)
  2537.   (TV:TURN-OFF-SHEET-BLINKERS *STATUS-WINDOW*))
  2538.  
  2539. (DEFUN PRINT-STATUS-PACKET-INFO ()
  2540.   (DECLARE (SPECIAL K*OPERATION K*FILNAM K*RECFILNAM K*PACKETS-TRANSFERRED
  2541.             K*BYTES-TRANSFERRED K*FILE-CHARS K*START-TIME K*PACKETS-RETRIED))
  2542.   (LET
  2543.     ((TIME-DIFF (MAX 1 (FLOOR (TIME-DIFFERENCE (TIME) K*START-TIME) 60))))
  2544.   
  2545.     (SEND *STATUS-WINDOW* :SET-CURSORPOS 82 1 :CHARACTER)
  2546.     (SEND *STATUS-WINDOW* :CLEAR-STRING "            ")
  2547.     (FORMAT *STATUS-WINDOW* "~5A/~@5A"
  2548.         (FLOOR K*BYTES-TRANSFERRED TIME-DIFF)
  2549.         (FLOOR K*FILE-CHARS TIME-DIFF))
  2550.     (SEND *STATUS-WINDOW* :SET-CURSORPOS 82 2 :CHARACTER)
  2551.     (SEND *STATUS-WINDOW* :CLEAR-STRING "       ")
  2552.     (FORMAT *STATUS-WINDOW* "~A" K*PACKETS-TRANSFERRED)
  2553.     (SEND *STATUS-WINDOW* :SET-CURSORPOS 82 3 :CHARACTER)
  2554.     (SEND *STATUS-WINDOW* :CLEAR-STRING "       ")
  2555.     (FORMAT *STATUS-WINDOW* "~A" K*PACKETS-RETRIED)))
  2556.   
  2557.   
  2558. (DEFUN PRINT-STATUS-FILE-INFO ()
  2559.   (DECLARE (SPECIAL K*VERBOSEP K*FILNAM K*RECFILNAM))
  2560.   (WHEN K*VERBOSEP
  2561.     (SEND *STATUS-WINDOW* :SET-CURSORPOS 27 2 :CHARACTER)
  2562.     (SEND *STATUS-WINDOW* :CLEAR-STRING "                               ")
  2563.     (FORMAT *STATUS-WINDOW* "~A" (IF K*FILNAM K*FILNAM ""))
  2564.     (SEND *STATUS-WINDOW* :SET-CURSORPOS 27 3 :CHARACTER)
  2565.     (SEND *STATUS-WINDOW* :CLEAR-STRING "                               ")
  2566.     (FORMAT *STATUS-WINDOW* "~A" (IF K*RECFILNAM K*RECFILNAM ""))))
  2567.  
  2568.  
  2569.  
  2570. (DEFUN CREATE-KERMIT-FILENAME (FILENAME)
  2571.   "Create a filename sutable for sending to another machine. Return file.type"
  2572.   (IF *FILNAMCNV*
  2573.       (LET* ((PATHNAME (FS:PARSE-PATHNAME FILENAME))
  2574.          (NAME (SEND PATHNAME :NAME))
  2575.          (TYPE (SEND PATHNAME :TYPE)))
  2576.     (IF (EQ NAME ':WILD)
  2577.         (SETQ NAME "*")
  2578.         (IF (EQ NAME ':UNSPECIFIC)
  2579.         (SETQ NAME "")
  2580.         (UNLESS (STRINGP NAME)
  2581.           (SETQ NAME ""))))
  2582.     (IF (EQ TYPE ':WILD)
  2583.         (SETQ TYPE "*")
  2584.         (IF (EQ TYPE ':UNSPECIFIC)
  2585.         (SETQ TYPE "")
  2586.         (UNLESS (STRINGP TYPE)
  2587.           (SETQ TYPE ""))))
  2588.     (FORMAT NIL "~A.~A" NAME TYPE))
  2589.       FILENAME))
  2590.  
  2591.  
  2592. (DEFUN ENCODE-PREFIXED-DATA (DATA BUFFER)
  2593.   "Decode string of data by passing it through BUFILL.
  2594.    Inputs are a string of data and a buffer to fill.
  2595.    Returned value is the size of the buffer."
  2596.   (DECLARE (SPECIAL K*BUFILLBUF K*BUFILLPTR))
  2597.   (LET
  2598.     ((SIZE 0))
  2599.     (WHEN                                       ; As long as noone is using BUFILL already...
  2600.       (AND (ZEROP (FILL-POINTER K*BUFILLBUF))
  2601.        (ZEROP K*BUFILLPTR))
  2602.       (SETQ SIZE
  2603.         (BUFILL BUFFER (MAKE-STRING-INPUT-STREAM DATA)))    ; Use BUFILL to encode the data
  2604.       (SETQ K*BUFILLPTR 0)            ; Reset the BUFILL pointer
  2605.       (SETF (FILL-POINTER K*BUFILLBUF) 0)    ; Clear the BUFILL buffer
  2606.       SIZE)))                    ; Return the SIZE of the buffer
  2607.  
  2608.  
  2609. (DEFUN DECODE-PREFIXED-DATA (PACKET LEN)
  2610.   "Decode a packet of data by passing it through BUFEMP.
  2611.    Inputs are a packet and length.  Returned value is the
  2612.    decoded string."
  2613.   (LET
  2614.     ((FILE (MAKE-STRING-OUTPUT-STREAM)))             ; Make a temporary output stream for BUFEMP
  2615.     (BUFEMP PACKET LEN FILE)                         ; Use BUFEMP to decode the data
  2616.     (GET-OUTPUT-STREAM-STRING FILE)))                ; Get the decoded data
  2617.  
  2618.  
  2619. (DEFUN EXPAND-WILDS (FILE-NAME)
  2620.   "Expand wildcards in a filename.  Returns a list
  2621.    of expanded filenames."
  2622.   (LET
  2623.     ((DIR NIL)
  2624.      (RESPONSE NIL))
  2625.     
  2626.     (CONDITION-CASE (ERR)
  2627.     (SETQ DIR
  2628.           (FS:DIRECTORY
  2629.         (MERGE-PATHNAMES
  2630.           FILE-NAME
  2631.           "FOO.BAR#>")))
  2632.       (ERROR                    ; If unable to get the directory due to error
  2633.        (SETQ RESPONSE                ; such as invalid host, pass on the file-name
  2634.          (LIST FILE-NAME)))            ; so it will error again at open time!
  2635.       (:NO-ERROR
  2636.        (SETQ RESPONSE
  2637.          (MAPCAR 'NAMESTRING DIR))))
  2638.     RESPONSE))                    ; Return RESPONSE
  2639.  
  2640. (DEFUN DEFAULT-ONLY-WILD-PATHNAME-COMPONENTS (PATH1 PATH2)
  2641.   "Fill in only the wild parts of PATH1 with the corresponding parts of PATH2."
  2642.   (FS:FAST-NEW-PATHNAME PATH1
  2643.             (WHEN (EQ (PATHNAME-DEVICE PATH1) :WILD) (PATHNAME-DEVICE PATH2))
  2644.             (WHEN (EQ (PATHNAME-DIRECTORY PATH1) :WILD) (PATHNAME-DIRECTORY PATH2))
  2645.             (WHEN (EQ (PATHNAME-NAME PATH1) :WILD) (PATHNAME-NAME PATH2))
  2646.             (WHEN (EQ (PATHNAME-TYPE PATH1) :WILD) (PATHNAME-TYPE PATH2))
  2647.             (WHEN (EQ (PATHNAME-VERSION PATH1) :W                  (PATHNAME-VERSION PATH2))))
  2648.  
  2649. <<< MKERMT.LSP >>>
  2650.  
  2651. ;;; -*- Mode:Common-Lisp; base:10; package:user -*-
  2652.  
  2653. (load "lm:kermit;defsystem.lisp#>")
  2654. (make-system 'kermit :compile :noconfirm :no-increment-patch)
  2655.  
  2656. <<< PTCH11.LSP >>>
  2657.  
  2658. ;;; -*- Mode: Lisp; Package: User; Base: 8.; Patch-File: T -*-
  2659. ;;; Written 10/17/86 12:26:15 by SPERRY,
  2660. ;;; Reason: Added definitions for :send-long-break and :send-short-break methods
  2661. ;;; to serial-stream-mixin, and defined the analagous commands for the 
  2662. ;;; VT100 emulator.
  2663. ;;; while running on A from band LOD1
  2664. ;;; with System  2.11, Compiler  2.0, File System  2.0, Universal Command Loop  2.0, Window System  2.1, Input Editor  2.0, ZMACS  2.3, Error Handler  2.0, Suggestions  2.0, Debug Utilities  2.2, Explorer-Net  2.5, Telnet  2.0, Vt100  2.0, File Server  2.0, Net-Config  2.1, Font Editor  2.0, Mailer  2.1, Mail-Reader  2.2, Streamer-Tape  2.3, Local-File  2.10, System-Log  2.0, Serial-Parallel  2.0, Printer  2.0, Glossary  2.0, IMAGEN  2.0, NVRAM  2.0, User Profile Utility  2.1, SPERRY  2.0, KEE2  1.6401, Graphics-Window  2.0, Graphics-Editor  2.0, Tree-Drawing-Utility  2.0, RTMS  2.5, NLMenu  2.0, NLMenu-RTMS-Interface  2.0, PROLOG  2.1, Grasper  2.0, Formatter  2.0, Color Graphics  1.0, IP  1.5, KERMIT  1.0, microcode 258, Rel 2.0.1 + KEE + 8 kits, 7-1-86.
  2665.  
  2666.  
  2667.  
  2668. #!Z
  2669. ; From file SERIAL-TELNET.LISP#> KERMIT; A:
  2670. #8R TELNET#:
  2671. (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET"))
  2672.                          (SI:LISP-MODE :ZETALISP)
  2673.                          (*READTABLE* SI:STANDARD-READTABLE)
  2674.                          (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL))
  2675.   (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#"
  2676.  
  2677. si:
  2678. (defmethod (serial-stream-mixin :SEND-LONG-BREAK) ()
  2679.  "Transmits a space condition for 3.5 seconds (long break)."
  2680.   (write-z-reg 5
  2681.            (logand #x7F            ; Turn off DTR
  2682.                (logior #x+10 WR5-CONTENTS)))  ;turn on send break
  2683.   (sleep 3.5 "Sending Long Break")
  2684.   (write-z-reg 5 WR5-CONTENTS)         ;restore register
  2685.   )
  2686. ))
  2687.  
  2688.  
  2689. #!Z
  2690. ; From file SERIAL-TELNET.LISP#> KERMIT; A:
  2691. #8R TELNET#:
  2692. (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET"))
  2693.                          (SI:LISP-MODE :ZETALISP)
  2694.                          (*READTABLE* SI:STANDARD-READTABLE)
  2695.                          (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL))
  2696.   (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#"
  2697.  
  2698. si:
  2699. (defmethod (serial-stream-mixin :SEND-SHORT-BREAK) ()
  2700.  "Transmits a space condition for .275 seconds (short break)."
  2701.   (write-z-reg 5 (logior #x+10 WR5-CONTENTS))  ;turn on send break
  2702.   (sleep .275 "Sending Short Break")
  2703.   (write-z-reg 5 WR5-CONTENTS)                 ;restore register
  2704.   )
  2705. ))
  2706.  
  2707. #!Z
  2708. ; From file SERIAL-TELNET.LISP#> KERMIT; A:
  2709. #8R TELNET#:
  2710. (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET"))
  2711.                          (SI:LISP-MODE :ZETALISP)
  2712.                          (*READTABLE* SI:STANDARD-READTABLE)
  2713.                          (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL))
  2714.   (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#"
  2715.  
  2716.  
  2717.  
  2718. (DEFCOMMAND (VT100-FRAME :LONG-BREAK) ()
  2719.   '(:DESCRIPTION "Send a short break to stream."
  2720.     :NAMES ("Long Break")
  2721.     :KEYS ((#\NETWORK #\CTRL-BREAK)))
  2722.   (if (not (null connection))
  2723.       (send stream :send-long-break)
  2724.       (format t "~&Not connected. Can't send Long Break.")
  2725.       (when (not ucl:preempting?)
  2726.     (send self :handle-prompt))))
  2727.  
  2728. ))
  2729.  
  2730. #!Z
  2731. ; From file SERIAL-TELNET.LISP#> KERMIT; A:
  2732. #8R TELNET#:
  2733. (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET"))
  2734.                          (SI:LISP-MODE :ZETALISP)
  2735.                          (*READTABLE* SI:STANDARD-READTABLE)
  2736.                          (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL))
  2737.   (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#"
  2738.  
  2739.  
  2740.  
  2741. (DEFCOMMAND (VT100-FRAME :SHORT-BREAK) ()
  2742.   '(:DESCRIPTION "Send a short break to stream."
  2743.     :NAMES ("Short Break")
  2744.     :KEYS ((#\NETWORK #\BREAK)))
  2745.   (if (not (null connection))
  2746.       (send stream :send-short-break)
  2747.       (format t "~&Not connected. Can't send Short Break.")
  2748.       (when (not ucl:preempting?)
  2749.     (send self :handle-prompt))))
  2750. ))
  2751.  
  2752. #!Z
  2753. ; From file SERIAL-TELNET.LISP#> KERMIT; A:
  2754. #8R TELNET#:
  2755. (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET"))
  2756.                          (SI:LISP-MODE :ZETALISP)
  2757.                          (*READTABLE* SI:STANDARD-READTABLE)
  2758.                          (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL))
  2759.   (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#"
  2760.  
  2761.  
  2762.  
  2763. (BUILD-COMMAND-TABLE 'VT100-TELNET-CMD-TABLE 'VT100-FRAME
  2764.   '((:method telnet-frame :exit-command)        
  2765.     (:method telnet-frame :disconnect-command)
  2766.     (:method telnet-frame :interrupt-process-command)
  2767.     :send-answerback-command
  2768.     :reverse-video-command
  2769.     :reset-command
  2770.     :escape-processing-command
  2771.     (:method telnet-frame :quit-and-disconnect-command)
  2772.     (:method telnet-frame :status-command)
  2773.     (:method telnet-frame :abort-output-command)
  2774.     :column-command
  2775.     :truncate-command
  2776.     :set-vt100-lines
  2777.     :network-help-command
  2778.     (:method telnet-frame :clear-input-command)
  2779.     (:method vt100-frame :autodial)                   ; BAC
  2780.     (:method vt100-frame :kermit)                     ; BAC
  2781.     :local-echo-command                               ; BAC
  2782.     :short-break
  2783.     :long-break
  2784.     )
  2785.   :INIT-OPTIONS
  2786.   '(:NAME "Vt100 & Telnet Commands"
  2787.       :DOCUMENTATION "The Vt100 & Telnet commands."))
  2788.  
  2789. ))
  2790.  
  2791. #!Z
  2792. ; From file SERIAL-TELNET.LISP#> KERMIT; A:
  2793. #8R TELNET#:
  2794. (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET"))
  2795.                          (SI:LISP-MODE :ZETALISP)
  2796.                          (*READTABLE* SI:STANDARD-READTABLE)
  2797.                          (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL))
  2798.   (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#"
  2799.  
  2800.  
  2801.  
  2802. (BUILD-MENU 'UCL-VT100-TELNET-MENU 'VT100-FRAME
  2803.   :DEFAULT-ITEM-OPTIONS
  2804.   '(:FONT FONTS:MEDFNT)
  2805.   :ITEM-LIST-ORDER  
  2806.     '( ;Row 1
  2807.       (:method telnet-frame :exit-command)        
  2808.       (:method telnet-frame :disconnect-command)
  2809.       (:method telnet-frame :interrupt-process-command)
  2810.       :send-answerback-command
  2811.       :reverse-video-command
  2812.       :reset-command
  2813.       :escape-processing-command
  2814.        ;Row 2
  2815.       (:method telnet-frame :quit-and-disconnect-command)
  2816.       (:method telnet-frame :status-command)
  2817.       (:method telnet-frame :abort-output-command)
  2818.       :column-command
  2819.       :truncate-command
  2820.       :set-vt100-lines
  2821.       :network-help-command
  2822.        ;Row 3                                           ; BAC
  2823.       (:method vt100-frame :autodial)                   ; BAC
  2824.       (:method vt100-frame :kermit)                     ; BAC
  2825.       :local-echo-command                               ; BAC
  2826.       :short-break
  2827.       :long-break
  2828.       ))
  2829.  
  2830. ))
  2831.  
  2832.  
  2833. <<< SCLOSE.LSP >>>
  2834.  
  2835. ;;; -*- Mode: Lisp; Package: User; Base: 8.; Patch-File: T -*-
  2836.  
  2837. ;;;                           RESTRICTED RIGHTS LEGEND
  2838.  
  2839. ;;;Use, duplication, or disclosure by the Government is subject to
  2840. ;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
  2841. ;;;Technical Data and Computer Software clause at 52.227-7013.
  2842. ;;;
  2843. ;;;                     TEXAS INSTRUMENTS INCORPORATED.
  2844. ;;;                              P.O. BOX 2909
  2845. ;;;                           AUSTIN, TEXAS 78769
  2846. ;;;                                 MS 2151
  2847. ;;;
  2848. ;;; Copyright (c) 1986, Texas Instruments Incorporated.  All rights reserved.
  2849.  
  2850. ;;; Written 5/16/86 17:44:10 by FORD,
  2851. ;;; Reason: Change :CLOSE to clear the hardware registers.
  2852. ;;; while running on B from band LOD2
  2853. ;;; with System 2.44, Compiler 2.5, File System 2.1, Universal Command Loop 2.0, Window System 2.5, Input Editor 2.0, ZMACS 2.5, Error Handler 2.0, Suggestions 2.1, Debug Utilities 2.7, Explorer-Net 2.6, Telnet 2.2, Vt100 2.0, File Server 2.0, Net-Config 2.2, Font Editor 2.2, Mailer 2.4, Mail-Reader 2.4, Streamer-Tape 2.7, Local-File 2.15, System-Log 2.2, Serial-Parallel 2.8, Printer 2.0, Glossary 2.0, IMAGEN 2.1, NVRAM 2.3, User Profile Utility 2.1, IP 1.15, Experimental Code Management Interface 2.22, Experimental Explorer Bug System 20.0, microcode 287, FAN23-MCR287-AUS.
  2854.  
  2855.  
  2856.  
  2857. #!Z
  2858. ; From file SERIAL-STREAM.LISP#> SERIAL; A:
  2859. #8R SYSTEM-INTERNALS#:
  2860. (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))
  2861.                          (SI:LISP-MODE :ZETALISP)
  2862.                          (*READTABLE* STANDARD-READTABLE)
  2863.                          (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL))
  2864.   (COMPILER#:PATCH-SOURCE-FILE "SYS: SERIAL; SERIAL-STREAM.#"
  2865.  
  2866.  
  2867. (Defmethod (Serial-Stream-Mixin :CLOSE) (&Optional Abort-P)
  2868.   ;; deallocate the serial buffers
  2869.   (IF *serial-output-buffer*
  2870.       (PROGN
  2871.         (IF (NOT abort-p) (FUNCALL-SELF ':finish))
  2872.         (return-serial-buffer *serial-Output-Buffer*)
  2873.         (SETQ *Serial-Output-Buffer* nil)))
  2874.   (IF *Serial-Input-Buffer*
  2875.       (PROGN
  2876.         (return-serial-buffer *Serial-Input-Buffer*)
  2877.         (SETQ *Serial-Input-Buffer* nil)))
  2878.   (array-dpb-offset 0 %%q-pointer *serial-port* %serial-receive-buffer)
  2879.   (array-dpb-offset 0 %%q-pointer *serial-port* %serial-transmit-buffer)
  2880.   (setq *serial-port-owner* nil)  
  2881.   (write-z-reg 9   0)  ;clear master interrupt control register
  2882.   (write-z-reg 5   0)  ;DTR, RTS, Tx disable
  2883.   (write-z-reg 3   0)  ;Rx disable
  2884.   (write-z-reg 15. 0)  ;disable external interrupts
  2885.   (write-z-reg 1   0)  ;disable interrupts
  2886.   (disable-serial-event)              ;disable SIB serial event posting
  2887.   )
  2888. ))
  2889.  
  2890. <<< STLNET.LSP >>>
  2891.  
  2892. ;;; -*- Mode:LISP; Package:TELNET; Base:8; Patch-File:T -*-
  2893.  
  2894. ;;;                           RESTRICTED RIGHTS LEGEND
  2895.  
  2896. ;;;Use, duplication, or disclosure by the Government is subject to
  2897. ;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
  2898. ;;;Technical Data and Computer Software clause at 52.227-7013.
  2899. ;;;
  2900. ;;;                     TEXAS INSTRUMENTS INCORPORATED.
  2901. ;;;                              P.O. BOX 2909
  2902. ;;;                           AUSTIN, TEXAS 78769
  2903. ;;;                                 MS 2151
  2904. ;;;
  2905. ;;; Copyright (c) 1986, Texas Instruments Incorporated.  All rights reserved.
  2906. ;;; Copyright (c) 1986, Sperry Corporation.  All rights reserved.
  2907.  
  2908. ;;; NOTES:
  2909. ;;;   This code will need review and possibly reimplementation for
  2910. ;;;   Release 3.0 because of GENI's release.
  2911.  
  2912. ;;; To eliminate compilation warnings, create required packages
  2913. ;;; if they don't already exist ;; BAC
  2914. (EVAL-WHEN (EVAL COMPILE)
  2915.   (PKG-FIND-PACKAGE "KERMIT" T)
  2916.   (PKG-FIND-PACKAGE "IP" T))
  2917.  
  2918. ;;; MAKE-SERIAL-STREAM-FROM-CVV
  2919. ;;;
  2920.  
  2921. (DEFVAR  *BAUD*                  #10r1200    "Baud rate.")
  2922. (DEFVAR  *FORCE-OUTPUT*          T           "Force output.")
  2923. (DEFVAR  *NUMBER-OF-DATA-BITS*   #10r8       "Number of data bits.")
  2924. (DEFVAR  *NUMBER-OF-STOP-BITS*   #10r2       "Number of stop bits.")
  2925. (DEFVAR  *PARITY*                :NONE       "Parity.")
  2926. (DEFVAR  *XON-XOFF-PROTOCOL*     NIL         "XON-XOFF protocol.")
  2927. (DEFVAR  *ASCII-CHARACTERS*      NIL         "Ascii-characters.")
  2928. (DEFVAR  *INPUT-BUFFER-SIZE*     #10r180     "Input buffer.") 
  2929. (DEFVAR  *OUTPUT-BUFFER-SIZE*    #10r180     "Output buffer.")
  2930.  
  2931. (DEFUN MAKE-SERIAL-STREAM-FROM-CVV ()
  2932.   "Produces a CVV to select serial stream parameters, then creates a stream
  2933. using SI:MAKE-SERIAL-STREAM.  Returns the created stream."
  2934.   (DECLARE (SPECIAL *BAUD* *FORCE-OUTPUT* *NUMBER-OF-DATA-BITS*
  2935.             *NUMBER-OF-STOP-BITS* *PARITY* *XON-XOFF-PROTOCOL*
  2936.             *ASCII-CHARACTERS* *INPUT-BUFFER-SIZE* *OUTPUT-BUFFER-SIZE*))
  2937.  
  2938.   (TV:CHOOSE-VARIABLE-VALUES
  2939.     '((*BAUD* "Baud rate"
  2940.           :DOCUMENTATION "Line speed.  (Most asynchronous modems use 1200 or 300)"
  2941.           :CHOOSE (#10r300 #10r1200 #10r2400 #10r4800 #10r9600 #10r19200))
  2942.       (*FORCE-OUTPUT* "Force output"
  2943.               :DOCUMENTATION "YES: send characters immediately.  NO: send characters when buffer is full."
  2944.               :BOOLEAN)
  2945.       (*NUMBER-OF-DATA-BITS* "Data Bits"
  2946.                  :DOCUMENTATION "Number of data bits."
  2947.                  :CHOOSE (#10r5 #10r6 #10r7 #10r8))
  2948.       (*NUMBER-OF-STOP-BITS* "Stop Bits"
  2949.                  :DOCUMENTATION "Number of stop bits."
  2950.                  :CHOOSE (1 2))
  2951.       (*PARITY* "Parity"
  2952.         :DOCUMENTATION "Type of parity to use."
  2953.         :CHOOSE (:NONE :EVEN :ODD))
  2954.       (*XON-XOFF-PROTOCOL* "XON-XOFF"
  2955.                :DOCUMENTATION "YES: use XON-XOFF characters.  NO: don't implement XON-XOFF characters."
  2956.                :BOOLEAN)
  2957.       (*ASCII-CHARACTERS* "Translate ASCII"
  2958.               :DOCUMENTATION "YES: Automatically translate between ASCII and LISPM characters.  NO: don't translate."
  2959.               :BOOLEAN)
  2960.       (*INPUT-BUFFER-SIZE* "Input Buffer size"
  2961.                :DOCUMENTATION "Size (in words) to allocate for the input buffers."
  2962.                :NUMBER)
  2963.       (*OUTPUT-BUFFER-SIZE* "Output Buffer size"
  2964.                 :DOCUMENTATION "Size (in words) to allocate for the output buffers."
  2965.                 :NUMBER))
  2966.     :NEAR-MODE '(:POINT 500 400)
  2967.     :LABEL "Choose Serial Stream Parameters"
  2968.     :MARGIN-CHOICES '("Do It"))
  2969.   
  2970.   (SI:MAKE-SERIAL-STREAM
  2971.     :BAUD *BAUD*
  2972.     :FORCE-OUTPUT *FORCE-OUTPUT*
  2973.     :NUMBER-OF-DATA-BITS *NUMBER-OF-DATA-BITS*
  2974.     :NUMBER-OF-STOP-BITS *NUMBER-OF-STOP-BITS*
  2975.     :PARITY *PARITY*
  2976.     :XON-XOFF-PROTOCOL *XON-XOFF-PROTOCOL*
  2977.     :ASCII-CHARACTERS *ASCII-CHARACTERS*
  2978.     :INPUT-BUFFER-SIZE *INPUT-BUFFER-SIZE*
  2979.     :OUTPUT-BUFFER-SIZE *OUTPUT-BUFFER-SIZE*))
  2980.  
  2981.  
  2982. ;;; Autodial
  2983. ;;;
  2984.  
  2985. (DEFVAR  *AUTODIAL-PREFIX*  "ATDT"            "Prefix to send to autodialer modem")
  2986. (DEFVAR  *AUTODIAL-NUMBER*  "8,8005551212"    "Number to dial")
  2987.  
  2988. (DEFUN AUTODIAL (&KEY
  2989.          (PREFIX *AUTODIAL-PREFIX*)
  2990.          (NUMBER *AUTODIAL-NUMBER*)
  2991.          STREAM                ; could bind this to *SERIAL-PORT-OWNER*
  2992.          MENU
  2993.          VERBOSE)
  2994.   "Dial a number using an autodialer.  If :NUMBER is not specified,
  2995. use the last number dialed.  If :MENU is specified, display a menu
  2996. to select the number to dial."
  2997.   
  2998.   (LET
  2999.     ((PRE PREFIX)
  3000.      (NUM NUMBER)
  3001.      (CONTINUE T))
  3002.     (DECLARE (SPECIAL PRE NUM))
  3003.     (WHEN MENU
  3004.       (SETQ CONTINUE
  3005.         (*CATCH 'END-CVV
  3006.           (TV:CHOOSE-VARIABLE-VALUES
  3007.         '((PRE
  3008.             "Prefix"
  3009.             :DOCUMENTATION "Modem's autodial prefix (e.g., ATDT)."
  3010.             :STRING)
  3011.           (NUM
  3012.             "Number"
  3013.             :DOCUMENTATION "Telephone number to dial.  A comma <,> causes a 2 second wait."
  3014.             :STRING))
  3015.         :NEAR-MODE '(:POINT 500 400)
  3016.         :LABEL "Serial Port Autodial"
  3017.         :MARGIN-CHOICES '("Do It" ("Quit" (*THROW 'END-CVV NIL))))
  3018.           T)))
  3019.  
  3020.     (WHEN CONTINUE
  3021.       (IF (NOT (STREAMP STREAM))
  3022.       (WHEN VERBOSE
  3023.         (FORMAT T "~&Stream <~A> is not a valid stream." STREAM))
  3024.       (PROGN
  3025.         (SETQ *AUTODIAL-PREFIX* PRE)
  3026.         (SETQ *AUTODIAL-NUMBER* NUM)
  3027.         (SEND STREAM :CLEAR-INPUT)
  3028.         (SEND STREAM :CLEAR-OUTPUT)
  3029.         (SEND STREAM :LINE-OUT (FORMAT NIL "~A~A" *AUTODIAL-PREFIX* *AUTODIAL-NUMBER*))
  3030.         (PROCESS-WAIT-WITH-TIMEOUT
  3031.           "Dialing..."
  3032.           3600
  3033.           (FUNCTION (LAMBDA (STREAM)
  3034.               (SEND STREAM :GET :DATA-CARRIER-DETECT)))
  3035.           STREAM)
  3036.         (SEND STREAM :CLEAR-INPUT)
  3037.         (SEND STREAM :CLEAR-OUTPUT)
  3038.         T)))))
  3039.  
  3040.  
  3041. ;;; RUN-SCRIPT
  3042. ;;;
  3043.  
  3044. (DEFUN RUN-SCRIPT (script &KEY (stream *TERMINAL-IO*) (debug-stream *DEBUG-IO*)
  3045.            &AUX (response (make-array 5000. :type art-string :fill-pointer 0))
  3046.                 (return-value nil))
  3047.   "Simulate an interactive user session with a script.
  3048. SCRIPT is a list of the form ((SEND RECEIVE ACTION)...).
  3049. SEND is a list of a format control string and its arguments that specify the output to be sent to STREAM.
  3050. RECEIVE is a list of a format control string and its arguments that specify the input expected from STREAM.
  3051. ACTION specifies what to do if the data received doesn't contain the string specified by RECEIVE.
  3052.   It can be :L (loop forever), :Q (quit,the default), a number indicating the number of times to loop and
  3053.   before quitting, or a list of a format control string and its arguments that specify an alternative output
  3054.   to be sent to STREAM.  
  3055. For each element of SCRIPT, first SEND is sent to STREAM, then STREAM is checked for input that matches
  3056.   RECEIVE, if it is found, the next form is processed, else, the ACTION is processed, and STREAM is again
  3057.   checked for input that matches RECEIVE.
  3058. STREAM is an I/O stream.
  3059. When DEBUG-STREAM is specified, it should be an I/O stream where debug info is sent.
  3060. RUN-SCRIPT returns :SUCCESSFUL if the last RECEIVE in SCRIPT was successful, :UNSUCCESSFUL otherwise."
  3061.    
  3062.   (CHECK-ARG SCRIPT LISTP "a list")
  3063.   (CHECK-ARG STREAM STREAMP "a stream")
  3064.   (CHECK-ARG DEBUG-STREAM STREAMP "a stream")
  3065.   (DOLIST (item script return-value)
  3066.     (SETQ return-value
  3067.       (LET* ((send (FIRST item))
  3068.          (receive (SECOND item))
  3069.          (action (THIRD item)))
  3070.         (DO ()
  3071.         (NIL)
  3072.           (WHEN send
  3073.         (LET ((formatted-string (APPLY #'FORMAT NIL (CAR send) (CDR send))))
  3074.           (SEND stream :STRING-OUT formatted-string)
  3075.           (WHEN debug-stream (FORMAT debug-stream "~%Sending:~A" formatted-string))))
  3076.           (IF receive
  3077.           (PROGN 
  3078.             (SETF (FILL-POINTER response) 0)
  3079.             (WHEN debug-stream (FORMAT debug-stream "~%Receiving:"))
  3080.             (DO ((char (SEND stream :TYI-WITH-TIMEOUT 1800.)(SEND stream :TYI-WITH-TIMEOUT 1800.)))
  3081.             ((NULL char) T)
  3082.               (WHEN (> char 0)
  3083.             (SETF (AREF response (FILL-POINTER response)) (LOGAND char #o177))
  3084.             (INCF (FILL-POINTER response))
  3085.             (WHEN debug-stream (FORMAT debug-stream "~C" (LOGAND char #o177)))))
  3086.             (WHEN debug-stream (FORMAT debug-stream "~%Searching:~A" (APPLY #'FORMAT NIL (CAR receive) nil)))
  3087.             (SEND stream :CLEAR-INPUT)
  3088.             (IF (STRING-SEARCH (APPLY #'FORMAT NIL (CAR receive) (CDR receive)) response)
  3089.             (RETURN :SUCCESSFUL)
  3090.             (IF action
  3091.                 (IF (EQ action :Q)
  3092.                 (RETURN :UNSUCCESSFUL)
  3093.                 (IF (INTEGERP action) 
  3094.                     (IF (< action 1)
  3095.                     (RETURN :UNSUCCESSFUL)
  3096.                     (DECF action))
  3097.                     (IF (LISTP action)
  3098.                     (SETQ send action)
  3099.                     (UNLESS (EQ action :L)
  3100.                       (FERROR t "The third element, ACTION, of an element of SCRIPT, ~A, was ~A, which is not :Q, :L, an integer, or a list." ITEM ACTION)))))
  3101.                 (RETURN :UNSUCCESSFUL))))
  3102.           (RETURN :SUCCESSFUL)))))))
  3103.  
  3104.  
  3105. ;;; Serial stream flavor addition: TYI-WITH-TIMEOUT 
  3106.  
  3107. SI:(DEFMETHOD (SERIAL-STREAM-MIXIN :TYI-WITH-TIMEOUT) (INTERVAL-IN-60THS)
  3108.      (IF (SI:PROCESS-WAIT-WITH-TIMEOUT
  3109.        "Serial Waiting"
  3110.        INTERVAL-IN-60THS
  3111.        (FUNCTION (LAMBDA (STREAM) (SEND STREAM :INPUT-CHARS-AVAILABLE-P)))
  3112.        SELF)
  3113.      (SEND SELF :TYI)))
  3114.  
  3115.  
  3116. ;;;  From sys:telnet;basic-telnet (sort of): 
  3117. ;;; 
  3118. ;;;  This method is almost identical to (:method basic-telnet :net-output),
  3119. ;;;  which vt100-frame inherits, except that this version doesn't
  3120. ;;;  automatically send a linefeed after a carriage-return unless the
  3121. ;;;  connection is a chaos connection.  Thus, it preserves the existing
  3122. ;;;  behavior for normal connections (and it seems to be the right thing)
  3123. ;;;  while removing the spurious linefeed from serial-port connections.
  3124. ;;;  There may well be a better way to do it.  - pf, Sept 11, 1985
  3125. (DEFMETHOD (vt100-frame :NET-OUTPUT) (ch)
  3126.   (lock-output
  3127.     (when (ldb-test 1701 ch)            ;An NVT char from TELNET-KEYS
  3128.       (if new-telnet-p
  3129.       (send stream ':tyo NVT-IAC))
  3130.       (setq ch (ldb 0010 ch)))
  3131.     (send stream ':tyo ch)
  3132.     (cond ((and (typep connection 'chaos:conn) (= ch 15))
  3133.        (send stream ':tyo 12))        ;CR is two chars, CR LF
  3134.       ((and (= ch NVT-IAC) new-telnet-p)
  3135.        (send stream ':tyo NVT-IAC)))))      ;IAC's must be quoted
  3136.  
  3137.  
  3138. ;;; Autodial command method
  3139. ;;;
  3140.  
  3141. (DEFCOMMAND (VT100-FRAME :AUTODIAL) ()
  3142.   '(:DESCRIPTION "Display a pop-up menu with commands to use an auto dialer."
  3143.          :NAMES ("Autodial"))
  3144.   (DECLARE (SPECIAL *AUTODIAL-PREFIX* *AUTODIAL-NUMBER*))
  3145.   (COND (CONNECTION
  3146.      (IF (NOT (FUNCTIONP 'AUTODIAL))
  3147.          (FORMAT T "~&AUTODIAL not loaded. Can't Autodial."))
  3148.          (FUNCALL 'AUTODIAL :STREAM STREAM :MENU T))
  3149.     (T
  3150.      (FORMAT T "~&Not connected.  Can't Autodial.")
  3151.      (WHEN (NOT UCL:PREEMPTING?)
  3152.        (SEND SELF ':HANDLE-PROMPT)))))
  3153.  
  3154.  
  3155. ;;; Kermit command method
  3156. ;;;
  3157.  
  3158. (DEFCOMMAND (VT100-FRAME :KERMIT) ()
  3159.   '(:DESCRIPTION "Display a pop-up menu of KERMIT file-transfer commands."
  3160.          :Names ("Kermit"))
  3161.   (COND (CONNECTION
  3162.      (IF (NOT (FUNCTIONP 'KERMIT:INTERACTIVE-KERMIT))
  3163.          (FORMAT T "~&KERMIT not loaded. Can't run KERMIT.")
  3164.          (LET
  3165.            ((VT100-SUBSTITUTE (SEND SELF :SELECTION-SUBSTITUTE))
  3166.         (KERMIT-SUPERIOR (SEND KERMIT:*KERMIT-FRAME* :SUPERIOR))
  3167.         (MENU-PANE (SEND SELF :GET-PANE 'MENU-TELNET)))
  3168.            (UNWIND-PROTECT
  3169.            (LET
  3170.              ((FORM NIL))
  3171.              (SEND TYPEOUT-PROCESS :ARREST-REASON 'KERMIT)    ; Stop the vt100 process from using serial stream
  3172.              (SETQ FORM (KERMIT:INTERACTIVE-KERMIT STREAM NIL)) ; Get the Kermit arguments
  3173.              (WHEN FORM
  3174.                (SETF (SEND MENU-PANE :INVISIBLE-TO-MOUSE-P) T)    ; Make the vt100 menu items non-mousable
  3175.                (SEND KERMIT:*KERMIT-FRAME* :SET-SUPERIOR SELF)
  3176.                (SEND SELF :SET-SELECTION-SUBSTITUTE KERMIT:*KERMIT-FRAME*)    ; Attach the kermit frame to vt100
  3177.                (EVAL FORM)))        ; Call Kermit
  3178.          (SEND TYPEOUT-PROCESS :REVOKE-ARREST-REASON 'KERMIT)    ; Reallow vt100 to use serial
  3179.          (SETF (SEND MENU-PANE :INVISIBLE-TO-MOUSE-P) NIL)    ; Make menu items mousable
  3180.          (SEND SELF :SET-SELECTION-SUBSTITUTE VT100-SUBSTITUTE)
  3181.          (SEND KERMIT:*KERMIT-FRAME* :SET-SUPERIOR KERMIT-SUPERIOR)))))
  3182.     (T
  3183.      (FORMAT T "~&Not connected.  Can't run KERMIT.")
  3184.      (WHEN (NOT UCL:PREEMPTING?)
  3185.        (SEND SELF ':HANDLE-PROMPT)))))
  3186.  
  3187.  
  3188. ;;; Local echo command method
  3189. ;;;
  3190.  
  3191. (DEFCOMMAND (vt100-frame :LOCAL-ECHO-COMMAND) ()
  3192.   '(:DESCRIPTION "Toggle local echo mode of Vt100 screen pane."
  3193.          :NAMES ("Local Echo"))
  3194.   (SETF ECHO-FLAG (IF ECHO-FLAG NIL T))
  3195.   (FORMAT T "~&Local echo now ~A.~%"
  3196.       (IF ECHO-FLAG "off" "on"))                  ; echo-flag=T means local echo is off!
  3197.   (WHEN (AND (NULL CONNECTION) (NOT UCL:PREEMPTING?))
  3198.       (SEND SELF ':HANDLE-PROMPT)))
  3199.  
  3200.  
  3201. ;;; Redefine the VT100 layout and menu
  3202. ;;;
  3203.  
  3204. (DEFFLAVOR VT100-TELNET-MENU
  3205.        (TV:INVISIBLE-TO-MOUSE-P)
  3206.        (TV:DYNAMIC-ITEM-LIST-MIXIN TV:COMMAND-MENU)
  3207.   (:SETTABLE-INSTANCE-VARIABLES TV:INVISIBLE-TO-MOUSE-P)
  3208.   (:DEFAULT-INIT-PLIST 
  3209.     :LABEL (LIST :TOP :FONT FONTS:HL12B :STRING "VT100 & Telnet Commands")
  3210.     :ROWS 3                       ; BAC changed from 2
  3211.     :COLUMNS 7                    ; BAC changed from 7
  3212.     :VSP 8.
  3213.     :FONT-MAP (list fonts:MEDFNT)
  3214.     :LABEL-BOX-P nil
  3215.     :ITEM-LIST nil)
  3216.   (:DOCUMENTATION :COMBINATION
  3217.     "Command menu needs dynamic-item-list-mixin for UCL."))
  3218.  
  3219. (BUILD-COMMAND-TABLE 'VT100-TELNET-CMD-TABLE 'VT100-FRAME
  3220.   '((:method telnet-frame :exit-command)        
  3221.     (:method telnet-frame :disconnect-command)
  3222.     (:method telnet-frame :interrupt-process-command)
  3223.     :send-answerback-command
  3224.     :reverse-video-command
  3225.     :reset-command
  3226.     :escape-processing-command
  3227.     (:method telnet-frame :quit-and-disconnect-command)
  3228.     (:method telnet-frame :status-command)
  3229.     (:method telnet-frame :abort-output-command)
  3230.     :column-command
  3231.     :truncate-command
  3232.     :set-vt100-lines
  3233.     :network-help-command
  3234.     (:method telnet-frame :clear-input-command)
  3235.     (:method vt100-frame :autodial)                   ; BAC
  3236.     (:method vt100-frame :kermit)                     ; BAC
  3237.     :local-echo-command                               ; BAC
  3238.     )
  3239.   :INIT-OPTIONS
  3240.   '(:NAME "Vt100 & Telnet Commands"
  3241.       :DOCUMENTATION "The Vt100 & Telnet commands."))
  3242.  
  3243. (BUILD-MENU 'UCL-VT100-TELNET-MENU 'VT100-FRAME
  3244.   :DEFAULT-ITEM-OPTIONS
  3245.   '(:FONT FONTS:MEDFNT)
  3246.   :ITEM-LIST-ORDER  
  3247.     '( ;Row 1
  3248.       (:method telnet-frame :exit-command)        
  3249.       (:method telnet-frame :disconnect-command)
  3250.       (:method telnet-frame :interrupt-process-command)
  3251.       :send-answerback-command
  3252.       :reverse-video-command
  3253.       :reset-command
  3254.       :escape-processing-command
  3255.        ;Row 2
  3256.       (:method telnet-frame :quit-and-disconnect-command)
  3257.       (:method telnet-frame :status-command)
  3258.       (:method telnet-frame :abort-output-command)
  3259.       :column-command
  3260.       :truncate-command
  3261.       :set-vt100-lines
  3262.       :network-help-command
  3263.        ;Row 3                                           ; BAC
  3264.       (:method vt100-frame :autodial)                   ; BAC
  3265.       (:method vt100-frame :kermit)                     ; BAC
  3266.       :local-echo-command                               ; BAC
  3267.       ))
  3268.  
  3269.  
  3270. ;;; The following add Serial streams to the TELNET and VT100 base system.
  3271. ;;;
  3272.  
  3273. (DEFVAR telnet:file NIL)
  3274.  
  3275. (DEFMETHOD (vt100-frame :TYPEOUT-TOP-LEVEL) (&aux (terminal-io vt100-pane))
  3276.   "Redefines (:METHOD BASIC-NVT :TYPOUT-TOP-LEVEL) to use :PROCESS-ESCAPE"
  3277.   (declare (special telnet:file))
  3278.   (process-wait "Never-open" #'car (locate-in-instance self 'connection))
  3279.   (ucl:ignore-errors-query-loop
  3280.     (condition-bind (((sys:remote-network-error
  3281.                ip:illegal-connection
  3282.                ip:connection-reset) 'typeout-net-error self))
  3283.       (do-forever
  3284.     (do ((ch (nvt-neti) (send stream :tyi-no-hang)))
  3285.         ((null ch) (if output-buffer (send self :force-output)))
  3286.       (when (not (null telnet:file))
  3287.         (send telnet:file :tyo ch))
  3288.       (send self :process-escape
  3289.         (IF (EQ CONNECTION T)
  3290.             (logand #b01111111 ch)   ; if we don't strip parity we get an error ;; BAC
  3291.             ch)))))))
  3292.  
  3293.  
  3294. ;;; This method should return the network connection. This can
  3295. ;;; be a stream or a connection object depending on the network type.
  3296. ;;;
  3297. ;;; The method :NETWORK-NEW-CONNECTION is not needed for serial telnet.
  3298. (DEFMETHOD (basic-nvt :case :network-new-connection :serial) 
  3299.        (host &optional (contact "TELNET") (window nil) )
  3300.   window contact host nil)                                       ; BAC to eliminate compile warnings
  3301.  
  3302. (RECOMPILE-FLAVOR 'vt100-frame :NETWORK-NEW-CONNECTION)
  3303.  
  3304. ;;; Return nil if the connection is not connected.
  3305. (DEFMETHOD (basic-nvt :case :network-connected-p :serial)()
  3306.   (and stream connection))
  3307.  
  3308. (RECOMPILE-FLAVOR 'vt100-frame :NETWORK-CONNECTED-P)
  3309.  
  3310. ;;; The method :NETWORK-NEW-CONNECTION passes the arguement which we
  3311. ;;; ignore for the serial implementation.
  3312. ;;;
  3313. ;;; Set stream to be the serial stream.
  3314. ;;; Connection should be something non nil, but does not need to be a connection.  
  3315. ;;; The connection instance variable is used by CHAOSNET.
  3316. (DEFMETHOD (basic-nvt :case :set-connection :serial) (ignore)
  3317.   (SEND typein-process :reset)
  3318.   (SEND typeout-process :reset)
  3319.   (SETF stream (MAKE-SERIAL-STREAM-FROM-CVV))
  3320. ;;  (SEND self :gobble-greeting)
  3321.   (SETF connection t)
  3322.   (SETQ black-on-white nil))
  3323.  
  3324. (RECOMPILE-FLAVOR 'vt100-frame :SET-CONNECTION)
  3325.  
  3326. ;;; This method should close the serial TELNET connection.
  3327. ;;; Make sure to set both instance variables, STREAM and CONNECTION,
  3328. ;;; to nil.
  3329. (DEFMETHOD (basic-nvt :case :network-disconnect :serial)()
  3330.   (WHEN stream
  3331.     (SEND stream :close)
  3332.     (SETF stream nil
  3333.       connection nil)))
  3334.  
  3335. (RECOMPILE-FLAVOR 'vt100-frame :NETWORK-DISCONNECT)
  3336.  
  3337. ;;; This method should indicate the connection state.
  3338. ;;; It would be nice if you could signal errors in the connection
  3339. ;;; state by throwing 'NVT-DONE because TELNET will try to eloquently
  3340. ;;; close the connection.
  3341. (defmethod (basic-nvt :case :check-connection-state :serial)()
  3342.   (unless stream
  3343.       (*THROW 'TELNET:NVT-DONE "Stream never opened.")))
  3344.  
  3345. (RECOMPILE-FLAVOR 'vt100-frame :CHECK-CONNECTION-STATE)
  3346.  
  3347. ;;; Send the TELNET command interrupt process (IP) to the remote host.
  3348. ;;; (Note: IP should not be confused with the acronym for a well known
  3349. ;;; network type.)
  3350. ;;; An IP command is defined to be the following two bytes: NVT-IAC NVT-IP.
  3351. ;;; Many implementations send the IP in urgent mode as the following sequence of bytes
  3352. ;;; NVT-IAC, NVT-IP, NVT-IAC, NVT-DM.  This is technically a SYNC signal but 
  3353. ;;; most systems handle no differently. The TCP/IP network sends a SYNC signal
  3354. ;;; in urgent mode, the CHAOS network sends a SYNC signal not in urgent mode
  3355. ;;; because there is no concept of urgent data, Wollongong sends just an IP command
  3356. ;;; and the MIT PC software sends a SYNC signal in urgent mode.
  3357. ;;;  
  3358. ;;; You may choose to send a SYNC signal or just IP command I think it makes little
  3359. ;;; difference (except with Wollongong which can't handle SYNC signals successfully).
  3360. ;;; However, since serial streams do not have a concept of 
  3361. ;;; urgent mode I choose to send a SYNC signal.
  3362. (DEFMETHOD (basic-telnet :case :network-send-ip :serial)()
  3363.   (lock-output
  3364.     (SEND stream :tyo NVT-IAC)
  3365.     (SEND stream :tyo NVT-IP)
  3366.     (SEND stream :tyo NVT-IAC)
  3367.     (SEND stream :tyo NVT-DM)
  3368.     ))
  3369.  
  3370. (RECOMPILE-FLAVOR 'vt100-frame :NETWORK-SEND-IP)
  3371.  
  3372. (UNLESS (MEMBER :serial protocols-supporting-telnet)   
  3373.   (PUSH :serial protocols-supporting-telnet))
  3374.  
  3375. ;;; This is a kludge to make serial telnet work correctly.
  3376. ;;; If there were serial host objects then this would not 
  3377. ;;; be necessary.
  3378. (setq default-network-type :serial)
  3379.  
  3380.  
  3381. <<< VTCURS.LSP >>>
  3382.  
  3383. ;;; -*- Mode: Lisp; Package: User; Base: 10.; Patch-File: T -*-
  3384.  
  3385. ;;;                           RESTRICTED RIGHTS LEGEND
  3386.  
  3387. ;;;Use, duplication, or disclosure by the Government is subject to
  3388. ;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
  3389. ;;;Technical Data and Computer Software clause at 52.227-7013.
  3390. ;;;
  3391. ;;;                     TEXAS INSTRUMENTS INCORPORATED.
  3392. ;;;                              P.O. BOX 2909
  3393. ;;;                           AUSTIN, TEXAS 78769
  3394. ;;;                                 MS 2151
  3395. ;;;
  3396. ;;; Copyright (c) 1986, Texas Instruments Incorporated.  All rights reserved.
  3397.  
  3398. ;;; Written 5/16/86 10:34:33 by FORD,
  3399. ;;; Reason: Fix (:METHOD VT100-ESCAPE-SEQUENCE-MIXIN :PROCESS-ESCAPE-BRACKET-NUMERIC-NUMERIC-SEMICOLON-SEQUENCE)
  3400. ;;; to properly process the second leading zero in escape sequences like 01H.
  3401. ;;; while running on B from band LOD2
  3402. ;;; with System 2.44, Compiler 2.5, File System 2.1, Universal Command Loop 2.0, Window System 2.5, Input Editor 2.0, ZMACS 2.5, Error Handler 2.0, Suggestions 2.1, Debug Utilities 2.7, Explorer-Net 2.6, Telnet 2.2, Vt100 2.0, File Server 2.0, Net-Config 2.2, Font Editor 2.2, Mailer 2.4, Mail-Reader 2.4, Streamer-Tape 2.7, Local-File 2.15, System-Log 2.2, Serial-Parallel 2.8, Printer 2.0, Glossary 2.0, IMAGEN 2.1, NVRAM 2.3, User Profile Utility 2.1, IP 1.15, Experimental Code Management Interface 2.22, Experimental Explorer Bug System 20.0, microcode 287, FAN23-MCR287-AUS.
  3403.  
  3404.  
  3405.  
  3406. #!Z
  3407. ; From file PROCESS-ESCAPE-SEQUENCE.LISP#> VT100; A:
  3408. #10R TELNET#:
  3409. (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET"))
  3410.                          (SI:LISP-MODE :ZETALISP)
  3411.                          (*READTABLE* SI:STANDARD-READTABLE)
  3412.                          (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL))
  3413.   (COMPILER#:PATCH-SOURCE-FILE "SYS: VT100; PROCESS-ESCAPE-SEQUENCE.#"
  3414.  
  3415.  
  3416. (DEFMETHOD (vt100-escape-sequence-mixin
  3417.          :PROCESS-ESCAPE-BRACKET-NUMERIC-NUMERIC-SEMICOLON-SEQUENCE) (ch)
  3418.   (cond ((= ch #/r)               ; ESC [ num num ; num num r 
  3419.      (setq scroll-ending-line       ; Scrolling regions
  3420.            (min ending-line (tv:sheet-number-of-inside-lines vt100-pane)))
  3421.      (setq scroll-starting-line starting-line-completed-value)
  3422.      (if (= scroll-ending-line 0)
  3423.          (setq scroll-ending-line (tv:sheet-number-of-inside-lines vt100-pane)))
  3424.      (setq top-of-scroll scroll-starting-line)
  3425.      (setq bottom-of-scroll scroll-ending-line)
  3426.      (send vt100-pane ':set-cursorpos 0 0 ':character)
  3427.      (send self ':reset))
  3428.     ((or (= ch #/H) (= ch #/f))    ; Direct cursor addressing 
  3429.      ; ESC [ 14 ; H   ESC [ 14 ; 1  H   ESC [ 14 ; 12 H
  3430.      ; And the same sequences with 'f'
  3431.      (send self ':move-to-direct-cursor-position
  3432.            starting-line-completed-value column)
  3433.      (send self ':reset))
  3434.     (escape-bracket-numeric-numeric-semicolon-numeric-flag
  3435.      ;This is the second of the two digits, so now make a two digit value
  3436.      (cond ((and test-for-three-digits-flag    ; Check for "00", ie, ESC [ 10;007H
  3437.              (= escape-bracket-numeric-numeric-semicolon-numeric-ch #/0))
  3438.         (setq test-for-three-digits-flag nil)
  3439.         (setq escape-bracket-numeric-numeric-semicolon-numeric-numeric-ch ch)
  3440.         (setq ending-line 
  3441.               (make-two-digit-value 
  3442.             escape-bracket-numeric-numeric-semicolon-numeric-ch
  3443.             escape-bracket-numeric-numeric-semicolon-numeric-numeric-ch))
  3444.         (setq column ending-line))
  3445.            (t (setq escape-bracket-numeric-numeric-semicolon-numeric-numeric-ch ch)
  3446.           (setq ending-line
  3447.             (make-two-digit-value 
  3448.               escape-bracket-numeric-numeric-semicolon-numeric-ch
  3449.               escape-bracket-numeric-numeric-semicolon-numeric-numeric-ch))
  3450.           (setq column ending-line))))
  3451.     ((and (>= ch #/0) (<= ch #/9))
  3452.      ;This is the first of the two digits
  3453.      (setq test-for-three-digits-flag t)
  3454.      (setq escape-bracket-numeric-numeric-semicolon-numeric-ch ch)
  3455.      (setq column (- ch #/0))
  3456.      (setq escape-bracket-numeric-numeric-semicolon-numeric-flag t)
  3457.      (cond ((=  starting-line-second-ch 99.)
  3458.         (setq ending-line
  3459.               (make-two-digit-value 
  3460.             escape-bracket-numeric-semicolon-numeric-ch
  3461.             escape-bracket-numeric-numeric-semicolon-numeric-ch))
  3462.         (setq starting-line (- starting-line #/0)))
  3463.            (t NIL)))
  3464.     (t 
  3465.      (send self ':reset))))
  3466. ))
  3467.  
  3468.  
  3469. <<< VTCKEY.LSP >>>
  3470.  
  3471. ;;; -*- Mode: Lisp; Package: User; Base: 10.; Patch-File: T -*-
  3472.  
  3473. ;;;                           RESTRICTED RIGHTS LEGEND
  3474.  
  3475. ;;;Use, duplication, or disclosure by the Government is subject to
  3476. ;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
  3477. ;;;Technical Data and Computer Software clause at 52.227-7013.
  3478. ;;;
  3479. ;;;                     TEXAS INSTRUMENTS INCORPORATED.
  3480. ;;;                              P.O. BOX 2909
  3481. ;;;                           AUSTIN, TEXAS 78769
  3482. ;;;                                 MS 2151
  3483. ;;;
  3484. ;;; Copyright (c) 1986, Texas Instruments Incorporated.  All rights reserved.
  3485.  
  3486. ;;; Written 8/07/86 13:42:03 by FORD,
  3487. ;;; Reason: Commented out check for Keypad-mode in cursor key methods.
  3488. ;;; It doesn't appear as if cursor-key mode and keypad-mode
  3489. ;;; should be connected.               Steve Ford 8-7-86
  3490. ;;; while running on D from band LOD1
  3491. ;;; with System 2.79, Compiler 2.7, File System 2.1, Universal Command Loop 2.0, Window System 2.10, Input Editor 2.0, ZMACS 2.10, Error Handler 2.2, Suggestions 2.22, Debug Utilities 2.12, Explorer-Net 2.7, Telnet 2.2, Vt100 2.1, File Server 2.0, Net-Config 2.4, Font Editor 2.2, Mailer 2.7, Mail-Reader 2.5, Streamer-Tape 2.20, Local-File 2.31, System-Log 2.3, Serial-Parallel 2.0, Printer 2.6, Glossary 2.0, IMAGEN 2.3, NVRAM 2.3, User Profile Utility 2.1, UCODE-DEPENDENT 2.17, microcode 310, REL 2.1 MINPROD.
  3492.  
  3493.  
  3494.  
  3495. #!Z
  3496. ; From file PROCESS-ESCAPE-SEQUENCE.LISP#> VT100; F:
  3497. #10R TELNET#:
  3498. (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET"))
  3499.                          (SI:LISP-MODE :ZETALISP)
  3500.                          (*READTABLE* SI:STANDARD-READTABLE)
  3501.                          (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL))
  3502.   (COMPILER#:PATCH-SOURCE-FILE "SYS: VT100; PROCESS-ESCAPE-SEQUENCE.#"
  3503.  
  3504.  
  3505.  
  3506. (DEFMETHOD (vt100-escape-sequence-mixin :AUXILIARY-UP) ()
  3507.   (cond (nil                                ;(and keypad-mode process-ch?)
  3508.      (send self ':applications-mode)
  3509.      (send self ':net-output #/A))
  3510.     (t
  3511.      (send self ':net-output #\escape)
  3512.      (send self ':net-output #/[)
  3513.      (send self ':net-output #/A))))
  3514.  
  3515. (DEFMETHOD (vt100-escape-sequence-mixin :AUXILIARY-DOWN) ()
  3516.   (cond (nil                                ;(and keypad-mode process-ch?)
  3517.      (send self ':applications-mode)
  3518.      (send self ':net-output #/B))
  3519.     (t
  3520.      (send self ':net-output #\escape)
  3521.      (send self ':net-output #/[)
  3522.      (send self ':net-output #/B))))
  3523.  
  3524. (DEFMETHOD (vt100-escape-sequence-mixin :AUXILIARY-RIGHT) ()
  3525.   (cond (nil                                ;(and keypad-mode process-ch?)
  3526.      (send self ':applications-mode)
  3527.      (send self ':net-output #/C))
  3528.     (t
  3529.      (send self ':net-output #\escape)
  3530.      (send self ':net-output #/[)
  3531.      (send self ':net-output #/C))))
  3532.  
  3533. (DEFMETHOD (vt100-escape-sequence-mixin :AUXILIARY-LEFT) ()
  3534.   (cond (nil                                ;(and keypad-mode process-ch?)
  3535.      (send self ':applications-mode)
  3536.      (send self ':net-output #/D))
  3537.     (t
  3538.      (send self ':net-output #\escape)
  3539.      (send self ':net-output #/[)
  3540.      (send self ':net-output #/D))))
  3541.  
  3542.  
  3543. ))
  3544.  
  3545. <<< PTCH11.LSP >>>
  3546.  
  3547. ;;; -*- Mode: Lisp; Package: User; Base: 8.; Patch-File: T -*-
  3548. ;;; Written 10/17/86 12:26:15 by SPERRY,
  3549. ;;; Reason: Added definitions for :send-long-break and :send-short-break methods
  3550. ;;; to serial-stream-mixin, and defined the analagous commands for the 
  3551. ;;; VT100 emulator.
  3552. ;;; while running on A from band LOD1
  3553. ;;; with System  2.11, Compiler  2.0, File System  2.0, Universal Command Loop  2.0, Window System  2.1, Input Editor  2.0, ZMACS  2.3, Error Handler  2.0, Suggestions  2.0, Debug Utilities  2.2, Explorer-Net  2.5, Telnet  2.0, Vt100  2.0, File Server  2.0, Net-Config  2.1, Font Editor  2.0, Mailer  2.1, Mail-Reader  2.2, Streamer-Tape  2.3, Local-File  2.10, System-Log  2.0, Serial-Parallel  2.0, Printer  2.0, Glossary  2.0, IMAGEN  2.0, NVRAM  2.0, User Profile Utility  2.1, SPERRY  2.0, KEE2  1.6401, Graphics-Window  2.0, Graphics-Editor  2.0, Tree-Drawing-Utility  2.0, RTMS  2.5, NLMenu  2.0, NLMenu-RTMS-Interface  2.0, PROLOG  2.1, Grasper  2.0, Formatter  2.0, Color Graphics  1.0, IP  1.5, KERMIT  1.0, microcode 258, Rel 2.0.1 + KEE + 8 kits, 7-1-86.
  3554.  
  3555.  
  3556.  
  3557. #!Z
  3558. ; From file SERIAL-TELNET.LISP#> KERMIT; A:
  3559. #8R TELNET#:
  3560. (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET"))
  3561.                          (SI:LISP-MODE :ZETALISP)
  3562.                          (*READTABLE* SI:STANDARD-READTABLE)
  3563.                          (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL))
  3564.   (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#"
  3565.  
  3566. si:
  3567. (defmethod (serial-stream-mixin :SEND-LONG-BREAK) ()
  3568.  "Transmits a space condition for 3.5 seconds (long break)."
  3569.   (write-z-reg 5
  3570.            (logand #x7F            ; Turn off DTR
  3571.                (logior #x+10 WR5-CONTENTS)))  ;turn on send break
  3572.   (sleep 3.5 "Sending Long Break")
  3573.   (write-z-reg 5 WR5-CONTENTS)         ;restore register
  3574.   )
  3575. ))
  3576.  
  3577.  
  3578. #!Z
  3579. ; From file SERIAL-TELNET.LISP#> KERMIT; A:
  3580. #8R TELNET#:
  3581. (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET"))
  3582.                          (SI:LISP-MODE :ZETALISP)
  3583.                          (*READTABLE* SI:STANDARD-READTABLE)
  3584.                          (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL))
  3585.   (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#"
  3586.  
  3587. si:
  3588. (defmethod (serial-stream-mixin :SEND-SHORT-BREAK) ()
  3589.  "Transmits a space condition for .275 seconds (short break)."
  3590.   (write-z-reg 5 (logior #x+10 WR5-CONTENTS))  ;turn on send break
  3591.   (sleep .275 "Sending Short Break")
  3592.   (write-z-reg 5 WR5-CONTENTS)                 ;restore register
  3593.   )
  3594. ))
  3595.  
  3596. #!Z
  3597. ; From file SERIAL-TELNET.LISP#> KERMIT; A:
  3598. #8R TELNET#:
  3599. (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET"))
  3600.                          (SI:LISP-MODE :ZETALISP)
  3601.                          (*READTABLE* SI:STANDARD-READTABLE)
  3602.                          (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL))
  3603.   (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#"
  3604.  
  3605.  
  3606.  
  3607. (DEFCOMMAND (VT100-FRAME :LONG-BREAK) ()
  3608.   '(:DESCRIPTION "Send a short break to stream."
  3609.     :NAMES ("Long Break")
  3610.     :KEYS ((#\NETWORK #\CTRL-BREAK)))
  3611.   (if (not (null connection))
  3612.       (send stream :send-long-break)
  3613.       (format t "~&Not connected. Can't send Long Break.")
  3614.       (when (not ucl:preempting?)
  3615.     (send self :handle-prompt))))
  3616.  
  3617. ))
  3618.  
  3619. #!Z
  3620. ; From file SERIAL-TELNET.LISP#> KERMIT; A:
  3621. #8R TELNET#:
  3622. (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET"))
  3623.                          (SI:LISP-MODE :ZETALISP)
  3624.                          (*READTABLE* SI:STANDARD-READTABLE)
  3625.                          (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL))
  3626.   (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#"
  3627.  
  3628.  
  3629.  
  3630. (DEFCOMMAND (VT100-FRAME :SHORT-BREAK) ()
  3631.   '(:DESCRIPTION "Send a short break to stream."
  3632.     :NAMES ("Short Break")
  3633.     :KEYS ((#\NETWORK #\BREAK)))
  3634.   (if (not (null connection))
  3635.       (send stream :send-short-break)
  3636.       (format t "~&Not connected. Can't send Short Break.")
  3637.       (when (not ucl:preempting?)
  3638.     (send self :handle-prompt))))
  3639. ))
  3640.  
  3641. #!Z
  3642. ; From file SERIAL-TELNET.LISP#> KERMIT; A:
  3643. #8R TELNET#:
  3644. (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET"))
  3645.                          (SI:LISP-MODE :ZETALISP)
  3646.                          (*READTABLE* SI:STANDARD-READTABLE)
  3647.                          (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL))
  3648.   (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#"
  3649.  
  3650.  
  3651.  
  3652. (BUILD-COMMAND-TABLE 'VT100-TELNET-CMD-TABLE 'VT100-FRAME
  3653.   '((:method telnet-frame :exit-command)        
  3654.     (:method telnet-frame :disconnect-command)
  3655.     (:method telnet-frame :interrupt-process-command)
  3656.     :send-answerback-command
  3657.     :reverse-video-command
  3658.     :reset-command
  3659.     :escape-processing-command
  3660.     (:method telnet-frame :quit-and-disconnect-command)
  3661.     (:method telnet-frame :status-command)
  3662.     (:method telnet-frame :abort-output-command)
  3663.     :column-command
  3664.     :truncate-command
  3665.     :set-vt100-lines
  3666.     :network-help-command
  3667.     (:method telnet-frame :clear-input-command)
  3668.     (:method vt100-frame :autodial)                   ; BAC
  3669.     (:method vt100-frame :kermit)                     ; BAC
  3670.     :local-echo-command                               ; BAC
  3671.     :short-break
  3672.     :long-break
  3673.     )
  3674.   :INIT-OPTIONS
  3675.   '(:NAME "Vt100 & Telnet Commands"
  3676.       :DOCUMENTATION "The Vt100 & Telnet commands."))
  3677.  
  3678. ))
  3679.  
  3680. #!Z
  3681. ; From file SERIAL-TELNET.LISP#> KERMIT; A:
  3682. #8R TELNET#:
  3683. (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET"))
  3684.                          (SI:LISP-MODE :ZETALISP)
  3685.                          (*READTABLE* SI:STANDARD-READTABLE)
  3686.                          (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL))
  3687.   (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#"
  3688.  
  3689.  
  3690.  
  3691. (BUILD-MENU 'UCL-VT100-TELNET-MENU 'VT100-FRAME
  3692.   :DEFAULT-ITEM-OPTIONS
  3693.   '(:FONT FONTS:MEDFNT)
  3694.   :ITEM-LIST-ORDER  
  3695.     '( ;Row 1
  3696.       (:method telnet-frame :exit-command)        
  3697.       (:method telnet-frame :disconnect-command)
  3698.       (:method telnet-frame :interrupt-process-command)
  3699.       :send-answerback-command
  3700.       :reverse-video-command
  3701.       :reset-command
  3702.       :escape-processing-command
  3703.        ;Row 2
  3704.       (:method telnet-frame :quit-and-disconnect-command)
  3705.       (:method telnet-frame :status-command)
  3706.       (:method telnet-frame :abort-output-command)
  3707.       :column-command
  3708.       :truncate-command
  3709.       :set-vt100-lines
  3710.       :network-help-command
  3711.        ;Row 3                                           ; BAC
  3712.       (:method vt100-frame :autodial)                   ; BAC
  3713.       (:method vt100-frame :kermit)                     ; BAC
  3714.       :local-echo-command                               ; BAC
  3715.       :short-break
  3716.       :long-break
  3717.       ))
  3718.  
  3719. ))
  3720.  
  3721. <<< SCLOSE.LSP >>>
  3722.  
  3723. ;;; -*- Mode: Lisp; Package: User; Base: 8.; Patch-File: T -*-
  3724.  
  3725. ;;;                           RESTRICTED RIGHTS LEGEND
  3726.  
  3727. ;;;Use, duplication, or disclosure by the Government is subject to
  3728. ;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
  3729. ;;;Technical Data and Computer Software clause at 52.227-7013.
  3730. ;;;
  3731. ;;;                     TEXAS INSTRUMENTS INCORPORATED.
  3732. ;;;                              P.O. BOX 2909
  3733. ;;;                           AUSTIN, TEXAS 78769
  3734. ;;;                                 MS 2151
  3735. ;;;
  3736. ;;; Copyright (c) 1986, Texas Instruments Incorporated.  All rights reserved.
  3737.  
  3738. ;;; Written 5/16/86 17:44:10 by FORD,
  3739. ;;; Reason: Change :CLOSE to clear the hardware registers.
  3740. ;;; while running on B from band LOD2
  3741. ;;; with System 2.44, Compiler 2.5, File System 2.1, Universal Command Loop 2.0, Window System 2.5, Input Editor 2.0, ZMACS 2.5, Error Handler 2.0, Suggestions 2.1, Debug Utilities 2.7, Explorer-Net 2.6, Telnet 2.2, Vt100 2.0, File Server 2.0, Net-Config 2.2, Font Editor 2.2, Mailer 2.4, Mail-Reader 2.4, Streamer-Tape 2.7, Local-File 2.15, System-Log 2.2, Serial-Parallel 2.8, Printer 2.0, Glossary 2.0, IMAGEN 2.1, NVRAM 2.3, User Profile Utility 2.1, IP 1.15, Experimental Code Management Interface 2.22, Experimental Explorer Bug System 20.0, microcode 287, FAN23-MCR287-AUS.
  3742.  
  3743.  
  3744.  
  3745. #!Z
  3746. ; From file SERIAL-STREAM.LISP#> SERIAL; A:
  3747. #8R SYSTEM-INTERNALS#:
  3748. (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))
  3749.                          (SI:LISP-MODE :ZETALISP)
  3750.                          (*READTABLE* STANDARD-READTABLE)
  3751.                          (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL))
  3752.   (COMPILER#:PATCH-SOURCE-FILE "SYS: SERIAL; SERIAL-STREAM.#"
  3753.  
  3754.  
  3755. (Defmethod (Serial-Stream-Mixin :CLOSE) (&Optional Abort-P)
  3756.   ;; deallocate the serial buffers
  3757.   (IF *serial-output-buffer*
  3758.       (PROGN
  3759.         (IF (NOT abort-p) (FUNCALL-SELF ':finish))
  3760.         (return-serial-buffer *serial-Output-Buffer*)
  3761.         (SETQ *Serial-Output-Buffer* nil)))
  3762.   (IF *Serial-Input-Buffer*
  3763.       (PROGN
  3764.         (return-serial-buffer *Serial-Input-Buffer*)
  3765.         (SETQ *Serial-Input-Buffer* nil)))
  3766.   (array-dpb-offset 0 %%q-pointer *serial-port* %serial-receive-buffer)
  3767.   (array-dpb-offset 0 %%q-pointer *serial-port* %serial-transmit-buffer)
  3768.   (setq *serial-port-owner* nil)  
  3769.   (write-z-reg 9   0)  ;clear master interrupt control register
  3770.   (write-z-reg 5   0)  ;DTR, RTS, Tx disable
  3771.   (write-z-reg 3   0)  ;Rx disable
  3772.   (write-z-reg 15. 0)  ;disable external interrupts
  3773.   (write-z-reg 1   0)  ;disable interrupts
  3774.   (disable-serial-event)              ;disable SIB serial event posting
  3775.   )
  3776. ))
  3777.  
  3778. <<< STLNET.LSP >>>
  3779.  
  3780. ;;; -*- Mode:LISP; Package:TELNET; Base:8; Patch-File:T -*-
  3781.  
  3782. ;;;                           RESTRICTED RIGHTS LEGEND
  3783.  
  3784. ;;;Use, duplication, or disclosure by the Government is subject to
  3785. ;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
  3786. ;;;Technical Data and Computer Software clause at 52.227-7013.
  3787. ;;;
  3788. ;;;                     TEXAS INSTRUMENTS INCORPORATED.
  3789. ;;;                              P.O. BOX 2909
  3790. ;;;                           AUSTIN, TEXAS 78769
  3791. ;;;                                 MS 2151
  3792. ;;;
  3793. ;;; Copyright (c) 1986, Texas Instruments Incorporated.  All rights reserved.
  3794. ;;; Copyright (c) 1986, Sperry Corporation.  All rights reserved.
  3795.  
  3796. ;;; NOTES:
  3797. ;;;   This code will need review and possibly reimplementation for
  3798. ;;;   Release 3.0 because of GENI's release.
  3799.  
  3800. ;;; To eliminate compilation warnings, create required packages
  3801. ;;; if they don't already exist ;; BAC
  3802. (EVAL-WHEN (EVAL COMPILE)
  3803.   (PKG-FIND-PACKAGE "KERMIT" T)
  3804.   (PKG-FIND-PACKAGE "IP" T))
  3805.  
  3806. ;;; MAKE-SERIAL-STREAM-FROM-CVV
  3807. ;;;
  3808.  
  3809. (DEFVAR  *BAUD*                  #10r1200    "Baud rate.")
  3810. (DEFVAR  *FORCE-OUTPUT*          T           "Force output.")
  3811. (DEFVAR  *NUMBER-OF-DATA-BITS*   #10r8       "Number of data bits.")
  3812. (DEFVAR  *NUMBER-OF-STOP-BITS*   #10r2       "Number of stop bits.")
  3813. (DEFVAR  *PARITY*                :NONE       "Parity.")
  3814. (DEFVAR  *XON-XOFF-PROTOCOL*     NIL         "XON-XOFF protocol.")
  3815. (DEFVAR  *ASCII-CHARACTERS*      NIL         "Ascii-characters.")
  3816. (DEFVAR  *INPUT-BUFFER-SIZE*     #10r180     "Input buffer.") 
  3817. (DEFVAR  *OUTPUT-BUFFER-SIZE*    #10r180     "Output buffer.")
  3818.  
  3819. (DEFUN MAKE-SERIAL-STREAM-FROM-CVV ()
  3820.   "Produces a CVV to select serial stream parameters, then creates a stream
  3821. using SI:MAKE-SERIAL-STREAM.  Returns the created stream."
  3822.   (DECLARE (SPECIAL *BAUD* *FORCE-OUTPUT* *NUMBER-OF-DATA-BITS*
  3823.             *NUMBER-OF-STOP-BITS* *PARITY* *XON-XOFF-PROTOCOL*
  3824.             *ASCII-CHARACTERS* *INPUT-BUFFER-SIZE* *OUTPUT-BUFFER-SIZE*))
  3825.  
  3826.   (TV:CHOOSE-VARIABLE-VALUES
  3827.     '((*BAUD* "Baud rate"
  3828.           :DOCUMENTATION "Line speed.  (Most asynchronous modems use 1200 or 300)"
  3829.           :CHOOSE (#10r300 #10r1200 #10r2400 #10r4800 #10r9600 #10r19200))
  3830.       (*FORCE-OUTPUT* "Force output"
  3831.               :DOCUMENTATION "YES: send characters immediately.  NO: send characters when buffer is full."
  3832.               :BOOLEAN)
  3833.       (*NUMBER-OF-DATA-BITS* "Data Bits"
  3834.                  :DOCUMENTATION "Number of data bits."
  3835.                  :CHOOSE (#10r5 #10r6 #10r7 #10r8))
  3836.       (*NUMBER-OF-STOP-BITS* "Stop Bits"
  3837.                  :DOCUMENTATION "Number of stop bits."
  3838.                  :CHOOSE (1 2))
  3839.       (*PARITY* "Parity"
  3840.         :DOCUMENTATION "Type of parity to use."
  3841.         :CHOOSE (:NONE :EVEN :ODD))
  3842.       (*XON-XOFF-PROTOCOL* "XON-XOFF"
  3843.                :DOCUMENTATION "YES: use XON-XOFF characters.  NO: don't implement XON-XOFF characters."
  3844.                :BOOLEAN)
  3845.       (*ASCII-CHARACTERS* "Translate ASCII"
  3846.               :DOCUMENTATION "YES: Automatically translate between ASCII and LISPM characters.  NO: don't translate."
  3847.               :BOOLEAN)
  3848.       (*INPUT-BUFFER-SIZE* "Input Buffer size"
  3849.                :DOCUMENTATION "Size (in words) to allocate for the input buffers."
  3850.                :NUMBER)
  3851.       (*OUTPUT-BUFFER-SIZE* "Output Buffer size"
  3852.                 :DOCUMENTATION "Size (in words) to allocate for the output buffers."
  3853.                 :NUMBER))
  3854.     :NEAR-MODE '(:POINT 500 400)
  3855.     :LABEL "Choose Serial Stream Parameters"
  3856.     :MARGIN-CHOICES '("Do It"))
  3857.   
  3858.   (SI:MAKE-SERIAL-STREAM
  3859.     :BAUD *BAUD*
  3860.     :FORCE-OUTPUT *FORCE-OUTPUT*
  3861.     :NUMBER-OF-DATA-BITS *NUMBER-OF-DATA-BITS*
  3862.     :NUMBER-OF-STOP-BITS *NUMBER-OF-STOP-BITS*
  3863.     :PARITY *PARITY*
  3864.     :XON-XOFF-PROTOCOL *XON-XOFF-PROTOCOL*
  3865.     :ASCII-CHARACTERS *ASCII-CHARACTERS*
  3866.     :INPUT-BUFFER-SIZE *INPUT-BUFFER-SIZE*
  3867.     :OUTPUT-BUFFER-SIZE *OUTPUT-BUFFER-SIZE*))
  3868.  
  3869.  
  3870. ;;; Autodial
  3871. ;;;
  3872.  
  3873. (DEFVAR  *AUTODIAL-PREFIX*  "ATDT"            "Prefix to send to autodialer modem")
  3874. (DEFVAR  *AUTODIAL-NUMBER*  "8,8005551212"    "Number to dial")
  3875.  
  3876. (DEFUN AUTODIAL (&KEY
  3877.          (PREFIX *AUTODIAL-PREFIX*)
  3878.          (NUMBER *AUTODIAL-NUMBER*)
  3879.          STREAM                ; could bind this to *SERIAL-PORT-OWNER*
  3880.          MENU
  3881.          VERBOSE)
  3882.   "Dial a number using an autodialer.  If :NUMBER is not specified,
  3883. use the last number dialed.  If :MENU is specified, display a menu
  3884. to select the number to dial."
  3885.   
  3886.   (LET
  3887.     ((PRE PREFIX)
  3888.      (NUM NUMBER)
  3889.      (CONTINUE T))
  3890.     (DECLARE (SPECIAL PRE NUM))
  3891.     (WHEN MENU
  3892.       (SETQ CONTINUE
  3893.         (*CATCH 'END-CVV
  3894.           (TV:CHOOSE-VARIABLE-VALUES
  3895.         '((PRE
  3896.             "Prefix"
  3897.             :DOCUMENTATION "Modem's autodial prefix (e.g., ATDT)."
  3898.             :STRING)
  3899.           (NUM
  3900.             "Number"
  3901.             :DOCUMENTATION "Telephone number to dial.  A comma <,> causes a 2 second wait."
  3902.             :STRING))
  3903.         :NEAR-MODE '(:POINT 500 400)
  3904.         :LABEL "Serial Port Autodial"
  3905.         :MARGIN-CHOICES '("Do It" ("Quit" (*THROW 'END-CVV NIL))))
  3906.           T)))
  3907.  
  3908.     (WHEN CONTINUE
  3909.       (IF (NOT (STREAMP STREAM))
  3910.       (WHEN VERBOSE
  3911.         (FORMAT T "~&Stream <~A> is not a valid stream." STREAM))
  3912.       (PROGN
  3913.         (SETQ *AUTODIAL-PREFIX* PRE)
  3914.         (SETQ *AUTODIAL-NUMBER* NUM)
  3915.         (SEND STREAM :CLEAR-INPUT)
  3916.         (SEND STREAM :CLEAR-OUTPUT)
  3917.         (SEND STREAM :LINE-OUT (FORMAT NIL "~A~A" *AUTODIAL-PREFIX* *AUTODIAL-NUMBER*))
  3918.         (PROCESS-WAIT-WITH-TIMEOUT
  3919.           "Dialing..."
  3920.           3600
  3921.           (FUNCTION (LAMBDA (STREAM)
  3922.               (SEND STREAM :GET :DATA-CARRIER-DETECT)))
  3923.           STREAM)
  3924.         (SEND STREAM :CLEAR-INPUT)
  3925.         (SEND STREAM :CLEAR-OUTPUT)
  3926.         T)))))
  3927.  
  3928.  
  3929. ;;; RUN-SCRIPT
  3930. ;;;
  3931.  
  3932. (DEFUN RUN-SCRIPT (script &KEY (stream *TERMINAL-IO*) (debug-stream *DEBUG-IO*)
  3933.            &AUX (response (make-array 5000. :type art-string :fill-pointer 0))
  3934.                 (return-value nil))
  3935.   "Simulate an interactive user session with a script.
  3936. SCRIPT is a list of the form ((SEND RECEIVE ACTION)...).
  3937. SEND is a list of a format control string and its arguments that specify the output to be sent to STREAM.
  3938. RECEIVE is a list of a format control string and its arguments that specify the input expected from STREAM.
  3939. ACTION specifies what to do if the data received doesn't contain the string specified by RECEIVE.
  3940.   It can be :L (loop forever), :Q (quit,the default), a number indicating the number of times to loop and
  3941.   before quitting, or a list of a format control string and its arguments that specify an alternative output
  3942.   to be sent to STREAM.  
  3943. For each element of SCRIPT, first SEND is sent to STREAM, then STREAM is checked for input that matches
  3944.   RECEIVE, if it is found, the next form is processed, else, the ACTION is processed, and STREAM is again
  3945.   checked for input that matches RECEIVE.
  3946. STREAM is an I/O stream.
  3947. When DEBUG-STREAM is specified, it should be an I/O stream where debug info is sent.
  3948. RUN-SCRIPT returns :SUCCESSFUL if the last RECEIVE in SCRIPT was successful, :UNSUCCESSFUL otherwise."
  3949.    
  3950.   (CHECK-ARG SCRIPT LISTP "a list")
  3951.   (CHECK-ARG STREAM STREAMP "a stream")
  3952.   (CHECK-ARG DEBUG-STREAM STREAMP "a stream")
  3953.   (DOLIST (item script return-value)
  3954.     (SETQ return-value
  3955.       (LET* ((send (FIRST item))
  3956.          (receive (SECOND item))
  3957.          (action (THIRD item)))
  3958.         (DO ()
  3959.         (NIL)
  3960.           (WHEN send
  3961.         (LET ((formatted-string (APPLY #'FORMAT NIL (CAR send) (CDR send))))
  3962.           (SEND stream :STRING-OUT formatted-string)
  3963.           (WHEN debug-stream (FORMAT debug-stream "~%Sending:~A" formatted-string))))
  3964.           (IF receive
  3965.           (PROGN 
  3966.             (SETF (FILL-POINTER response) 0)
  3967.             (WHEN debug-stream (FORMAT debug-stream "~%Receiving:"))
  3968.             (DO ((char (SEND stream :TYI-WITH-TIMEOUT 1800.)(SEND stream :TYI-WITH-TIMEOUT 1800.)))
  3969.             ((NULL char) T)
  3970.               (WHEN (> char 0)
  3971.             (SETF (AREF response (FILL-POINTER response)) (LOGAND char #o177))
  3972.             (INCF (FILL-POINTER response))
  3973.             (WHEN debug-stream (FORMAT debug-stream "~C" (LOGAND char #o177)))))
  3974.             (WHEN debug-stream (FORMAT debug-stream "~%Searching:~A" (APPLY #'FORMAT NIL (CAR receive) nil)))
  3975.             (SEND stream :CLEAR-INPUT)
  3976.             (IF (STRING-SEARCH (APPLY #'FORMAT NIL (CAR receive) (CDR receive)) response)
  3977.             (RETURN :SUCCESSFUL)
  3978.             (IF action
  3979.                 (IF (EQ action :Q)
  3980.                 (RETURN :UNSUCCESSFUL)
  3981.                 (IF (INTEGERP action) 
  3982.                     (IF (< action 1)
  3983.                     (RETURN :UNSUCCESSFUL)
  3984.                     (DECF action))
  3985.                     (IF (LISTP action)
  3986.                     (SETQ send action)
  3987.                     (UNLESS (EQ action :L)
  3988.                       (FERROR t "The third element, ACTION, of an element of SCRIPT, ~A, was ~A, which is not :Q, :L, an integer, or a list." ITEM ACTION)))))
  3989.                 (RETURN :UNSUCCESSFUL))))
  3990.           (RETURN :SUCCESSFUL)))))))
  3991.  
  3992.  
  3993. ;;; Serial stream flavor addition: TYI-WITH-TIMEOUT 
  3994.  
  3995. SI:(DEFMETHOD (SERIAL-STREAM-MIXIN :TYI-WITH-TIMEOUT) (INTERVAL-IN-60THS)
  3996.      (IF (SI:PROCESS-WAIT-WITH-TIMEOUT
  3997.        "Serial Waiting"
  3998.        INTERVAL-IN-60THS
  3999.        (FUNCTION (LAMBDA (STREAM) (SEND STREAM :INPUT-CHARS-AVAILABLE-P)))
  4000.        SELF)
  4001.      (SEND SELF :TYI)))
  4002.  
  4003.  
  4004. ;;;  From sys:telnet;basic-telnet (sort of): 
  4005. ;;; 
  4006. ;;;  This method is almost identical to (:method basic-telnet :net-output),
  4007. ;;;  which vt100-frame inherits, except that this version doesn't
  4008. ;;;  automatically send a linefeed after a carriage-return unless the
  4009. ;;;  connection is a chaos connection.  Thus, it preserves the existing
  4010. ;;;  behavior for normal connections (and it seems to be the right thing)
  4011. ;;;  while removing the spurious linefeed from serial-port connections.
  4012. ;;;  There may well be a better way to do it.  - pf, Sept 11, 1985
  4013. (DEFMETHOD (vt100-frame :NET-OUTPUT) (ch)
  4014.   (lock-output
  4015.     (when (ldb-test 1701 ch)            ;An NVT char from TELNET-KEYS
  4016.       (if new-telnet-p
  4017.       (send stream ':tyo NVT-IAC))
  4018.       (setq ch (ldb 0010 ch)))
  4019.     (send stream ':tyo ch)
  4020.     (cond ((and (typep connection 'chaos:conn) (= ch 15))
  4021.        (send stream ':tyo 12))        ;CR is two chars, CR LF
  4022.       ((and (= ch NVT-IAC) new-telnet-p)
  4023.        (send stream ':tyo NVT-IAC)))))      ;IAC's must be quoted
  4024.  
  4025.  
  4026. ;;; Autodial command method
  4027. ;;;
  4028.  
  4029. (DEFCOMMAND (VT100-FRAME :AUTODIAL) ()
  4030.   '(:DESCRIPTION "Display a pop-up menu with commands to use an auto dialer."
  4031.          :NAMES ("Autodial"))
  4032.   (DECLARE (SPECIAL *AUTODIAL-PREFIX* *AUTODIAL-NUMBER*))
  4033.   (COND (CONNECTION
  4034.      (IF (NOT (FUNCTIONP 'AUTODIAL))
  4035.          (FORMAT T "~&AUTODIAL not loaded. Can't Autodial."))
  4036.          (FUNCALL 'AUTODIAL :STREAM STREAM :MENU T))
  4037.     (T
  4038.      (FORMAT T "~&Not connected.  Can't Autodial.")
  4039.      (WHEN (NOT UCL:PREEMPTING?)
  4040.        (SEND SELF ':HANDLE-PROMPT)))))
  4041.  
  4042.  
  4043. ;;; Kermit command method
  4044. ;;;
  4045.  
  4046. (DEFCOMMAND (VT100-FRAME :KERMIT) ()
  4047.   '(:DESCRIPTION "Display a pop-up menu of KERMIT file-transfer commands."
  4048.          :Names ("Kermit"))
  4049.   (COND (CONNECTION
  4050.      (IF (NOT (FUNCTIONP 'KERMIT:INTERACTIVE-KERMIT))
  4051.          (FORMAT T "~&KERMIT not loaded. Can't run KERMIT.")
  4052.          (LET
  4053.            ((VT100-SUBSTITUTE (SEND SELF :SELECTION-SUBSTITUTE))
  4054.         (KERMIT-SUPERIOR (SEND KERMIT:*KERMIT-FRAME* :SUPERIOR))
  4055.         (MENU-PANE (SEND SELF :GET-PANE 'MENU-TELNET)))
  4056.            (UNWIND-PROTECT
  4057.            (LET
  4058.              ((FORM NIL))
  4059.              (SEND TYPEOUT-PROCESS :ARREST-REASON 'KERMIT)    ; Stop the vt100 process from using serial stream
  4060.              (SETQ FORM (KERMIT:INTERACTIVE-KERMIT STREAM NIL)) ; Get the Kermit arguments
  4061.              (WHEN FORM
  4062.                (SETF (SEND MENU-PANE :INVISIBLE-TO-MOUSE-P) T)    ; Make the vt100 menu items non-mousable
  4063.                (SEND KERMIT:*KERMIT-FRAME* :SET-SUPERIOR SELF)
  4064.                (SEND SELF :SET-SELECTION-SUBSTITUTE KERMIT:*KERMIT-FRAME*)    ; Attach the kermit frame to vt100
  4065.                (EVAL FORM)))        ; Call Kermit
  4066.          (SEND TYPEOUT-PROCESS :REVOKE-ARREST-REASON 'KERMIT)    ; Reallow vt100 to use serial
  4067.          (SETF (SEND MENU-PANE :INVISIBLE-TO-MOUSE-P) NIL)    ; Make menu items mousable
  4068.          (SEND SELF :SET-SELECTION-SUBSTITUTE VT100-SUBSTITUTE)
  4069.          (SEND KERMIT:*KERMIT-FRAME* :SET-SUPERIOR KERMIT-SUPERIOR)))))
  4070.     (T
  4071.      (FORMAT T "~&Not connected.  Can't run KERMIT.")
  4072.      (WHEN (NOT UCL:PREEMPTING?)
  4073.        (SEND SELF ':HANDLE-PROMPT)))))
  4074.  
  4075.  
  4076. ;;; Local echo command method
  4077. ;;;
  4078.  
  4079. (DEFCOMMAND (vt100-frame :LOCAL-ECHO-COMMAND) ()
  4080.   '(:DESCRIPTION "Toggle local echo mode of Vt100 screen pane."
  4081.          :NAMES ("Local Echo"))
  4082.   (SETF ECHO-FLAG (IF ECHO-FLAG NIL T))
  4083.   (FORMAT T "~&Local echo now ~A.~%"
  4084.       (IF ECHO-FLAG "off" "on"))                  ; echo-flag=T means local echo is off!
  4085.   (WHEN (AND (NULL CONNECTION) (NOT UCL:PREEMPTING?))
  4086.       (SEND SELF ':HANDLE-PROMPT)))
  4087.  
  4088.  
  4089. ;;; Redefine the VT100 layout and menu
  4090. ;;;
  4091.  
  4092. (DEFFLAVOR VT100-TELNET-MENU
  4093.        (TV:INVISIBLE-TO-MOUSE-P)
  4094.        (TV:DYNAMIC-ITEM-LIST-MIXIN TV:COMMAND-MENU)
  4095.   (:SETTABLE-INSTANCE-VARIABLES TV:INVISIBLE-TO-MOUSE-P)
  4096.   (:DEFAULT-INIT-PLIST 
  4097.     :LABEL (LIST :TOP :FONT FONTS:HL12B :STRING "VT100 & Telnet Commands")
  4098.     :ROWS 3                       ; BAC changed from 2
  4099.     :COLUMNS 7                    ; BAC changed from 7
  4100.     :VSP 8.
  4101.     :FONT-MAP (list fonts:MEDFNT)
  4102.     :LABEL-BOX-P nil
  4103.     :ITEM-LIST nil)
  4104.   (:DOCUMENTATION :COMBINATION
  4105.     "Command menu needs dynamic-item-list-mixin for UCL."))
  4106.  
  4107. (BUILD-COMMAND-TABLE 'VT100-TELNET-CMD-TABLE 'VT100-FRAME
  4108.   '((:method telnet-frame :exit-command)        
  4109.     (:method telnet-frame :disconnect-command)
  4110.     (:method telnet-frame :interrupt-process-command)
  4111.     :send-answerback-command
  4112.     :reverse-video-command
  4113.     :reset-command
  4114.     :escape-processing-command
  4115.     (:method telnet-frame :quit-and-disconnect-command)
  4116.     (:method telnet-frame :status-command)
  4117.     (:method telnet-frame :abort-output-command)
  4118.     :column-command
  4119.     :truncate-command
  4120.     :set-vt100-lines
  4121.     :network-help-command
  4122.     (:method telnet-frame :clear-input-command)
  4123.     (:method vt100-frame :autodial)                   ; BAC
  4124.     (:method vt100-frame :kermit)                     ; BAC
  4125.     :local-echo-command                               ; BAC
  4126.     )
  4127.   :INIT-OPTIONS
  4128.   '(:NAME "Vt100 & Telnet Commands"
  4129.       :DOCUMENTATION "The Vt100 & Telnet commands."))
  4130.  
  4131. (BUILD-MENU 'UCL-VT100-TELNET-MENU 'VT100-FRAME
  4132.   :DEFAULT-ITEM-OPTIONS
  4133.   '(:FONT FONTS:MEDFNT)
  4134.   :ITEM-LIST-ORDER  
  4135.     '( ;Row 1
  4136.       (:method telnet-frame :exit-command)        
  4137.       (:method telnet-frame :disconnect-command)
  4138.       (:method telnet-frame :interrupt-process-command)
  4139.       :send-answerback-command
  4140.       :reverse-video-command
  4141.       :reset-command
  4142.       :escape-processing-command
  4143.        ;Row 2
  4144.       (:method telnet-frame :quit-and-disconnect-command)
  4145.       (:method telnet-frame :status-command)
  4146.       (:method telnet-frame :abort-output-command)
  4147.       :column-command
  4148.       :truncate-command
  4149.       :set-vt100-lines
  4150.       :network-help-command
  4151.        ;Row 3                                           ; BAC
  4152.       (:method vt100-frame :autodial)                   ; BAC
  4153.       (:method vt100-frame :kermit)                     ; BAC
  4154.       :local-echo-command                               ; BAC
  4155.       ))
  4156.  
  4157.  
  4158. ;;; The following add Serial streams to the TELNET and VT100 base system.
  4159. ;;;
  4160.  
  4161. (DEFVAR telnet:file NIL)
  4162.  
  4163. (DEFMETHOD (vt100-frame :TYPEOUT-TOP-LEVEL) (&aux (terminal-io vt100-pane))
  4164.   "Redefines (:METHOD BASIC-NVT :TYPOUT-TOP-LEVEL) to use :PROCESS-ESCAPE"
  4165.   (declare (special telnet:file))
  4166.   (process-wait "Never-open" #'car (locate-in-instance self 'connection))
  4167.   (ucl:ignore-errors-query-loop
  4168.     (condition-bind (((sys:remote-network-error
  4169.                ip:illegal-connection
  4170.                ip:connection-reset) 'typeout-net-error self))
  4171.       (do-forever
  4172.     (do ((ch (nvt-neti) (send stream :tyi-no-hang)))
  4173.         ((null ch) (if output-buffer (send self :force-output)))
  4174.       (when (not (null telnet:file))
  4175.         (send telnet:file :tyo ch))
  4176.       (send self :process-escape
  4177.         (IF (EQ CONNECTION T)
  4178.             (logand #b01111111 ch)   ; if we don't strip parity we get an error ;; BAC
  4179.             ch)))))))
  4180.  
  4181.  
  4182. ;;; This method should return the network connection. This can
  4183. ;;; be a stream or a connection object depending on the network type.
  4184. ;;;
  4185. ;;; The method :NETWORK-NEW-CONNECTION is not needed for serial telnet.
  4186. (DEFMETHOD (basic-nvt :case :network-new-connection :serial) 
  4187.        (host &optional (contact "TELNET") (window nil) )
  4188.   window contact host nil)                                       ; BAC to eliminate compile warnings
  4189.  
  4190. (RECOMPILE-FLAVOR 'vt100-frame :NETWORK-NEW-CONNECTION)
  4191.  
  4192. ;;; Return nil if the connection is not connected.
  4193. (DEFMETHOD (basic-nvt :case :network-connected-p :serial)()
  4194.   (and stream connection))
  4195.  
  4196. (RECOMPILE-FLAVOR 'vt100-frame :NETWORK-CONNECTED-P)
  4197.  
  4198. ;;; The method :NETWORK-NEW-CONNECTION passes the arguement which we
  4199. ;;; ignore for the serial implementation.
  4200. ;;;
  4201. ;;; Set stream to be the serial stream.
  4202. ;;; Connection should be something non nil, but does not need to be a connection.  
  4203. ;;; The connection instance variable is used by CHAOSNET.
  4204. (DEFMETHOD (basic-nvt :case :set-connection :serial) (ignore)
  4205.   (SEND typein-process :reset)
  4206.   (SEND typeout-process :reset)
  4207.   (SETF stream (MAKE-SERIAL-STREAM-FROM-CVV))
  4208. ;;  (SEND self :gobble-greeting)
  4209.   (SETF connection t)
  4210.   (SETQ black-on-white nil))
  4211.  
  4212. (RECOMPILE-FLAVOR 'vt100-frame :SET-CONNECTION)
  4213.  
  4214. ;;; This method should close the serial TELNET connection.
  4215. ;;; Make sure to set both instance variables, STREAM and CONNECTION,
  4216. ;;; to nil.
  4217. (DEFMETHOD (basic-nvt :case :network-disconnect :serial)()
  4218.   (WHEN stream
  4219.     (SEND stream :close)
  4220.     (SETF stream nil
  4221.       connection nil)))
  4222.  
  4223. (RECOMPILE-FLAVOR 'vt100-frame :NETWORK-DISCONNECT)
  4224.  
  4225. ;;; This method should indicate the connection state.
  4226. ;;; It would be nice if you could signal errors in the connection
  4227. ;;; state by throwing 'NVT-DONE because TELNET will try to eloquently
  4228. ;;; close the connection.
  4229. (defmethod (basic-nvt :case :check-connection-state :serial)()
  4230.   (unless stream
  4231.       (*THROW 'TELNET:NVT-DONE "Stream never opened.")))
  4232.  
  4233. (RECOMPILE-FLAVOR 'vt100-frame :CHECK-CONNECTION-STATE)
  4234.  
  4235. ;;; Send the TELNET command interrupt process (IP) to the remote host.
  4236. ;;; (Note: IP should not be confused with the acronym for a well known
  4237. ;;; network type.)
  4238. ;;; An IP command is defined to be the following two bytes: NVT-IAC NVT-IP.
  4239. ;;; Many implementations send the IP in urgent mode as the following sequence of bytes
  4240. ;;; NVT-IAC, NVT-IP, NVT-IAC, NVT-DM.  This is technically a SYNC signal but 
  4241. ;;; most systems handle no differently. The TCP/IP network sends a SYNC signal
  4242. ;;; in urgent mode, the CHAOS network sends a SYNC signal not in urgent mode
  4243. ;;; because there is no concept of urgent data, Wollongong sends just an IP command
  4244. ;;; and the MIT PC software sends a SYNC signal in urgent mode.
  4245. ;;;  
  4246. ;;; You may choose to send a SYNC signal or just IP command I think it makes little
  4247. ;;; difference (except with Wollongong which can't handle SYNC signals successfully).
  4248. ;;; However, since serial streams do not have a concept of 
  4249. ;;; urgent mode I choose to send a SYNC signal.
  4250. (DEFMETHOD (basic-telnet :case :network-send-ip :serial)()
  4251.   (lock-output
  4252.     (SEND stream :tyo NVT-IAC)
  4253.     (SEND stream :tyo NVT-IP)
  4254.     (SEND stream :tyo NVT-IAC)
  4255.     (SEND stream :tyo NVT-DM)
  4256.     ))
  4257.  
  4258. (RECOMPILE-FLAVOR 'vt100-frame :NETWORK-SEND-IP)
  4259.  
  4260. (UNLESS (MEMBER :serial protocols-supporting-telnet)   
  4261.   (PUSH :serial protocols-supporting-telnet))
  4262.  
  4263. ;;; This is a kludge to make serial telnet work correctly.
  4264. ;;; If there were serial host objects then this would not 
  4265. ;;; be necessary.
  4266. (setq default-network-type :serial)
  4267.  
  4268. <<< VTCURS.LSP >>>
  4269.  
  4270. ;;; -*- Mode: Lisp; Package: User; Base: 10.; Patch-File: T -*-
  4271.  
  4272. ;;;                           RESTRICTED RIGHTS LEGEND
  4273.  
  4274. ;;;Use, duplication, or disclosure by the Government is subject to
  4275. ;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
  4276. ;;;Technical Data and Computer Software clause at 52.227-7013.
  4277. ;;;
  4278. ;;;                     TEXAS INSTRUMENTS INCORPORATED.
  4279. ;;;                              P.O. BOX 2909
  4280. ;;;                           AUSTIN, TEXAS 78769
  4281. ;;;                                 MS 2151
  4282. ;;;
  4283. ;;; Copyright (c) 1986, Texas Instruments Incorporated.  All rights reserved.
  4284.  
  4285. ;;; Written 5/16/86 10:34:33 by FORD,
  4286. ;;; Reason: Fix (:METHOD VT100-ESCAPE-SEQUENCE-MIXIN :PROCESS-ESCAPE-BRACKET-NUMERIC-NUMERIC-SEMICOLON-SEQUENCE)
  4287. ;;; to properly process the second leading zero in escape sequences like 01H.
  4288. ;;; while running on B from band LOD2
  4289. ;;; with System 2.44, Compiler 2.5, File System 2.1, Universal Command Loop 2.0, Window System 2.5, Input Editor 2.0, ZMACS 2.5, Error Handler 2.0, Suggestions 2.1, Debug Utilities 2.7, Explorer-Net 2.6, Telnet 2.2, Vt100 2.0, File Server 2.0, Net-Config 2.2, Font Editor 2.2, Mailer 2.4, Mail-Reader 2.4, Streamer-Tape 2.7, Local-File 2.15, System-Log 2.2, Serial-Parallel 2.8, Printer 2.0, Glossary 2.0, IMAGEN 2.1, NVRAM 2.3, User Profile Utility 2.1, IP 1.15, Experimental Code Management Interface 2.22, Experimental Explorer Bug System 20.0, microcode 287, FAN23-MCR287-AUS.
  4290.  
  4291.  
  4292.  
  4293. #!Z
  4294. ; From file PROCESS-ESCAPE-SEQUENCE.LISP#> VT100; A:
  4295. #10R TELNET#:
  4296. (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET"))
  4297.                          (SI:LISP-MODE :ZETALISP)
  4298.                          (*READTABLE* SI:STANDARD-READTABLE)
  4299.                          (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL))
  4300.   (COMPILER#:PATCH-SOURCE-FILE "SYS: VT100; PROCESS-ESCAPE-SEQUENCE.#"
  4301.  
  4302.  
  4303. (DEFMETHOD (vt100-escape-sequence-mixin
  4304.          :PROCESS-ESCAPE-BRACKET-NUMERIC-NUMERIC-SEMICOLON-SEQUENCE) (ch)
  4305.   (cond ((= ch #/r)               ; ESC [ num num ; num num r 
  4306.      (setq scroll-ending-line       ; Scrolling regions
  4307.            (min ending-line (tv:sheet-number-of-inside-lines vt100-pane)))
  4308.      (setq scroll-starting-line starting-line-completed-value)
  4309.      (if (= scroll-ending-line 0)
  4310.          (setq scroll-ending-line (tv:sheet-number-of-inside-lines vt100-pane)))
  4311.      (setq top-of-scroll scroll-starting-line)
  4312.      (setq bottom-of-scroll scroll-ending-line)
  4313.      (send vt100-pane ':set-cursorpos 0 0 ':character)
  4314.      (send self ':reset))
  4315.     ((or (= ch #/H) (= ch #/f))    ; Direct cursor addressing 
  4316.      ; ESC [ 14 ; H   ESC [ 14 ; 1  H   ESC [ 14 ; 12 H
  4317.      ; And the same sequences with 'f'
  4318.      (send self ':move-to-direct-cursor-position
  4319.            starting-line-completed-value column)
  4320.      (send self ':reset))
  4321.     (escape-bracket-numeric-numeric-semicolon-numeric-flag
  4322.      ;This is the second of the two digits, so now make a two digit value
  4323.      (cond ((and test-for-three-digits-flag    ; Check for "00", ie, ESC [ 10;007H
  4324.              (= escape-bracket-numeric-numeric-semicolon-numeric-ch #/0))
  4325.         (setq test-for-three-digits-flag nil)
  4326.         (setq escape-bracket-numeric-numeric-semicolon-numeric-numeric-ch ch)
  4327.         (setq ending-line 
  4328.               (make-two-digit-value 
  4329.             escape-bracket-numeric-numeric-semicolon-numeric-ch
  4330.             escape-bracket-numeric-numeric-semicolon-numeric-numeric-ch))
  4331.         (setq column ending-line))
  4332.            (t (setq escape-bracket-numeric-numeric-semicolon-numeric-numeric-ch ch)
  4333.           (setq ending-line
  4334.             (make-two-digit-value 
  4335.               escape-bracket-numeric-numeric-semicolon-numeric-ch
  4336.               escape-bracket-numeric-numeric-semicolon-numeric-numeric-ch))
  4337.           (setq column ending-line))))
  4338.     ((and (>= ch #/0) (<= ch #/9))
  4339.      ;This is the first of the two digits
  4340.      (setq test-for-three-digits-flag t)
  4341.      (setq escape-bracket-numeric-numeric-semicolon-numeric-ch ch)
  4342.      (setq column (- ch #/0))
  4343.      (setq escape-bracket-numeric-numeric-semicolon-numeric-flag t)
  4344.      (cond ((=  starting-line-second-ch 99.)
  4345.         (setq ending-line
  4346.               (make-two-digit-value 
  4347.             escape-bracket-numeric-semicolon-numeric-ch
  4348.             escape-bracket-numeric-numeric-semicolon-numeric-ch))
  4349.         (setq starting-line (- starting-line #/0)))
  4350.            (t NIL)))
  4351.     (t 
  4352.      (send self ':reset))))
  4353. ))
  4354.  
  4355.  
  4356. <<< VTCKEY.LSP >>>
  4357.  
  4358. ;;; -*- Mode: Lisp; Package: User; Base: 10.; Patch-File: T -*-
  4359.  
  4360. ;;;                           RESTRICTED RIGHTS LEGEND
  4361.  
  4362. ;;;Use, duplication, or disclosure by the Government is subject to
  4363. ;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
  4364. ;;;Technical Data and Computer Software clause at 52.227-7013.
  4365. ;;;
  4366. ;;;                     TEXAS INSTRUMENTS INCORPORATED.
  4367. ;;;                              P.O. BOX 2909
  4368. ;;;                           AUSTIN, TEXAS 78769
  4369. ;;;                                 MS 2151
  4370. ;;;
  4371. ;;; Copyright (c) 1986, Texas Instruments Incorporated.  All rights reserved.
  4372.  
  4373. ;;; Written 8/07/86 13:42:03 by FORD,
  4374. ;;; Reason: Commented out check for Keypad-mode in cursor key methods.
  4375. ;;; It doesn't appear as if cursor-key mode and keypad-mode
  4376. ;;; should be connected.               Steve Ford 8-7-86
  4377. ;;; while running on D from band LOD1
  4378. ;;; with System 2.79, Compiler 2.7, File System 2.1, Universal Command Loop 2.0, Window System 2.10, Input Editor 2.0, ZMACS 2.10, Error Handler 2.2, Suggestions 2.22, Debug Utilities 2.12, Explorer-Net 2.7, Telnet 2.2, Vt100 2.1, File Server 2.0, Net-Config 2.4, Font Editor 2.2, Mailer 2.7, Mail-Reader 2.5, Streamer-Tape 2.20, Local-File 2.31, System-Log 2.3, Serial-Parallel 2.0, Printer 2.6, Glossary 2.0, IMAGEN 2.3, NVRAM 2.3, User Profile Utility 2.1, UCODE-DEPENDENT 2.17, microcode 310, REL 2.1 MINPROD.
  4379.  
  4380.  
  4381.  
  4382. #!Z
  4383. ; From file PROCESS-ESCAPE-SEQUENCE.LISP#> VT100; F:
  4384. #10R TELNET#:
  4385. (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET"))
  4386.                          (SI:LISP-MODE :ZETALISP)
  4387.                          (*READTABLE* SI:STANDARD-READTABLE)
  4388.                          (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL))
  4389.   (COMPILER#:PATCH-SOURCE-FILE "SYS: VT100; PROCESS-ESCAPE-SEQUENCE.#"
  4390.  
  4391.  
  4392.  
  4393. (DEFMETHOD (vt100-escape-sequence-mixin :AUXILIARY-UP) ()
  4394.   (cond (nil                                ;(and keypad-mode process-ch?)
  4395.      (send self ':applications-mode)
  4396.      (send self ':net-output #/A))
  4397.     (t
  4398.      (send self ':net-output #\escape)
  4399.      (send self ':net-output #/[)
  4400.      (send self ':net-output #/A))))
  4401.  
  4402. (DEFMETHOD (vt100-escape-sequence-mixin :AUXILIARY-DOWN) ()
  4403.   (cond (nil                                ;(and keypad-mode process-ch?)
  4404.      (send self ':applications-mode)
  4405.      (send self ':net-output #/B))
  4406.     (t
  4407.      (send self ':net-output #\escape)
  4408.      (send self ':net-output #/[)
  4409.      (send self ':net-output #/B))))
  4410.  
  4411. (DEFMETHOD (vt100-escape-sequence-mixin :AUXILIARY-RIGHT) ()
  4412.   (cond (nil                                ;(and keypad-mode process-ch?)
  4413.      (send self ':applications-mode)
  4414.      (send self ':net-output #/C))
  4415.     (t
  4416.      (send self ':net-output #\escape)
  4417.      (send self ':net-output #/[)
  4418.      (send self ':net-output #/C))))
  4419.  
  4420. (DEFMETHOD (vt100-escape-sequence-mixin :AUXILIARY-LEFT) ()
  4421.   (cond (nil                                ;(and keypad-mode process-ch?)
  4422.      (send self ':applications-mode)
  4423.      (send self ':net-output #/D))
  4424.     (t
  4425.      (send self ':net-output #\escape)
  4426.      (send self ':net-output #/[)
  4427.      (send self ':net-output #/D))))
  4428.  
  4429.  
  4430. ))
  4431.