;;; -*- 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))))