home *** CD-ROM | disk | FTP | other *** search
/ kermit.columbia.edu / kermit.columbia.edu.tar / kermit.columbia.edu / pygmyforth / pfkerm.src < prev    next >
Text File  |  1997-11-12  |  10KB  |  437 lines
  1. file pfkerm.src
  2.  
  3.    This is a conversion of the Forth block file KERMIT.SCR
  4.    so as to be readable as a plain text file.  Do not try
  5.    load it (compile it) without editing it to suit your
  6.    version of Forth.  Don't load it under Pygmy Forth;
  7.    instead, get the actual block files from
  8.  
  9.          http://www.eskimo.com/~pygmy/pfkerm.zip
  10.  
  11.  
  12.  
  13. KERMIT.SCR
  14.   Contains a simple implementation of the Kermit
  15.   file transfer protocol.
  16.  
  17.   copyright 1997 Frank Sergeant               pygmy@pobox.com
  18.                  809 W. San Antonio St.
  19.                  San Marcos, TX  78666
  20.  
  21.   This source code is not Public Domain or Shareware.
  22.   You may use it freely for any private or commercial purpose
  23.   provided you do so at your own risk.
  24.  
  25.  
  26.  
  27.  
  28.  
  29.  
  30. ( load screen    Kermit file transfer protocol)
  31.  
  32.  "  *** Simple Kermit file transfer protocol Copyright (c) 1997
  33. Frank Sergeant (pygmy@pobox.com) *** "  DROP
  34.  
  35.  
  36. 12002 12024 THRU
  37.  
  38.  
  39.  
  40.  
  41.  
  42.  
  43.  
  44.  
  45.  
  46.  
  47. EXIT ( KERMIT - user interface)
  48.  
  49. : GET-Y/N ( - f)
  50.   BEGIN KEY DUP 'Y = OVER 'y = OR IF DROP -1 EXIT THEN
  51.             DUP 'N = SWAP 'n = OR IF       0 EXIT THEN  BEEP
  52.   AGAIN  ;
  53.  
  54. : TRY-AGAIN? ( a - f)
  55.   CR COUNT TYPE CR ." Try again? (Y/N) "
  56.   GET-Y/N  ( f)  ;
  57.  
  58. : .MSG ( a -) 0 0 AT 160 SPACES  0 0 AT COUNT TYPE  ;
  59.  
  60.  
  61.  
  62.  
  63.  
  64. ( KERMIT)
  65. 1 CONSTANT SOH
  66. VARIABLE SEQ    SEQ OFF
  67. : BUMPSEQ ( -) SEQ @ 1+ 63 AND SEQ !  ;
  68.   94  ( 35) CONSTANT MYMAXL ( fields SEQ TYPE DATA & CKSUM)
  69.  
  70. CREATE OUT-BUF  MYMAXL ( 1+) 2 + ALLOT     VARIABLE OUTLEN
  71. CREATE  IN-BUF  MYMAXL ( 1+) 2 + ALLOT     VARIABLE INLEN
  72.  
  73. : ?NUM-OK ( n -) $5E > ABORT" too big"  ;
  74. : CHAR ( n - c) DUP ?NUM-OK ( n) $20 +  ;
  75. : UNCHAR ( c - n) $20 - ( n) DUP ?NUM-OK  ;
  76.  
  77.  
  78.  
  79.  
  80.  
  81. ( KERMIT  - protocol parameters)
  82. VARIABLE MAXL
  83. VARIABLE QCTL
  84. VARIABLE NPAD
  85. VARIABLE PADC
  86. VARIABLE EOLC
  87. VARIABLE TIMEOUT
  88.  
  89. : INIT-LIMITS ( -)
  90.   MYMAXL MAXL !  ( maximum "len" value)
  91.       '# QCTL !  ( control code escape character)
  92.        0 NPAD !  ( number of pad characters)
  93.        0 PADC !  ( pad character)
  94.      $0D EOLC !  ( end of line character)
  95.     4 TIMEOUT !  ( timeout in seconds)     ;   INIT-LIMITS
  96.  
  97.  
  98. ( KERMIT  - address of fields in buffers)
  99. : FIELD: ( offset -) ( buff - a) CREATE C,   DOES> C@ +  ;
  100.  
  101. 0 FIELD: >LEN
  102. 1 FIELD: >SEQ
  103. 2 FIELD: >TYPE
  104. 3 FIELD: >DATA
  105. : >CKSUM ( buff - a) >LEN DUP C@ UNCHAR  +  ;
  106.  
  107. 3 FIELD: >MAXL
  108. 4 FIELD: >TIME
  109. 5 FIELD: >NPAD
  110. 6 FIELD: >PADC
  111. 7 FIELD: >EOLC
  112. 8 FIELD: >QCTL
  113.  
  114.  
  115. ( KERMIT - compromise on the parameters)
  116.  
  117. : COMPROMISE ( -)
  118.   OUT-BUF IN-BUF ( a a)
  119.   OVER >MAXL C@ UNCHAR  OVER >MAXL C@ UNCHAR
  120.       MIN  MAXL ! ( a a)
  121.   OVER >TIME C@ UNCHAR  OVER >TIME C@ UNCHAR
  122.       MAX  TIMEOUT ! ( a a)    2DROP  ;
  123.  
  124.  
  125.  
  126.  
  127.  
  128.  
  129.  
  130.  
  131.  
  132. DEFER M  ( the menu to return to)
  133. : KSER-IN ( - c f)
  134.   TIMEOUT @ 1000 * ( ms)
  135.   BEGIN  KEY? IF KEY DROP CR
  136.                     ." Abort file transfer (Y/N)? "  GET-Y/N CR
  137.                     IF ." Transfer aborted -- press "
  138.                        ." any key to return to menu"
  139.                        KEY DROP M
  140.                     ELSE ." Transfer continuing "
  141.               THEN  THEN
  142.     SER-IN? IF ( ms) DROP SER-IN DUP SOH = ( c f) EXIT THEN
  143.     ( ms) 1-  DUP 0= IF POP 2DROP 'V  -1 EXIT THEN     1 MS
  144.   AGAIN  ;
  145.  
  146. : TEST-IN ( - c f)  KSER-IN  ;
  147.  
  148.  
  149. ( KERMIT )
  150. : CTRL ( c - c')
  151.   DUP QCTL @ = OVER '~ = OR IF EXIT THEN  $40 XOR  ;
  152.  
  153. : CTRL? ( c - f)
  154.   DUP $20 < OVER QCTL @ = OR OVER $7E = OR SWAP $7F = OR  ;
  155.  
  156. : (KEMIT ( c -) OUT-BUF  OUTLEN @ + C! (  ) 1 OUTLEN +!  ;
  157.  
  158. : KEMIT  ( c -)  PAUSE ( just in case)
  159.   ( c) DUP CTRL? IF  QCTL @ (KEMIT  CTRL  ( c) THEN (KEMIT  ;
  160.  
  161. : ROOM? ( - u) MAXL @ 1- OUTLEN @  >  ;
  162.  
  163.  
  164.  
  165.  
  166. ( KERMIT )
  167. : CK%% ( u - c)
  168.   DUP $C0 AND 2/ 2/ 2/ 2/ 2/ 2/ + $3F AND CHAR ;
  169.  
  170. : CKSUM ( buffer - c) >LEN DUP C@ UNCHAR ( a #) 0 ROT ROT
  171.   FOR ( sum a) C@+ +UNDER NEXT DROP  CK%% ( c)  ;
  172.  
  173. : CKSUM? ( - f)
  174.   IN-BUF CKSUM ( c)  IN-BUF >CKSUM C@ ( c c)  =  ;
  175.  
  176.  
  177.  
  178.  
  179.  
  180.  
  181.  
  182.  
  183.  
  184. DEFER MODEM!
  185. ( ' EMIT)  ' SER-OUT IS MODEM!
  186.  
  187. : DATA! ( a # - a' #')    SWAP  ( # a)
  188.   BEGIN ( # a) OVER 0= ROOM? 0= OR ( ie out of source or room)
  189.    NOT WHILE ( # a) C@+ KEMIT  -1 +UNDER  REPEAT SWAP ( a #) ;
  190.  
  191. : BUILD-FRAME ( a # type - a' #')   OUTLEN OFF
  192.   0 ( ie dummy len) CHAR (KEMIT    SEQ @ CHAR (KEMIT
  193.   (KEMIT ( a #) DATA! ( a' #')
  194.   OUTLEN @ CHAR  OUT-BUF >LEN C!  ( a #)
  195.   OUT-BUF CKSUM  OUT-BUF >CKSUM C! ( a #)  ;
  196.  
  197.  
  198.  
  199.  
  200. ( KERMIT - debugging aids)
  201.  
  202. : .FRAME ( buf -) ." len = "  C@+ UNCHAR DUP PUSH 2 U.R
  203.   ."  seq = " C@+ UNCHAR 2 U.R SPACE SPACE
  204.   ." myseq = " SEQ @ 2 U.R SPACE SPACE
  205.   POP 1- TYPE  CR  ;
  206.  
  207. : .INB ( type -) .S 3 SPACES
  208.    'V = IF ." V-frame "  CR ELSE ."  IN: " IN-BUF .FRAME THEN ;
  209.  
  210. : .OUTB ( -) .S 3 SPACES ." OUT: " OUT-BUF .FRAME  ;
  211.  
  212. " WHAT DOES THE SYMBOL # STAND FOR?" CONSTANT TEST1
  213.  
  214. " as much labor for the study of its" CONSTANT TEST2
  215.  
  216.  
  217. ( KERMIT)
  218.  
  219. : SENDFRAME ( -) SOH MODEM!  OUT-BUF >LEN DUP C@ UNCHAR 1+
  220.  FOR ( a) C@+ MODEM!  NEXT DROP (  )  $0D MODEM!  ;
  221.  
  222.  
  223.  
  224.  
  225.  
  226.  
  227.  
  228.  
  229.  
  230.  
  231.  
  232.  
  233.  
  234. ( KERMIT)
  235. : LIMITS ( type -)
  236.   SEQ OFF  PUSH
  237.   '~  ( the repeat char)
  238.   '1  ( 1-byte chksum, either '1 or 1 CHAR seems to work)
  239.   'N  ( no hi-bit prefix)
  240.   QCTL @          EOLC @ CHAR  PADC @ CTRL
  241.   NPAD @ CHAR  TIMEOUT @ CHAR  MAXL @ CHAR    POP
  242.   SEQ @ CHAR   12 ( len) CHAR
  243.   OUT-BUF  12 FOR DUP PUSH C!  POP 1+ NEXT DROP  (  )
  244.   OUT-BUF CKSUM  OUT-BUF >CKSUM C!  ;
  245.  
  246.  
  247.  
  248.  
  249.  
  250.  
  251. ( KERMIT)
  252. : BUILD/SEND  ( a # type -) BUILD-FRAME  SENDFRAME 2DROP  ;
  253. : KINIT ( -) 'S LIMITS  SENDFRAME  ;
  254. : KINITACK ( -) 'Y LIMITS COMPROMISE 'Y LIMITS SENDFRAME  ;
  255. : FILEHEADER ( a # -) " sending file " .MSG 2DUP TYPE
  256.   ( a #)   'F BUILD/SEND  ;
  257. : EMPTY-FRAME ( type -) (  ) CREATE C,
  258.   DOES> C@ 0 0 ROT BUILD/SEND  ;
  259.  
  260. 'Y EMPTY-FRAME (ACK     'N EMPTY-FRAME (NAK
  261. 'Z EMPTY-FRAME EOF      'B EMPTY-FRAME EOT
  262. 'A EMPTY-FRAME ATTRIB   'E EMPTY-FRAME ERROR
  263.  
  264. : ACK ( seq# -) SEQ @ SWAP SEQ ! (ACK  SEQ !  ;
  265. : NAK ( seq# -) SEQ @ SWAP SEQ ! (NAK  SEQ !  ;
  266.  
  267.  
  268. ( KERMIT)
  269.  
  270. VARIABLE EXPECTED
  271.  
  272. : INBUF! ( c -)  IN-BUF INLEN @ + C!  1 INLEN +!  ;
  273.  
  274. : SETLENGTH ( clength -)
  275.   INLEN OFF  DUP INBUF!  ( c)   UNCHAR  EXPECTED !  ;
  276.  
  277. : PUT-IN-BUFFER ( c - f)  INBUF! INLEN @ EXPECTED @ > ;
  278.  
  279.  
  280.  
  281.  
  282.  
  283.  
  284.  
  285. ( KERMIT)
  286.  
  287. : GETFRAME ( -  type f)
  288.   BEGIN KSER-IN NIP UNTIL (  )  ( ie await SOH)
  289.   BEGIN
  290.      BEGIN KSER-IN WHILE DROP REPEAT ( c) SETLENGTH (  )
  291.      BEGIN KSER-IN NOT WHILE ( c) PUT-IN-BUFFER ( f)
  292.       IF  IN-BUF >TYPE C@ CKSUM?
  293.           OVER 'E = OVER AND ABORT" Fatal Error in Kermit"
  294.           EXIT THEN (  )
  295.      REPEAT ( c) DROP
  296.   AGAIN  ( type f)  ;
  297.  
  298.  
  299.  
  300.  
  301.  
  302. ( KERMIT)
  303.  
  304. : GET-GOOD-FRAME ( - type)
  305.   BEGIN  GETFRAME ( type cksumflag) NOT WHILE
  306.        ."  bad cksum " DROP  REPEAT  ;
  307.  
  308.  
  309. : IN-SEQ ( - u)  IN-BUF >SEQ C@ UNCHAR  ;
  310.  
  311. : GOOD-SEQ? ( - f)  IN-SEQ SEQ @ =  ;
  312.  
  313.  
  314.  
  315.  
  316.  
  317.  
  318.  
  319. ( KERMIT)
  320. : (GETACK ( - type)
  321.   BEGIN GETFRAME ( type f) NOT WHILE DROP REPEAT ( type)  ;
  322.  
  323. : GETACK ( -)
  324.   BEGIN   (GETACK  ( type)
  325.     'Y OF  GOOD-SEQ? ( f) DUP IF BUMPSEQ THEN    ( f)  ELSE
  326.     'N OF  GOOD-SEQ? IF SENDFRAME THEN              0  ELSE
  327.     'V OF  SENDFRAME                                0  ELSE
  328.     ( default) DROP  0 [ 3 ] THENS ( f)
  329.   UNTIL  ;
  330.  
  331. : READ ( h - a #) PUSH 32767 BUFFER ( ie dummy buffer)
  332.   DUP 1024 POP FILE-READ #BYTES-READ @  ;
  333.  
  334.  
  335.  
  336. ( KERMIT)
  337.  
  338. : GET-FIRST-NAK ( -) BEGIN (GETACK 'N = UNTIL  ;
  339.  
  340. : SEND ( name -) CLS " Waiting to send " .MSG INIT-LIMITS
  341.   DUP FOPEN IF CR ." cannot open input file" CR  EXIT THEN
  342.   ( name h) 1000 MS  ( name h)   GET-FIRST-NAK
  343.   ( n h)  KINIT RESET-SER-IN  GETACK
  344.   COMPROMISE  SWAP COUNT ( h a #) FILEHEADER ( h) GETACK
  345.   BEGIN ( h) DUP READ DUP WHILE ( h a #)
  346.    BEGIN 'D BUILD-FRAME SENDFRAME GETACK  '. EMIT
  347.    DUP 0= UNTIL 2DROP
  348.   REPEAT 2DROP ( h) FCLOSE (   ) EMPTY-BUFFERS ( just in case)
  349.   EOF GETACK  EOT GETACK  ;
  350.  
  351.  
  352.  
  353. ( KERMIT)
  354.  
  355. CREATE IN-DATA    MYMAXL 3 / 94 * 2 +  ALLOT
  356.  
  357. : C!+ ( c a - a+) DUP PUSH C! POP 1+  ;
  358.  
  359. : C@+- ( fr # - fr # c) 1- PUSH C@+ POP SWAP  ;
  360.  
  361. : UNCTRL'd ( from # c - from # c)
  362.   DUP QCTL @ - IF EXIT THEN    DROP C@+- CTRL   ;
  363.  
  364.  
  365.  
  366.  
  367.  
  368.  
  369.  
  370. ( KERMIT)
  371. : REPEAT'd ( to from # - to from #)  ROT PUSH ( fr #)
  372.   C@+- UNCHAR PUSH C@+- ( fr # c) UNCTRL'd ( fr # c)
  373.   POP POP ( ie rpt# to) 2DUP + PUSH ( fr # c rpt# to)
  374.   SWAP ROT FILL ( fr #) POP ROT ROT ( to fr #)  ;
  375.  
  376. : UNCTRL ( from to # - a #)
  377.   ROT PUSH PUSH DUP POP POP SWAP ( to to from #)
  378.   BEGIN DUP WHILE ( to to fr #)
  379.       C@+- DUP '~ = IF ( to to fr # c) DROP REPEAT'd
  380.       ELSE UNCTRL'd PUSH ROT POP SWAP C!+ ROT ROT  THEN
  381.   REPEAT ( to to fr 0) 2DROP  OVER -  ( a #)  ;
  382.  
  383. : >IN-DATA ( - a #) IN-BUF >DATA IN-DATA ( from to)
  384.   IN-BUF C@ UNCHAR 3 - ( from to #) UNCTRL ;
  385.  
  386.  
  387. ( KERMIT)
  388. VARIABLE KHANDLE
  389. CREATE KFNAME 50 ALLOT
  390.  
  391. : BUILDFNAME ( -)
  392.   >IN-DATA ( a #) DUP PUSH KFNAME 1+ SWAP CMOVE (  )
  393.   0 KFNAME R@ + 1+ C!  ( make name into an asciiz string)
  394.   POP KFNAME C!   ;
  395.  
  396. : RCVNAME ( -)
  397.   BUILDFNAME   KFNAME FMAKE ( h f)
  398.   ABORT" cannot open output file" ( h) KHANDLE !
  399.   " receiving file " .MSG KFNAME COUNT TYPE SPACE  ;
  400.  
  401.  
  402.  
  403.  
  404. ( KERMIT)
  405. : GETNEXT ( - type)
  406.   BEGIN GETFRAME ( type f)
  407.      IF ( type) DUP 'V =
  408.         IF ( type) SEQ @ NAK    -1  ( type f)
  409.         ELSE ( type) IN-SEQ DUP ACK ( type seq) SEQ @ -
  410.         THEN
  411.      ELSE
  412.         ( ie bad cksum)
  413.         SEQ @ NAK  -1  ( type f)  ( -1 ABORT"  BAD CKSUM" )
  414.      THEN
  415.    WHILE DROP
  416.   REPEAT   BUMPSEQ  ;
  417.  
  418. : WRITE ( -) >IN-DATA KHANDLE @ ( a # h) FILE-WRITE   ;
  419.  
  420.  
  421. ( KERMIT)
  422.  
  423. : RECEIVE ( -) CLS  " Waiting to receive " .MSG
  424.   RESET-SER-IN    INIT-LIMITS
  425.   BEGIN 0 NAK  1000 MS  GET-GOOD-FRAME  'S = UNTIL
  426.   (  ) KINITACK  BUMPSEQ
  427.   BEGIN  GETNEXT ( type) ( DUP EMIT )
  428.      'D OF  WRITE  '. EMIT       0  ELSE
  429.      'F OF  RCVNAME              0  ELSE
  430.      'Z OF  KHANDLE @ FCLOSE     0  ELSE
  431.      'B OF                      -1  ELSE
  432.      ( otherwise)  DROP          0 [ 4 ] THENS
  433.   UNTIL  (  )  ;
  434.  
  435.  
  436. (end file pfkerm.src)
  437.