home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
kermit.columbia.edu
/
kermit.columbia.edu.tar
/
kermit.columbia.edu
/
archives
/
tiexplorer.zip
/
kermit.lsp
< prev
next >
Wrap
Text File
|
1986-09-22
|
108KB
|
2,628 lines
;;; -*- 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))))