KERMIT.SCR Contains a simple implementation of the Kermit file transfer protocol. copyright 1997 Frank Sergeant pygmy@pobox.com 809 W. San Antonio St. San Marcos, TX 78666 This source code is not Public Domain or Shareware. You may use it freely for any private or commercial purpose provided you do so at your own risk. ( load screen Kermit file transfer protocol) " *** Simple Kermit file transfer protocol Copyright (c) 1997 Frank Sergeant (pygmy@pobox.com) *** " DROP 12002 12024 THRU EXIT ( KERMIT - user interface) : GET-Y/N ( - f) BEGIN KEY DUP 'Y = OVER 'y = OR IF DROP -1 EXIT THEN DUP 'N = SWAP 'n = OR IF 0 EXIT THEN BEEP AGAIN ; : TRY-AGAIN? ( a - f) CR COUNT TYPE CR ." Try again? (Y/N) " GET-Y/N ( f) ; : .MSG ( a -) 0 0 AT 160 SPACES 0 0 AT COUNT TYPE ; ( KERMIT) 1 CONSTANT SOH VARIABLE SEQ SEQ OFF : BUMPSEQ ( -) SEQ @ 1+ 63 AND SEQ ! ; 94 ( 35) CONSTANT MYMAXL ( fields SEQ TYPE DATA & CKSUM) CREATE OUT-BUF MYMAXL ( 1+) 2 + ALLOT VARIABLE OUTLEN CREATE IN-BUF MYMAXL ( 1+) 2 + ALLOT VARIABLE INLEN : ?NUM-OK ( n -) $5E > ABORT" too big" ; : CHAR ( n - c) DUP ?NUM-OK ( n) $20 + ; : UNCHAR ( c - n) $20 - ( n) DUP ?NUM-OK ; ( KERMIT - protocol parameters) VARIABLE MAXL VARIABLE QCTL VARIABLE NPAD VARIABLE PADC VARIABLE EOLC VARIABLE TIMEOUT : INIT-LIMITS ( -) MYMAXL MAXL ! ( maximum "len" value) '# QCTL ! ( control code escape character) 0 NPAD ! ( number of pad characters) 0 PADC ! ( pad character) $0D EOLC ! ( end of line character) 4 TIMEOUT ! ( timeout in seconds) ; INIT-LIMITS ( KERMIT - address of fields in buffers) : FIELD: ( offset -) ( buff - a) CREATE C, DOES> C@ + ; 0 FIELD: >LEN 1 FIELD: >SEQ 2 FIELD: >TYPE 3 FIELD: >DATA : >CKSUM ( buff - a) >LEN DUP C@ UNCHAR + ; 3 FIELD: >MAXL 4 FIELD: >TIME 5 FIELD: >NPAD 6 FIELD: >PADC 7 FIELD: >EOLC 8 FIELD: >QCTL ( KERMIT - compromise on the parameters) : COMPROMISE ( -) OUT-BUF IN-BUF ( a a) OVER >MAXL C@ UNCHAR OVER >MAXL C@ UNCHAR MIN MAXL ! ( a a) OVER >TIME C@ UNCHAR OVER >TIME C@ UNCHAR MAX TIMEOUT ! ( a a) 2DROP ; DEFER M ( the menu to return to) : KSER-IN ( - c f) TIMEOUT @ 1000 * ( ms) BEGIN KEY? IF KEY DROP CR ." Abort file transfer (Y/N)? " GET-Y/N CR IF ." Transfer aborted -- press " ." any key to return to menu" KEY DROP M ELSE ." Transfer continuing " THEN THEN SER-IN? IF ( ms) DROP SER-IN DUP SOH = ( c f) EXIT THEN ( ms) 1- DUP 0= IF POP 2DROP 'V -1 EXIT THEN 1 MS AGAIN ; : TEST-IN ( - c f) KSER-IN ; ( KERMIT ) : CTRL ( c - c') DUP QCTL @ = OVER '~ = OR IF EXIT THEN $40 XOR ; : CTRL? ( c - f) DUP $20 < OVER QCTL @ = OR OVER $7E = OR SWAP $7F = OR ; : (KEMIT ( c -) OUT-BUF OUTLEN @ + C! ( ) 1 OUTLEN +! ; : KEMIT ( c -) PAUSE ( just in case) ( c) DUP CTRL? IF QCTL @ (KEMIT CTRL ( c) THEN (KEMIT ; : ROOM? ( - u) MAXL @ 1- OUTLEN @ > ; ( KERMIT ) : CK%% ( u - c) DUP $C0 AND 2/ 2/ 2/ 2/ 2/ 2/ + $3F AND CHAR ; : CKSUM ( buffer - c) >LEN DUP C@ UNCHAR ( a #) 0 ROT ROT FOR ( sum a) C@+ +UNDER NEXT DROP CK%% ( c) ; : CKSUM? ( - f) IN-BUF CKSUM ( c) IN-BUF >CKSUM C@ ( c c) = ; DEFER MODEM! ( ' EMIT) ' SER-OUT IS MODEM! : DATA! ( a # - a' #') SWAP ( # a) BEGIN ( # a) OVER 0= ROOM? 0= OR ( ie out of source or room) NOT WHILE ( # a) C@+ KEMIT -1 +UNDER REPEAT SWAP ( a #) ; : BUILD-FRAME ( a # type - a' #') OUTLEN OFF 0 ( ie dummy len) CHAR (KEMIT SEQ @ CHAR (KEMIT (KEMIT ( a #) DATA! ( a' #') OUTLEN @ CHAR OUT-BUF >LEN C! ( a #) OUT-BUF CKSUM OUT-BUF >CKSUM C! ( a #) ; ( KERMIT - debugging aids) : .FRAME ( buf -) ." len = " C@+ UNCHAR DUP PUSH 2 U.R ." seq = " C@+ UNCHAR 2 U.R SPACE SPACE ." myseq = " SEQ @ 2 U.R SPACE SPACE POP 1- TYPE CR ; : .INB ( type -) .S 3 SPACES 'V = IF ." V-frame " CR ELSE ." IN: " IN-BUF .FRAME THEN ; : .OUTB ( -) .S 3 SPACES ." OUT: " OUT-BUF .FRAME ; " WHAT DOES THE SYMBOL # STAND FOR?" CONSTANT TEST1 " as much labor for the study of its" CONSTANT TEST2 ( KERMIT) : SENDFRAME ( -) SOH MODEM! OUT-BUF >LEN DUP C@ UNCHAR 1+ FOR ( a) C@+ MODEM! NEXT DROP ( ) $0D MODEM! ; ( KERMIT) : LIMITS ( type -) SEQ OFF PUSH '~ ( the repeat char) '1 ( 1-byte chksum, either '1 or 1 CHAR seems to work) 'N ( no hi-bit prefix) QCTL @ EOLC @ CHAR PADC @ CTRL NPAD @ CHAR TIMEOUT @ CHAR MAXL @ CHAR POP SEQ @ CHAR 12 ( len) CHAR OUT-BUF 12 FOR DUP PUSH C! POP 1+ NEXT DROP ( ) OUT-BUF CKSUM OUT-BUF >CKSUM C! ; ( KERMIT) : BUILD/SEND ( a # type -) BUILD-FRAME SENDFRAME 2DROP ; : KINIT ( -) 'S LIMITS SENDFRAME ; : KINITACK ( -) 'Y LIMITS COMPROMISE 'Y LIMITS SENDFRAME ; : FILEHEADER ( a # -) " sending file " .MSG 2DUP TYPE ( a #) 'F BUILD/SEND ; : EMPTY-FRAME ( type -) ( ) CREATE C, DOES> C@ 0 0 ROT BUILD/SEND ; 'Y EMPTY-FRAME (ACK 'N EMPTY-FRAME (NAK 'Z EMPTY-FRAME EOF 'B EMPTY-FRAME EOT 'A EMPTY-FRAME ATTRIB 'E EMPTY-FRAME ERROR : ACK ( seq# -) SEQ @ SWAP SEQ ! (ACK SEQ ! ; : NAK ( seq# -) SEQ @ SWAP SEQ ! (NAK SEQ ! ; ( KERMIT) VARIABLE EXPECTED : INBUF! ( c -) IN-BUF INLEN @ + C! 1 INLEN +! ; : SETLENGTH ( clength -) INLEN OFF DUP INBUF! ( c) UNCHAR EXPECTED ! ; : PUT-IN-BUFFER ( c - f) INBUF! INLEN @ EXPECTED @ > ; ( KERMIT) : GETFRAME ( - type f) BEGIN KSER-IN NIP UNTIL ( ) ( ie await SOH) BEGIN BEGIN KSER-IN WHILE DROP REPEAT ( c) SETLENGTH ( ) BEGIN KSER-IN NOT WHILE ( c) PUT-IN-BUFFER ( f) IF IN-BUF >TYPE C@ CKSUM? OVER 'E = OVER AND ABORT" Fatal Error in Kermit" EXIT THEN ( ) REPEAT ( c) DROP AGAIN ( type f) ; ( KERMIT) : GET-GOOD-FRAME ( - type) BEGIN GETFRAME ( type cksumflag) NOT WHILE ." bad cksum " DROP REPEAT ; : IN-SEQ ( - u) IN-BUF >SEQ C@ UNCHAR ; : GOOD-SEQ? ( - f) IN-SEQ SEQ @ = ; ( KERMIT) : (GETACK ( - type) BEGIN GETFRAME ( type f) NOT WHILE DROP REPEAT ( type) ; : GETACK ( -) BEGIN (GETACK ( type) 'Y OF GOOD-SEQ? ( f) DUP IF BUMPSEQ THEN ( f) ELSE 'N OF GOOD-SEQ? IF SENDFRAME THEN 0 ELSE 'V OF SENDFRAME 0 ELSE ( default) DROP 0 [ 3 ] THENS ( f) UNTIL ; : READ ( h - a #) PUSH 32767 BUFFER ( ie dummy buffer) DUP 1024 POP FILE-READ #BYTES-READ @ ; ( KERMIT) : GET-FIRST-NAK ( -) BEGIN (GETACK 'N = UNTIL ; : SEND ( name -) CLS " Waiting to send " .MSG INIT-LIMITS DUP FOPEN IF CR ." cannot open input file" CR EXIT THEN ( name h) 1000 MS ( name h) GET-FIRST-NAK ( n h) KINIT RESET-SER-IN GETACK COMPROMISE SWAP COUNT ( h a #) FILEHEADER ( h) GETACK BEGIN ( h) DUP READ DUP WHILE ( h a #) BEGIN 'D BUILD-FRAME SENDFRAME GETACK '. EMIT DUP 0= UNTIL 2DROP REPEAT 2DROP ( h) FCLOSE ( ) EMPTY-BUFFERS ( just in case) EOF GETACK EOT GETACK ; ( KERMIT) CREATE IN-DATA MYMAXL 3 / 94 * 2 + ALLOT : C!+ ( c a - a+) DUP PUSH C! POP 1+ ; : C@+- ( fr # - fr # c) 1- PUSH C@+ POP SWAP ; : UNCTRL'd ( from # c - from # c) DUP QCTL @ - IF EXIT THEN DROP C@+- CTRL ; ( KERMIT) : REPEAT'd ( to from # - to from #) ROT PUSH ( fr #) C@+- UNCHAR PUSH C@+- ( fr # c) UNCTRL'd ( fr # c) POP POP ( ie rpt# to) 2DUP + PUSH ( fr # c rpt# to) SWAP ROT FILL ( fr #) POP ROT ROT ( to fr #) ; : UNCTRL ( from to # - a #) ROT PUSH PUSH DUP POP POP SWAP ( to to from #) BEGIN DUP WHILE ( to to fr #) C@+- DUP '~ = IF ( to to fr # c) DROP REPEAT'd ELSE UNCTRL'd PUSH ROT POP SWAP C!+ ROT ROT THEN REPEAT ( to to fr 0) 2DROP OVER - ( a #) ; : >IN-DATA ( - a #) IN-BUF >DATA IN-DATA ( from to) IN-BUF C@ UNCHAR 3 - ( from to #) UNCTRL ; ( KERMIT) VARIABLE KHANDLE CREATE KFNAME 50 ALLOT : BUILDFNAME ( -) >IN-DATA ( a #) DUP PUSH KFNAME 1+ SWAP CMOVE ( ) 0 KFNAME R@ + 1+ C! ( make name into an asciiz string) POP KFNAME C! ; : RCVNAME ( -) BUILDFNAME KFNAME FMAKE ( h f) ABORT" cannot open output file" ( h) KHANDLE ! " receiving file " .MSG KFNAME COUNT TYPE SPACE ; ( KERMIT) : GETNEXT ( - type) BEGIN GETFRAME ( type f) IF ( type) DUP 'V = IF ( type) SEQ @ NAK -1 ( type f) ELSE ( type) IN-SEQ DUP ACK ( type seq) SEQ @ - THEN ELSE ( ie bad cksum) SEQ @ NAK -1 ( type f) ( -1 ABORT" BAD CKSUM" ) THEN WHILE DROP REPEAT BUMPSEQ ; : WRITE ( -) >IN-DATA KHANDLE @ ( a # h) FILE-WRITE ; ( KERMIT) : RECEIVE ( -) CLS " Waiting to receive " .MSG RESET-SER-IN INIT-LIMITS BEGIN 0 NAK 1000 MS GET-GOOD-FRAME 'S = UNTIL ( ) KINITACK BUMPSEQ BEGIN GETNEXT ( type) ( DUP EMIT ) 'D OF WRITE '. EMIT 0 ELSE 'F OF RCVNAME 0 ELSE 'Z OF KHANDLE @ FCLOSE 0 ELSE 'B OF -1 ELSE ( otherwise) DROP 0 [ 4 ] THENS UNTIL ( ) ;
