;*** DEFSYS.LSP *** ;-*- Mode:LISP; Package:USER; Base:10. -*- ;;; See if packages KERMIT and IP exist - if not, create them! (PKG-FIND-PACKAGE "KERMIT" T) (PKG-FIND-PACKAGE "IP" T) (defsystem KERMIT (:name "KERMIT") (:short-name "KERMIT") (:pathname-default "KERMIT;") (:patchable "KERMIT;") (:initial-status :RELEASED) (:compile-load ("KERMIT")) (:compile-load ("SERIAL-CLOSE-FIX")) ; (:compile-load ("VT100-CURSOR-FIX")) (:compile-load ("VT100-CURSOR-KEY-FIX")) (:compile-load ("SERIAL-TELNET"))) ;*** KERMIT.LSP *** ;;; -*- Mode:COMMON-LISP; Package:KERMIT; Base:10 -*- ;;; Copyright (c) 1981, 1982, 1983, 1984 Trustees of Columbia University, New York ;;; Copyright (c) 1986 Sperry Corporation ;;; Copyright (c) 1986 Texas Instruments Incorporated ;;; Permission is granted to any individual or institution to copy or use this ;;; software but not to resell it for a price in excess of its media cost. ;;; K e r m i t File Transfer Utility ;;; ;;; Release 1.0 9/22/86 ;;; Remember @@TTY W,132 for 1100 ;;; Global constants (DEFCONSTANT *ASCII-NUL* 0 "ASCII NUL") (DEFCONSTANT *ASCII-SOH* 1 "ASCII Start of Header") (DEFCONSTANT *ASCII-BS* 8 "ASCII back space") (DEFCONSTANT *ASCII-TAB* 9 "ASCII tab") (DEFCONSTANT *ASCII-LF* 10 "ASCII line feed") (DEFCONSTANT *ASCII-FF* 12 "ASCII form feed") (DEFCONSTANT *ASCII-CR* 13 "ASCII carriage return") (DEFCONSTANT *ASCII-SP* 32 "ASCII space") (DEFCONSTANT *ASCII-NS* 35 "ASCII quote") (DEFCONSTANT *ASCII-AMP* 38 "ASCII ampersand - for 8-bit quoting") (DEFCONSTANT *ASCII-1* 49 "ASCII 1") (DEFCONSTANT *ASCII-N* 78 "ASCII N") (DEFCONSTANT *ASCII-Y* 89 "ASCII Y") (DEFCONSTANT *ASCII-TILDE* 126 "ASCII tilde - for repeat count prefixing") (DEFCONSTANT *ASCII-DEL* 127 "ASCII delete - rubout") (DEFCONSTANT *LISPM-RUBOUT* 135 "LISPM rubout") (DEFCONSTANT *LISPM-BS* 136 "LISPM backspace") (DEFCONSTANT *LISPM-TAB* 137 "LISPM tab") (DEFCONSTANT *LISPM-LF* 138 "LISPM linefeed") (DEFCONSTANT *LISPM-DEL* 139 "LISPM delete") (DEFCONSTANT *LISPM-PAGE* 140 "LISPM page") (DEFCONSTANT *LISPM-NEWLINE* 141 "LISPM version of CRLF") ;;; States - The letter doesn't matter as long as all are unique. (DEFCONSTANT *ABORT-STATE* #\A) (DEFCONSTANT *SBREAK-STATE* #\B) (DEFCONSTANT *COMPLETE-STATE* #\C) (DEFCONSTANT *SDATA-STATE* #\D) (DEFCONSTANT *EXIT-STATE* #\E) (DEFCONSTANT *SFILE-STATE* #\F) (DEFCONSTANT *SGENERIC-STATE* #\G) (DEFCONSTANT *RSERVER-STATE* #\I) (DEFCONSTANT *RCANCEL-STATE* #\K) (DEFCONSTANT *RFILE-STATE* #\L) (DEFCONSTANT *RDATA-STATE* #\M) (DEFCONSTANT *LOGOUT-STATE* #\Q) (DEFCONSTANT *RINIT-STATE* #\R) (DEFCONSTANT *SINIT-STATE* #\S) (DEFCONSTANT *SSERVER-STATE* #\V) (DEFCONSTANT *SEOF-STATE* #\Z) (DEFCONSTANT *KERMIT-NAME* "Explorer Kermit") ;;; Window variables. (DEFFLAVOR KERMIT-FRAME () (TV:INFERIORS-NOT-IN-SELECT-MENU-MIXIN TV:ALIAS-FOR-INFERIORS-MIXIN TV:BORDERED-CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER TV:LABEL-MIXIN)) (DEFMETHOD (KERMIT-FRAME :NAME-FOR-SELECTION) () (SEND SELF :NAME)) (DEFVAR *KERMIT-FRAME* ; Define the KERMIT frame (MAKE-INSTANCE 'KERMIT-FRAME :EDGES '(44 107 980 478) ; left,top,right,bottom :SAVE-BITS T :BORDERS 2 :LABEL '(:TOP :CENTERED :STRING "Explorer Kermit - Release 1.0" :FONT FONTS:HIGHER-MEDFNB) :SELECTION-SUBSTITUTE 'INFO-PANE :PANES '((STATUS-PANE TV:WINDOW :LABEL NIL :BORDERS (0 2 0 1) :DEEXPOSED-TYPEOUT-ACTION :PERMIT) (INFO-PANE TV:WINDOW :LABEL NIL :BORDERS (0 1 0 1) :DEEXPOSED-TYPEOUT-ACTION :PERMIT) (MENU-PANE TV:COMMAND-MENU :BORDERS (0 1 0 0) :ROWS 1 :COLUMNS 3 :ITEM-LIST (("Abort" :VALUE "Z" :DOCUMENTATION "Abort the current operation.") ("Abort-Save" :VALUE "S" :DOCUMENTATION "Abort the current operation but save the file.") ("End" :VALUE "E" :DOCUMENTATION "Exit Kermit (valid only if an operation is complete).")))) :CONSTRAINTS '((MAIN . ((STATUS-PANE INFO-PANE MENU-PANE) ((STATUS-PANE 5 :LINES)) ((MENU-PANE 3 :LINES)) ((INFO-PANE :EVEN))))))) (DEFVAR *STATUS-WINDOW* (SEND *KERMIT-FRAME* :GET-PANE 'STATUS-PANE)) (DEFVAR *INFO-WINDOW* (SEND *KERMIT-FRAME* :GET-PANE 'INFO-PANE)) ;;; Global variables - If values of these are changed, change in CHANGE-KERMIT-PARAMETERS function also (DEFVAR *RARG1* "" "Receive argument for interactive KERMIT CVV") (DEFVAR *RARG2* "" "Receive argument for interactive KERMIT CVV") (DEFVAR *SARG1* "" "Send argument for interactive KERMIT CVV") (DEFVAR *SARG2* "" "Send argument for interactive KERMIT CVV") (DEFVAR *CARG1* "" "Command argument for interactive KERMIT CVV") (DEFVAR *CARG2* "" "Command argument for interactive KERMIT CVV") (DEFVAR *IMAGE* NIL "T means 8-bit mode - NIL means 7-bit mode") (DEFVAR *DEBUG* NIL "T means print debugging information") (DEFVAR *MORE* NIL "T means enable **MORE** in kermit window") (DEFVAR *LOGFILE* NIL "If a filename specified, log info to a file") (DEFVAR *FILNAMCNV* T "T means convert filename to name.type - NIL means don't convert file names") (DEFVAR *SAVEFILES* NIL "T means save partially received file if xfer interrupted - NIL means delete") (DEFVAR *MYMAXTRY* 10 "Times to retry a packet") (DEFVAR *MYMAXPACSIZ* 94 "Maximum packet size") (DEFVAR *MYTIME* 10 "Seconds after which I should be timed out") (DEFVAR *MYPAD* 0 "Number of padding characters I will need - I don't need any!") (DEFVAR *MYPADCHAR* 0 "Padding character I need - none") (DEFVAR *MYEOL* *ASCII-CR* "End-Of-Line character") (DEFVAR *MYQUOTE* *ASCII-NS* "Quote character I will use") ;;; Macro Definitions: (DEFSUBST TOCHAR (ch) "converts a control character to a printable one by adding a space" (+ ch *ASCII-SP*)) (DEFSUBST UNCHAR (ch) "undoes TOCHAR by subtracting a space" (- ch *ASCII-SP*)) (DEFSUBST CTL (ch) "converts between control characters and printable characters by toggling the control bit (ie. ^A becomes A and A becomes ^A). #b1000000 is #o100." (LOGXOR ch #b1000000)) (DEFSUBST COMPUTE-FINAL-CHECKSUM (NUM) "Compute final checksum by folding in bits 7 and 8. #b11000000 is #o300, #b111111 is #o077." (LOGAND (+ (LSH (LOGAND NUM #b11000000) -6) NUM) #b111111)) (DEFSUBST CONVERT-FROM-ASCII (ch) "Function to convert some characters from ASCII to Lisp." (COND ((OR (AND (> ch *ASCII-CR*) (< ch *ASCII-DEL*)) (AND (> ch *ASCII-DEL*) (< ch 256))) ch) ((= ch *ASCII-CR*) *LISPM-NEWLINE*) ((= ch *ASCII-TAB*) *LISPM-TAB*) ((= ch *ASCII-LF*) *LISPM-LF*) ((= ch *ASCII-FF*) *LISPM-PAGE*) ((= ch *ASCII-DEL*) *LISPM-RUBOUT*) ((= ch *ASCII-BS*) *LISPM-BS*) (T (IF (OR (< ch 0) (> ch 255)) NIL ch)))) (DEFSUBST CONVERT-TO-ASCII (ch) "Function to convert characters from Lisp to ASCII. Converts any appropriate control characters but maps the unimportant control chars to NIL." (COND ((<= ch *ASCII-DEL*) ch) ((= ch *LISPM-BS*) *ASCII-BS*) ((= ch *LISPM-TAB*) *ASCII-TAB*) ((= ch *LISPM-LF*) *ASCII-LF*) ((= ch *LISPM-PAGE*) *ASCII-FF*) ((= ch *LISPM-NEWLINE*) *ASCII-CR*) ((= ch *LISPM-RUBOUT*) *ASCII-DEL*) (T NIL))) (DEFUN INTERACTIVE-KERMIT (&OPTIONAL STREAM (EXECUTE T)) "Produce a selection menu. If EXECUTE is non-nil, call KERMIT; otherwise, return a form that can be EVALed to call KERMIT." (LET* ((SELECTION (TV:MENU-CHOOSE '( ("Get File(s) " :VALUE (:GET "Get File(s)" ((*RARG1* "Remote File Name " :DOCUMENTATION "File(s) to transfer from the remote Kermit server." :STRING) (*RARG2* "New Local File Name" :DOCUMENTATION "Name to give to the transferred file(s)." :STRING))) :DOCUMENTATION "Transfer file(s) from a remote Kermit in server mode.") ("Receive File(s) " :VALUE (:RECEIVE "Receive File(s)" ((*RARG1* "New Local File Name" :DOCUMENTATION "Local name to give to the received file(s)." :STRING))) :DOCUMENTATION "Wait for the arrival of file(s) transferred by a remote Kermit executing a Send command.") ("Send File(s) " :VALUE (:SEND "Send File(s)" ((*SARG1* "Local File Name " :DOCUMENTATION "Local file(s) to transfer to the remote Kermit." :STRING) (*SARG2* "New Remote File Name" :DOCUMENTATION "Name to give to the transferred file(s) on the remote host." :STRING))) :DOCUMENTATION "Transfer file(s) to a remote Kermit in Server mode or executing a Receive command.") ("" :NO-SELECT nil) ("Bye " :VALUE (:BYE) :DOCUMENTATION "Shut down and logout a remote Kermit server.") ("Finish " :VALUE (:FINISH) :DOCUMENTATION "Shut down a remote Kermit server without logging out the remote job.") ("" :NO-SELECT nil) ("Set Parameters " :VALUE (:SET) :DOCUMENTATION "Modify local Kermit operating parameters.") ("" :NO-SELECT nil) ("Begin Logging " :VALUE (:LOG-BEGIN "Begin Logging to File" ((*CARG1* "Log File Pathname" :DOCUMENTATION "Pathname used to write logging information." :STRING))) :DOCUMENTATION "Begin logging local Kermit actions to a file.") ("End Logging " :VALUE (:LOG-END) :DOCUMENTATION "End logging local Kermit actions to a file.") ("" :NO-SELECT nil) ("Server Mode " :VALUE (:SERVER) :DOCUMENTATION "Place local Kermit in server mode.") ("" :NO-SELECT nil) ("Remote Copy " :VALUE (:REMOTE-COPY "Remote Copy" ((*CARG1* "File Name " :DOCUMENTATION "File to copy on the remote KERMIT server." :STRING) (*CARG2* "File Copy Name" :DOCUMENTATION "Name to give to the copy file." :STRING))) :DOCUMENTATION "Copy the specified file to another location on a remote KERMIT server.") ("Remote CWD " :VALUE (:REMOTE-CWD "Remote Change Working Directory" ((*CARG1* "New Remote Directory" :DOCUMENTATION "New working directory pathname for the remote Kermit server." :STRING))) :DOCUMENTATION "Change the working directory of a remote Kermit server.") ("Remote Delete " :VALUE (:REMOTE-DELETE "Remote Delete File" ((*CARG1* "Remote File Name" :DOCUMENTATION "Name of file to delete on remote Kermit server." :STRING))) :DOCUMENTATION "Delete a file on a remote Kermit server.") ("Remote Directory" :VALUE (:REMOTE-DIRECTORY "Remote Directory" ((*CARG1* "Remote Directory" :DOCUMENTATION "Directory pathname for remote Kermit server." :STRING))) :DOCUMENTATION "Display names of files in directory on remote Kermit server.") ("Remote Help " :VALUE (:REMOTE-HELP "Remote Help" ((*CARG1* "Help Topic" :DOCUMENTATION "Optional topic on which to obtain help." :STRING))) :DOCUMENTATION "Display a list of remote KERMIT server help commands.") ("Remote Host " :VALUE (:REMOTE-HOST "Remote Host" ((*CARG1* "Host Command" :DOCUMENTATION "Command to pass to the remote host." :STRING))) :DOCUMENTATION "Pass the given command to the remote KERMIT server host for processing. The command must be in the remote KERMIT server host's own command level syntax.") ("Remote Kermit " :VALUE (:REMOTE-KERMIT "Remote Kermit" ((*CARG1* "Kermit Command" :DOCUMENTATION "Command to pass to the remote KERMIT server." :STRING))) :DOCUMENTATION "Pass the given command to the remote KERMIT server for execution. The command must be in the remote KERMIT server's own interactive mode syntax.") ("Remote Rename " :VALUE (:REMOTE-RENAME "Remote Rename File" ((*CARG1* "File Name " :DOCUMENTATION "File to rename on the remote KERMIT server." :STRING) (*CARG2* "New File Name" :DOCUMENTATION "New name to give to the file." :STRING))) :DOCUMENTATION "Rename the specified file on a remote KERMIT server.") ("Remote Set " :VALUE (:REMOTE-SET "Remote Set Parameter" ((*CARG1* "Parameter" :DOCUMENTATION "Name of parameter to set on remote KERMIT server." :STRING) (*CARG2* "Value " :DOCUMENTATION "New value to give to the parameter." :STRING))) :DOCUMENTATION "Set a parameter to a given value on a remote KERMIT server.") ("Remote Show " :VALUE (:REMOTE-SHOW "Remote Show Parameter" ((*CARG1* "Parameter" :DOCUMENTATION "Name of parameter to query on remote KERMIT server." :STRING))) :DOCUMENTATION "Obtain the value of a parameter on a remote KERMIT server.") ("Remote Space " :VALUE (:REMOTE-SPACE "Remote Disk Space" ((*CARG1* "Remote Directory" :DOCUMENTATION "Remote directory pathname." :STRING))) :DOCUMENTATION "Display information about disk usage for a directory on remote Kermit server.") ("Remote Type " :VALUE (:REMOTE-TYPE "Remote File Type" ((*CARG1* "File Name" :DOCUMENTATION "Name of file to list." :STRING))) :DOCUMENTATION "Display the specified filename from a remote KERMIT server.")) "KERMIT OPERATIONS" '(:POINT 500 400))) (OPERATION (FIRST SELECTION)) (LABEL (SECOND SELECTION)) (CVV-LIST (THIRD SELECTION))) (WHEN CVV-LIST ; If a cvv is required, display it (WHEN (*CATCH 'END-CVV ; Setup catch - if true, we used it (TV:CHOOSE-VARIABLE-VALUES CVV-LIST :NEAR-MODE '(:POINT 500 400) :WIDTH 50 :LABEL LABEL :MARGIN-CHOICES '("Do It" ("Quit" (*THROW 'END-CVV T)))) NIL) ; Return nil from entire block (SETQ OPERATION NIL))) ; If we returned with T, the throw was used. (WHEN OPERATION (LET ((FORM `(KERMIT ,OPERATION :ARG1 ,(EVAL (FIRST (FIRST CVV-LIST))) :ARG2 ,(EVAL (FIRST (SECOND CVV-LIST))) :STREAM ,STREAM :VERBOSEP T))) (IF EXECUTE (EVAL FORM) FORM))))) (DEFUN KERMIT (OPERATION &KEY ARG1 ARG2 STREAM VERBOSEP) "Transfers files using the KERMIT protocol. OPERATION - :GET Transfer file(s) from a remote Kermit in server mode :RECEIVE Wait for the arrival of file(s) transferred by a remote Kermit executing a Send command :SEND Transfer file(s) to a remote KERMIT in server mode or executing a Receive command :BYE Shut down and logout a remote KERMIT server :FINISH Shut down a remote KERMIT server without logging out the remote job :SET Modify the local KERMIT operating parameters :LOG-BEGIN Begin logging local KERMIT actions to a file :LOG-END End logging local KERMIT actions to a file :SERVER Place local KERMIT in server mode :REMOTE-COPY Copy the specified file to another location on a remote KERMIT server :REMOTE-CWD Change the working directory of a remote KERMIT server :REMOTE-DELETE Delete a file on a remote KERMIT server :REMOTE-DIRECTORY Display names of files in a directory on remote KERMIT server :REMOTE-HELP Display a list of remote KERMIT server help commands :REMOTE-HOST Pass the given command to the remote KERMIT server host for processing (the command must be in the remote KERMIT host's own command level syntax) :REMOTE-KERMIT Pass the given command to the remote KERMIT server for execution (the command must be in the remote KERMIT's own interactive mode syntax) :REMOTE-RENAME Rename the specified file on a remote KERMIT server :REMOTE-SET Set a parameter to a given value on a remote KERMIT server :REMOTE-SHOW Obtain the value of a parameter on a remote KERMIT serve :REMOTE-SPACE Display information about disk usage for a directory on remote KERMIT server :REMOTE-TYPE Display the specified filename from a remote KERMIT server :ARG1 - Filename, directory, command or parameter :ARG2 - New filename, destination name or parameter :STREAM - Serial stream to use :VERBOSEP - T means verbose output." ;;; All Kermit variables that are passed between functions (but not global via DEFVAR) ;;; are defined here and prefixed with K* (LET ((K*OPERATION OPERATION) ; Action to be taken (K*TTYFD STREAM) ; Serial stream for I/O (K*TTYFD-BITS NIL) ; Number of data bits in serial stream (K*VERBOSEP VERBOSEP) ; T means print things on the screen (K*STATE NIL) ; Represents the present state of RECSW or SENDSW (K*PCKT-NUM 0) ; Packet number (K*NUMTRY 0) ; Times this packet retried (K*SIZE 0) ; Size of data in the buffer (K*FILE-CHARS 0) ; Total number of file chars read or written (K*YOURMAXPACSIZ *MYMAXPACSIZ*) ; Maximum send packet size - default to my size (K*YOURTIME (+ 5 *MYTIME*)) ; Timeout on sends - default to longer (K*YOURPAD 0) ; Padding to send - assume none (K*YOURPADCHAR 0) ; Padding character to send - none (K*YOUREOL *ASCII-CR*) ; End-Of-Line character to send (K*YOURQUOTE *ASCII-NS*) ; Quote character in incoming data (K*BINQUOTE *ASCII-N*) ; 8-bit quoting character (K*REPEAT *ASCII-TILDE*) ; Repeat character (K*SPACKET ; Send packet buffer (MAKE-ARRAY (* 2 *MYMAXPACSIZ*) :TYPE 'ART-STRING :FILL-POINTER 0)) (K*RPACKET ; Receive packet buffer (MAKE-ARRAY (* 2 *MYMAXPACSIZ*) :TYPE 'ART-STRING :FILL-POINTER 0)) (K*BUFFER ; Local packet buffer (MAKE-ARRAY (* 2 *MYMAXPACSIZ*) :TYPE 'ART-STRING :FILL-POINTER 0)) (K*ARG1LIST (IF (LISTP ARG1) ; Make sure ARG1 is a list ARG1 (LIST ARG1))) (K*ARG2LIST (IF (LISTP ARG2) ; Make sure ARG2 is a list ARG2 (LIST ARG2))) (K*FILNAM NIL) ; Current file name (K*RECFILNAM NIL) ; Default pathname into which to place the received file (K*EMPTY-PATHNAME (MAKE-PATHNAME)) ; Empty pathname used for merging (K*FP NIL) ; File pointer to currently opened disk file (K*BUFILLPTR 0) ; Pointer to current location in K*BUFILLBUF (K*BUFILLBUF ; Temporary file buffer for BUFILL to handle file input (MAKE-ARRAY 2048 ; Buffer size is 2 blocks :TYPE 'ART-STRING :FILL-POINTER 0)) (K*IGNORE-NEXT-LINEFEED NIL) ; Flag for ASCII conversion (K*SEND-TO-TTY NIL) ; Flag indicating whether to send data to TTY or file (K*FILES-TRANSFERRED NIL) ; List of files successfully sent or received (K*CANCEL NIL) ; Used to poll the keyboard to see if we should cancel xfer (K*ABORT-REASON NIL) ; Contains string with error (K*PACKETS-TRANSFERRED 0) ; Total number of packets transferred (K*PACKETS-RETRIED 0) ; Total number of packets retried (K*BYTES-TRANSFERRED 0) ; Total number of bytes transferred (K*START-TIME 0)) ; Time at which transfer began (DECLARE (SPECIAL K*OPERATION K*TTYFD K*VERBOSEP K*STATE K*PCKT-NUM K*NUMTRY K*SIZE K*FILE-CHARS K*START-TIME K*YOURMAXPACSIZ K*YOURTIME K*YOURPAD K*YOURPADCHAR K*YOUREOL K*YOURQUOTE K*EMPTY-PATHNAME K*BINQUOTE K*REPEAT K*SPACKET K*RPACKET K*BUFFER K*ARG1LIST K*ARG2LIST K*FILNAM K*RECFILNAM K*FP K*BUFILLBUF K*BUFILLPTR K*IGNORE-NEXT-LINEFEED K*SEND-TO-TTY K*BYTES-TRANSFERRED K*FILES-TRANSFERRED K*CANCEL K*ABORT-REASON K*PACKETS-TRANSFERRED K*PACKETS-RETRIED)) ; (CONDITION-CASE (K-ERROR) ; Setup error trap (PROGN ; First form is the body... (WHEN K*VERBOSEP ; Setup the KERMIT output window (INITIALIZE-STATUS-WINDOW) ; Initialize the status window (SEND *INFO-WINDOW* :CLEAR-WINDOW) ; Clear the Interactive window (SEND *KERMIT-FRAME* :SELECT)) ; Select and expose the entire frame (WHEN (EQL OPERATION :SET) ; If the SET operation was specified, (SETQ K*VERBOSEP NIL)) ; force quiet mode! (WHEN (NOT K*TTYFD) ; If no stream was supplied, make one. (SETQ K*TTYFD (SI:MAKE-SERIAL-STREAM))) ; Could use SI:*SERIAL-PORT-OWNER* ;; BAC (SEND K*TTYFD :CLEAR-INPUT) (SEND K*TTYFD :CLEAR-OUTPUT) (SETQ K*TTYFD-BITS ; Determine the number of data bits in the stream (SEND K*TTYFD :GET :NUMBER-OF-DATA-BITS)) (SETQ K*BINQUOTE ; Set the initial value for the 8-bit quote char (IF *IMAGE* ; Image mode? (IF (= K*TTYFD-BITS 8) ; - Yes, 8-bit? *ASCII-Y* ; -- Yes, set to Y *ASCII-AMP*) ; -- No, set to & *ASCII-N*)) ; - No, set to N (WHEN ARG1 ; If a filename was specified, (GET-NEXT-FILE)) ; Set K*FILNAM to the first in the list (UNWIND-PROTECT ; Surround entire selection in unwind-protect (SELECTQ OPERATION (:SEND ; Send command (IF K*FILNAM ; Required filename specified? (LET ; - Yes ((HOST-SPECIFIED? (STRING-SEARCH ":" K*RECFILNAM)) (PATH-RECFILNAM (FS:PARSE-PATHNAME K*RECFILNAM NIL K*EMPTY-PATHNAME))) (SETQ K*ARG1LIST (EXPAND-WILDS K*FILNAM)) ; Expand any wildcards in the filename (SETQ K*ARG2LIST ; expand the transfer name list (MAPCAR ; Map over each of the send files (FUNCTION ; replacing any wildcard components (LAMBDA (x) (LET ((EXPANDED-PATH (DEFAULT-ONLY-WILD-PATHNAME-COMPONENTS PATH-RECFILNAM x))) (IF HOST-SPECIFIED? EXPANDED-PATH (SEND EXPANDED-PATH :STRING-FOR-HOST))))) K*ARG1LIST)) (GET-NEXT-FILE) ; Get the file to process (SW *SINIT-STATE*)) ; - Yes, start with SINIT as initial state (PRINTMSG "~%~A" ; - No, setup error (SETQ K*ABORT-REASON "No file(s) specified")))) (:GET (IF K*FILNAM ; Required filename specified? (PROGN ; - Yes (SETQ K*FILNAM (CREATE-KERMIT-FILENAME K*FILNAM)) ; Make a suitable packet filename (SW *SGENERIC-STATE* #\R K*FILNAM)) ; SGENERIC is the initial state (PRINTMSG "~%~A" ; - No, setup error (SETQ K*ABORT-REASON "No file(s) specified")))) (:RECEIVE (SW *RINIT-STATE*)) ; Start with RINIT as initial state (:BYE (SW *SGENERIC-STATE* #\G "L")) ; SGENERIC is initial state (:FINISH (SW *SGENERIC-STATE* #\G "F")) ; SGENERIC is initial state (:SET (CHANGE-KERMIT-PARAMETERS)) (:LOG-BEGIN (IF K*FILNAM ; Required filename specified? (CONDITION-CASE (ERR) ; - Yes, try to open the logfile (PROGN (SETQ K*FILNAM ; Merge the filename with the home directory (SEND (FS:MERGE-PATHNAME-DEFAULTS K*FILNAM (USER-HOMEDIR-PATHNAME)) :STRING-FOR-PRINTING)) (SETQ *LOGFILE* ; Try to open the file (OPEN K*FILNAM :DIRECTION :OUTPUT :IF-EXISTS ':NEW-VERSION :IF-DOES-NOT-EXIST ':CREATE))) (ERROR ; If unable to merge the filename or open the file (PRINTMSG "~%~A" (SETQ K*ABORT-REASON (FORMAT NIL "~A: Error <~A> opening log file ~A" *KERMIT-NAME* (SEND ERR :REPORT-STRING) K*FILNAM)))) (:NO-ERROR (MULTIPLE-VALUE-BIND (SS MM HH DY MN YR) (GET-DECODED-TIME) (PRINTMSG "~%Begin logging at ~A:~A:~A ~A/~A/~A to file ~A" HH MM SS MN DY YR K*FILNAM)))) (PRINTMSG "~%~A" ; - No, filename not specified (SETQ K*ABORT-REASON "No log file name specified")))) (:LOG-END (IF *LOGFILE* ; Is there an open logfile? (PROGN ; - Yes (MULTIPLE-VALUE-BIND (SS MM HH DY MN YR) (GET-DECODED-TIME) (PRINTMSG "~%End logging to file ~A at ~A:~A:~A ~A/~A/~A~%" (SEND (SEND *LOGFILE* :TRUENAME) :STRING-FOR-PRINTING) HH MM SS MN DY YR)) (SEND *LOGFILE* :CLOSE) ; Close the file (SETQ *LOGFILE* NIL)) (PRINTMSG "~%~A" ; - No (SETQ K*ABORT-REASON (FORMAT NIL "~A: No log file was opened" *KERMIT-NAME*))))) (:SERVER (SW *RSERVER-STATE*)) ; RSERVER is initial state (:REMOTE-COPY (IF (AND K*FILNAM K*RECFILNAM) ; Required filenames specified? (SW *SGENERIC-STATE* ; - Yes, SGENERIC is initial state #\G ; Start with G packet (FORMAT NIL "K~C~A~C~A" ; Setup data packet (TOCHAR (LENGTH K*FILNAM)) K*FILNAM (TOCHAR (LENGTH K*RECFILNAM)) K*RECFILNAM)) (PRINTMSG "~%~A" ; - No, setup error (SETQ K*ABORT-REASON "Both files must be specified")))) (:REMOTE-CWD (SW *SGENERIC-STATE* ; SGENERIC is initial state #\G ; Start with G packet (FORMAT NIL "C~C~A" ; Setup data packet (TOCHAR (LENGTH K*FILNAM)) K*FILNAM))) (:REMOTE-DELETE (IF K*FILNAM ; Required filename specified? (SW *SGENERIC-STATE* ; - Yes, SGENERIC is initial state #\G ; Start with G packet (FORMAT NIL "E~C~A" ; Setup data packet (TOCHAR (LENGTH K*FILNAM)) K*FILNAM)) (PRINTMSG "~%~A" ; - No, setup error (SETQ K*ABORT-REASON "No file(s) specified")))) (:REMOTE-DIRECTORY (IF K*FILNAM ; Required filename specified? (SW *SGENERIC-STATE* ; - Yes, SGENERIC is initial state #\G ; Start with G packet (FORMAT NIL "D~C~A" ; Setup data packet (TOCHAR (LENGTH K*FILNAM)) K*FILNAM)) (PRINTMSG "~%~A" ; - No, setup error (SETQ K*ABORT-REASON "No file(s) specified")))) (:REMOTE-HELP (SW *SGENERIC-STATE* ; SGENERIC is initial state #\G ; Start with G packet (FORMAT NIL "H~C~A" ; Setup data packet (TOCHAR (LENGTH K*FILNAM)) K*FILNAM))) (:REMOTE-HOST (IF K*FILNAM ; Required command specified? (SW *SGENERIC-STATE* ; - Yes, SGENERIC is initial state #\C ; Start with C packet (FORMAT NIL "~A" ; Setup data packet K*FILNAM)) (PRINTMSG "~%~A" ; - No, setup error (SETQ K*ABORT-REASON "No command specified")))) (:REMOTE-KERMIT (IF K*FILNAM ; Required command specified? (SW *SGENERIC-STATE* ; - Yes, SGENERIC is initial state #\K ; Start with K packet (FORMAT NIL "~A" ; Setup data packet K*FILNAM)) (PRINTMSG "~%~A" ; - No, setup error (SETQ K*ABORT-REASON "No command specified")))) (:REMOTE-RENAME (IF (AND K*FILNAM K*RECFILNAM) ; Required filenames specified? (SW *SGENERIC-STATE* ; - Yes, SGENERIC is initial state #\G ; Start with G packet (FORMAT NIL "R~C~A~C~A" ; Setup data packet (TOCHAR (LENGTH K*FILNAM)) K*FILNAM (TOCHAR (LENGTH K*RECFILNAM)) K*RECFILNAM)) (PRINTMSG "~%~A" ; - No, setup error (SETQ K*ABORT-REASON "Both files must be specified")))) (:REMOTE-SET (IF (AND K*FILNAM K*RECFILNAM) ; Required parameters specified? (SW *SGENERIC-STATE* ; - Yes, SGENERIC is initial state #\G ; Start with G packet (FORMAT NIL "V~CS~C~A~C~A" ; Setup data packet (TOCHAR 1) (TOCHAR (LENGTH K*FILNAM)) K*FILNAM (TOCHAR (LENGTH K*RECFILNAM)) K*RECFILNAM)) (PRINTMSG "~%~A" ; - No, setup error (SETQ K*ABORT-REASON "Both variable and value must be specified")))) (:REMOTE-SHOW (IF K*FILNAM ; Required parameter specified? (SW *SGENERIC-STATE* ; - Yes, SGENERIC is initial state #\G ; Start with G packet (FORMAT NIL "V~CQ~C~A" ; Setup data packet (TOCHAR 1) (TOCHAR (LENGTH K*FILNAM)) K*FILNAM)) (PRINTMSG "~%~A" ; - No, setup error (SETQ K*ABORT-REASON "Variable must be specified")))) (:REMOTE-SPACE (SW *SGENERIC-STATE* ; SGENERIC is initial state #\G (FORMAT NIL "U~C~A" (TOCHAR (LENGTH K*FILNAM)) K*FILNAM))) (:REMOTE-TYPE (IF K*FILNAM ; Required filename specified? (SW *SGENERIC-STATE* ; - Yes, SGENERIC is initial state #\G ; Start with G packet (FORMAT NIL "T~C~A" ; Setup data packet (TOCHAR (LENGTH K*FILNAM)) K*FILNAM)) (PRINTMSG "~%~A" ; - No, setup error (SETQ K*ABORT-REASON "No file(s) specified")))) (:OTHERWISE ; Unknown command (PRINTMSG "~%~A" (SETQ K*ABORT-REASON "Invalid operation specified")))) (IF K*FP (SEND K*FP :CLOSE))) ; No matter what happened, close any opened file (WHEN K*VERBOSEP ; When not in quiet mode (PRINTMSG "~%KERMIT operation ~A ~A." OPERATION (IF K*ABORT-REASON "failed" "succeeded")) (WHEN K*FILES-TRANSFERRED (PRINTMSG "~%Files transferred: ~A." K*FILES-TRANSFERRED)) (PRINTMSG "~%Press any key or click on END to continue.") (SEND *INFO-WINDOW* :CLEAR-INPUT) ; Clear the input buffer (SEND *INFO-WINDOW* :ANY-TYI) ; Wait for a keypress or mouse blip (SEND *KERMIT-FRAME* :BURY)) ; Bury the Interactive window (IF K*ABORT-REASON (VALUES NIL K*FILES-TRANSFERRED K*ABORT-REASON) (VALUES T K*FILES-TRANSFERRED NIL))) ; (ERROR ; (PRINTMSG "~%~%ERROR: ~A" (SEND K-ERROR :REPORT-STRING)) ; (SIGNAL-CONDITION K-ERROR))) )) (DEFUN SW (STATE &OPTIONAL SPACK-TYPE SPACK-DATA) "This is the state table switcher for transferring files. It loops until either it finishes, or an error is encountered. The routines called by this function are responsible for returning a new state." (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*NUMTRY K*OPERATION K*VERBOSEP K*CANCEL K*FP K*ABORT-REASON)) (SETQ K*STATE STATE) ; Initialize the start state (SETQ K*CANCEL NIL) (SETQ K*PCKT-NUM 0) ; Initialize the packet number (SETQ K*NUMTRY 0) ; Say no tries yet (LOOP UNTIL (NOT K*STATE) DO (WHEN *DEBUG* (PRINTMSG "~%Function SW in state ~C" K*STATE)) (WHEN (>= K*NUMTRY *MYMAXTRY*) (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: No valid packet received after ~A retries." *KERMIT-NAME* K*NUMTRY))) (SETQ K*STATE *ABORT-STATE*) (SETQ K*NUMTRY 0)) (WHEN (AND K*VERBOSEP (NOT K*CANCEL)) ; When verbose and not already cancelled (SETQ K*CANCEL (SEND *INFO-WINDOW* :ANY-TYI-NO-HANG)) ; Get a char from the io buffer (IF ; Command menu blip? (AND (CONSP K*CANCEL) (EQ (FIRST K*CANCEL) :MENU)) (PROGN ; - Yes (SETQ K*CANCEL (GET (SECOND K*CANCEL) :VALUE)) ; Set the value of K*CANCEL (IF (STRING-EQUAL K*CANCEL "E") ; End requsted? (PROGN ; -- Yes (SETQ K*CANCEL NIL) ; Reset K*CANCEL (PRINTMSG "~%~A: END not valid here; ABORT or ABORT-SAVE first." *KERMIT-NAME*)) (PRINTMSG "~%~A" ; -- No, (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: User requested cancellation." *KERMIT-NAME*))))) (SETQ K*CANCEL NIL))) ; - No (SETQ K*STATE (SELECT K*STATE (*RDATA-STATE* (RDATA)) (*SDATA-STATE* (SDATA)) (*RINIT-STATE* (RINIT)) (*SINIT-STATE* (SINIT)) (*RFILE-STATE* (RFILE)) (*SFILE-STATE* (SFILE)) (*SEOF-STATE* (SEOF)) (*SBREAK-STATE* (SBREAK)) (*SGENERIC-STATE* (SGENERIC SPACK-TYPE SPACK-DATA)) (*SSERVER-STATE* (SSERVER)) (*RSERVER-STATE* (RSERVER)) (*COMPLETE-STATE* (IF (EQL K*OPERATION :SERVER) *RSERVER-STATE* NIL)) (*RCANCEL-STATE* (RCANCEL)) (*ABORT-STATE* (IF K*FP (SEND K*FP :CLOSE)) (IF (AND (EQL K*OPERATION :SERVER) (NOT K*CANCEL)) *RSERVER-STATE* NIL)) (:OTHERWISE NIL))))) (DEFUN SINIT () "Send-Initiate function to send this host's parameters and get other side's back." (DECLARE (SPECIAL K*YOUREOL K*STATE K*CANCEL K*PCKT-NUM K*YOURQUOTE K*ABORT-REASON K*SPACKET)) (SETQ K*PCKT-NUM 0) ; Initialize the packet number (IF K*CANCEL ; Cancelled? *ABORT-STATE* ; - Yes, abort (PROGN ; - No (SETQ K*SPACKET (SPAR K*SPACKET)) ; Fill up init info packet (SPACK #\S K*PCKT-NUM (LENGTH K*SPACKET) K*SPACKET) ; Send an S packet with type,number,length,packet (MULTIPLE-VALUE-BIND (TYPE LEN NUM PACKET) (RPACK) ; What was the reply? (SELECTQ TYPE ; (#\Y ; ACK... (IF (= K*PCKT-NUM NUM) ; Correct ACK? (PROGN ; - Yes (RPAR PACKET LEN) ; Get other side's init info (INCREMENT-PACKET-NUMBER) ; Bump packet count *SFILE-STATE*) ; OK, switch to SFILE-STATE K*STATE)) ; - No, stay in same K*STATE (#\N ; NAK (INCREMENT-RETRIES) ; Increment the retries K*STATE) ; stay in same state and try again (#\E ; Error packet received (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET))) *ABORT-STATE*) (NIL ; No packet received - timeout (INCREMENT-RETRIES) ; Increment the retries K*STATE) ; and try again (:OTHERWISE ; Received unknown packet - abort (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: Received unknown packet type <~A>." *KERMIT-NAME* TYPE))) *ABORT-STATE*)))))) (DEFUN SFILE () "Send File Header." (DECLARE (SPECIAL K*FP K*FILNAM K*RECFILNAM K*SPACKET K*STATE K*PCKT-NUM K*CANCEL K*SIZE K*SEND-TO-TTY K*ABORT-REASON)) (IF K*CANCEL ; Cancelled? *ABORT-STATE* ; - Yes (PROGN ; - No (WHEN (NOT K*FP) ; If file is not already open, (LET ((FILNAM ; Merge the filename with the home directory (SEND (FS:MERGE-PATHNAME-DEFAULTS K*FILNAM (USER-HOMEDIR-PATHNAME)) :STRING-FOR-PRINTING))) (WHEN *DEBUG* ; Print debugging info (PRINTMSG "~%Opening ~A for sending." FILNAM)) (CONDITION-CASE (ERR) (SETQ K*FP ; Try to open the file (OPEN FILNAM)) (ERROR ; Error in opening? (PRINTMSG "~%~A" ; Print error (SETQ K*ABORT-REASON (FORMAT NIL "~A: Error <~A> opening file ~A." *KERMIT-NAME* (SEND ERR :REPORT-STRING) FILNAM))) (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON) ; Send E packet (SETQ K*FP NIL))))) ; Be sure the pointer is not set (IF (NOT K*FP) ; Did we get an error opening the file? *ABORT-STATE* ; - Yes, abort (PROGN ; - No, setup the filename to send (SETQ K*RECFILNAM (IF K*SEND-TO-TTY ; Send to the other KERMIT'S tty? "" ; - Yes, don't worry about any transfer name (CREATE-KERMIT-FILENAME ; - No, convert the transfer name (IF K*RECFILNAM ; Was a transfer filename specified? K*RECFILNAM ; -- Yes, use it (SEND ; -- No, use the true open file name (SEND K*FP :TRUENAME) :STRING-FOR-PRINTING))))) (SETQ K*SIZE (ENCODE-PREFIXED-DATA K*RECFILNAM K*SPACKET)) (INITIALIZE-STATUS-COUNTS) ; Reset the timing info (PRINT-STATUS-FILE-INFO) ; update the filenames on the screen (PRINTMSG "~%Sending data...") (IF K*SEND-TO-TTY ; Are we sending to other KERMIT's TTY? (SPACK #\X K*PCKT-NUM K*SIZE K*SPACKET) ; - Yes, send an X packet (SPACK #\F K*PCKT-NUM K*SIZE K*SPACKET)) ; - No, send an F packet (MULTIPLE-VALUE-BIND (TYPE IGNORE NUM PACKET) (RPACK) ; What was the reply? (SELECTQ TYPE (#\Y ; ACK (IF (= NUM K*PCKT-NUM) ; See if it's correct ACK (PROGN ; - Yes, (INCREMENT-PACKET-NUMBER) ; Increment the packet count (SETQ K*SIZE (BUFILL K*SPACKET K*FP)) ; Get first data from file *SDATA-STATE*) ; Switch to DATA-STATE K*STATE)) ; - No, stay in same K*STATE (#\N ; NAK (IF (= (IF (> NUM 0 ) (1- NUM) 63) ; See if this is a NAK for the previous packet K*PCKT-NUM) (PROGN ; - Yes, so treat it as an ACK (INCREMENT-PACKET-NUMBER) ; Increment the packet count (SETQ K*SIZE (BUFILL K*SPACKET K*FP)) ; Get first data from file *SDATA-STATE*) ; Switch to SDATA-STATE (PROGN ; - No, (INCREMENT-RETRIES) ; increment the retries K*STATE))) ; Remain in same K*STATE (#\E ; Error packet received (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET)) (PRINTMSG "~%~A" K*ABORT-REASON) *ABORT-STATE*) (NIL ; Timeout (INCREMENT-RETRIES) ; Increment the retries K*STATE) ; Remain in same K*STATE (:OTHERWISE ; Unknown packet - abort (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: Received unknown packet type <~A>." *KERMIT-NAME* TYPE))) *ABORT-STATE*)))))))) (DEFUN SDATA () "Send File Data." (DECLARE (SPECIAL K*FP K*STATE K*PCKT-NUM K*SIZE K*CANCEL K*SPACKET K*ABORT-REASON)) (SPACK #\D K*PCKT-NUM K*SIZE K*SPACKET) ; Send a D packet (COUNT-AND-PRINT-PACKETS K*SIZE) ; Keep track of packet totals (MULTIPLE-VALUE-BIND (TYPE IGNORE NUM PACKET) (RPACK) ; What was the reply? (SELECTQ TYPE (#\Y ; ACK (IF (= NUM K*PCKT-NUM) ; See if it's correct ACK (PROGN ; - Yes, (INCREMENT-PACKET-NUMBER) ; Increment the packet count (SETQ K*SIZE (BUFILL K*SPACKET K*FP)) ; Get more data from the file (IF (OR (ZEROP K*SIZE) K*CANCEL) ; EOF or cancel flag? *SEOF-STATE* ; -- Yes, switch to SEOF-STATE *SDATA-STATE*)) ; -- No, stay in SDATA-STATE (PROGN ; - No (INCREMENT-RETRIES) ; Increment the retries K*STATE))) ; Stay in same K*STATE (#\N ; NAK (IF (= (IF (> NUM 0 ) (1- NUM) 63) ; See if it's a NAK for last packet K*PCKT-NUM) (PROGN ; - Yes, treat as ACK (INCREMENT-PACKET-NUMBER) ; Increment the packet count (SETQ K*SIZE (BUFILL K*SPACKET K*FP)) ; Get more date from the file (IF (OR (ZEROP K*SIZE) K*CANCEL) ; EOF or cancel flag? *SEOF-STATE* ; -- Yes, switch to SEOF-STATE *SDATA-STATE*)) ; -- No, stay in SDATA-STATE (PROGN ; - No (INCREMENT-RETRIES) ; Increment the retries K*STATE))) ; Stay in same K*STATE (#\E ; Error packet received (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET))) *ABORT-STATE*) (NIL ; Timeout (INCREMENT-RETRIES) ; Increment the retries K*STATE) ; Remain in same K*STATE (:OTHERWISE ; Unknown packet - abort (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: Received unknown packet type <~A>." *KERMIT-NAME* TYPE))) *ABORT-STATE*)))) (DEFUN SEOF () "Send End-Of-File." (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*FP K*FILNAM K*CANCEL K*ABORT-REASON)) (IF K*CANCEL ; Has cancellation been requested? (SPACK #\Z K*PCKT-NUM 1 "D") ; - Yes, send a Z packet with a D for Discard! (SPACK #\Z K*PCKT-NUM 0 NIL)) ; - No, send a Z packet to close (MULTIPLE-VALUE-BIND (TYPE IGNORE NUM PACKET) (RPACK) ; What was the reply? (SELECTQ TYPE (#\Y ; ACK (IF (= NUM K*PCKT-NUM) ; See if it's correct ACK (PROGN ; - Yes (INCREMENT-PACKET-NUMBER) ; Increment the packet count (PRINTMSG "~%Sending completed.") (SEND K*FP :CLOSE) ; Close the input file (SETQ K*FP NIL) ; Set flag indicating no file open (IF (GET-NEXT-FILE) ; Any more files? (PROGN ; -- Yes (IF *DEBUG* ; Print debugging info (PRINTMSG "~%New file is ~A." K*FILNAM)) *SFILE-STATE*) ; Switch to SFILE-STATE *SBREAK-STATE*)) ; -- No, Break (EOT) and all done (PROGN ; - No (INCREMENT-RETRIES) ; Increment the retries K*STATE))) ; Stay in same K*STATE (#\N ; NAK (IF (= (IF (> NUM 0 ) (1- NUM) 63) ; See if it's a NAK for last packet K*PCKT-NUM) (PROGN ; - Yes, treat as ACK (INCREMENT-PACKET-NUMBER) ; Increment the packet count (PRINTMSG "~%Sending completed.") (SEND K*FP :CLOSE) ; Close the input file (SETQ K*FP NIL) ; Set flag indicating no file open (IF (GET-NEXT-FILE) ; Any more files? (PROGN ; -- Yes, (IF *DEBUG* ; Print debugging info (PRINTMSG "~%New file is ~A." K*FILNAM)) *SFILE-STATE*) ; Switch to SFILE-STATE *SBREAK-STATE*)) ; -- No, Break (EOT) and all done (PROGN ; - No, (INCREMENT-RETRIES) ; Increment the retries K*STATE))) ; Stay in same K*STATE (#\E ; Error packet received (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET))) *ABORT-STATE*) (NIL ; Timeout (INCREMENT-RETRIES) ; Increment the retries K*STATE) ; Remain in same K*STATE (:OTHERWISE ; Unknown packet - abort (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: Received unknown packet type <~A>." *KERMIT-NAME* TYPE))) *ABORT-STATE*)))) (DEFUN SBREAK () "Send Break (EOT)." (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*ABORT-REASON)) (SPACK #\B K*PCKT-NUM 0 NIL) ; Send a B packet (MULTIPLE-VALUE-BIND (TYPE IGNORE NUM PACKET) (RPACK) ; What was the reply? (SELECTQ TYPE (#\Y ; ACK (IF (= NUM K*PCKT-NUM) ; See if it's correct ACK (PROGN ; - Yes (INCREMENT-PACKET-NUMBER) ; Increment the packet count *COMPLETE-STATE*) ; Switch to COMPLETE-STATE (PROGN ; - No (INCREMENT-RETRIES) ; Increment the retries K*STATE))) ; Stay in same K*STATE (#\N ; NAK (IF (= (IF (> NUM 0 ) (1- NUM) 63) ; See if it's a NAK for last packet K*PCKT-NUM) (PROGN ; - Yes, treat as ACK (INCREMENT-PACKET-NUMBER) ; Increment the packet count *COMPLETE-STATE*) ; Switch to COMPLETE-STATE (PROGN ; - No, (INCREMENT-RETRIES) ; Increment the retries K*STATE))) ; Stay in same K*STATE (#\E ; Error packet received (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET))) *ABORT-STATE*) (NIL ; Timeout (INCREMENT-RETRIES) ; Increment the retries K*STATE) ; Remain in same K*STATE (:OTHERWISE ; Unknown packet - abort (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: Received unknown packet type <~A>." *KERMIT-NAME* TYPE))) *ABORT-STATE*)))) (DEFUN RINIT () "Receive-Initiate function to receive other side's host's parameters and send ours back." (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*CANCEL K*ABORT-REASON)) (SETQ K*PCKT-NUM 0) ; Initialize the packet number (IF K*CANCEL ; Cancel? *ABORT-STATE* ; - Yes, abort (MULTIPLE-VALUE-BIND (TYPE LEN IGNORE PACKET) ; - No, get a packet (RPACK) (SELECTQ TYPE ; What type was it? (#\S ; Send-Init (RPAR PACKET LEN) ; Get other side's init info (SETQ PACKET (SPAR PACKET)) ; Fill up my init info packet (SPACK #\Y K*PCKT-NUM (LENGTH PACKET) PACKET) ; ACK with my parameters (INCREMENT-PACKET-NUMBER) ; Bump packet number *RFILE-STATE*) ; OK, enter File-Receive state (#\E ; Error packet received (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET))) *ABORT-STATE*) (NIL ; Didn't get a packet (SPACK #\N 0 0 NIL) ; Return a NAK (INCREMENT-RETRIES) ; Increment the retries K*STATE) ; and keep trying (:OTHERWISE ; Unknown packet (SPACK #\N K*PCKT-NUM 0 NIL) ; Return a NAK (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: Received unknown packet type <~A>." *KERMIT-NAME* TYPE))) *ABORT-STATE*))))) ; and abort (DEFUN RFILE () "Receive File Header." (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*FP K*RECFILNAM K*CANCEL K*VERBOSEP K*ABORT-REASON K*EMPTY-PATHNAME)) (IF K*CANCEL ; Cancel? *ABORT-STATE* ; - Yes, abort (MULTIPLE-VALUE-BIND (TYPE LEN NUM PACKET) ; - No... (RPACK) ; Get a packet (SELECTQ TYPE ; What was the type? (#\S ; Send-Init (IF (= NUM (IF (= K*PCKT-NUM 0) 63 (1- K*PCKT-NUM))) ; See if it's previous packet (PROGN ; - Yes (SETQ PACKET (SPAR PACKET)) ; Load in our Send-Init parameters (SPACK #\Y K*PCKT-NUM (LENGTH PACKET) PACKET) ; Send the ACK packet (INCREMENT-RETRIES) ; Increment the retries K*STATE) ; Stay in same state (PROGN ; - No, (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Otherwise set up error (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM))) *ABORT-STATE*))) ; abort (#\Z ; End-Of-File (IF (= NUM (IF (= K*PCKT-NUM 0) 63 (1- K*PCKT-NUM))) ; See if it's previous packet (PROGN ; - Yes (SPACK #\Y K*PCKT-NUM 0 NIL) ; Send the ACK packet (INCREMENT-RETRIES) ; Increment the retries K*STATE) ; Finally, stay in this K*STATE (PROGN ; - No (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Set up error (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM))) *ABORT-STATE*))) ; abort (#\F ; File Header (just what we want) (IF (= NUM K*PCKT-NUM) ; Correct packet number? (LET ; - Yes ((FILNAM (DECODE-PREFIXED-DATA PACKET LEN)) ; Decode the packet to get the filename (NEWFILNAM NIL)) (CONDITION-CASE (ERR) (PROGN (SETQ NEWFILNAM ; Determine the filename to use (SEND (FS:MERGE-PATHNAMES (FS:DEFAULT-WILD-PATHNAME-COMPONENTS (FS:PARSE-PATHNAME ; Make a pathname from the transfer name (IF K*RECFILNAM ; Transfer name specified? K*RECFILNAM ; -- Yes, use it "") ; -- No, use empty-string NIL K*EMPTY-PATHNAME) ; Merge with empty pathname (FS:PARSE-PATHNAME (CREATE-KERMIT-FILENAME FILNAM) ; Create a suitible filename from FILNAM NIL K*EMPTY-PATHNAME)) (USER-HOMEDIR-PATHNAME)) :STRING-FOR-PRINTING)) (SETQ K*FP ; Try to open the file (OPEN NEWFILNAM :DIRECTION :OUTPUT :IF-EXISTS ':NEW-VERSION :IF-DOES-NOT-EXIST ':CREATE))) (ERROR (PRINTMSG "~%~A" ; Print error (SETQ K*ABORT-REASON (FORMAT NIL "~A: Error <~A> while creating file." *KERMIT-NAME* (SEND ERR :REPORT-STRING)))) (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON) *ABORT-STATE*) ; abort (:NO-ERROR (INITIALIZE-STATUS-COUNTS) ; Reset the timing info (PRINT-STATUS-FILE-INFO) ; update the filenames on the screen (PRINTMSG "~%Receiving ~A as ~A." FILNAM NEWFILNAM) (SPACK #\Y K*PCKT-NUM (LENGTH NEWFILNAM) NEWFILNAM) ; ACKnowledge the file header (INCREMENT-PACKET-NUMBER) ; Bump packet count *RDATA-STATE*))) ; Switch to RDATA-STATE (PROGN ; - No, incorrect packet number (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Set up error (FORMAT NIL "~A: Received incorrect S packet number <~A>." *KERMIT-NAME* NUM))) *ABORT-STATE*))) ; abort (#\X ; Print to TTY (IF (= NUM K*PCKT-NUM) ; Correct packet number? (PROGN ; - Yes (SETQ K*FP ; Direct the output to the TTY (IF K*VERBOSEP *INFO-WINDOW* (MAKE-STRING-OUTPUT-STREAM))) (INITIALIZE-STATUS-COUNTS) ; Reset the timing info (PRINT-STATUS-FILE-INFO) ; update the filenames on the screen (PRINTMSG "~%Receiving ~A on screen.~%" PACKET) (SPACK #\Y K*PCKT-NUM 0 NIL) ; ACKnowledge the file header (INCREMENT-PACKET-NUMBER) ; Bump packet count *RDATA-STATE*) ; Switch to RDATA-STATE (PROGN ; - No (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Set up error (FORMAT NIL "~A: Received incorrect S packet number <~A>." *KERMIT-NAME* NUM))) *ABORT-STATE*))) ; abort (#\B ; Break transmission (EOT) (IF (= NUM K*PCKT-NUM) ; Correct packet number? (PROGN ; - Yes (SPACK #\Y K*PCKT-NUM 0 NIL) ; Say OK *COMPLETE-STATE*) ; Switch to COMPLETE-STATE (PROGN ; - No (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Set up error (FORMAT NIL "~A: Received incorrect S packet number <~A>." *KERMIT-NAME* NUM))) *ABORT-STATE*))) ; abort (#\E ; Error packet received (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET))) *ABORT-STATE*) (NIL ; Didn't get packet - timeout (SPACK #\N K*PCKT-NUM 0 NIL) ; Return a NAK (INCREMENT-RETRIES) ; Increment the retries K*STATE) ; Stay in same K*STATE and keep trying (:OTHERWISE ; Unknown packet - abort (SPACK #\N K*PCKT-NUM 0 NIL) ; Return a NAK (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: Received unknown packet type <~A>." *KERMIT-NAME* TYPE))) *ABORT-STATE*))))) (DEFUN RDATA () "Receive Data." (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*CANCEL K*ABORT-REASON K*FILE-CHARS K*FP)) (MULTIPLE-VALUE-BIND (TYPE LEN NUM PACKET) (RPACK) ; Get a packet (SELECTQ TYPE ; What was the type? (#\D ; Data packet (IF (= NUM K*PCKT-NUM) ; Correct packet number? (PROGN ; - Yes, (COUNT-AND-PRINT-PACKETS LEN) ; Keep track of packet totals (INCF K*FILE-CHARS (BUFEMP PACKET LEN K*FP)) ; Write the data to the file and increment total chars (IF K*CANCEL ; Should the transfer be interrupted? (PROGN ; -- Yes (SPACK #\Y K*PCKT-NUM 1 "Z") ; Send the ACK with cancel (INCREMENT-PACKET-NUMBER) ; Bump packet count *RCANCEL-STATE*) ; Switch to RCANCEL-STATE (PROGN ; -- No (SPACK #\Y K*PCKT-NUM 0 NIL) ; Send regular ACK (INCREMENT-PACKET-NUMBER) ; Bump packet count *RDATA-STATE*))) ; Remain in RDATA-STATE (PROGN ; - No, wrong packet number (IF (= NUM (IF (= K*PCKT-NUM 0) 63 (1- K*PCKT-NUM))) ; See if it's previous packet (PROGN ; -- Yes (SPACK #\Y K*PCKT-NUM 0 NIL) ; Send an ACK (INCREMENT-RETRIES) ; Increment the retries K*STATE) ; Finally, stay in this K*STATE so no data will be written (PROGN ; -- No (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Otherwise, set up error (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM))) *ABORT-STATE*))))) ; abort (#\F ; File header (IF (= NUM (IF (= K*PCKT-NUM 0) 63 (1- K*PCKT-NUM))) ; See if it's previous packet (PROGN ; - Yes (SPACK #\Y K*PCKT-NUM 0 NIL) ; Send ACK (INCREMENT-RETRIES) ; Increment the retries K*STATE) ; Finally, stay in this K*STATE (PROGN ; - No (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Otherwise, set up error (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM))) *ABORT-STATE*))) ; abort (#\X ; File header (IF (= NUM (IF (= K*PCKT-NUM 0) 63 (1- K*PCKT-NUM))) ; See if it's previous packet (PROGN ; - Yes (SPACK #\Y K*PCKT-NUM 0 NIL) ; Send ACK (INCREMENT-RETRIES) ; Increment the retries K*STATE) ; Finally, stay in this K*STATE (PROGN ; - No (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Set up error (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM))) *ABORT-STATE*))) ; abort (#\Z ; End-Of-File (IF (= NUM K*PCKT-NUM) ; Correct packet number? (PROGN ; - Yes (IF (AND (> LEN 0) ; (EQUAL (SUBSEQ PACKET 0 1) "D")) ; Is D specified? (PROGN ; -- Yes (IF (OR *SAVEFILES* ; Should the file be saved? e.g., is *SAVEFILES* true (STRING-EQUAL K*CANCEL "S")) ; or K*CANCEL save? (PROGN ; --- Yes (SEND K*FP :CLOSE) ; Close but save the file (PRINTMSG "~%Receive aborted - file saved.")) (PROGN ; --- No (SEND K*FP :CLOSE T) ; Close with abort (discard) (PRINTMSG "~%Receive aborted - file discarded.")))) (PROGN ; -- No (SEND K*FP :CLOSE) ; Close the file [NOTE IF SEND-TO-TTY must save stream BAC] (PRINTMSG "~%Receive completed - file closed."))) (SETQ K*FP NIL) ; Clear the file pointer (SPACK #\Y K*PCKT-NUM 0 NIL) ; Say OK (INCREMENT-PACKET-NUMBER) ; Bump packet count *RFILE-STATE*) ; Go back to Receive File K*STATE (PROGN ; - No (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Set up error (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM))) *ABORT-STATE*))) ; abort (#\E ; Error packet received (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET))) *ABORT-STATE*) (NIL ; Didn't get packet - timeout (SPACK #\N K*PCKT-NUM 0 NIL) ; Return a NAK (INCREMENT-RETRIES) ; Increment the retries K*STATE) ; Stay in same K*STATE and keep trying (:OTHERWISE ; Unknown packet - abort (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: Received unknown packet type <~A>." TYPE))) (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON) ; Send an error packet *ABORT-STATE*)))) (DEFUN RCANCEL () "We cancelled receive - now send an ERROR packet when we get a DATA packet." (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*CANCEL K*ABORT-REASON K*FP)) (MULTIPLE-VALUE-BIND (TYPE LEN NUM PACKET) (RPACK) ; Get a packet (SELECTQ TYPE ; What was the type? (#\D ; Data packet (IF (= NUM K*PCKT-NUM) ; Correct packet number? (PROGN ; - Yes (SEND K*FP :CLOSE T) ; Close with abort (discard) (PRINTMSG "~%Receive aborted - file discarded") (SETQ K*FP NIL) ; Clear the file pointer (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON) ; Send an error packet (INCREMENT-PACKET-NUMBER) ; Bump packet count (IF K*CANCEL ; Cancel all further transfers? (really not valid, since only Z supported) *ABORT-STATE* ; -- Yes, abort (PROGN ; -- No (SETQ K*CANCEL NIL) ; Reset K*CANCEL and *RFILE-STATE*))) ; switch to RFILE-STATE (PROGN ; - No, wrong packet number (IF (= NUM (IF (= K*PCKT-NUM 0) 63 (1- K*PCKT-NUM))) ; See if it's previous packet (PROGN ; -- Yes (SPACK #\Y K*PCKT-NUM 0 NIL) ; Send an ACK (INCREMENT-RETRIES) ; Increment the retries K*STATE) ; Finally, stay in this K*STATE so no data will be written (PROGN ; -- No (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Set up error (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM))) *ABORT-STATE*))))) ; abort (#\F ; File header (IF (= NUM (IF (= K*PCKT-NUM 0) 63 (1- K*PCKT-NUM))) ; See if it's previous packet (PROGN ; - Yes (SPACK #\Y K*PCKT-NUM 0 NIL) ; Send ACK (INCREMENT-RETRIES) ; Increment the retries K*STATE) ; Finally, stay in this K*STATE (PROGN ; - No (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; set up error (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM))) *ABORT-STATE*))) ; abort (#\X ; TTY (IF (= NUM (IF (= K*PCKT-NUM 0) 63 (1- K*PCKT-NUM))) ; See if it's previous packet (PROGN ; - Yes (SPACK #\Y K*PCKT-NUM 0 NIL) ; Send ACK (INCREMENT-RETRIES) ; Increment the retries K*STATE) ; Finally, stay in this K*STATE (PROGN ; - No (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Set up error (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM))) *ABORT-STATE*))) ; abort (#\Z ; End-Of-File (IF (= NUM K*PCKT-NUM) ; Correct packet number? (PROGN ; - Yes (IF (AND (> LEN 0) ; D specified to discard file? (EQUAL (SUBSEQ PACKET 0 1) "D")) (PROGN ; -- Yes (IF (OR *SAVEFILES* ; Should the file be saved? e.g., is *SAVEFILES* true (STRING-EQUAL K*CANCEL "S")) ; or K*CANCEL save? (PROGN ; --- Yes (SEND K*FP :CLOSE) ; Close but save the file (PRINTMSG "~%Receive aborted - file saved.")) (PROGN ; --- No (SEND K*FP :CLOSE T) ; Close with abort (discard) (PRINTMSG "~%Receive aborted - file discarded.")))) (PROGN ; -- No (SEND K*FP :CLOSE) ; Close the file [NOTE IF SEND-TO-TTY must save stream BAC] (PRINTMSG "~%Receive aborted - file ~A closed"))) (SETQ K*FP NIL) ; Clear the file pointer (SPACK #\Y K*PCKT-NUM 0 NIL) ; Say OK (INCREMENT-PACKET-NUMBER) ; Bump packet count (IF K*CANCEL ; Cancel all further transfers? (not needed, since only Z supported) *ABORT-STATE* ; -- Yes, abort (PROGN ; -- No (SETQ K*CANCEL NIL) ; reset K*CANCEL and *RFILE-STATE*))) ; switch to RFILE-STATE (PROGN ; - No, incorrect packet number (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Set up error (FORMAT NIL "~A: Received incorrect packet number <~A>." *KERMIT-NAME* NUM))) *ABORT-STATE*))) ; abort (#\E ; Error packet received (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET))) *ABORT-STATE*) (NIL ; Didn't get packet (SPACK #\N K*PCKT-NUM 0 NIL) ; Return a NAK (INCREMENT-RETRIES) ; Increment the retries K*STATE) ; Stay in same K*STATE and keep trying (:OTHERWISE ; Unknown packet - abort (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: Received unknown packet type <~A>." TYPE))) (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON) ; Send an error packet *ABORT-STATE*)))) (DEFUN SGENERIC (SPACK-TYPE &OPTIONAL SPACK-DATA) "Used for server commands expecting short response such as ACK. SPACK-TYPE should be a G, R or C packet type." (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*NUMTRY K*SPACKET K*VERBOSEP K*CANCEL K*SERVER-PACK-TYPE K*FP K*PACKETS-RETRIED K*ABORT-REASON)) (IF K*CANCEL ; Cancel? *ABORT-STATE* ; - Yes (PROGN ; - No (INITIALIZE-STATUS-COUNTS) ; Initialize the packet counts and timing (WHEN (EQL SPACK-TYPE #\G) ; When processing a Generic server command (ENCODE-PREFIXED-DATA SPACK-DATA K*SPACKET) ; Prefix encode the data (SETQ SPACK-DATA K*SPACKET)) (SPACK SPACK-TYPE 0 (LENGTH SPACK-DATA) SPACK-DATA) ; Send a G, R or C packet (MULTIPLE-VALUE-BIND (TYPE LEN NUM PACKET) (RPACK) ; What was the reply? (SELECTQ TYPE (#\S ; Send-Init (IF (ZEROP NUM) ; Packet number 0? (PROGN ; - Yes, (RPAR PACKET LEN) ; Get other side's init info (SETQ PACKET (SPAR PACKET)) ; Fill up my init info packet (SPACK #\Y K*PCKT-NUM (LENGTH PACKET) PACKET) ; ACK with my parameters (INCREMENT-PACKET-NUMBER) ; Bump packet number *RFILE-STATE*) ; OK, enter File-Receive state (PROGN ; - No (PRINTMSG "~%~A" ; setup error (SETQ K*ABORT-REASON (FORMAT NIL "~A: Received non-zero packet number <~A>." *KERMIT-NAME* NUM))) *ABORT-STATE*))) ; abort (#\X ; Text header (IF (ZEROP NUM) ; Correct packet number? ; maybe K*PCKT-NUM instead? ; BAC (PROGN ; - Yes (SETQ K*FP ; set the file pointer to (IF K*VERBOSEP ; either the info window or a string stream *INFO-WINDOW* (MAKE-STRING-OUTPUT-STREAM))) (PRINTMSG "~%Receiving ~A on the screen.~%" PACKET) (SPACK #\Y K*PCKT-NUM 0 NIL) ; ACKnowledge the file header (INCREMENT-PACKET-NUMBER) ; Bump packet count *RDATA-STATE*) ; switch to RDATA-STATE (PROGN ; - No (PRINTMSG "~%~A" ; setup error (SETQ K*ABORT-REASON (FORMAT NIL "~A: Received non-zero packet number <~A>." *KERMIT-NAME* NUM))) *ABORT-STATE*))) ; abort (#\N ; NAK (INCREMENT-RETRIES) ; Increment the retries K*STATE) ; Stay in same K*STATE (#\Y ; ACK (IF (ZEROP NUM) ; See if it's correct ACK (PROGN ; - Yes (PRINTMSG "~%~A" PACKET) ; print data on tty *COMPLETE-STATE*) ; Switch to COMPLETE-STATE (PROGN ; - No (PRINTMSG "~%~A" ; setup error (SETQ K*ABORT-REASON (FORMAT NIL "~A: Received non-zero packet number <~A>." *KERMIT-NAME* NUM))) *ABORT-STATE*))) ; abort (#\E ; Error packet received (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: Received error packet <~A>." *KERMIT-NAME* PACKET))) *ABORT-STATE*) (NIL ; Timeout (IF (AND (= SPACK-TYPE #\G) ; Did we just request (OR (EQUAL (SUBSEQ SPACK-DATA 0 1) "L") ; a remote logout (EQUAL (SUBSEQ SPACK-DATA 0 1) "F"))) ; or a remote finish? *COMPLETE-STATE* ; - Yes, the remote KERMIT will never respond so we're finished (PROGN ; - No (INCREMENT-RETRIES) ; Increment the retries K*STATE))) ; remain in same K*STATE (:OTHERWISE ; Unknown packet - abort (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: Received unknown packet type <~A>." TYPE))) *ABORT-STATE*)))))) (DEFUN SSERVER () "Used for server commands expecting large responses." (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*SPACKET K*CANCEL K*YOUREOL K*YOURQUOTE K*VERBOSEP K*FP K*ABORT-REASON)) (IF K*CANCEL ; Cancel? *ABORT-STATE* ; - Yes, so abort (PROGN ; - No (SETQ K*SPACKET (SPAR K*SPACKET)) ; Fill up init info packet (SPACK #\I K*PCKT-NUM (LENGTH K*SPACKET) K*SPACKET) ; Send an I packet with type,number,length,packet (MULTIPLE-VALUE-BIND (TYPE LEN NUM PACKET) (RPACK) ; What was the reply? (SELECTQ TYPE (#\Y ; ACK (IF (ZEROP NUM) ; Correct packet number (0)? (PROGN ; -- Yes (RPAR PACKET LEN) ; Get other side's init info *SGENERIC-STATE*) ; Move to SGENERIC-STATE (PROGN ; -- No (PRINTMSG "~%~A" ; setup error (SETQ K*ABORT-REASON (FORMAT NIL "~A: Received non-zero packet number <~A>." *KERMIT-NAME* NUM))) *ABORT-STATE*))) ; abort (#\N ; NAK (INCREMENT-RETRIES) ; Increment the retries K*STATE) ; Stay in same K*STATE (#\E ; Error packet received - use defaults - but how? ;; BAC *SGENERIC-STATE*) ; Switch to SGENERIC-STATE (NIL ; Timeout (INCREMENT-RETRIES) ; Increment the retries K*STATE) ; remain in same K*STATE (:OTHERWISE ; Unknown packet - abort (PRINTMSG "~%~A" (SETQ K*ABORT-REASON ; Save the error (FORMAT NIL "~A: Received unknown packet type <~A>." TYPE))) *ABORT-STATE*)))))) (DEFUN RSERVER () "Receive Server - This KERMIT in server mode, idle and waiting for a message." (DECLARE (SPECIAL K*STATE K*PCKT-NUM K*NUMTRY K*FILNAM K*SPACKET K*ABORT-REASON K*PACKETS-RETRIED K*CANCEL K*YOURMAXPACSIZ K*FP K*SEND-TO-TTY K*ARG1LIST)) (SETQ K*PCKT-NUM 0) ; Initialize the packet number (SETQ K*NUMTRY 0) ; Zero the number of tries - can't exceed maxtry in this state (SETQ K*ABORT-REASON "") ; Reset the abort reason string (INITIALIZE-STATUS-COUNTS) ; Initialize the packet counts and timing info (IF K*CANCEL ; Cancel? *ABORT-STATE* ; - Yes (MULTIPLE-VALUE-BIND (TYPE LEN NUM PACKET) ; - No (RPACK 900) ; Get a packet - wait 15 seconds (60 * 15) for it (SELECTQ TYPE (#\I ; INIT (IF (ZEROP NUM) ; Correct packet number (0)? (PROGN ; -- Yes (SPACK #\Y K*PCKT-NUM 0 NIL) ; Send ACK K*STATE) ; Stay in same K*STATE (PROGN ; -- No (PRINTMSG "~%~A" ; setup error (SETQ K*ABORT-REASON (FORMAT NIL "~A: Server received non-zero packet number <~A>." *KERMIT-NAME* NUM))) (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON) ; Send E packet K*STATE))) ; Stay in same K*STATE (#\S ; SEND-INIT (IF (ZEROP NUM) ; Correct packet number (0)? (PROGN ; -- Yes (RPAR PACKET LEN) ; Get other side's init info (SETQ PACKET (SPAR PACKET)) ; Fill up my init info packet (SPACK #\Y K*PCKT-NUM (LENGTH PACKET) PACKET) ; ACK with my parameters (INCREMENT-PACKET-NUMBER) ; Bump packet number *RFILE-STATE*) ; OK, enter File-Receive state (PROGN ; -- No (PRINTMSG "~%~A" ; setup error (SETQ K*ABORT-REASON (FORMAT NIL "~A: Server received non-zero packet number <~A>." *KERMIT-NAME* NUM))) (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON) K*STATE))) ; and stay in same K*STATE (#\R ; RECEIVE-INIT (IF (ZEROP NUM) ; Correct packet number (0)? (PROGN ; -- Yes (SETQ K*ARG1LIST (EXPAND-WILDS ; Expand any wildcards in the filename (DECODE-PREFIXED-DATA PACKET LEN))) ; Decode the packet to get the requested filename (GET-NEXT-FILE) ; Get the file to process *SINIT-STATE*) ; Proceed to SINIT-STATE (PROGN ; -- No (PRINTMSG "~%~A" ; setup error (SETQ K*ABORT-REASON (FORMAT NIL "~A: Server received non-zero packet number <~A>." *KERMIT-NAME* NUM))) (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON) K*STATE))) ; and stay in same K*STATE (#\K ; KERMIT command (IF (ZEROP NUM) ; Correct packet number (0)? (LET ((RESULT (PROCESS-KERMIT-COMMAND PACKET LEN))) (IF (OR K*FILNAM ; Filename specified for transfer? (> (LENGTH RESULT) ; or long reply? (FLOOR K*YOURMAXPACSIZ 1.5))) (PROGN ; - Yes (SETQ K*SEND-TO-TTY T) ; Set tty flag (WHEN (NOT K*FILNAM) (SETQ K*FP (MAKE-STRING-INPUT-STREAM RESULT))) *SINIT-STATE*) ; Go to SINIT-STATE (PROGN ; - No (SPACK #\Y K*PCKT-NUM (LENGTH RESULT) RESULT) ; ACK with the requested info K*STATE))) ; Stay in same state (PROGN ; -- No (PRINTMSG "~%~A" ; setup error (SETQ K*ABORT-REASON (FORMAT NIL "~A: Server received non-zero packet number <~A>." *KERMIT-NAME* NUM))) (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON) K*STATE))) ; Stay in same state (#\C ; HOST command (IF (ZEROP NUM) ; Correct packet number (0)? (LET ((RESULT (PROCESS-HOST-COMMAND PACKET LEN))) (IF (OR K*FILNAM ; Filename specified for tranfer? (> (LENGTH RESULT) ; or long reply? (FLOOR K*YOURMAXPACSIZ 1.5))) (PROGN ; - Yes (SETQ K*SEND-TO-TTY T) ; Set tty flag (WHEN (NOT K*FILNAM) (SETQ K*FP (MAKE-STRING-INPUT-STREAM RESULT))) *SINIT-STATE*) ; Go to SINIT-STATE (PROGN ; - No (SPACK #\Y K*PCKT-NUM (LENGTH RESULT) RESULT) ; ACK with the requested info K*STATE))) ; Stay in same state (PROGN ; -- No (PRINTMSG "~%~A" ; setup error (SETQ K*ABORT-REASON (FORMAT NIL "~A: Server received non-zero packet number <~A>." *KERMIT-NAME* NUM))) (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON) K*STATE))) ; Stay in same state (#\G ; GENERIC command (IF (ZEROP NUM) ; Correct packet number (0)? (LET ((RESULT (PROCESS-GENERIC-COMMAND PACKET LEN))) (IF (OR K*FILNAM ; Filename specified for tranfer? (> (LENGTH RESULT) ; or long reply? (FLOOR K*YOURMAXPACSIZ 1.5))) (PROGN ; - Yes (SETQ K*SEND-TO-TTY T) ; Set tty flag (WHEN (NOT K*FILNAM) (SETQ K*FP (MAKE-STRING-INPUT-STREAM RESULT))) *SINIT-STATE*) ; Go to SINIT-STATE (PROGN ; - No (SPACK #\Y K*PCKT-NUM (LENGTH RESULT) RESULT) ; ACK with the requested info K*STATE))) ; Stay in same state (PROGN ; -- No (PRINTMSG "~%~A" ; setup error (SETQ K*ABORT-REASON (FORMAT NIL "~A: Server received non-zero packet number <~A>." *KERMIT-NAME* NUM))) (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON) K*STATE))) ; Stay in same state (#\E ; Error packet received (PRINTMSG "~%~A" (SETQ K*ABORT-REASON (FORMAT NIL "~%~A: Received error packet <~A>." *KERMIT-NAME* PACKET))) K*STATE) ; Stay in same K*STATE (NIL ; Timeout (SPACK #\N 0 0 NIL) ; Return a NAK K*STATE) ; and keep trying (:OTHERWISE ; Unknown packet (PRINTMSG "~%~A" (SETQ K*ABORT-REASON (FORMAT NIL "~A: Server received unknown packet type <~A>." *KERMIT-NAME* TYPE))) (SPACK #\E K*PCKT-NUM (LENGTH K*ABORT-REASON) K*ABORT-REASON) ; Send E packet with an error message K*STATE))))) ;;; KERMIT utilities. (DEFUN SPACK (TYPE NUM LEN DATA) "Send a packet. Returns T." (DECLARE (SPECIAL K*BUFFER K*YOURPAD K*YOURPADCHAR K*YOUREOL K*TTYFD)) (SEND K*TTYFD :CLEAR-INPUT) ; clear the input buffer (LET ((IND 0) (CHECKSUM 0)) (DOTIMES (i K*YOURPAD) (SETF (AREF K*BUFFER i) K*YOURPADCHAR) ; Issue any padding (INCF IND)) (SETF (AREF K*BUFFER IND) *ASCII-SOH*) ; Packet marker, ASCII 1 SOH (INCF IND) ; Increment (SETF (AREF K*BUFFER IND) (TOCHAR (+ LEN 3))) ; Character count (INCF IND) ; Increment (SETQ CHECKSUM (TOCHAR (+ LEN 3))) ; Initialize the checksum (SETF (AREF K*BUFFER IND) (TOCHAR NUM)) ; Packet number (INCF IND) ; Increment (SETQ CHECKSUM (+ CHECKSUM (TOCHAR NUM))) ; Update checksum to include NUM (SETF (AREF K*BUFFER IND) TYPE) ; Packet type (INCF IND) ; Increment (SETQ CHECKSUM (+ CHECKSUM TYPE)) ; Update checksum to include TYPE (DOTIMES (i LEN) ; Loop for all data characters (SETF (AREF K*BUFFER IND) (AREF DATA i)) ; Get a character (INCF IND) ; Increment (SETQ CHECKSUM (+ CHECKSUM (AREF DATA i)))) ; Update checksum to include character (SETQ CHECKSUM (COMPUTE-FINAL-CHECKSUM CHECKSUM)) ; Compute final checksum (SETF (AREF K*BUFFER IND) (TOCHAR CHECKSUM)) ; Put it in the packet (INCF IND) ; Increment (SETF (AREF K*BUFFER IND) K*YOUREOL) ; Extra-packet line terminator (INCF IND) ; Increment (SETF (FILL-POINTER K*BUFFER) IND) ; Setup the length of the buffer (SEND K*TTYFD :STRING-OUT K*BUFFER 0 IND) ; Send the packet (WHEN *DEBUG* ; For Debugging display outgoing packet (PRINTMSG "~%SPACK: type=~A num=~D len=~D data=~S buffer=~S" type num len data K*BUFFER))) T) ; Finally, return T (DEFUN RPACK (&OPTIONAL (TIMEOUT (* *MYTIME* 60))) "Read a packet from the K*TTYFD stream. Returns values TYPE, LEN, NUM and DATA. :TYI-WITH-TIMEOUT added to Explorer serial stream. Optional timeout supplied to allow server mode to have longer timeouts." (DECLARE (SPECIAL K*TTYFD K*YOURMAXPACSIZ K*RPACKET)) (LET ((CCHECKSUM 0) (RCHECKSUM 0) (DATA-COUNT 0) (TYPE NIL) (LEN 0) (NUM 0) (READ-STATE 0)) (SETF (FILL-POINTER K*RPACKET) 0) ; Say no data in array yet (LOOP UNTIL (> READ-STATE 7) FOR T-CHAR = (SEND K*TTYFD :TYI-WITH-TIMEOUT TIMEOUT) WHEN (NULL T-CHAR) DO (SETQ READ-STATE 99) ELSE DO (WHEN (NOT *IMAGE*) ; If not in *IMAGE* mode, (SETQ T-CHAR (LOGAND T-CHAR #b1111111))) ; handle the parity - #b1111111 is #o177 (WHEN (= T-CHAR *ASCII-SOH*) ; If *ASCII-SOH* (SETQ READ-STATE 1)) ; resynchronize! (SELECTQ READ-STATE (0 ; Never had a Start Header NIL) ; Do nothing (1 ; Start Header (INCF READ-STATE)) ; ... on to next state (2 ; Length (SETQ CCHECKSUM T-CHAR) ; Start the checksum (SETQ LEN (- (UNCHAR T-CHAR) 3)) ; Character count (SETQ LEN (ABS LEN)) ; temp - must handle this BAC (WHEN (OR (> LEN K*YOURMAXPACSIZ) (< LEN 0)) ; BAC - carefull (SETQ TYPE NIL) ; Error in packet length (SETQ READ-STATE 99) ; Get out of loop! (PRINTMSG "~%RPACK: Error reading length <~A>~%" LEN)) (INCF READ-STATE)) ; ... on to the next state (3 ; Packet number (SETQ CCHECKSUM (+ CCHECKSUM T-CHAR)) ; Update checksum (SETQ NUM (UNCHAR T-CHAR)) ; Packet number (INCF READ-STATE)) ; ... on to the next state (4 ; Packet type (SETQ CCHECKSUM (+ CCHECKSUM T-CHAR)) ; Update checksum (SETQ TYPE (CODE-CHAR T-CHAR)) ; Packet type - make number into a character (IF (ZEROP LEN) ; Check for any data (SETQ READ-STATE 6) ; If no data, skip to checksum state (PROGN ; data ... (SETQ DATA-COUNT 0) ; set up DATA-COUNT for next state (INCF READ-STATE)))) ; ... on to the next state (5 ; Data characters (SETQ CCHECKSUM (+ CCHECKSUM T-CHAR)) ; Update checksum (SETF (AREF K*RPACKET DATA-COUNT) T-CHAR) ; Get a character (INCF DATA-COUNT) ; Increment the data count (WHEN (= DATA-COUNT LEN) ; If no more data characters (INCF READ-STATE))) ; ... on to the next state (6 ; Checksum (SETQ RCHECKSUM (UNCHAR T-CHAR)) ; Convert to numeric (SETQ CCHECKSUM (COMPUTE-FINAL-CHECKSUM CCHECKSUM)) ; Compute the checksum (WHEN (NOT (= CCHECKSUM RCHECKSUM)) ; If checksum is not ok, (SETQ TYPE NIL) ; indicate an error so that we'll loop again (WHEN *DEBUG* ; For debugging, print checksum errors (PRINTMSG "~%RPACK: Error comparing received checksum <~A> to computed checksum <~A> in packet number <~A>~%" RCHECKSUM CCHECKSUM NUM))) (SETF (AREF K*RPACKET LEN) 0) ; Mark the end of the data (SETF (FILL-POINTER K*RPACKET) LEN) ; (INCF READ-STATE)) ; ... on to the next state (7 ; EOL character - throw it away! (INCF READ-STATE)))) ; ... on to the next state DONE!!! (WHEN *DEBUG* ; For Debugging display incoming packet (PRINTMSG "~%RPACK: type=~A num=~D len=~D data=~A" TYPE NUM LEN K*RPACKET)) (VALUES TYPE LEN NUM K*RPACKET))) ; Return values (DEFUN BUFILL (BUFFER FILEPOINTER) "Fill a packet buffer with data from a file. Input parameters are the buffer in which to place the file data, and a file pointer from which to read the data. As a result of processing, BUFFER is filled and the position in FILEPOINTER is advanced. Returned value is the length of the buffer. K*BUFILLPTR and K*BUFILLBUF are used to buffer the file data for look-ahead processing." (DECLARE (SPECIAL K*BUFILLBUF K*BUFILLPTR K*YOURMAXPACSIZ K*YOURQUOTE K*REPEAT K*BINQUOTE K*FILE-CHARS)) (LET ((7-CHAR NIL) (8-CHAR NIL) (EOF NIL) (INDEX 0) (TMPBUFILLPTR NIL) (LENBUFILLBUF (LENGTH K*BUFILLBUF)) (ACTUALMAXPACSIZ (- K*YOURMAXPACSIZ 8)) (QUOTABLES (LIST K*YOURQUOTE (WHEN (NOT (= K*BINQUOTE *ASCII-N*)) K*BINQUOTE) (WHEN (NOT (= K*REPEAT *ASCII-SP*)) K*REPEAT)))) (LOOP UNTIL (OR (>= INDEX ACTUALMAXPACSIZ) EOF) ; Until we exceed length of the packet or are at EOF WHEN (= K*BUFILLPTR LENBUFILLBUF) ; When we run out of data in the buffer DO (SETQ K*BUFILLPTR 0) ; Reset the pointer (WHEN (ZEROP (SEND FILEPOINTER :STRING-IN NIL K*BUFILLBUF)) ; and get more (SETQ EOF T)) ; If no more, set EOF (SETQ LENBUFILLBUF (LENGTH K*BUFILLBUF)) ; Newly filled buffer so get the length ELSE DO (SETQ 8-CHAR (AREF K*BUFILLBUF K*BUFILLPTR)) ; Get the next character from the file buffer (INCF K*BUFILLPTR) ; Increment the pointer (INCF K*FILE-CHARS) ; Increment the total number of file chars read (WHEN (NOT (= K*REPEAT *ASCII-SP*)) ; If we have agreed to do repeat processing, (SETQ TMPBUFILLPTR K*BUFILLPTR) ; handle the repeat characters (LOOP ; Loop until UNTIL (OR (= TMPBUFILLPTR LENBUFILLBUF) ; either we run out of chars from the buffer (NOT (= 8-CHAR (AREF K*BUFILLBUF TMPBUFILLPTR)))) ; or we get one that's not equal to 8-char DO (INCF TMPBUFILLPTR)) (SETQ TMPBUFILLPTR (1+ (- TMPBUFILLPTR K*BUFILLPTR))) ; We repeat the char TMPBUFILLPTR times (WHEN (> TMPBUFILLPTR 3) ; If this is more than 3, do repeat prefixing! (WHEN (> TMPBUFILLPTR 94) (SETQ TMPBUFILLPTR 94)) ; Also, truncate the number of repeats to 94 (SETF (AREF BUFFER INDEX) K*REPEAT) ; Put repeat character in the packet (INCF INDEX) ; Increment (SETF (AREF BUFFER INDEX) (TOCHAR TMPBUFILLPTR)) ; Put my repeat count in the packet (INCF INDEX) ; Increment (SETQ K*BUFILLPTR (+ K*BUFILLPTR TMPBUFILLPTR -1)) ; adjust the buffer index for the next character (SETQ K*FILE-CHARS (+ K*FILE-CHARS TMPBUFILLPTR -1)))) ; Adjust the total file chars read (WHEN (AND (NOT (= K*BINQUOTE *ASCII-N*)) ; Handle 8-bit quoting (> 8-CHAR *ASCII-DEL*)) ; If the 8-bit char is > 127 (SETF (AREF BUFFER INDEX) K*BINQUOTE) ; Put K*BINQUOTE in buffer (INCF INDEX)) ; Increment (WHEN (NOT *IMAGE*) ; As long as we're not in image mode (SETQ 8-CHAR (CONVERT-TO-ASCII 8-CHAR))) ; force characters to ASCII (SETQ 7-CHAR (LOGAND 8-CHAR #b1111111)) ; Get low order 7 bits - #b1111111 is #o177 (WHEN (OR (< 7-CHAR *ASCII-SP*) ; Does char require special handling? (MEMBER 7-CHAR QUOTABLES) (= 7-CHAR *ASCII-DEL*)) (WHEN (AND (= 7-CHAR *ASCII-CR*) ; Map CR->CRLF when (NOT *IMAGE*)) ; not in image mode (SETF (AREF BUFFER INDEX) K*YOURQUOTE) ; Put K*YOURQUOTE in buffer (INCF INDEX) ; Increment (SETF (AREF BUFFER INDEX) (CTL *ASCII-CR*)) ; Put the character in buffer (INCF INDEX) ; Increment (SETQ 8-CHAR *ASCII-LF*) ; Replace the char with a linefeed (SETQ 7-CHAR (LOGAND 8-CHAR #b1111111))) ; Get low order 7 bits - #b1111111 is #o177 (SETF (AREF BUFFER INDEX) K*YOURQUOTE) ; Put K*YOURQUOTE in buffer (INCF INDEX) ; Increment (WHEN ; Make printable characters (NOT(MEMBER 7-CHAR QUOTABLES)) ; As long as it's not the active quote, binquote or repeat (SETQ 7-CHAR (CTL 7-CHAR)) (SETQ 8-CHAR (CTL 8-CHAR)))) (IF *IMAGE* (SETF (AREF BUFFER INDEX) 8-CHAR) (SETF (AREF BUFFER INDEX) 7-CHAR)) (INCF INDEX)) (SETF (FILL-POINTER BUFFER) INDEX) INDEX)) ; Return the index (DEFUN BUFEMP (BUFFER LEN FILEPOINTER) "Put data from an incoming packet buffer into a file. Input parameters are the packet, it's length, and a pointer to the file in which to store the data. As a result of processing, data is written to the file. This function returns the total number of characters written to the file." (DECLARE (SPECIAL K*IGNORE-NEXT-LINEFEED K*REPEAT K*BINQUOTE)) (LET (T-CHAR 7-CHAR REPEAT BINQUOTED (FILE-CHARS 0) (QUOTABLES (LIST *MYQUOTE* (WHEN (NOT (= K*BINQUOTE *ASCII-N*)) K*BINQUOTE) (WHEN (NOT (= K*REPEAT *ASCII-SP*)) K*REPEAT)))) (LOOP WITH IND = 0 UNTIL (= IND LEN) DO (SETQ T-CHAR (AREF BUFFER IND)) ; Get a character (SETQ REPEAT 1) (SETQ BINQUOTED NIL) (WHEN (AND (NOT (= K*REPEAT *ASCII-SP*)) (= T-CHAR K*REPEAT)) ; Is it the repeat prefix? (INCF IND) (SETQ REPEAT (UNCHAR (LOGAND (AREF BUFFER IND) #b1111111))) ; Get the repeat count (INCF IND) ; Increment (SETQ T-CHAR (AREF BUFFER IND))) ; Get next char (WHEN (AND (NOT (= K*BINQUOTE *ASCII-N*)) (= T-CHAR K*BINQUOTE)) ; Is it the binary quote prefix? (SETQ BINQUOTED T) ; flag it (INCF IND) (SETQ T-CHAR (AREF BUFFER IND))) ; Get next char (WHEN (= T-CHAR *MYQUOTE*) ; Control quote? (INCF IND) ; Increment (SETQ T-CHAR (AREF BUFFER IND)) ; Get the quoted character (SETQ 7-CHAR (LOGAND T-CHAR #b1111111)) ; and strip off the parity bit (WHEN (NOT (MEMBER 7-CHAR QUOTABLES)) ; Low order bits match active quote, binquote or repeat char? (SETQ T-CHAR (CTL T-CHAR)))) ; - No, uncontrollify it (WHEN BINQUOTED ; If the binary prefix was set (SETQ T-CHAR (LOGXOR T-CHAR #b10000000))) ; set the 8th bit (LOOP FOR I FROM 1 TO REPEAT ; Now do the repeat count processing DO (IF *IMAGE* ; Image mode? (PROGN ; - Yes (SEND FILEPOINTER :TYO T-CHAR) ; send the character (INCF FILE-CHARS)) ; Increment the total file chars written (PROGN ; - No, (SETQ T-CHAR (LOGAND T-CHAR #b1111111)) ; Strip off the parity bit (IF (AND (= T-CHAR *ASCII-LF*) ; Is it a linefeed K*IGNORE-NEXT-LINEFEED) ; after a CR? (SETQ K*IGNORE-NEXT-LINEFEED NIL) ; -- Yes, ignore the LF and clear the flag (PROGN ; -- No, (SETQ K*IGNORE-NEXT-LINEFEED ; setup the flag (IF (= T-CHAR *ASCII-CR*) T NIL)) ; T If it's a CR; otherwise NIL (SETQ T-CHAR (CONVERT-FROM-ASCII T-CHAR)) ; Convert the character (WHEN T-CHAR ; If it has an appropriate conversion, (SEND FILEPOINTER :TYO T-CHAR) ; Write char to the file (INCF FILE-CHARS))))))) ; Increment the total file chars written (INCF IND)) ; Increment the index FILE-CHARS)) ; Return the total number of chars written (DEFUN GET-NEXT-FILE () "Get next file in a file group. Returns NIL if no more files." (DECLARE (SPECIAL K*FILNAM K*RECFILNAM K*ARG1LIST K*ARG2LIST)) (SETQ K*FILNAM (CAR K*ARG1LIST)) ; Get the next file (SETQ K*ARG1LIST (CDR K*ARG1LIST)) ; Shorten the list (SETQ K*RECFILNAM (CAR K*ARG2LIST)) ; Get the next recfile (SETQ K*ARG2LIST (CDR K*ARG2LIST)) ; Shorten the list (WHEN (AND (STRINGP K*FILNAM) (ZEROP (LENGTH K*FILNAM))) ; If its an empty string, make it nil (SETQ K*FILNAM NIL)) (WHEN (AND (STRINGP K*RECFILNAM) (ZEROP (LENGTH K*RECFILNAM))) ; If its an empty string, make it nil (SETQ K*RECFILNAM NIL)) (WHEN *DEBUG* ; Print debugging info (PRINTMSG "~%Function GET-NEXT-FILE: k*filnam=~A k*recfilnam=~A k*arg1list=~A k*arg2list=~A" K*FILNAM K*RECFILNAM K*ARG1LIST K*ARG2LIST)) (IF K*FILNAM ; More files? T NIL)) (DEFUN SPAR (DATA) "Fill the data array with my send-init parameters. Returns the data array." (DECLARE (SPECIAL K*BINQUOTE K*REPEAT)) (SETF (FILL-POINTER DATA) 9) ; Set array length to 9 (SETF (AREF DATA 0) (TOCHAR *MYMAXPACSIZ*)) ; Biggest packet I can receive (SETF (AREF DATA 1) (TOCHAR *MYTIME*)) ; When I will time out (SETF (AREF DATA 2) (TOCHAR *MYPAD*)) ; How much padding I need (SETF (AREF DATA 3) (CTL *MYPADCHAR*)) ; Padding character I want (SETF (AREF DATA 4) (TOCHAR *MYEOL*)) ; End-Of-Line character I want (SETF (AREF DATA 5) *MYQUOTE*) ; Quote character I use (SETF (AREF DATA 6) K*BINQUOTE) ; 8-bit quote character I use (SETF (AREF DATA 7) *ASCII-1*) ; Only know how to do 1 char checksum (SETF (AREF DATA 8) K*REPEAT) ; Repeat count character I use DATA) (DEFUN RPAR (DATA LEN) "Read the data array to get the other host's send-init parameters. Returns the data array." (DECLARE (SPECIAL K*YOURMAXPACSIZ K*YOURTIME K*YOURPAD K*YOURPADCHAR K*YOUREOL K*YOURQUOTE K*BINQUOTE K*REPEAT K*STATE K*TTYFD-BITS)) (LET ((REPEAT 0) (BINQUOTE 0)) (WHEN (> LEN 0) (SETQ K*YOURMAXPACSIZ (UNCHAR (AREF DATA 0)))) ; Maximum send packet size (WHEN (> LEN 1) (SETQ K*YOURTIME (UNCHAR (AREF DATA 1)))) ; When you will time out (WHEN (> LEN 2) (SETQ K*YOURPAD (UNCHAR (AREF DATA 2)))) ; Number of pads to send (WHEN (> LEN 3) (SETQ K*YOURPADCHAR (CTL (AREF DATA 3)))) ; Padding character to send (WHEN (> LEN 4) (SETQ K*YOUREOL (UNCHAR (AREF DATA 4)))) ; EOL character to send (WHEN (> LEN 5) (SETQ K*YOURQUOTE (CHAR-CODE (AREF DATA 5)))) ; quote character to send (WHEN (> LEN 6) (SETQ K*BINQUOTE (CHAR-CODE (AREF DATA 6)))) ; 8-bit quote character to send (WHEN (> LEN 8) (SETQ REPEAT (CHAR-CODE (AREF DATA 8)))) ; Repeat character to send (WHEN *DEBUG* (PRINTMSG "~%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)) (IF (ZEROP K*YOURMAXPACSIZ) ; Is other KERMIT packet size unspecified? (SETQ K*YOURMAXPACSIZ *MYMAXPACSIZ*) ; - Yes, use our size (IF (< K*YOURMAXPACSIZ *MYMAXPACSIZ*) ; - No, is other KERMIT's smaller? (SETQ *MYMAXPACSIZ* K*YOURMAXPACSIZ))) ; -- Yes - we'll both use other KERMIT's (WHEN (ZEROP K*YOUREOL) ; Is other KERMIT EOL character unspecified? (SETQ K*YOUREOL *MYEOL*)) ; - Yes, use *MYEOL* (WHEN (ZEROP K*YOURQUOTE) ; Is other KERMIT quote character unspecified? (SETQ K*YOURQUOTE *MYQUOTE*)) ; - Yes, use *MYQUOTE* (IF (AND (= K*STATE *RINIT-STATE*) ; If we have never sent our parameters (= K*STATE *SGENERIC-STATE*) ; and are processing the other (= K*STATE *RSERVER-STATE*)) ; KERMIT's parameters first (e.g., he did the init) (PROGN ; - Yes, we never sent (COND ; Process the 8-bit quoting char ((AND ; If the other KERMIT has a valid 8-bit quote char... (OR (AND (> BINQUOTE 32) (< BINQUOTE 63)) (AND (> BINQUOTE 95) (< BINQUOTE 127))) (NOT (= BINQUOTE K*YOURQUOTE))) (SETQ K*BINQUOTE BINQUOTE)) ; use it ((= BINQUOTE *ASCII-Y*) ; If 8-bit quote char is a Y (IF *IMAGE* ; Are we in image mode? (IF (= K*TTYFD-BITS 8) ; -- Yes, do we have an 8-bit stream? (SETQ K*BINQUOTE *ASCII-N*) ; -- Yes, say no quoting (SETQ K*BINQUOTE *ASCII-AMP*)) ; -- No, say we'll quote with & (SETQ K*BINQUOTE *ASCII-N*))) ; -- No, not in image mode so don't do 8-bit (T ; Otherwise...say no 8-bit quoting (SETQ K*BINQUOTE *ASCII-N*))) (IF ; Process the repeat char (AND (OR (AND (> REPEAT 32) (< REPEAT 63)) ; Is it valid? (AND (> REPEAT 95) (< REPEAT 127))) (NOT (= REPEAT K*YOURQUOTE)) (NOT (= REPEAT K*BINQUOTE))) (SETQ K*REPEAT REPEAT) ; -- Yes, setup the repeat char (SETQ K*REPEAT *ASCII-SP*))) ; -- No...say no repeating (PROGN ; - No, our parameters have been sent (we did the init) (WHEN (AND (NOT (= BINQUOTE K*BINQUOTE)) ; Process the 8-bit quote char (NOT (= BINQUOTE *ASCII-Y*)) ; If it's not what we sent, and its not a Y (SETQ K*BINQUOTE *ASCII-N*))) ; say no 8-bit quoting (WHEN (NOT (= REPEAT K*REPEAT)) ; Process the repeat char - If it's not what we sent, (SETQ K*REPEAT *ASCII-SP*)))) ; say no repeating (WHEN *DEBUG* (PRINTMSG "~%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))) DATA) ; Finally, return DATA as the value of the function ;;; Support functions (DEFUN PROCESS-KERMIT-COMMAND (PACKET IGNORE) "Given a packet containing the command, try to process it. Return a flag indicating success or failure, and the response." (FORMAT NIL "~A: Unimplemented KERMIT server command <~A>." *KERMIT-NAME* PACKET)) (DEFUN PROCESS-HOST-COMMAND (PACKET IGNORE) "Process a host command. If an error is encountered, returns an error string." (LET ((RESULT NIL) (RESPONSE NIL)) (CONDITION-CASE (ERR) (SETQ RESPONSE (WITH-OUTPUT-TO-STRING (STANDARD-OUTPUT) ; Force the output to go to the string (SETQ RESULT (EVAL (READ-FROM-STRING PACKET))))) ; Evaluate the command (ERROR (SETQ RESPONSE (FORMAT NIL "~A: Error <~A> while processing HOST command <~A>." *KERMIT-NAME* (SEND ERR :REPORT-STRING) PACKET))) (:NO-ERROR (FORMAT NIL "~A~A" RESPONSE RESULT))))) ; Just return the response (DEFUN PROCESS-GENERIC-COMMAND (PACKET LEN) "Generic Kermit Command. Single character in data field (possibly followed by operands, shown in {braces}, optional fields in [brackets]): I Login [{*user[*password[*account]]}] C CWD, Change Working Directory [{*directory[*password]}] L Bye (Logout) * F Finish (Shut down the server, but don't logout). * D Directory [{*filespec}] * U Disk Space Query (Usage) [{*area}] * E Delete (Erase) {*filespec} * T Type {*filespec} * R Rename {*oldname*newname} * K Copy {*source*destination} * W Who's logged in? (Finger) [{*user ID or network host[*options]}] M Send a short Message {*destination*text} H Help [{*topic}] * Q Server Status Query P Program {*[program-filespec][*program-commands]} J Journal {*command[*argument]} V Variable {*command[*argument[*argument]]}" (DECLARE (SPECIAL K*FILNAM K*CANCEL)) (LET ((COMD NIL) (ARGS (DECODE-PREFIXED-DATA PACKET LEN)) ; Decode the data (ARG1 NIL) (ARG2 NIL) (ARG3 NIL) (LNTH 0) (INDX 0) (DIR NIL)) (SETQ COMD (SUBSEQ ARGS 0 1)) (INCF INDX) (WHEN (< INDX (LENGTH ARGS)) ; Get the first argument (SETQ LNTH (UNCHAR (COERCE (SUBSEQ ARGS INDX (1+ INDX)) 'CHARACTER))) (INCF INDX) (SETQ ARG1 (SUBSEQ ARGS INDX (+ INDX LNTH))) (INCF INDX LNTH) (WHEN (< INDX (LENGTH ARGS)) ; Get the second argument (SETQ LNTH (UNCHAR (COERCE (SUBSEQ ARGS INDX (1+ INDX)) 'CHARACTER))) (INCF INDX) (SETQ ARG2 (SUBSEQ ARGS INDX (+ INDX LNTH))) (INCF INDX LNTH) (WHEN (< INDX (LENGTH ARGS)) ; Get the third argument (SETQ LNTH (UNCHAR (COERCE (SUBSEQ ARGS INDX (1+ INDX)) 'CHARACTER))) (INCF INDX) (SETQ ARG3 (SUBSEQ ARGS INDX (+ INDX LNTH))) (INCF INDX LNTH)))) (COND ((EQUAL COMD "D") (GENERIC-DIRECTORY ARG1)) ((EQUAL COMD "E") (GENERIC-DELETE ARG1)) ((EQUAL COMD "F") (SETQ K*CANCEL "Z")) ((EQUAL COMD "K") (GENERIC-COPY ARG1 ARG2)) ((EQUAL COMD "Q") (GENERIC-STATUS)) ((EQUAL COMD "R") (GENERIC-RENAME ARG1 ARG2)) ((EQUAL COMD "T") (SETQ K*FILNAM ARG1)) ((EQUAL COMD "U") (GENERIC-DISK-USAGE ARG1)) ((EQUAL COMD "W") (GENERIC-WHO)) (T (FORMAT NIL "~A: Unimplemented server GENERIC command <~A>" *KERMIT-NAME* COMD))))) (DEFUN GENERIC-COPY (FILE1 FILE2) "Copies FILE1 to FILE2. If an error is encountered, returns an error string." (LET ((F1 (MERGE-PATHNAMES FILE1 (USER-HOMEDIR-PATHNAME))) (F2 (MERGE-PATHNAMES FILE2 (USER-HOMEDIR-PATHNAME))) (RESPONSE NIL)) (CONDITION-CASE (ERR) (COPY-FILE F1 F2 :CREATE-DIRECTORIES T) (ERROR (SETQ RESPONSE (FORMAT NIL "~A: Error <~A> while processing GENERIC COPY command." *KERMIT-NAME* (SEND ERR :REPORT-STRING)))) (:NO-ERROR (SETQ RESPONSE (FORMAT NIL "FIle ~A copied to ~A." F1 F2)))))) (DEFUN GENERIC-RENAME (FILE1 FILE2) "Renames FILE1 to FILE2. If an error is encountered, returns an error string." (LET ((F1 (MERGE-PATHNAMES FILE1 (USER-HOMEDIR-PATHNAME))) (F2 (MERGE-PATHNAMES FILE2 (USER-HOMEDIR-PATHNAME))) (RESPONSE NIL)) (CONDITION-CASE (ERR) (RENAME-FILE F1 F2) (ERROR (SETQ RESPONSE (FORMAT NIL "~A: Error <~A> while processing GENERIC RENAME command." *KERMIT-NAME* (SEND ERR :REPORT-STRING)))) (:NO-ERROR (SETQ RESPONSE (FORMAT NIL "FIle ~A renamed to ~A." F1 F2)))))) (DEFUN GENERIC-DELETE (FILE1) "Deletes FILE1. If an error is encountered, returns an error string." (LET ((F1 (MERGE-PATHNAMES FILE1 (USER-HOMEDIR-PATHNAME))) (RESPONSE NIL)) (CONDITION-CASE (ERR) (DELETE-FILE F1) (ERROR (SETQ RESPONSE (FORMAT NIL "~A: Error <~A> while processing GENERIC DELETE command." *KERMIT-NAME* (SEND ERR :REPORT-STRING)))) (:NO-ERROR (SETQ RESPONSE (FORMAT NIL "FIle ~A deleted." F1)))))) (DEFUN GENERIC-DIRECTORY (&OPTIONAL DIRECTORY-NAME) "Returns a string containing the contents of current directory or directory-name. If an error is encountered, returns an error string." (LET ((DIR NIL) (RESPONSE NIL)) (CONDITION-CASE (ERR) (SETQ DIR (FS:DIRECTORY-LIST (MERGE-PATHNAMES (IF DIRECTORY-NAME DIRECTORY-NAME (USER-HOMEDIR-PATHNAME)) "*.*#*"))) (ERROR ; If unable to get the directory-list (SETQ RESPONSE (FORMAT NIL "~A: Error <~A> while processing GENERIC DIRECTORY command." *KERMIT-NAME* (SEND ERR :REPORT-STRING)))) (:NO-ERROR (SETQ RESPONSE (FORMAT NIL "Directory listing for ~A~%~A~%~:{~A~35T~@8A (~A)~51T~A~73T~A~%~}" (SEND (GET (CAR DIR) :PATHNAME) :STRING-FOR-PRINTING) (GET (CAR DIR) :DISK-SPACE-DESCRIPTION) (MAPCAR (FUNCTION (LAMBDA (flist) (LIST (SEND (CAR flist) :STRING-FOR-DIRED) (GET flist :LENGTH-IN-BYTES) (GET flist :BYTE-SIZE) (MULTIPLE-VALUE-BIND (SS MM HH DY MN YEAR) (DECODE-UNIVERSAL-TIME (GET flist :CREATION-DATE)) (FORMAT NIL "~A/~A/~A~11T~A:~A:~A" MN DY YEAR HH MM SS)) (GET flist :AUTHOR)))) (CDR DIR)))))))) (DEFUN GENERIC-DISK-USAGE (&OPTIONAL DIRECTORY-NAME) "Returns a string containing the disk-usage of current directory or directory-name. If an error is encountered, returns an error string." (LET ((DIR NIL) (RESPONSE NIL)) (CONDITION-CASE (ERR) (SETQ DIR (FS:DIRECTORY-LIST (MERGE-PATHNAMES (IF DIRECTORY-NAME DIRECTORY-NAME (USER-HOMEDIR-PATHNAME)) "*.*#*"))) (ERROR ; If unable to get the directory-list (SETQ RESPONSE (FORMAT NIL "~A: Error <~A> while processing GENERIC DISK-USAGE command." *KERMIT-NAME* (SEND ERR :REPORT-STRING)))) (:NO-ERROR (SETQ RESPONSE (GET (CAR DIR) :DISK-SPACE-DESCRIPTION)))))) (DEFUN GENERIC-STATUS () "Returns a string containing the status of the current Kermit environment." (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*)) (DEFUN GENERIC-WHO () "Returns a string describing who's logged on each machine on the network." (LET ((STREAM (MAKE-STRING-OUTPUT-STREAM))) ; make an output stream for FINGER-LISPMS to write to (CHAOS:FINGER-LISPMS STREAM) (GET-OUTPUT-STREAM-STRING STREAM))) (DEFUN CHANGE-KERMIT-PARAMETERS () "Change local operating parameters" (LET ((IMAGE *IMAGE*) (DEBUG *DEBUG*) (MORE *MORE*) (MYMAXTRY *MYMAXTRY*) (MYMAXPACSIZ *MYMAXPACSIZ*) (MYTIME *MYTIME*) (MYPAD *MYPAD*) (MYPADCHAR *MYPADCHAR*) (MYEOL *MYEOL*) (MYQUOTE *MYQUOTE*) (FILNAMCNV *FILNAMCNV*) (SAVEFILES *SAVEFILES*) (RESET NIL)) (DECLARE (SPECIAL IMAGE DEBUG MORE MYMAXTRY MYMAXPACSIZ MYTIME MYPAD MYPADCHAR MYEOL MYQUOTE FILNAMCNV SAVEFILES RESET)) (*CATCH 'QUIT-CVV (TV:CHOOSE-VARIABLE-VALUES '((IMAGE "Image Mode " :DOCUMENTATION "YES: Send file as 8-bit data. NO: Send file as ASCII characters." :BOOLEAN) (DEBUG "Debug Mode " :DOCUMENTATION "YES: Print debugging information. NO: Do not print debugging information." :BOOLEAN) (MORE "More Processing " :DOCUMENTATION "YES: Enable **MORE** in the KERMIT window. NO: Do not use **MORE**." :BOOLEAN) "" (MYMAXTRY "Maximum tries " :DOCUMENTATION "Maximum number of times to retry a packet" :NUMBER) (MYMAXPACSIZ "Maximum packet size " :DOCUMENTATION "Maximum packet size - must not be greater than 94" :NUMBER) (MYTIME "Timeout seconds " :DOCUMENTATION "Number of seconds after which I should be timed out" :NUMBER) (MYPAD "Number of pad characters " :DOCUMENTATION "Number of padding characters to use" :NUMBER) (MYPADCHAR "Padding character " :DOCUMENTATION "Padding character to use - enter the character number" :NUMBER) (MYEOL "EOL character " :DOCUMENTATION "End-Of-Line character to use - enter the character number" :NUMBER) (MYQUOTE "Quote character " :DOCUMENTATION "Quote character to use - enter the character number" :NUMBER) "" (FILNAMCNV "Filename conversion " :DOCUMENTATION "YES: Convert filenames to name.type format. NO: Do not convert filenames." :BOOLEAN) (SAVEFILES "Save partial files " :DOCUMENTATION "YES: Save partially received file if transfer is interrupted. NO: Delete the file." :BOOLEAN) "" (RESET "Reset parameters " :DOCUMENTATION "YES: Immediately reset parameters to default values. NO: Use current parameter values." :BOOLEAN)) :NEAR-MODE '(:POINT 500 400) :WIDTH 50 :LABEL "Change Parameters" :MARGIN-CHOICES '("Do It" ("Quit" (*THROW 'QUIT-CVV T)))) (SETQ *IMAGE* IMAGE) (SETQ *DEBUG* DEBUG) (SETQ *MORE* MORE) (SETQ *MYMAXTRY* MYMAXTRY) (SETQ *MYMAXPACSIZ* MYMAXPACSIZ) (SETQ *MYTIME* MYTIME) (SETQ *MYPAD* MYPAD) (SETQ *MYPADCHAR* MYPADCHAR) (SETQ *MYEOL* MYEOL) (SETQ *MYQUOTE* MYQUOTE) (SETQ *FILNAMCNV* FILNAMCNV) (SETQ *SAVEFILES* SAVEFILES)) (WHEN RESET ; If these values are changed, change in DEFVAR as well (SETQ *IMAGE* NIL) (SETQ *DEBUG* NIL) (SETQ *MORE* NIL) (SETQ *MYMAXTRY* 10) (SETQ *MYMAXPACSIZ* 94) (SETQ *MYTIME* 10) (SETQ *MYPAD* 0) (SETQ *MYPADCHAR* 0) (SETQ *MYEOL* *ASCII-CR*) (SETQ *MYQUOTE* *ASCII-NS*) (SETQ *FILNAMCNV* T) (SETQ *SAVEFILES* NIL)) (SEND *INFO-WINDOW* :SET-MORE-P *MORE*))) ; Set in window ;;; Kermit printing routines: (DEFUN PRINTMSG (MSG-CTL-STRING &OPTIONAL &REST ARGS) "Print message on standard output if in verbose mode." (DECLARE (SPECIAL K*VERBOSEP K*ERROR-MESSAGE)) (WHEN K*VERBOSEP ; When verbose, (APPLY 'FORMAT *INFO-WINDOW* MSG-CTL-STRING ARGS)) ; print to the window. (WHEN *LOGFILE* ; If a logfile has been specified, (APPLY 'FORMAT *LOGFILE* MSG-CTL-STRING ARGS))) ; write to the file. (DEFUN INCREMENT-PACKET-NUMBER () "Increments packet number by +1 but resets after 63. Also zeros K*NUMTRY." (DECLARE (SPECIAL K*PCKT-NUM K*NUMTRY)) (SETQ K*PCKT-NUM (IF (< K*PCKT-NUM 63) (1+ K*PCKT-NUM) 0)) (SETQ K*NUMTRY 0)) (DEFUN INCREMENT-RETRIES () "Increments the number of retries." (DECLARE (SPECIAL K*NUMTRY K*PACKETS-RETRIED)) (INCF K*NUMTRY) ; Increment the retries (INCF K*PACKETS-RETRIED)) ; Increment the total retries (DEFUN INITIALIZE-STATUS-COUNTS () "Initialize the status counting for packet numbers and transfer times." (DECLARE (SPECIAL K*PACKETS-TRANSFERRED K*PACKETS-RETRIED K*BYTES-TRANSFERRED K*FILE-CHARS K*START-TIME)) (SETQ K*PACKETS-TRANSFERRED 0) ; Initialize total packet count (SETQ K*PACKETS-RETRIED 0) ; Initialize total retry count (SETQ K*BYTES-TRANSFERRED 0) ; Reset the bytes transferred counter (SETQ K*FILE-CHARS 0) ; Reset the total file chars (SETQ K*START-TIME (TIME))) ; Save the current internal time in 60ths of a second (DEFUN COUNT-AND-PRINT-PACKETS (PACKET-LENGTH) ; called in RDATA and SDATA "Increment total packet count and print totals." (DECLARE (SPECIAL K*PACKETS-TRANSFERRED K*BYTES-TRANSFERRED K*VERBOSEP)) (INCF K*PACKETS-TRANSFERRED) (INCF K*BYTES-TRANSFERRED PACKET-LENGTH) (WHEN K*VERBOSEP (PRINT-STATUS-PACKET-INFO))) (DEFUN INITIALIZE-STATUS-WINDOW () (DECLARE (SPECIAL K*OPERATION)) (SEND *STATUS-WINDOW* :CLEAR-WINDOW) (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) (TV:TURN-OFF-SHEET-BLINKERS *STATUS-WINDOW*)) (DEFUN PRINT-STATUS-PACKET-INFO () (DECLARE (SPECIAL K*OPERATION K*FILNAM K*RECFILNAM K*PACKETS-TRANSFERRED K*BYTES-TRANSFERRED K*FILE-CHARS K*START-TIME K*PACKETS-RETRIED)) (LET ((TIME-DIFF (MAX 1 (FLOOR (TIME-DIFFERENCE (TIME) K*START-TIME) 60)))) (SEND *STATUS-WINDOW* :SET-CURSORPOS 82 1 :CHARACTER) (SEND *STATUS-WINDOW* :CLEAR-STRING " ") (FORMAT *STATUS-WINDOW* "~5A/~@5A" (FLOOR K*BYTES-TRANSFERRED TIME-DIFF) (FLOOR K*FILE-CHARS TIME-DIFF)) (SEND *STATUS-WINDOW* :SET-CURSORPOS 82 2 :CHARACTER) (SEND *STATUS-WINDOW* :CLEAR-STRING " ") (FORMAT *STATUS-WINDOW* "~A" K*PACKETS-TRANSFERRED) (SEND *STATUS-WINDOW* :SET-CURSORPOS 82 3 :CHARACTER) (SEND *STATUS-WINDOW* :CLEAR-STRING " ") (FORMAT *STATUS-WINDOW* "~A" K*PACKETS-RETRIED))) (DEFUN PRINT-STATUS-FILE-INFO () (DECLARE (SPECIAL K*VERBOSEP K*FILNAM K*RECFILNAM)) (WHEN K*VERBOSEP (SEND *STATUS-WINDOW* :SET-CURSORPOS 27 2 :CHARACTER) (SEND *STATUS-WINDOW* :CLEAR-STRING " ") (FORMAT *STATUS-WINDOW* "~A" (IF K*FILNAM K*FILNAM "")) (SEND *STATUS-WINDOW* :SET-CURSORPOS 27 3 :CHARACTER) (SEND *STATUS-WINDOW* :CLEAR-STRING " ") (FORMAT *STATUS-WINDOW* "~A" (IF K*RECFILNAM K*RECFILNAM "")))) (DEFUN CREATE-KERMIT-FILENAME (FILENAME) "Create a filename sutable for sending to another machine. Return file.type" (IF *FILNAMCNV* (LET* ((PATHNAME (FS:PARSE-PATHNAME FILENAME)) (NAME (SEND PATHNAME :NAME)) (TYPE (SEND PATHNAME :TYPE))) (IF (EQ NAME ':WILD) (SETQ NAME "*") (IF (EQ NAME ':UNSPECIFIC) (SETQ NAME "") (UNLESS (STRINGP NAME) (SETQ NAME "")))) (IF (EQ TYPE ':WILD) (SETQ TYPE "*") (IF (EQ TYPE ':UNSPECIFIC) (SETQ TYPE "") (UNLESS (STRINGP TYPE) (SETQ TYPE "")))) (FORMAT NIL "~A.~A" NAME TYPE)) FILENAME)) (DEFUN ENCODE-PREFIXED-DATA (DATA BUFFER) "Decode string of data by passing it through BUFILL. Inputs are a string of data and a buffer to fill. Returned value is the size of the buffer." (DECLARE (SPECIAL K*BUFILLBUF K*BUFILLPTR)) (LET ((SIZE 0)) (WHEN ; As long as noone is using BUFILL already... (AND (ZEROP (FILL-POINTER K*BUFILLBUF)) (ZEROP K*BUFILLPTR)) (SETQ SIZE (BUFILL BUFFER (MAKE-STRING-INPUT-STREAM DATA))) ; Use BUFILL to encode the data (SETQ K*BUFILLPTR 0) ; Reset the BUFILL pointer (SETF (FILL-POINTER K*BUFILLBUF) 0) ; Clear the BUFILL buffer SIZE))) ; Return the SIZE of the buffer (DEFUN DECODE-PREFIXED-DATA (PACKET LEN) "Decode a packet of data by passing it through BUFEMP. Inputs are a packet and length. Returned value is the decoded string." (LET ((FILE (MAKE-STRING-OUTPUT-STREAM))) ; Make a temporary output stream for BUFEMP (BUFEMP PACKET LEN FILE) ; Use BUFEMP to decode the data (GET-OUTPUT-STREAM-STRING FILE))) ; Get the decoded data (DEFUN EXPAND-WILDS (FILE-NAME) "Expand wildcards in a filename. Returns a list of expanded filenames." (LET ((DIR NIL) (RESPONSE NIL)) (CONDITION-CASE (ERR) (SETQ DIR (FS:DIRECTORY (MERGE-PATHNAMES FILE-NAME "FOO.BAR#>"))) (ERROR ; If unable to get the directory due to error (SETQ RESPONSE ; such as invalid host, pass on the file-name (LIST FILE-NAME))) ; so it will error again at open time! (:NO-ERROR (SETQ RESPONSE (MAPCAR 'NAMESTRING DIR)))) RESPONSE)) ; Return RESPONSE (DEFUN DEFAULT-ONLY-WILD-PATHNAME-COMPONENTS (PATH1 PATH2) "Fill in only the wild parts of PATH1 with the corresponding parts of PATH2." (FS:FAST-NEW-PATHNAME PATH1 (WHEN (EQ (PATHNAME-DEVICE PATH1) :WILD) (PATHNAME-DEVICE PATH2)) (WHEN (EQ (PATHNAME-DIRECTORY PATH1) :WILD) (PATHNAME-DIRECTORY PATH2)) (WHEN (EQ (PATHNAME-NAME PATH1) :WILD) (PATHNAME-NAME PATH2)) (WHEN (EQ (PATHNAME-TYPE PATH1) :WILD) (PATHNAME-TYPE PATH2)) (WHEN (EQ (PATHNAME-VERSION PATH1) :W (PATHNAME-VERSION PATH2)))) ;*** MKERMT.LSP *** ;;; -*- Mode:Common-Lisp; base:10; package:user -*- (load "lm:kermit;defsystem.lisp#>") (make-system 'kermit :compile :noconfirm :no-increment-patch) ;***PTCH11.LSP *** ;;; -*- Mode: Lisp; Package: User; Base: 8.; Patch-File: T -*- ;;; Written 10/17/86 12:26:15 by SPERRY, ;;; Reason: Added definitions for :send-long-break and :send-short-break methods ;;; to serial-stream-mixin, and defined the analagous commands for the ;;; VT100 emulator. ;;; while running on A from band LOD1 ;;; 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. #!Z ; From file SERIAL-TELNET.LISP#> KERMIT; A: #8R TELNET#: (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET")) (SI:LISP-MODE :ZETALISP) (*READTABLE* SI:STANDARD-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL)) (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#" si: (defmethod (serial-stream-mixin :SEND-LONG-BREAK) () "Transmits a space condition for 3.5 seconds (long break)." (write-z-reg 5 (logand #x7F ; Turn off DTR (logior #x+10 WR5-CONTENTS))) ;turn on send break (sleep 3.5 "Sending Long Break") (write-z-reg 5 WR5-CONTENTS) ;restore register ) )) #!Z ; From file SERIAL-TELNET.LISP#> KERMIT; A: #8R TELNET#: (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET")) (SI:LISP-MODE :ZETALISP) (*READTABLE* SI:STANDARD-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL)) (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#" si: (defmethod (serial-stream-mixin :SEND-SHORT-BREAK) () "Transmits a space condition for .275 seconds (short break)." (write-z-reg 5 (logior #x+10 WR5-CONTENTS)) ;turn on send break (sleep .275 "Sending Short Break") (write-z-reg 5 WR5-CONTENTS) ;restore register ) )) #!Z ; From file SERIAL-TELNET.LISP#> KERMIT; A: #8R TELNET#: (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET")) (SI:LISP-MODE :ZETALISP) (*READTABLE* SI:STANDARD-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL)) (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#" (DEFCOMMAND (VT100-FRAME :LONG-BREAK) () '(:DESCRIPTION "Send a short break to stream." :NAMES ("Long Break") :KEYS ((#\NETWORK #\CTRL-BREAK))) (if (not (null connection)) (send stream :send-long-break) (format t "~&Not connected. Can't send Long Break.") (when (not ucl:preempting?) (send self :handle-prompt)))) )) #!Z ; From file SERIAL-TELNET.LISP#> KERMIT; A: #8R TELNET#: (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET")) (SI:LISP-MODE :ZETALISP) (*READTABLE* SI:STANDARD-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL)) (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#" (DEFCOMMAND (VT100-FRAME :SHORT-BREAK) () '(:DESCRIPTION "Send a short break to stream." :NAMES ("Short Break") :KEYS ((#\NETWORK #\BREAK))) (if (not (null connection)) (send stream :send-short-break) (format t "~&Not connected. Can't send Short Break.") (when (not ucl:preempting?) (send self :handle-prompt)))) )) #!Z ; From file SERIAL-TELNET.LISP#> KERMIT; A: #8R TELNET#: (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET")) (SI:LISP-MODE :ZETALISP) (*READTABLE* SI:STANDARD-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL)) (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#" (BUILD-COMMAND-TABLE 'VT100-TELNET-CMD-TABLE 'VT100-FRAME '((:method telnet-frame :exit-command) (:method telnet-frame :disconnect-command) (:method telnet-frame :interrupt-process-command) :send-answerback-command :reverse-video-command :reset-command :escape-processing-command (:method telnet-frame :quit-and-disconnect-command) (:method telnet-frame :status-command) (:method telnet-frame :abort-output-command) :column-command :truncate-command :set-vt100-lines :network-help-command (:method telnet-frame :clear-input-command) (:method vt100-frame :autodial) ; BAC (:method vt100-frame :kermit) ; BAC :local-echo-command ; BAC :short-break :long-break ) :INIT-OPTIONS '(:NAME "Vt100 & Telnet Commands" :DOCUMENTATION "The Vt100 & Telnet commands.")) )) #!Z ; From file SERIAL-TELNET.LISP#> KERMIT; A: #8R TELNET#: (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET")) (SI:LISP-MODE :ZETALISP) (*READTABLE* SI:STANDARD-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL)) (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#" (BUILD-MENU 'UCL-VT100-TELNET-MENU 'VT100-FRAME :DEFAULT-ITEM-OPTIONS '(:FONT FONTS:MEDFNT) :ITEM-LIST-ORDER '( ;Row 1 (:method telnet-frame :exit-command) (:method telnet-frame :disconnect-command) (:method telnet-frame :interrupt-process-command) :send-answerback-command :reverse-video-command :reset-command :escape-processing-command ;Row 2 (:method telnet-frame :quit-and-disconnect-command) (:method telnet-frame :status-command) (:method telnet-frame :abort-output-command) :column-command :truncate-command :set-vt100-lines :network-help-command ;Row 3 ; BAC (:method vt100-frame :autodial) ; BAC (:method vt100-frame :kermit) ; BAC :local-echo-command ; BAC :short-break :long-break )) )) ;***SCLOSE.LSP *** ;;; -*- Mode: Lisp; Package: User; Base: 8.; Patch-File: T -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (c) 1986, Texas Instruments Incorporated. All rights reserved. ;;; Written 5/16/86 17:44:10 by FORD, ;;; Reason: Change :CLOSE to clear the hardware registers. ;;; while running on B from band LOD2 ;;; 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. #!Z ; From file SERIAL-STREAM.LISP#> SERIAL; A: #8R SYSTEM-INTERNALS#: (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")) (SI:LISP-MODE :ZETALISP) (*READTABLE* STANDARD-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL)) (COMPILER#:PATCH-SOURCE-FILE "SYS: SERIAL; SERIAL-STREAM.#" (Defmethod (Serial-Stream-Mixin :CLOSE) (&Optional Abort-P) ;; deallocate the serial buffers (IF *serial-output-buffer* (PROGN (IF (NOT abort-p) (FUNCALL-SELF ':finish)) (return-serial-buffer *serial-Output-Buffer*) (SETQ *Serial-Output-Buffer* nil))) (IF *Serial-Input-Buffer* (PROGN (return-serial-buffer *Serial-Input-Buffer*) (SETQ *Serial-Input-Buffer* nil))) (array-dpb-offset 0 %%q-pointer *serial-port* %serial-receive-buffer) (array-dpb-offset 0 %%q-pointer *serial-port* %serial-transmit-buffer) (setq *serial-port-owner* nil) (write-z-reg 9 0) ;clear master interrupt control register (write-z-reg 5 0) ;DTR, RTS, Tx disable (write-z-reg 3 0) ;Rx disable (write-z-reg 15. 0) ;disable external interrupts (write-z-reg 1 0) ;disable interrupts (disable-serial-event) ;disable SIB serial event posting ) )) ;***STLNET.LSP *** ;;; -*- Mode:LISP; Package:TELNET; Base:8; Patch-File:T -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (c) 1986, Texas Instruments Incorporated. All rights reserved. ;;; Copyright (c) 1986, Sperry Corporation. All rights reserved. ;;; NOTES: ;;; This code will need review and possibly reimplementation for ;;; Release 3.0 because of GENI's release. ;;; To eliminate compilation warnings, create required packages ;;; if they don't already exist ;; BAC (EVAL-WHEN (EVAL COMPILE) (PKG-FIND-PACKAGE "KERMIT" T) (PKG-FIND-PACKAGE "IP" T)) ;;; MAKE-SERIAL-STREAM-FROM-CVV ;;; (DEFVAR *BAUD* #10r1200 "Baud rate.") (DEFVAR *FORCE-OUTPUT* T "Force output.") (DEFVAR *NUMBER-OF-DATA-BITS* #10r8 "Number of data bits.") (DEFVAR *NUMBER-OF-STOP-BITS* #10r2 "Number of stop bits.") (DEFVAR *PARITY* :NONE "Parity.") (DEFVAR *XON-XOFF-PROTOCOL* NIL "XON-XOFF protocol.") (DEFVAR *ASCII-CHARACTERS* NIL "Ascii-characters.") (DEFVAR *INPUT-BUFFER-SIZE* #10r180 "Input buffer.") (DEFVAR *OUTPUT-BUFFER-SIZE* #10r180 "Output buffer.") (DEFUN MAKE-SERIAL-STREAM-FROM-CVV () "Produces a CVV to select serial stream parameters, then creates a stream using SI:MAKE-SERIAL-STREAM. Returns the created stream." (DECLARE (SPECIAL *BAUD* *FORCE-OUTPUT* *NUMBER-OF-DATA-BITS* *NUMBER-OF-STOP-BITS* *PARITY* *XON-XOFF-PROTOCOL* *ASCII-CHARACTERS* *INPUT-BUFFER-SIZE* *OUTPUT-BUFFER-SIZE*)) (TV:CHOOSE-VARIABLE-VALUES '((*BAUD* "Baud rate" :DOCUMENTATION "Line speed. (Most asynchronous modems use 1200 or 300)" :CHOOSE (#10r300 #10r1200 #10r2400 #10r4800 #10r9600 #10r19200)) (*FORCE-OUTPUT* "Force output" :DOCUMENTATION "YES: send characters immediately. NO: send characters when buffer is full." :BOOLEAN) (*NUMBER-OF-DATA-BITS* "Data Bits" :DOCUMENTATION "Number of data bits." :CHOOSE (#10r5 #10r6 #10r7 #10r8)) (*NUMBER-OF-STOP-BITS* "Stop Bits" :DOCUMENTATION "Number of stop bits." :CHOOSE (1 2)) (*PARITY* "Parity" :DOCUMENTATION "Type of parity to use." :CHOOSE (:NONE :EVEN :ODD)) (*XON-XOFF-PROTOCOL* "XON-XOFF" :DOCUMENTATION "YES: use XON-XOFF characters. NO: don't implement XON-XOFF characters." :BOOLEAN) (*ASCII-CHARACTERS* "Translate ASCII" :DOCUMENTATION "YES: Automatically translate between ASCII and LISPM characters. NO: don't translate." :BOOLEAN) (*INPUT-BUFFER-SIZE* "Input Buffer size" :DOCUMENTATION "Size (in words) to allocate for the input buffers." :NUMBER) (*OUTPUT-BUFFER-SIZE* "Output Buffer size" :DOCUMENTATION "Size (in words) to allocate for the output buffers." :NUMBER)) :NEAR-MODE '(:POINT 500 400) :LABEL "Choose Serial Stream Parameters" :MARGIN-CHOICES '("Do It")) (SI:MAKE-SERIAL-STREAM :BAUD *BAUD* :FORCE-OUTPUT *FORCE-OUTPUT* :NUMBER-OF-DATA-BITS *NUMBER-OF-DATA-BITS* :NUMBER-OF-STOP-BITS *NUMBER-OF-STOP-BITS* :PARITY *PARITY* :XON-XOFF-PROTOCOL *XON-XOFF-PROTOCOL* :ASCII-CHARACTERS *ASCII-CHARACTERS* :INPUT-BUFFER-SIZE *INPUT-BUFFER-SIZE* :OUTPUT-BUFFER-SIZE *OUTPUT-BUFFER-SIZE*)) ;;; Autodial ;;; (DEFVAR *AUTODIAL-PREFIX* "ATDT" "Prefix to send to autodialer modem") (DEFVAR *AUTODIAL-NUMBER* "8,8005551212" "Number to dial") (DEFUN AUTODIAL (&KEY (PREFIX *AUTODIAL-PREFIX*) (NUMBER *AUTODIAL-NUMBER*) STREAM ; could bind this to *SERIAL-PORT-OWNER* MENU VERBOSE) "Dial a number using an autodialer. If :NUMBER is not specified, use the last number dialed. If :MENU is specified, display a menu to select the number to dial." (LET ((PRE PREFIX) (NUM NUMBER) (CONTINUE T)) (DECLARE (SPECIAL PRE NUM)) (WHEN MENU (SETQ CONTINUE (*CATCH 'END-CVV (TV:CHOOSE-VARIABLE-VALUES '((PRE "Prefix" :DOCUMENTATION "Modem's autodial prefix (e.g., ATDT)." :STRING) (NUM "Number" :DOCUMENTATION "Telephone number to dial. A comma <,> causes a 2 second wait." :STRING)) :NEAR-MODE '(:POINT 500 400) :LABEL "Serial Port Autodial" :MARGIN-CHOICES '("Do It" ("Quit" (*THROW 'END-CVV NIL)))) T))) (WHEN CONTINUE (IF (NOT (STREAMP STREAM)) (WHEN VERBOSE (FORMAT T "~&Stream <~A> is not a valid stream." STREAM)) (PROGN (SETQ *AUTODIAL-PREFIX* PRE) (SETQ *AUTODIAL-NUMBER* NUM) (SEND STREAM :CLEAR-INPUT) (SEND STREAM :CLEAR-OUTPUT) (SEND STREAM :LINE-OUT (FORMAT NIL "~A~A" *AUTODIAL-PREFIX* *AUTODIAL-NUMBER*)) (PROCESS-WAIT-WITH-TIMEOUT "Dialing..." 3600 (FUNCTION (LAMBDA (STREAM) (SEND STREAM :GET :DATA-CARRIER-DETECT))) STREAM) (SEND STREAM :CLEAR-INPUT) (SEND STREAM :CLEAR-OUTPUT) T))))) ;;; RUN-SCRIPT ;;; (DEFUN RUN-SCRIPT (script &KEY (stream *TERMINAL-IO*) (debug-stream *DEBUG-IO*) &AUX (response (make-array 5000. :type art-string :fill-pointer 0)) (return-value nil)) "Simulate an interactive user session with a script. SCRIPT is a list of the form ((SEND RECEIVE ACTION)...). SEND is a list of a format control string and its arguments that specify the output to be sent to STREAM. RECEIVE is a list of a format control string and its arguments that specify the input expected from STREAM. ACTION specifies what to do if the data received doesn't contain the string specified by RECEIVE. It can be :L (loop forever), :Q (quit,the default), a number indicating the number of times to loop and before quitting, or a list of a format control string and its arguments that specify an alternative output to be sent to STREAM. For each element of SCRIPT, first SEND is sent to STREAM, then STREAM is checked for input that matches RECEIVE, if it is found, the next form is processed, else, the ACTION is processed, and STREAM is again checked for input that matches RECEIVE. STREAM is an I/O stream. When DEBUG-STREAM is specified, it should be an I/O stream where debug info is sent. RUN-SCRIPT returns :SUCCESSFUL if the last RECEIVE in SCRIPT was successful, :UNSUCCESSFUL otherwise." (CHECK-ARG SCRIPT LISTP "a list") (CHECK-ARG STREAM STREAMP "a stream") (CHECK-ARG DEBUG-STREAM STREAMP "a stream") (DOLIST (item script return-value) (SETQ return-value (LET* ((send (FIRST item)) (receive (SECOND item)) (action (THIRD item))) (DO () (NIL) (WHEN send (LET ((formatted-string (APPLY #'FORMAT NIL (CAR send) (CDR send)))) (SEND stream :STRING-OUT formatted-string) (WHEN debug-stream (FORMAT debug-stream "~%Sending:~A" formatted-string)))) (IF receive (PROGN (SETF (FILL-POINTER response) 0) (WHEN debug-stream (FORMAT debug-stream "~%Receiving:")) (DO ((char (SEND stream :TYI-WITH-TIMEOUT 1800.)(SEND stream :TYI-WITH-TIMEOUT 1800.))) ((NULL char) T) (WHEN (> char 0) (SETF (AREF response (FILL-POINTER response)) (LOGAND char #o177)) (INCF (FILL-POINTER response)) (WHEN debug-stream (FORMAT debug-stream "~C" (LOGAND char #o177))))) (WHEN debug-stream (FORMAT debug-stream "~%Searching:~A" (APPLY #'FORMAT NIL (CAR receive) nil))) (SEND stream :CLEAR-INPUT) (IF (STRING-SEARCH (APPLY #'FORMAT NIL (CAR receive) (CDR receive)) response) (RETURN :SUCCESSFUL) (IF action (IF (EQ action :Q) (RETURN :UNSUCCESSFUL) (IF (INTEGERP action) (IF (< action 1) (RETURN :UNSUCCESSFUL) (DECF action)) (IF (LISTP action) (SETQ send action) (UNLESS (EQ action :L) (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))))) (RETURN :UNSUCCESSFUL)))) (RETURN :SUCCESSFUL))))))) ;;; Serial stream flavor addition: TYI-WITH-TIMEOUT SI:(DEFMETHOD (SERIAL-STREAM-MIXIN :TYI-WITH-TIMEOUT) (INTERVAL-IN-60THS) (IF (SI:PROCESS-WAIT-WITH-TIMEOUT "Serial Waiting" INTERVAL-IN-60THS (FUNCTION (LAMBDA (STREAM) (SEND STREAM :INPUT-CHARS-AVAILABLE-P))) SELF) (SEND SELF :TYI))) ;;; From sys:telnet;basic-telnet (sort of): ;;; ;;; This method is almost identical to (:method basic-telnet :net-output), ;;; which vt100-frame inherits, except that this version doesn't ;;; automatically send a linefeed after a carriage-return unless the ;;; connection is a chaos connection. Thus, it preserves the existing ;;; behavior for normal connections (and it seems to be the right thing) ;;; while removing the spurious linefeed from serial-port connections. ;;; There may well be a better way to do it. - pf, Sept 11, 1985 (DEFMETHOD (vt100-frame :NET-OUTPUT) (ch) (lock-output (when (ldb-test 1701 ch) ;An NVT char from TELNET-KEYS (if new-telnet-p (send stream ':tyo NVT-IAC)) (setq ch (ldb 0010 ch))) (send stream ':tyo ch) (cond ((and (typep connection 'chaos:conn) (= ch 15)) (send stream ':tyo 12)) ;CR is two chars, CR LF ((and (= ch NVT-IAC) new-telnet-p) (send stream ':tyo NVT-IAC))))) ;IAC's must be quoted ;;; Autodial command method ;;; (DEFCOMMAND (VT100-FRAME :AUTODIAL) () '(:DESCRIPTION "Display a pop-up menu with commands to use an auto dialer." :NAMES ("Autodial")) (DECLARE (SPECIAL *AUTODIAL-PREFIX* *AUTODIAL-NUMBER*)) (COND (CONNECTION (IF (NOT (FUNCTIONP 'AUTODIAL)) (FORMAT T "~&AUTODIAL not loaded. Can't Autodial.")) (FUNCALL 'AUTODIAL :STREAM STREAM :MENU T)) (T (FORMAT T "~&Not connected. Can't Autodial.") (WHEN (NOT UCL:PREEMPTING?) (SEND SELF ':HANDLE-PROMPT))))) ;;; Kermit command method ;;; (DEFCOMMAND (VT100-FRAME :KERMIT) () '(:DESCRIPTION "Display a pop-up menu of KERMIT file-transfer commands." :Names ("Kermit")) (COND (CONNECTION (IF (NOT (FUNCTIONP 'KERMIT:INTERACTIVE-KERMIT)) (FORMAT T "~&KERMIT not loaded. Can't run KERMIT.") (LET ((VT100-SUBSTITUTE (SEND SELF :SELECTION-SUBSTITUTE)) (KERMIT-SUPERIOR (SEND KERMIT:*KERMIT-FRAME* :SUPERIOR)) (MENU-PANE (SEND SELF :GET-PANE 'MENU-TELNET))) (UNWIND-PROTECT (LET ((FORM NIL)) (SEND TYPEOUT-PROCESS :ARREST-REASON 'KERMIT) ; Stop the vt100 process from using serial stream (SETQ FORM (KERMIT:INTERACTIVE-KERMIT STREAM NIL)) ; Get the Kermit arguments (WHEN FORM (SETF (SEND MENU-PANE :INVISIBLE-TO-MOUSE-P) T) ; Make the vt100 menu items non-mousable (SEND KERMIT:*KERMIT-FRAME* :SET-SUPERIOR SELF) (SEND SELF :SET-SELECTION-SUBSTITUTE KERMIT:*KERMIT-FRAME*) ; Attach the kermit frame to vt100 (EVAL FORM))) ; Call Kermit (SEND TYPEOUT-PROCESS :REVOKE-ARREST-REASON 'KERMIT) ; Reallow vt100 to use serial (SETF (SEND MENU-PANE :INVISIBLE-TO-MOUSE-P) NIL) ; Make menu items mousable (SEND SELF :SET-SELECTION-SUBSTITUTE VT100-SUBSTITUTE) (SEND KERMIT:*KERMIT-FRAME* :SET-SUPERIOR KERMIT-SUPERIOR))))) (T (FORMAT T "~&Not connected. Can't run KERMIT.") (WHEN (NOT UCL:PREEMPTING?) (SEND SELF ':HANDLE-PROMPT))))) ;;; Local echo command method ;;; (DEFCOMMAND (vt100-frame :LOCAL-ECHO-COMMAND) () '(:DESCRIPTION "Toggle local echo mode of Vt100 screen pane." :NAMES ("Local Echo")) (SETF ECHO-FLAG (IF ECHO-FLAG NIL T)) (FORMAT T "~&Local echo now ~A.~%" (IF ECHO-FLAG "off" "on")) ; echo-flag=T means local echo is off! (WHEN (AND (NULL CONNECTION) (NOT UCL:PREEMPTING?)) (SEND SELF ':HANDLE-PROMPT))) ;;; Redefine the VT100 layout and menu ;;; (DEFFLAVOR VT100-TELNET-MENU (TV:INVISIBLE-TO-MOUSE-P) (TV:DYNAMIC-ITEM-LIST-MIXIN TV:COMMAND-MENU) (:SETTABLE-INSTANCE-VARIABLES TV:INVISIBLE-TO-MOUSE-P) (:DEFAULT-INIT-PLIST :LABEL (LIST :TOP :FONT FONTS:HL12B :STRING "VT100 & Telnet Commands") :ROWS 3 ; BAC changed from 2 :COLUMNS 7 ; BAC changed from 7 :VSP 8. :FONT-MAP (list fonts:MEDFNT) :LABEL-BOX-P nil :ITEM-LIST nil) (:DOCUMENTATION :COMBINATION "Command menu needs dynamic-item-list-mixin for UCL.")) (BUILD-COMMAND-TABLE 'VT100-TELNET-CMD-TABLE 'VT100-FRAME '((:method telnet-frame :exit-command) (:method telnet-frame :disconnect-command) (:method telnet-frame :interrupt-process-command) :send-answerback-command :reverse-video-command :reset-command :escape-processing-command (:method telnet-frame :quit-and-disconnect-command) (:method telnet-frame :status-command) (:method telnet-frame :abort-output-command) :column-command :truncate-command :set-vt100-lines :network-help-command (:method telnet-frame :clear-input-command) (:method vt100-frame :autodial) ; BAC (:method vt100-frame :kermit) ; BAC :local-echo-command ; BAC ) :INIT-OPTIONS '(:NAME "Vt100 & Telnet Commands" :DOCUMENTATION "The Vt100 & Telnet commands.")) (BUILD-MENU 'UCL-VT100-TELNET-MENU 'VT100-FRAME :DEFAULT-ITEM-OPTIONS '(:FONT FONTS:MEDFNT) :ITEM-LIST-ORDER '( ;Row 1 (:method telnet-frame :exit-command) (:method telnet-frame :disconnect-command) (:method telnet-frame :interrupt-process-command) :send-answerback-command :reverse-video-command :reset-command :escape-processing-command ;Row 2 (:method telnet-frame :quit-and-disconnect-command) (:method telnet-frame :status-command) (:method telnet-frame :abort-output-command) :column-command :truncate-command :set-vt100-lines :network-help-command ;Row 3 ; BAC (:method vt100-frame :autodial) ; BAC (:method vt100-frame :kermit) ; BAC :local-echo-command ; BAC )) ;;; The following add Serial streams to the TELNET and VT100 base system. ;;; (DEFVAR telnet:file NIL) (DEFMETHOD (vt100-frame :TYPEOUT-TOP-LEVEL) (&aux (terminal-io vt100-pane)) "Redefines (:METHOD BASIC-NVT :TYPOUT-TOP-LEVEL) to use :PROCESS-ESCAPE" (declare (special telnet:file)) (process-wait "Never-open" #'car (locate-in-instance self 'connection)) (ucl:ignore-errors-query-loop (condition-bind (((sys:remote-network-error ip:illegal-connection ip:connection-reset) 'typeout-net-error self)) (do-forever (do ((ch (nvt-neti) (send stream :tyi-no-hang))) ((null ch) (if output-buffer (send self :force-output))) (when (not (null telnet:file)) (send telnet:file :tyo ch)) (send self :process-escape (IF (EQ CONNECTION T) (logand #b01111111 ch) ; if we don't strip parity we get an error ;; BAC ch))))))) ;;; This method should return the network connection. This can ;;; be a stream or a connection object depending on the network type. ;;; ;;; The method :NETWORK-NEW-CONNECTION is not needed for serial telnet. (DEFMETHOD (basic-nvt :case :network-new-connection :serial) (host &optional (contact "TELNET") (window nil) ) window contact host nil) ; BAC to eliminate compile warnings (RECOMPILE-FLAVOR 'vt100-frame :NETWORK-NEW-CONNECTION) ;;; Return nil if the connection is not connected. (DEFMETHOD (basic-nvt :case :network-connected-p :serial)() (and stream connection)) (RECOMPILE-FLAVOR 'vt100-frame :NETWORK-CONNECTED-P) ;;; The method :NETWORK-NEW-CONNECTION passes the arguement which we ;;; ignore for the serial implementation. ;;; ;;; Set stream to be the serial stream. ;;; Connection should be something non nil, but does not need to be a connection. ;;; The connection instance variable is used by CHAOSNET. (DEFMETHOD (basic-nvt :case :set-connection :serial) (ignore) (SEND typein-process :reset) (SEND typeout-process :reset) (SETF stream (MAKE-SERIAL-STREAM-FROM-CVV)) ;; (SEND self :gobble-greeting) (SETF connection t) (SETQ black-on-white nil)) (RECOMPILE-FLAVOR 'vt100-frame :SET-CONNECTION) ;;; This method should close the serial TELNET connection. ;;; Make sure to set both instance variables, STREAM and CONNECTION, ;;; to nil. (DEFMETHOD (basic-nvt :case :network-disconnect :serial)() (WHEN stream (SEND stream :close) (SETF stream nil connection nil))) (RECOMPILE-FLAVOR 'vt100-frame :NETWORK-DISCONNECT) ;;; This method should indicate the connection state. ;;; It would be nice if you could signal errors in the connection ;;; state by throwing 'NVT-DONE because TELNET will try to eloquently ;;; close the connection. (defmethod (basic-nvt :case :check-connection-state :serial)() (unless stream (*THROW 'TELNET:NVT-DONE "Stream never opened."))) (RECOMPILE-FLAVOR 'vt100-frame :CHECK-CONNECTION-STATE) ;;; Send the TELNET command interrupt process (IP) to the remote host. ;;; (Note: IP should not be confused with the acronym for a well known ;;; network type.) ;;; An IP command is defined to be the following two bytes: NVT-IAC NVT-IP. ;;; Many implementations send the IP in urgent mode as the following sequence of bytes ;;; NVT-IAC, NVT-IP, NVT-IAC, NVT-DM. This is technically a SYNC signal but ;;; most systems handle no differently. The TCP/IP network sends a SYNC signal ;;; in urgent mode, the CHAOS network sends a SYNC signal not in urgent mode ;;; because there is no concept of urgent data, Wollongong sends just an IP command ;;; and the MIT PC software sends a SYNC signal in urgent mode. ;;; ;;; You may choose to send a SYNC signal or just IP command I think it makes little ;;; difference (except with Wollongong which can't handle SYNC signals successfully). ;;; However, since serial streams do not have a concept of ;;; urgent mode I choose to send a SYNC signal. (DEFMETHOD (basic-telnet :case :network-send-ip :serial)() (lock-output (SEND stream :tyo NVT-IAC) (SEND stream :tyo NVT-IP) (SEND stream :tyo NVT-IAC) (SEND stream :tyo NVT-DM) )) (RECOMPILE-FLAVOR 'vt100-frame :NETWORK-SEND-IP) (UNLESS (MEMBER :serial protocols-supporting-telnet) (PUSH :serial protocols-supporting-telnet)) ;;; This is a kludge to make serial telnet work correctly. ;;; If there were serial host objects then this would not ;;; be necessary. (setq default-network-type :serial) ;***VTCURS.LSP *** ;;; -*- Mode: Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (c) 1986, Texas Instruments Incorporated. All rights reserved. ;;; Written 5/16/86 10:34:33 by FORD, ;;; Reason: Fix (:METHOD VT100-ESCAPE-SEQUENCE-MIXIN :PROCESS-ESCAPE-BRACKET-NUMERIC-NUMERIC-SEMICOLON-SEQUENCE) ;;; to properly process the second leading zero in escape sequences like . ;;; while running on B from band LOD2 ;;; 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. #!Z ; From file PROCESS-ESCAPE-SEQUENCE.LISP#> VT100; A: #10R TELNET#: (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET")) (SI:LISP-MODE :ZETALISP) (*READTABLE* SI:STANDARD-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL)) (COMPILER#:PATCH-SOURCE-FILE "SYS: VT100; PROCESS-ESCAPE-SEQUENCE.#" (DEFMETHOD (vt100-escape-sequence-mixin :PROCESS-ESCAPE-BRACKET-NUMERIC-NUMERIC-SEMICOLON-SEQUENCE) (ch) (cond ((= ch #/r) ; ESC [ num num ; num num r (setq scroll-ending-line ; Scrolling regions (min ending-line (tv:sheet-number-of-inside-lines vt100-pane))) (setq scroll-starting-line starting-line-completed-value) (if (= scroll-ending-line 0) (setq scroll-ending-line (tv:sheet-number-of-inside-lines vt100-pane))) (setq top-of-scroll scroll-starting-line) (setq bottom-of-scroll scroll-ending-line) (send vt100-pane ':set-cursorpos 0 0 ':character) (send self ':reset)) ((or (= ch #/H) (= ch #/f)) ; Direct cursor addressing ; ESC [ 14 ; H ESC [ 14 ; 1 H ESC [ 14 ; 12 H ; And the same sequences with 'f' (send self ':move-to-direct-cursor-position starting-line-completed-value column) (send self ':reset)) (escape-bracket-numeric-numeric-semicolon-numeric-flag ;This is the second of the two digits, so now make a two digit value (cond ((and test-for-three-digits-flag ; Check for "00", ie, ESC [ 10;007H (= escape-bracket-numeric-numeric-semicolon-numeric-ch #/0)) (setq test-for-three-digits-flag nil) (setq escape-bracket-numeric-numeric-semicolon-numeric-numeric-ch ch) (setq ending-line (make-two-digit-value escape-bracket-numeric-numeric-semicolon-numeric-ch escape-bracket-numeric-numeric-semicolon-numeric-numeric-ch)) (setq column ending-line)) (t (setq escape-bracket-numeric-numeric-semicolon-numeric-numeric-ch ch) (setq ending-line (make-two-digit-value escape-bracket-numeric-numeric-semicolon-numeric-ch escape-bracket-numeric-numeric-semicolon-numeric-numeric-ch)) (setq column ending-line)))) ((and (>= ch #/0) (<= ch #/9)) ;This is the first of the two digits (setq test-for-three-digits-flag t) (setq escape-bracket-numeric-numeric-semicolon-numeric-ch ch) (setq column (- ch #/0)) (setq escape-bracket-numeric-numeric-semicolon-numeric-flag t) (cond ((= starting-line-second-ch 99.) (setq ending-line (make-two-digit-value escape-bracket-numeric-semicolon-numeric-ch escape-bracket-numeric-numeric-semicolon-numeric-ch)) (setq starting-line (- starting-line #/0))) (t NIL))) (t (send self ':reset)))) )) ;***VTCKEY.LSP *** ;;; -*- Mode: Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (c) 1986, Texas Instruments Incorporated. All rights reserved. ;;; Written 8/07/86 13:42:03 by FORD, ;;; Reason: Commented out check for Keypad-mode in cursor key methods. ;;; It doesn't appear as if cursor-key mode and keypad-mode ;;; should be connected. Steve Ford 8-7-86 ;;; while running on D from band LOD1 ;;; 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. #!Z ; From file PROCESS-ESCAPE-SEQUENCE.LISP#> VT100; F: #10R TELNET#: (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET")) (SI:LISP-MODE :ZETALISP) (*READTABLE* SI:STANDARD-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL)) (COMPILER#:PATCH-SOURCE-FILE "SYS: VT100; PROCESS-ESCAPE-SEQUENCE.#" (DEFMETHOD (vt100-escape-sequence-mixin :AUXILIARY-UP) () (cond (nil ;(and keypad-mode process-ch?) (send self ':applications-mode) (send self ':net-output #/A)) (t (send self ':net-output #\escape) (send self ':net-output #/[) (send self ':net-output #/A)))) (DEFMETHOD (vt100-escape-sequence-mixin :AUXILIARY-DOWN) () (cond (nil ;(and keypad-mode process-ch?) (send self ':applications-mode) (send self ':net-output #/B)) (t (send self ':net-output #\escape) (send self ':net-output #/[) (send self ':net-output #/B)))) (DEFMETHOD (vt100-escape-sequence-mixin :AUXILIARY-RIGHT) () (cond (nil ;(and keypad-mode process-ch?) (send self ':applications-mode) (send self ':net-output #/C)) (t (send self ':net-output #\escape) (send self ':net-output #/[) (send self ':net-output #/C)))) (DEFMETHOD (vt100-escape-sequence-mixin :AUXILIARY-LEFT) () (cond (nil ;(and keypad-mode process-ch?) (send self ':applications-mode) (send self ':net-output #/D)) (t (send self ':net-output #\escape) (send self ':net-output #/[) (send self ':net-output #/D)))) )) ;*** PTCH11.LSP *** ;;; -*- Mode: Lisp; Package: User; Base: 8.; Patch-File: T -*- ;;; Written 10/17/86 12:26:15 by SPERRY, ;;; Reason: Added definitions for :send-long-break and :send-short-break methods ;;; to serial-stream-mixin, and defined the analagous commands for the ;;; VT100 emulator. ;;; while running on A from band LOD1 ;;; 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. #!Z ; From file SERIAL-TELNET.LISP#> KERMIT; A: #8R TELNET#: (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET")) (SI:LISP-MODE :ZETALISP) (*READTABLE* SI:STANDARD-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL)) (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#" si: (defmethod (serial-stream-mixin :SEND-LONG-BREAK) () "Transmits a space condition for 3.5 seconds (long break)." (write-z-reg 5 (logand #x7F ; Turn off DTR (logior #x+10 WR5-CONTENTS))) ;turn on send break (sleep 3.5 "Sending Long Break") (write-z-reg 5 WR5-CONTENTS) ;restore register ) )) #!Z ; From file SERIAL-TELNET.LISP#> KERMIT; A: #8R TELNET#: (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET")) (SI:LISP-MODE :ZETALISP) (*READTABLE* SI:STANDARD-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL)) (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#" si: (defmethod (serial-stream-mixin :SEND-SHORT-BREAK) () "Transmits a space condition for .275 seconds (short break)." (write-z-reg 5 (logior #x+10 WR5-CONTENTS)) ;turn on send break (sleep .275 "Sending Short Break") (write-z-reg 5 WR5-CONTENTS) ;restore register ) )) #!Z ; From file SERIAL-TELNET.LISP#> KERMIT; A: #8R TELNET#: (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET")) (SI:LISP-MODE :ZETALISP) (*READTABLE* SI:STANDARD-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL)) (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#" (DEFCOMMAND (VT100-FRAME :LONG-BREAK) () '(:DESCRIPTION "Send a short break to stream." :NAMES ("Long Break") :KEYS ((#\NETWORK #\CTRL-BREAK))) (if (not (null connection)) (send stream :send-long-break) (format t "~&Not connected. Can't send Long Break.") (when (not ucl:preempting?) (send self :handle-prompt)))) )) #!Z ; From file SERIAL-TELNET.LISP#> KERMIT; A: #8R TELNET#: (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET")) (SI:LISP-MODE :ZETALISP) (*READTABLE* SI:STANDARD-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL)) (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#" (DEFCOMMAND (VT100-FRAME :SHORT-BREAK) () '(:DESCRIPTION "Send a short break to stream." :NAMES ("Short Break") :KEYS ((#\NETWORK #\BREAK))) (if (not (null connection)) (send stream :send-short-break) (format t "~&Not connected. Can't send Short Break.") (when (not ucl:preempting?) (send self :handle-prompt)))) )) #!Z ; From file SERIAL-TELNET.LISP#> KERMIT; A: #8R TELNET#: (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET")) (SI:LISP-MODE :ZETALISP) (*READTABLE* SI:STANDARD-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL)) (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#" (BUILD-COMMAND-TABLE 'VT100-TELNET-CMD-TABLE 'VT100-FRAME '((:method telnet-frame :exit-command) (:method telnet-frame :disconnect-command) (:method telnet-frame :interrupt-process-command) :send-answerback-command :reverse-video-command :reset-command :escape-processing-command (:method telnet-frame :quit-and-disconnect-command) (:method telnet-frame :status-command) (:method telnet-frame :abort-output-command) :column-command :truncate-command :set-vt100-lines :network-help-command (:method telnet-frame :clear-input-command) (:method vt100-frame :autodial) ; BAC (:method vt100-frame :kermit) ; BAC :local-echo-command ; BAC :short-break :long-break ) :INIT-OPTIONS '(:NAME "Vt100 & Telnet Commands" :DOCUMENTATION "The Vt100 & Telnet commands.")) )) #!Z ; From file SERIAL-TELNET.LISP#> KERMIT; A: #8R TELNET#: (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET")) (SI:LISP-MODE :ZETALISP) (*READTABLE* SI:STANDARD-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL)) (COMPILER#:PATCH-SOURCE-FILE "LM: KERMIT; SERIAL-TELNET.#" (BUILD-MENU 'UCL-VT100-TELNET-MENU 'VT100-FRAME :DEFAULT-ITEM-OPTIONS '(:FONT FONTS:MEDFNT) :ITEM-LIST-ORDER '( ;Row 1 (:method telnet-frame :exit-command) (:method telnet-frame :disconnect-command) (:method telnet-frame :interrupt-process-command) :send-answerback-command :reverse-video-command :reset-command :escape-processing-command ;Row 2 (:method telnet-frame :quit-and-disconnect-command) (:method telnet-frame :status-command) (:method telnet-frame :abort-output-command) :column-command :truncate-command :set-vt100-lines :network-help-command ;Row 3 ; BAC (:method vt100-frame :autodial) ; BAC (:method vt100-frame :kermit) ; BAC :local-echo-command ; BAC :short-break :long-break )) )) ;*** SCLOSE.LSP *** ;;; -*- Mode: Lisp; Package: User; Base: 8.; Patch-File: T -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (c) 1986, Texas Instruments Incorporated. All rights reserved. ;;; Written 5/16/86 17:44:10 by FORD, ;;; Reason: Change :CLOSE to clear the hardware registers. ;;; while running on B from band LOD2 ;;; 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. #!Z ; From file SERIAL-STREAM.LISP#> SERIAL; A: #8R SYSTEM-INTERNALS#: (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")) (SI:LISP-MODE :ZETALISP) (*READTABLE* STANDARD-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL)) (COMPILER#:PATCH-SOURCE-FILE "SYS: SERIAL; SERIAL-STREAM.#" (Defmethod (Serial-Stream-Mixin :CLOSE) (&Optional Abort-P) ;; deallocate the serial buffers (IF *serial-output-buffer* (PROGN (IF (NOT abort-p) (FUNCALL-SELF ':finish)) (return-serial-buffer *serial-Output-Buffer*) (SETQ *Serial-Output-Buffer* nil))) (IF *Serial-Input-Buffer* (PROGN (return-serial-buffer *Serial-Input-Buffer*) (SETQ *Serial-Input-Buffer* nil))) (array-dpb-offset 0 %%q-pointer *serial-port* %serial-receive-buffer) (array-dpb-offset 0 %%q-pointer *serial-port* %serial-transmit-buffer) (setq *serial-port-owner* nil) (write-z-reg 9 0) ;clear master interrupt control register (write-z-reg 5 0) ;DTR, RTS, Tx disable (write-z-reg 3 0) ;Rx disable (write-z-reg 15. 0) ;disable external interrupts (write-z-reg 1 0) ;disable interrupts (disable-serial-event) ;disable SIB serial event posting ) )) ;*** STLNET.LSP *** ;;; -*- Mode:LISP; Package:TELNET; Base:8; Patch-File:T -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (c) 1986, Texas Instruments Incorporated. All rights reserved. ;;; Copyright (c) 1986, Sperry Corporation. All rights reserved. ;;; NOTES: ;;; This code will need review and possibly reimplementation for ;;; Release 3.0 because of GENI's release. ;;; To eliminate compilation warnings, create required packages ;;; if they don't already exist ;; BAC (EVAL-WHEN (EVAL COMPILE) (PKG-FIND-PACKAGE "KERMIT" T) (PKG-FIND-PACKAGE "IP" T)) ;;; MAKE-SERIAL-STREAM-FROM-CVV ;;; (DEFVAR *BAUD* #10r1200 "Baud rate.") (DEFVAR *FORCE-OUTPUT* T "Force output.") (DEFVAR *NUMBER-OF-DATA-BITS* #10r8 "Number of data bits.") (DEFVAR *NUMBER-OF-STOP-BITS* #10r2 "Number of stop bits.") (DEFVAR *PARITY* :NONE "Parity.") (DEFVAR *XON-XOFF-PROTOCOL* NIL "XON-XOFF protocol.") (DEFVAR *ASCII-CHARACTERS* NIL "Ascii-characters.") (DEFVAR *INPUT-BUFFER-SIZE* #10r180 "Input buffer.") (DEFVAR *OUTPUT-BUFFER-SIZE* #10r180 "Output buffer.") (DEFUN MAKE-SERIAL-STREAM-FROM-CVV () "Produces a CVV to select serial stream parameters, then creates a stream using SI:MAKE-SERIAL-STREAM. Returns the created stream." (DECLARE (SPECIAL *BAUD* *FORCE-OUTPUT* *NUMBER-OF-DATA-BITS* *NUMBER-OF-STOP-BITS* *PARITY* *XON-XOFF-PROTOCOL* *ASCII-CHARACTERS* *INPUT-BUFFER-SIZE* *OUTPUT-BUFFER-SIZE*)) (TV:CHOOSE-VARIABLE-VALUES '((*BAUD* "Baud rate" :DOCUMENTATION "Line speed. (Most asynchronous modems use 1200 or 300)" :CHOOSE (#10r300 #10r1200 #10r2400 #10r4800 #10r9600 #10r19200)) (*FORCE-OUTPUT* "Force output" :DOCUMENTATION "YES: send characters immediately. NO: send characters when buffer is full." :BOOLEAN) (*NUMBER-OF-DATA-BITS* "Data Bits" :DOCUMENTATION "Number of data bits." :CHOOSE (#10r5 #10r6 #10r7 #10r8)) (*NUMBER-OF-STOP-BITS* "Stop Bits" :DOCUMENTATION "Number of stop bits." :CHOOSE (1 2)) (*PARITY* "Parity" :DOCUMENTATION "Type of parity to use." :CHOOSE (:NONE :EVEN :ODD)) (*XON-XOFF-PROTOCOL* "XON-XOFF" :DOCUMENTATION "YES: use XON-XOFF characters. NO: don't implement XON-XOFF characters." :BOOLEAN) (*ASCII-CHARACTERS* "Translate ASCII" :DOCUMENTATION "YES: Automatically translate between ASCII and LISPM characters. NO: don't translate." :BOOLEAN) (*INPUT-BUFFER-SIZE* "Input Buffer size" :DOCUMENTATION "Size (in words) to allocate for the input buffers." :NUMBER) (*OUTPUT-BUFFER-SIZE* "Output Buffer size" :DOCUMENTATION "Size (in words) to allocate for the output buffers." :NUMBER)) :NEAR-MODE '(:POINT 500 400) :LABEL "Choose Serial Stream Parameters" :MARGIN-CHOICES '("Do It")) (SI:MAKE-SERIAL-STREAM :BAUD *BAUD* :FORCE-OUTPUT *FORCE-OUTPUT* :NUMBER-OF-DATA-BITS *NUMBER-OF-DATA-BITS* :NUMBER-OF-STOP-BITS *NUMBER-OF-STOP-BITS* :PARITY *PARITY* :XON-XOFF-PROTOCOL *XON-XOFF-PROTOCOL* :ASCII-CHARACTERS *ASCII-CHARACTERS* :INPUT-BUFFER-SIZE *INPUT-BUFFER-SIZE* :OUTPUT-BUFFER-SIZE *OUTPUT-BUFFER-SIZE*)) ;;; Autodial ;;; (DEFVAR *AUTODIAL-PREFIX* "ATDT" "Prefix to send to autodialer modem") (DEFVAR *AUTODIAL-NUMBER* "8,8005551212" "Number to dial") (DEFUN AUTODIAL (&KEY (PREFIX *AUTODIAL-PREFIX*) (NUMBER *AUTODIAL-NUMBER*) STREAM ; could bind this to *SERIAL-PORT-OWNER* MENU VERBOSE) "Dial a number using an autodialer. If :NUMBER is not specified, use the last number dialed. If :MENU is specified, display a menu to select the number to dial." (LET ((PRE PREFIX) (NUM NUMBER) (CONTINUE T)) (DECLARE (SPECIAL PRE NUM)) (WHEN MENU (SETQ CONTINUE (*CATCH 'END-CVV (TV:CHOOSE-VARIABLE-VALUES '((PRE "Prefix" :DOCUMENTATION "Modem's autodial prefix (e.g., ATDT)." :STRING) (NUM "Number" :DOCUMENTATION "Telephone number to dial. A comma <,> causes a 2 second wait." :STRING)) :NEAR-MODE '(:POINT 500 400) :LABEL "Serial Port Autodial" :MARGIN-CHOICES '("Do It" ("Quit" (*THROW 'END-CVV NIL)))) T))) (WHEN CONTINUE (IF (NOT (STREAMP STREAM)) (WHEN VERBOSE (FORMAT T "~&Stream <~A> is not a valid stream." STREAM)) (PROGN (SETQ *AUTODIAL-PREFIX* PRE) (SETQ *AUTODIAL-NUMBER* NUM) (SEND STREAM :CLEAR-INPUT) (SEND STREAM :CLEAR-OUTPUT) (SEND STREAM :LINE-OUT (FORMAT NIL "~A~A" *AUTODIAL-PREFIX* *AUTODIAL-NUMBER*)) (PROCESS-WAIT-WITH-TIMEOUT "Dialing..." 3600 (FUNCTION (LAMBDA (STREAM) (SEND STREAM :GET :DATA-CARRIER-DETECT))) STREAM) (SEND STREAM :CLEAR-INPUT) (SEND STREAM :CLEAR-OUTPUT) T))))) ;;; RUN-SCRIPT ;;; (DEFUN RUN-SCRIPT (script &KEY (stream *TERMINAL-IO*) (debug-stream *DEBUG-IO*) &AUX (response (make-array 5000. :type art-string :fill-pointer 0)) (return-value nil)) "Simulate an interactive user session with a script. SCRIPT is a list of the form ((SEND RECEIVE ACTION)...). SEND is a list of a format control string and its arguments that specify the output to be sent to STREAM. RECEIVE is a list of a format control string and its arguments that specify the input expected from STREAM. ACTION specifies what to do if the data received doesn't contain the string specified by RECEIVE. It can be :L (loop forever), :Q (quit,the default), a number indicating the number of times to loop and before quitting, or a list of a format control string and its arguments that specify an alternative output to be sent to STREAM. For each element of SCRIPT, first SEND is sent to STREAM, then STREAM is checked for input that matches RECEIVE, if it is found, the next form is processed, else, the ACTION is processed, and STREAM is again checked for input that matches RECEIVE. STREAM is an I/O stream. When DEBUG-STREAM is specified, it should be an I/O stream where debug info is sent. RUN-SCRIPT returns :SUCCESSFUL if the last RECEIVE in SCRIPT was successful, :UNSUCCESSFUL otherwise." (CHECK-ARG SCRIPT LISTP "a list") (CHECK-ARG STREAM STREAMP "a stream") (CHECK-ARG DEBUG-STREAM STREAMP "a stream") (DOLIST (item script return-value) (SETQ return-value (LET* ((send (FIRST item)) (receive (SECOND item)) (action (THIRD item))) (DO () (NIL) (WHEN send (LET ((formatted-string (APPLY #'FORMAT NIL (CAR send) (CDR send)))) (SEND stream :STRING-OUT formatted-string) (WHEN debug-stream (FORMAT debug-stream "~%Sending:~A" formatted-string)))) (IF receive (PROGN (SETF (FILL-POINTER response) 0) (WHEN debug-stream (FORMAT debug-stream "~%Receiving:")) (DO ((char (SEND stream :TYI-WITH-TIMEOUT 1800.)(SEND stream :TYI-WITH-TIMEOUT 1800.))) ((NULL char) T) (WHEN (> char 0) (SETF (AREF response (FILL-POINTER response)) (LOGAND char #o177)) (INCF (FILL-POINTER response)) (WHEN debug-stream (FORMAT debug-stream "~C" (LOGAND char #o177))))) (WHEN debug-stream (FORMAT debug-stream "~%Searching:~A" (APPLY #'FORMAT NIL (CAR receive) nil))) (SEND stream :CLEAR-INPUT) (IF (STRING-SEARCH (APPLY #'FORMAT NIL (CAR receive) (CDR receive)) response) (RETURN :SUCCESSFUL) (IF action (IF (EQ action :Q) (RETURN :UNSUCCESSFUL) (IF (INTEGERP action) (IF (< action 1) (RETURN :UNSUCCESSFUL) (DECF action)) (IF (LISTP action) (SETQ send action) (UNLESS (EQ action :L) (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))))) (RETURN :UNSUCCESSFUL)))) (RETURN :SUCCESSFUL))))))) ;;; Serial stream flavor addition: TYI-WITH-TIMEOUT SI:(DEFMETHOD (SERIAL-STREAM-MIXIN :TYI-WITH-TIMEOUT) (INTERVAL-IN-60THS) (IF (SI:PROCESS-WAIT-WITH-TIMEOUT "Serial Waiting" INTERVAL-IN-60THS (FUNCTION (LAMBDA (STREAM) (SEND STREAM :INPUT-CHARS-AVAILABLE-P))) SELF) (SEND SELF :TYI))) ;;; From sys:telnet;basic-telnet (sort of): ;;; ;;; This method is almost identical to (:method basic-telnet :net-output), ;;; which vt100-frame inherits, except that this version doesn't ;;; automatically send a linefeed after a carriage-return unless the ;;; connection is a chaos connection. Thus, it preserves the existing ;;; behavior for normal connections (and it seems to be the right thing) ;;; while removing the spurious linefeed from serial-port connections. ;;; There may well be a better way to do it. - pf, Sept 11, 1985 (DEFMETHOD (vt100-frame :NET-OUTPUT) (ch) (lock-output (when (ldb-test 1701 ch) ;An NVT char from TELNET-KEYS (if new-telnet-p (send stream ':tyo NVT-IAC)) (setq ch (ldb 0010 ch))) (send stream ':tyo ch) (cond ((and (typep connection 'chaos:conn) (= ch 15)) (send stream ':tyo 12)) ;CR is two chars, CR LF ((and (= ch NVT-IAC) new-telnet-p) (send stream ':tyo NVT-IAC))))) ;IAC's must be quoted ;;; Autodial command method ;;; (DEFCOMMAND (VT100-FRAME :AUTODIAL) () '(:DESCRIPTION "Display a pop-up menu with commands to use an auto dialer." :NAMES ("Autodial")) (DECLARE (SPECIAL *AUTODIAL-PREFIX* *AUTODIAL-NUMBER*)) (COND (CONNECTION (IF (NOT (FUNCTIONP 'AUTODIAL)) (FORMAT T "~&AUTODIAL not loaded. Can't Autodial.")) (FUNCALL 'AUTODIAL :STREAM STREAM :MENU T)) (T (FORMAT T "~&Not connected. Can't Autodial.") (WHEN (NOT UCL:PREEMPTING?) (SEND SELF ':HANDLE-PROMPT))))) ;;; Kermit command method ;;; (DEFCOMMAND (VT100-FRAME :KERMIT) () '(:DESCRIPTION "Display a pop-up menu of KERMIT file-transfer commands." :Names ("Kermit")) (COND (CONNECTION (IF (NOT (FUNCTIONP 'KERMIT:INTERACTIVE-KERMIT)) (FORMAT T "~&KERMIT not loaded. Can't run KERMIT.") (LET ((VT100-SUBSTITUTE (SEND SELF :SELECTION-SUBSTITUTE)) (KERMIT-SUPERIOR (SEND KERMIT:*KERMIT-FRAME* :SUPERIOR)) (MENU-PANE (SEND SELF :GET-PANE 'MENU-TELNET))) (UNWIND-PROTECT (LET ((FORM NIL)) (SEND TYPEOUT-PROCESS :ARREST-REASON 'KERMIT) ; Stop the vt100 process from using serial stream (SETQ FORM (KERMIT:INTERACTIVE-KERMIT STREAM NIL)) ; Get the Kermit arguments (WHEN FORM (SETF (SEND MENU-PANE :INVISIBLE-TO-MOUSE-P) T) ; Make the vt100 menu items non-mousable (SEND KERMIT:*KERMIT-FRAME* :SET-SUPERIOR SELF) (SEND SELF :SET-SELECTION-SUBSTITUTE KERMIT:*KERMIT-FRAME*) ; Attach the kermit frame to vt100 (EVAL FORM))) ; Call Kermit (SEND TYPEOUT-PROCESS :REVOKE-ARREST-REASON 'KERMIT) ; Reallow vt100 to use serial (SETF (SEND MENU-PANE :INVISIBLE-TO-MOUSE-P) NIL) ; Make menu items mousable (SEND SELF :SET-SELECTION-SUBSTITUTE VT100-SUBSTITUTE) (SEND KERMIT:*KERMIT-FRAME* :SET-SUPERIOR KERMIT-SUPERIOR))))) (T (FORMAT T "~&Not connected. Can't run KERMIT.") (WHEN (NOT UCL:PREEMPTING?) (SEND SELF ':HANDLE-PROMPT))))) ;;; Local echo command method ;;; (DEFCOMMAND (vt100-frame :LOCAL-ECHO-COMMAND) () '(:DESCRIPTION "Toggle local echo mode of Vt100 screen pane." :NAMES ("Local Echo")) (SETF ECHO-FLAG (IF ECHO-FLAG NIL T)) (FORMAT T "~&Local echo now ~A.~%" (IF ECHO-FLAG "off" "on")) ; echo-flag=T means local echo is off! (WHEN (AND (NULL CONNECTION) (NOT UCL:PREEMPTING?)) (SEND SELF ':HANDLE-PROMPT))) ;;; Redefine the VT100 layout and menu ;;; (DEFFLAVOR VT100-TELNET-MENU (TV:INVISIBLE-TO-MOUSE-P) (TV:DYNAMIC-ITEM-LIST-MIXIN TV:COMMAND-MENU) (:SETTABLE-INSTANCE-VARIABLES TV:INVISIBLE-TO-MOUSE-P) (:DEFAULT-INIT-PLIST :LABEL (LIST :TOP :FONT FONTS:HL12B :STRING "VT100 & Telnet Commands") :ROWS 3 ; BAC changed from 2 :COLUMNS 7 ; BAC changed from 7 :VSP 8. :FONT-MAP (list fonts:MEDFNT) :LABEL-BOX-P nil :ITEM-LIST nil) (:DOCUMENTATION :COMBINATION "Command menu needs dynamic-item-list-mixin for UCL.")) (BUILD-COMMAND-TABLE 'VT100-TELNET-CMD-TABLE 'VT100-FRAME '((:method telnet-frame :exit-command) (:method telnet-frame :disconnect-command) (:method telnet-frame :interrupt-process-command) :send-answerback-command :reverse-video-command :reset-command :escape-processing-command (:method telnet-frame :quit-and-disconnect-command) (:method telnet-frame :status-command) (:method telnet-frame :abort-output-command) :column-command :truncate-command :set-vt100-lines :network-help-command (:method telnet-frame :clear-input-command) (:method vt100-frame :autodial) ; BAC (:method vt100-frame :kermit) ; BAC :local-echo-command ; BAC ) :INIT-OPTIONS '(:NAME "Vt100 & Telnet Commands" :DOCUMENTATION "The Vt100 & Telnet commands.")) (BUILD-MENU 'UCL-VT100-TELNET-MENU 'VT100-FRAME :DEFAULT-ITEM-OPTIONS '(:FONT FONTS:MEDFNT) :ITEM-LIST-ORDER '( ;Row 1 (:method telnet-frame :exit-command) (:method telnet-frame :disconnect-command) (:method telnet-frame :interrupt-process-command) :send-answerback-command :reverse-video-command :reset-command :escape-processing-command ;Row 2 (:method telnet-frame :quit-and-disconnect-command) (:method telnet-frame :status-command) (:method telnet-frame :abort-output-command) :column-command :truncate-command :set-vt100-lines :network-help-command ;Row 3 ; BAC (:method vt100-frame :autodial) ; BAC (:method vt100-frame :kermit) ; BAC :local-echo-command ; BAC )) ;;; The following add Serial streams to the TELNET and VT100 base system. ;;; (DEFVAR telnet:file NIL) (DEFMETHOD (vt100-frame :TYPEOUT-TOP-LEVEL) (&aux (terminal-io vt100-pane)) "Redefines (:METHOD BASIC-NVT :TYPOUT-TOP-LEVEL) to use :PROCESS-ESCAPE" (declare (special telnet:file)) (process-wait "Never-open" #'car (locate-in-instance self 'connection)) (ucl:ignore-errors-query-loop (condition-bind (((sys:remote-network-error ip:illegal-connection ip:connection-reset) 'typeout-net-error self)) (do-forever (do ((ch (nvt-neti) (send stream :tyi-no-hang))) ((null ch) (if output-buffer (send self :force-output))) (when (not (null telnet:file)) (send telnet:file :tyo ch)) (send self :process-escape (IF (EQ CONNECTION T) (logand #b01111111 ch) ; if we don't strip parity we get an error ;; BAC ch))))))) ;;; This method should return the network connection. This can ;;; be a stream or a connection object depending on the network type. ;;; ;;; The method :NETWORK-NEW-CONNECTION is not needed for serial telnet. (DEFMETHOD (basic-nvt :case :network-new-connection :serial) (host &optional (contact "TELNET") (window nil) ) window contact host nil) ; BAC to eliminate compile warnings (RECOMPILE-FLAVOR 'vt100-frame :NETWORK-NEW-CONNECTION) ;;; Return nil if the connection is not connected. (DEFMETHOD (basic-nvt :case :network-connected-p :serial)() (and stream connection)) (RECOMPILE-FLAVOR 'vt100-frame :NETWORK-CONNECTED-P) ;;; The method :NETWORK-NEW-CONNECTION passes the arguement which we ;;; ignore for the serial implementation. ;;; ;;; Set stream to be the serial stream. ;;; Connection should be something non nil, but does not need to be a connection. ;;; The connection instance variable is used by CHAOSNET. (DEFMETHOD (basic-nvt :case :set-connection :serial) (ignore) (SEND typein-process :reset) (SEND typeout-process :reset) (SETF stream (MAKE-SERIAL-STREAM-FROM-CVV)) ;; (SEND self :gobble-greeting) (SETF connection t) (SETQ black-on-white nil)) (RECOMPILE-FLAVOR 'vt100-frame :SET-CONNECTION) ;;; This method should close the serial TELNET connection. ;;; Make sure to set both instance variables, STREAM and CONNECTION, ;;; to nil. (DEFMETHOD (basic-nvt :case :network-disconnect :serial)() (WHEN stream (SEND stream :close) (SETF stream nil connection nil))) (RECOMPILE-FLAVOR 'vt100-frame :NETWORK-DISCONNECT) ;;; This method should indicate the connection state. ;;; It would be nice if you could signal errors in the connection ;;; state by throwing 'NVT-DONE because TELNET will try to eloquently ;;; close the connection. (defmethod (basic-nvt :case :check-connection-state :serial)() (unless stream (*THROW 'TELNET:NVT-DONE "Stream never opened."))) (RECOMPILE-FLAVOR 'vt100-frame :CHECK-CONNECTION-STATE) ;;; Send the TELNET command interrupt process (IP) to the remote host. ;;; (Note: IP should not be confused with the acronym for a well known ;;; network type.) ;;; An IP command is defined to be the following two bytes: NVT-IAC NVT-IP. ;;; Many implementations send the IP in urgent mode as the following sequence of bytes ;;; NVT-IAC, NVT-IP, NVT-IAC, NVT-DM. This is technically a SYNC signal but ;;; most systems handle no differently. The TCP/IP network sends a SYNC signal ;;; in urgent mode, the CHAOS network sends a SYNC signal not in urgent mode ;;; because there is no concept of urgent data, Wollongong sends just an IP command ;;; and the MIT PC software sends a SYNC signal in urgent mode. ;;; ;;; You may choose to send a SYNC signal or just IP command I think it makes little ;;; difference (except with Wollongong which can't handle SYNC signals successfully). ;;; However, since serial streams do not have a concept of ;;; urgent mode I choose to send a SYNC signal. (DEFMETHOD (basic-telnet :case :network-send-ip :serial)() (lock-output (SEND stream :tyo NVT-IAC) (SEND stream :tyo NVT-IP) (SEND stream :tyo NVT-IAC) (SEND stream :tyo NVT-DM) )) (RECOMPILE-FLAVOR 'vt100-frame :NETWORK-SEND-IP) (UNLESS (MEMBER :serial protocols-supporting-telnet) (PUSH :serial protocols-supporting-telnet)) ;;; This is a kludge to make serial telnet work correctly. ;;; If there were serial host objects then this would not ;;; be necessary. (setq default-network-type :serial) ;*** VTCURS.LSP *** ;;; -*- Mode: Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (c) 1986, Texas Instruments Incorporated. All rights reserved. ;;; Written 5/16/86 10:34:33 by FORD, ;;; Reason: Fix (:METHOD VT100-ESCAPE-SEQUENCE-MIXIN :PROCESS-ESCAPE-BRACKET-NUMERIC-NUMERIC-SEMICOLON-SEQUENCE) ;;; to properly process the second leading zero in escape sequences like . ;;; while running on B from band LOD2 ;;; 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. #!Z ; From file PROCESS-ESCAPE-SEQUENCE.LISP#> VT100; A: #10R TELNET#: (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET")) (SI:LISP-MODE :ZETALISP) (*READTABLE* SI:STANDARD-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL)) (COMPILER#:PATCH-SOURCE-FILE "SYS: VT100; PROCESS-ESCAPE-SEQUENCE.#" (DEFMETHOD (vt100-escape-sequence-mixin :PROCESS-ESCAPE-BRACKET-NUMERIC-NUMERIC-SEMICOLON-SEQUENCE) (ch) (cond ((= ch #/r) ; ESC [ num num ; num num r (setq scroll-ending-line ; Scrolling regions (min ending-line (tv:sheet-number-of-inside-lines vt100-pane))) (setq scroll-starting-line starting-line-completed-value) (if (= scroll-ending-line 0) (setq scroll-ending-line (tv:sheet-number-of-inside-lines vt100-pane))) (setq top-of-scroll scroll-starting-line) (setq bottom-of-scroll scroll-ending-line) (send vt100-pane ':set-cursorpos 0 0 ':character) (send self ':reset)) ((or (= ch #/H) (= ch #/f)) ; Direct cursor addressing ; ESC [ 14 ; H ESC [ 14 ; 1 H ESC [ 14 ; 12 H ; And the same sequences with 'f' (send self ':move-to-direct-cursor-position starting-line-completed-value column) (send self ':reset)) (escape-bracket-numeric-numeric-semicolon-numeric-flag ;This is the second of the two digits, so now make a two digit value (cond ((and test-for-three-digits-flag ; Check for "00", ie, ESC [ 10;007H (= escape-bracket-numeric-numeric-semicolon-numeric-ch #/0)) (setq test-for-three-digits-flag nil) (setq escape-bracket-numeric-numeric-semicolon-numeric-numeric-ch ch) (setq ending-line (make-two-digit-value escape-bracket-numeric-numeric-semicolon-numeric-ch escape-bracket-numeric-numeric-semicolon-numeric-numeric-ch)) (setq column ending-line)) (t (setq escape-bracket-numeric-numeric-semicolon-numeric-numeric-ch ch) (setq ending-line (make-two-digit-value escape-bracket-numeric-numeric-semicolon-numeric-ch escape-bracket-numeric-numeric-semicolon-numeric-numeric-ch)) (setq column ending-line)))) ((and (>= ch #/0) (<= ch #/9)) ;This is the first of the two digits (setq test-for-three-digits-flag t) (setq escape-bracket-numeric-numeric-semicolon-numeric-ch ch) (setq column (- ch #/0)) (setq escape-bracket-numeric-numeric-semicolon-numeric-flag t) (cond ((= starting-line-second-ch 99.) (setq ending-line (make-two-digit-value escape-bracket-numeric-semicolon-numeric-ch escape-bracket-numeric-numeric-semicolon-numeric-ch)) (setq starting-line (- starting-line #/0))) (t NIL))) (t (send self ':reset)))) )) ;*** VTCKEY.LSP *** ;;; -*- Mode: Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (c) 1986, Texas Instruments Incorporated. All rights reserved. ;;; Written 8/07/86 13:42:03 by FORD, ;;; Reason: Commented out check for Keypad-mode in cursor key methods. ;;; It doesn't appear as if cursor-key mode and keypad-mode ;;; should be connected. Steve Ford 8-7-86 ;;; while running on D from band LOD1 ;;; 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. #!Z ; From file PROCESS-ESCAPE-SEQUENCE.LISP#> VT100; F: #10R TELNET#: (COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TELNET")) (SI:LISP-MODE :ZETALISP) (*READTABLE* SI:STANDARD-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* NIL)) (COMPILER#:PATCH-SOURCE-FILE "SYS: VT100; PROCESS-ESCAPE-SEQUENCE.#" (DEFMETHOD (vt100-escape-sequence-mixin :AUXILIARY-UP) () (cond (nil ;(and keypad-mode process-ch?) (send self ':applications-mode) (send self ':net-output #/A)) (t (send self ':net-output #\escape) (send self ':net-output #/[) (send self ':net-output #/A)))) (DEFMETHOD (vt100-escape-sequence-mixin :AUXILIARY-DOWN) () (cond (nil ;(and keypad-mode process-ch?) (send self ':applications-mode) (send self ':net-output #/B)) (t (send self ':net-output #\escape) (send self ':net-output #/[) (send self ':net-output #/B)))) (DEFMETHOD (vt100-escape-sequence-mixin :AUXILIARY-RIGHT) () (cond (nil ;(and keypad-mode process-ch?) (send self ':applications-mode) (send self ':net-output #/C)) (t (send self ':net-output #\escape) (send self ':net-output #/[) (send self ':net-output #/C)))) (DEFMETHOD (vt100-escape-sequence-mixin :AUXILIARY-LEFT) () (cond (nil ;(and keypad-mode process-ch?) (send self ':applications-mode) (send self ':net-output #/D)) (t (send self ':net-output #\escape) (send self ':net-output #/[) (send self ':net-output #/D)))) ))