home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / hp86 / hp8krc.bas < prev   
BASIC Source File  |  2020-01-01  |  51KB  |  870 lines
  1. 10   ! **************************************************************** !
  2. 20   ! *                                                              * !
  3. 30   ! *  KERMIT DATA TRANSFER PROGRAM FOR THE HP86 MICROCOMPUTER     * !
  4. 35   ! *                                                              * !
  5. 40   ! *  Version 1.01    :        Date:- 16 Apr 87 at 11:25          * !
  6. 45   ! *                                                              * !
  7. 50   ! *  Programmer:- Martin J. Rootes                               * !
  8. 60   ! *  Location  :- Computer Services Department,                  * !
  9. 70   ! *               Sheffield City Polytechnic.                    * !
  10. 80   ! *                                                              * !
  11. 90   ! **************************************************************** !
  12. 100 DIM IBUFF$[264],OBUFF$[264] !         Define input & output buffers
  13. 105 DIM K$[1],k$[1],I$[256] !             Define string variables
  14. 110 DIM CR$[1],LF$[1],ESC$[1],BEL$[1] !   Define control characters
  15. 115 DIM EL$[1],BS$[1],DEL$[1],NULL$[1] !    ''     ''       ''
  16. 120 DIM SP$[1] !                          Define space
  17. 125 INTEGER S1,S2,S3,S4,K,R,C,I,F !       Define integer variables
  18. 130 CR$[1]=CHR$ (13) @ LF$=CHR$ (10) !    <CR> & <LF>
  19. 135 ESC$[1]=CHR$ (27) @ BEL$=CHR$ (7) !   Escape & bell
  20. 140 EL$[1]=CHR$ (154) @ BS$=CHR$ (155) !  Endline & Backspace keys
  21. 145 DEL$[1]=CHR$ (127) @ NULL$=CHR$ (0) ! Delete & Null
  22. 150 SP$=" " !                             Space
  23. 155 DIM RP$[96],OP$[96],ID$[91],OD$[91] !                         Packets
  24. 160 DIM S$[256],DB$[256],SF$[17],DF$[40],T$[1],RT$[1],c$[1] !
  25. 165 DIM SI$[1],SH$[1],SD$[1],SE$[1],SB$[1],TM$[1],AK$[1],NK$[1] ! Packet types
  26. 170 DIM RQCTL$[1],SQCTL$[1],RPADC$[1],SPADC$[1] !                 Prefix & pad
  27. 175 DIM MK$[1],SEOL$[1],REOL$[1],CRLF$[4] !                       Mark & EOLs
  28. 180 INTEGER N,S,T,e,f,i,j,l,m,r,t !                               Temp vars
  29. 185 INTEGER n,rn,db,tmo,nk,bp,rr,rc,sr,sc !                       Parameters
  30. 190 INTEGER RMAXL,SMAXL,MAXL,MINL,RTO,STO,RNPAD,SNPAD,REOL,SEOL,TMO,STM,RLIM
  31. 195 SI$="S" @ SH$="F" @ SD$="D" @ SE$="Z" @ SB$="B" !  Send packet types
  32. 200 AK$="Y" @ NK$="N" @ TM$="T" @ ER$="E" !            Other packet types
  33. 205 MK$=CHR$ (1) @ CRLF$="#M#J" !                      Mark ^A, <CR><LF>
  34. 210 SEOL$,REOL$=CR$ @ RPADC$=NULL$ @ SQCTL$="#" !  EOL's, pad char & prefix
  35. 215 RMAXL=94 @ RTO,STO=20 @ RNPAD=0 @ SEOL=13 !    Max len, Timeouts, pad & eol
  36. 220 RLIM=10 @ STM=10000 @ rr=17 @ sr=15 @ rc,sc=10 ! Retries, send timeout
  37. 225 db=1 !                                         Debug (ON FOR TESTING)
  38. 250 DIM F$[80],CL$[61],CP$[24]
  39. 255 CL$="CONNECT, SEND, RECEIVE, SET, SHOW, EXIT, QUIT, CAT"
  40. 260 KP$="KERMIT-HP86" @ CP$=KP$ !              Kermit prompt, Command prompt
  41. 265 DIM VC$[63],DT$[1],CN$[1],UL$[1],FTYP$[8] !   Dimension variables
  42. 270 VC$=".1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ" ! Legal characters
  43. 275 DT$="." @ CN$=":" @ UL$="_" @ Q$=CHR$ (34) !  Dot, colon, underline & qoute
  44. 280 FTYP$="DATA" !                                Default file type
  45. 300 ALPHALL @ PAGESIZE 24 @ CLEAR @ R=0 !         Set no of lines (24)
  46. 310 DIM EM$(24)[24] !
  47. 320 EM$(0)="Transfer successfull" @ EM$(1)="Timeout receiving"
  48. 325 EM$(2)="NAK received" @ EM$(3)="Checksum error" @ EM$(4)="Incorrect packet"
  49. 330 EM$(5)="Timeout sending" @ EM$(6)="Cannot rename file"
  50. 335 EM$(7)="Disc write protected" @ EM$(8)="*File closed*"
  51. 340 EM$(9)="File does not exist" @ EM$(10)="Incorrect file type"
  52. 345 EM$(11)="*Random overflow*" @ EM$(12)="Read error"
  53. 350 EM$(13)="End of file" @ EM$(14)="Record does not exist"
  54. 355 EM$(15)="No M.S. device" @ EM$(16)="Directory full"
  55. 360 EM$(17)="Volume not found" @ EM$(18)="MSUS not found"
  56. 365 EM$(19)="Read verify error" @ EM$(20)="Disc full"
  57. 370 EM$(21)="Medium damaged" @ EM$(22)="Disc drive fault"
  58. 372 EM$(23)="Data type error" @ EM$(24)="Transfer aborted"
  59. 375 FSE$=CHR$ (60) @ FOR i=66 TO 72 @ FSE$=FSE$&CHR$ (i) @ NEXT i
  60. 380 FSE$=FSE$&CHR$ (120) @ FOR i=124 TO 130 @ FSE$=FSE$&CHR$ (i) @ NEXT i
  61. 390 DIM A$(9)[18],ST$(1)[9],st$(1)[8]
  62. 395 A$(0)="initialise        " @ A$(1)="file header      "
  63. 400 A$(2)="data              " @ A$(3)="end of file      "
  64. 405 A$(4)="break             " @ A$(5)="error            "
  65. 410 A$(6)="ACK               " @ A$(7)="NAK              "
  66. 415 A$(8)="file header/break " @ A$(9)="data/EOF         "
  67. 420 ST$(0)="Sending" @ st$(0)="sent" @ ST$(1)="Receiving" @ st$(1)="received"
  68. 425 DIM RE$[4],PF$[18] ! End of record sequence, previous file name
  69. 430 INTEGER RE,RL,NR ! No of chars in RE$, Record length, No of records
  70. 435 RE$=CR$&LF$ @ RE=LEN (RE$) @ RL=256 @ NR=40 @ FS=RL*NR/1024 @ PF$=""
  71. 440 DIM SL$[164],OO$[7],DX$[10],FC$[23],PT$[28],BR$[8],HS$[29]
  72. 445 SL$="TIMEOUT, RETRIES, SEND-CONVERT, DEBUG, PREFIX, END-OF-LINE, "
  73. 450 SL$=SL$&"RECORD-END, FILE-SIZE, RECORD-LENGTH, NO-OF-RECORDS, "
  74. 455 SL$=SL$&"DUPLEX, LOCAL-ECHO, FLOW-CONTROL, HANDSHAKE, PARITY"
  75. 460 OO$="OFF, ON" @ DX$="FULL, HALF" @ FC$="NONE, XON/XOFF, DTR/RTS"
  76. 462 PT$="NONE, ODD, EVEN, MARK, SPACE" @ BR$="110, 300"
  77. 463 HS$="NONE, BELL, LF, CR, XON, XOFF"
  78. 465 DIM SS$[47],RS$[32]
  79. 470 SS$="SEND "&Q$&"Source filename"&Q$&" <"&Q$&"Destination filespec"&Q$&">"
  80. 475 RS$="RECEIVE <"&Q$&"Destination filespec"&Q$&">"
  81. 480 DIM IO$[14],IC$[14],IV$[13]
  82. 485 IO$="Illegal option" @ IC$="Illegal string" @ IV$="Illegal value"
  83. 490 INTEGER BR,DX,LE,FC,HS,PT,SC,ps
  84. 495 BR,DX,LE=1 @ PT=3 @ FC,SC,ps=0 @ HS=4 @ GOSUB rs_set
  85. 500 ! ******************************************************************** !
  86. 510 ! *                                                                  * !
  87. 520 ! *                  COMMAND PROCESSOR SECTION                       * !
  88. 530 ! *                                                                  * !
  89. 540 ! ******************************************************************** !
  90. 550 ! #
  91. 560 ! # This section passes a parameter list to the required command in S$
  92. 570 !
  93. 580 !                      COMMAND PROCESSOR
  94. 590 !                      -----------------
  95. 600 com_proc: GOSUB dkeys  !       Set keys to jump to dummy routine
  96. 610 AWRITE 20,0 @ DISP CP$&" > Enter command ";! Display command prompt
  97. 620 RELEASE KEYBOARD !             Resort to normal keyboard operation
  98. 630 INPUT S$@ CP$=KP$ !            Input string, reset command prompt
  99. 640 TAKE KEYBOARD !                Block out keyboard again
  100. 645 AWRITE 19,0,RPT$ (" ",80) !     Blank any message from previous command
  101. 646 AWRITE 22,0,RPT$ (" ",160) !    ''   ''    ''     ''     ''      ''
  102. 650 GOSUB split  !                 Split at fist space
  103. 660 C=FNinlist(F$,CL$) !           Is command in command list
  104. 670 IF C=0 THEN AWRITE 22,0,"Invalid command - "&F$ ! No - display
  105. 675 IF C<1 THEN 610 !              ? - re-enter
  106. 680 ON C GOSUB connect ,send_file ,rec_file ,set ,show_pars ,exit ,exit ,dir
  107. 690 GOTO com_proc
  108. 700 !
  109. 710 !        ROUTINE TO SPLIT STRING AT FIRST SPACE OR QOUTE
  110. 720 !        -----------------------------------------------
  111. 730 split: S$=TRIM$ (S$) !                       Trim leading/trailing spaces
  112. 740 p=POS (S$,Q$) @ P=POS (S$,SP$) !             Find position of qoute & space
  113. 745 IF p*P=0 THEN P=MAX (P,p) ELSE P=MIN (P,p) ! If both find first
  114. 750 IF P=0 THEN F$=S$ @ S$="" ELSE F$=S$[1,P-1] @ S$=S$[P,LEN (S$)]
  115. 760 RETURN !                       Return F$=First 'word' S$=rest
  116. 850 !
  117. 860 !                     EXIT ROUTINE
  118. 870 !                     ------------
  119. 880 exit: CLEAR @ RELEASE KEYBOARD @ ABORTIO 10 @ DISP "Kermit finished" @ END
  120. 900 !
  121. 910 !                       CATALOGUE DISK
  122. 920 !                       --------------
  123. 930 dir: ON ERROR GOSUB fserr  @ f=0 !              Set error trap
  124. 935 S$=TRIM$ (S$) @ IF S$#"" THEN CAT S$ ELSE CAT ! Catalogue disk
  125. 940 IF f#0 THEN AWRITE 19,0,EM$(f) @ RETURN ! If error display message
  126. 950 FOR I=1 TO 4 @ DISP @ NEXT I @ RETURN !   Move screen up 4 lines
  127. 1000 ! ****************************************************************** !
  128. 1010 ! *                                                                * !
  129. 1020 ! *                     TERMINAL EMULATION                         * !
  130. 1030 ! *                                                                * !
  131. 1040 ! ****************************************************************** !
  132. 1050 connect: F,f=0 !                   Reset escape flag & cr flag
  133. 1070 C=0 @ START CRT AT R !             Set initial position on screen
  134. 1080 AWRITE 0,0 @ CLEAR !               Clear screen
  135. 1090 DISP "HP86 Kermit - Terminal emulation mode" @ DISP
  136. 1100 DISP "Function key   Escape character   Action"
  137. 1110 DISP "--------------------------------------------------"
  138. 1120 DISP "   k1                 C           Return to KERMIT"
  139. 1130 DISP "   k7                 B           Transmit break"
  140. 1135 DISP "   k14                            Enable transmit"
  141. 1140 AWRITE 23,0 !                      Move cursor to first position
  142. 1150 DEL=5 !                            Keyboard delay = 05 milliseconds
  143. 1160 ON KEY# 1 GOTO EXIT1  !            Set k1 to branch to an exit routine
  144. 1170 ON KEY# 7 GOSUB BREAK  !           k7 transmit a break
  145. 1172 ON KEY# 14 GOSUB TX_EN  !          k14 re-enable transmitter
  146. 1180 ON EOT 10 GOSUB BUFFULL  !         Input buffer full routine
  147. 1190 TAKE KEYBOARD !                    place all keys in buffer (except k1-14)
  148. 1200 k$=" " @ AWRITE 23,0,HGL?$ (k$,1) !   Set cursor on
  149. 1210 !
  150. 1220 !                    START OF LOOP
  151. 1230 !                    -------------
  152. 1240 START: STATUS 10,9 ; S1,S2 !       Get RS232 transmit status
  153. 1250 ! Bit 7 of S1 = Transmit enabled  :  Bit 5 of S2 = Transmit buffer empty
  154. 1260 ! Check transmit status if can't transmit get byte from RS232 (if there)
  155. 1270 IF BINAND (S1,128)=0 OR BINAND (S2,32)=0 THEN RSGET
  156. 1280 !
  157. 1290 !                 CHECK KEYBOARD GET KEY PRESSED
  158. 1300 !                 ------------------------------
  159. 1310 K$=KEY$  @ IF K$="" THEN RSGET !   Get key if null get byte from RS232
  160. 1320 IF F=0 THEN KOUT ELSE F=0 !        If escape not pressed last time skip
  161. 1330 IF K$=ESC$ THEN 1500 !              If escape - transmit
  162. 1340 IF K$="C" OR K$="c" THEN EXIT1 !   If C exit program
  163. 1350 IF K$="B" OR K$="b" THEN GOSUB BREAK  ! If B - Break
  164. 1360 GOTO START  !                      Next character
  165. 1370 KOUT: IF K$=BS$ THEN K$=DEL$ !     Backspace = Delete (127)
  166. 1380 IF K$=EL$ THEN K$=CR$ @ f=HS#0 !   Endline = CR, set flag if handshake
  167. 1390 IF K$=ESC$ THEN F=1 @ BEEP @ GOTO RSGET  ! Escape set flag
  168. 1400 IF K$>DEL$ THEN RSGET !            If char > 127 then ignore
  169. 1405 IF LE=0 THEN 1500 !                If no local echo transmit
  170. 1410 AWRITE 23,C,k$ !                   Remove cursor
  171. 1420 IF K$ >= SP$ THEN 1450 !           If char is not ctrl char skip
  172. 1430 IF K$=CR$ THEN C=0 @ GOTO 1490 !   If <CR> then reset column count
  173. 1440 IF K$=LF$ THEN 1470 !              If <LF> then nextline
  174. 1450 AWRITE 23,C,K$ !                   Display char
  175. 1460 C=C+1 @ IF C<80 THEN 1490 ELSE C=0 ! increase column count
  176. 1470 R=R+1 @ IF R=204 THEN R=0 !        next line (reset if screen end)
  177. 1480 AWRITE 24,0,RPT$ (SP$,80) @ START CRT AT R !        set screen to new line
  178. 1490 AWRITE 23,C @ AREAD k$ @ AWRITE 23,C,HGL?$ (k$,1) ! redraw cursor
  179. 1500 OUTPUT OBUFF$ USING "#,A" ; K$ !            Output char to buffer
  180. 1502 IF f THEN OUTPUT OBUFF$ USING "#,A" ; HC$ ! Output handshake character
  181. 1506 STATUS OBUFF$,1 ; S1,S,S3 !        Get buffer status
  182. 1508 IF S1=0 OR S3#0 THEN 1520 !        If buffer empty or transfer active skip
  183. 1510 TRANSFER OBUFF$ TO  10 INTR !      Output buffer to RS232
  184. 1520 WAIT DEL !                         Wait to avoid multiple characters
  185. 1530 !
  186. 1540 !               GET BYTE FROM RS232 IF AVAILABLE
  187. 1550 !               -----------------------------------
  188. 1560 RSGET: STATUS IBUFF$,1 ; S3 !      Get no of characters in buffer
  189. 1565 IF S3=0 THEN START !              If no data in buffer - start of loop
  190. 1570 AWRITE 23,C,k$ !                   Cursor off (reprint old char)
  191. 1580 ENTER IBUFF$ USING "#,#K" ; I$ !   Get string from buffer
  192. 1590 FOR I=1 TO LEN (I$) !              For no of chars
  193. 1600 K$=I$[I,I] !                       Get character from buffer
  194. 1610 IF K$ >= SP$ THEN 1660 !            If char is not ctrl char skip
  195. 1620 IF K$=CR$ THEN C=0 @ GOTO 1700 !   If <CR> then reset column count
  196. 1630 IF K$=LF$ THEN 1680 !              If <LF> then nextline
  197. 1640 IF K$=BEL$ THEN BEEP @ GOTO 1700 ! If <BEL> beep
  198. 1650 GOTO 1700 !                        Ignore other control characters
  199. 1660 AWRITE 23,C,K$ !                   Display char
  200. 1670 C=C+1 @ IF C<80 THEN 1700 ELSE C=0 ! Increase column count
  201. 1680 R=R+1 @ IF R=204 THEN R=0 !        next line (reset if screen end)
  202. 1690 AWRITE 24,0,RPT$ (SP$,80) @ START CRT AT R ! set screen to new line
  203. 1700 NEXT I !                           Next char
  204. 1710 AWRITE 23,C @ AREAD k$ @ AWRITE 23,C,HGL?$ (k$,1) ! redraw cursor
  205. 1720 GOTO START  !                      Return to start of loop
  206. 1730 !
  207. 1740 !                     BUFFER FULL ROUTINE
  208. 1750 !                     -------------------
  209. 1760 BUFFULL: OFF EOT 10 @ STATUS 10,11 ; S4 ! Find reason
  210. 1765 IF BINAND (S4,64)#0 THEN 1810 !           Input buffer full
  211. 1770 IF f=0 THEN 1850 !                        Not CR and handshake
  212. 1780 f=0 @ STATUS 10,9 ; S@ S=BINAND (S,127) ! Mask off Transmit enable bit
  213. 1790 ABORTIO 10 @ CONTROL 10,9 ; S@ TRANSFER 10 TO  IBUFF$ INTR ! Disable TX
  214. 1800 GOTO 1850
  215. 1810 ENTER IBUFF$ USING "#,#K" ; I$@ TRANSFER 10 TO  IBUFF$ INTR
  216. 1820 ! Enter complete buffer and restart input
  217. 1830 DISP I$ !                                 Display buffer contents
  218. 1840 DISP "BUFFER FULL POSSIBLE DATA LOSS !" ! Display warning
  219. 1850 ON EOT 10 GOSUB BUFFULL  @ RETURN !       Return
  220. 1860 !
  221. 1870 !                        EXIT ROUTINE
  222. 1880 !                        ------------
  223. 1890 EXIT1: ! END ALL INPUT/OUTPUT
  224. 1900 RELEASE KEYBOARD @ OFF EOT 10 @ CLEAR !   Reset
  225. 1910 RETURN !                                  Return
  226. 1920 !
  227. 1930 !                    TRANSMIT A BREAK
  228. 1940 !                    --------------------
  229. 1950 BREAK: REQUEST 10;8 @ RETURN !            Transmit break signal
  230. 1960 !
  231. 1970 !                    RE-ENABLE TRANSMITER
  232. 1980 !                    --------------------
  233. 1990 TX_EN: RESUME 10 @ RETURN !               Re-enable transmiter
  234. 2000 ! ***************************************************************** !
  235. 2010 ! *                                                               * !
  236. 2020 ! *       SEND FILE - EXTRACT FILE NAME SECTION                   * !
  237. 2030 ! *                                                               * !
  238. 2040 ! ***************************************************************** !
  239. 2050 ! # This section extracts the file names from the parameter list following
  240. 2060 ! # the SEND command .
  241. 2070 ! # S$ - contains the parameter list
  242. 2080 ! #
  243. 2160 !
  244. 2170 !           EXTRACT FILE NAMES FROM PARAMETER LIST
  245. 2180 !           --------------------------------------
  246. 2190 send_file: S$=TRIM$ (S$) @ DF$="" !  Strip excess blanks from parameters
  247. 2195 IF S$="?" THEN AWRITE 22,0,SS$ @ RETURN ! Display send syntax
  248. 2200 p=FNfsplit(S$) @ IF p=0 THEN errfn ! Check for "filename"
  249. 2210 SF$=TRIM$ (S$[2,p]) !                Get source filename
  250. 2220 IF l<p+2 THEN volrem !               If no dest filename convert source
  251. 2230 S$=TRIM$ (S$[p+2,l]) !               Get destination filename
  252. 2240 p=FNfsplit(S$) @ IF p=0 THEN errfn ! Check for "filename"
  253. 2250 S$=TRIM$ (S$[2,p]) @ GOTO chckfn  !  Get destination filename
  254. 2260 !
  255. 2270 !           REMOVE VOLUME OR DRIVE No FROM FILE NAME
  256. 2280 !           ----------------------------------------
  257. 2290 volrem: S$=SF$ !                              Get file name
  258. 2300 p=POS (S$,DT$) @ IF p=0 THEN p=POS (S$,CN$) ! "." - volume ":" - drive
  259. 2310 IF p>0 THEN S$=S$[1,p-1] !                    Extract file name
  260. 2320 !
  261. 2330 !         CHECK FILE NAME AND CONVERT TO A 'LEGAL' NAME
  262. 2340 !         ---------------------------------------------
  263. 2350 chckfn: l=LEN (S$) @ f=0 @ j=0 !     Get len,clear flag,reset char count
  264. 2360 S$=UPC$ (S$) !                       Convert to upper case
  265. 2370 IF POS (S$,DT$) THEN 2410 !          If name contains "." skip
  266. 2380 p=POS (S$,SP$) @ IF p>0 THEN 2400 !  If name contains space convert to "."
  267. 2390 p=POS (S$,UL$) @ IF p=0 THEN 2410 !  If name does not contain "_" skip
  268. 2400 S$[p,p]=DT$ !                        Convert character to "."
  269. 2410 FOR i=1 TO l @ p=POS (VC$,S$[i,i]) ! Check char with legal list
  270. 2420 IF p=0 OR p=1 AND (f=1 OR j=0 OR j=l-1) THEN 2450 ! skip if illegal
  271. 2430 IF p=1 THEN f=1 !                    Set flag to ensure only one "."
  272. 2440 j=j+1 @ DF$[j,j]=S$[i,i] !           Transfer legal character to file name
  273. 2450 NEXT i
  274. 2460 IF j=0 THEN DF$=SF$ @ GOTO 2800 !    If file name illegal send source name
  275. 2470 l=LEN (DF$) @ p=POS (DF$,DT$) !      Find length of name and "." position
  276. 2480 IF p=0 THEN DF$=DF$&"." @ p=l !      If no "." add one to end of DF$
  277. 2490 IF p=l THEN DF$=DF$&FTYP$ !          If "." at end of DF$ add default type
  278. 2600 ! ******************************************************************** !
  279. 2610 ! *                                                                  * !
  280. 2620 ! *                SEND COMMAND MAIN SECTION                         * !
  281. 2630 ! *                                                                  * !
  282. 2640 ! ******************************************************************** !
  283. 2650 ! # This section sends the file from the HP86 to the remote kermit
  284. 2660 ! # The following variables are used from previous sections
  285. 2670 ! # SF$ - The source file name
  286. 2680 ! # DF$ - The destination file name
  287. 2690 ! # Also the following parameters changed by SET (* or Y(0))
  288. 2700 ! # Receiving  Sending    Meaning
  289. 2710 ! # RMAXL      SMAXL  *   Maximum packet length
  290. 2720 ! # RTO     *  STO        Timeout values
  291. 2730 ! # RNPAD      SNPAD  *   Number of padding characters
  292. 2740 ! # RPADC$     SPADC$ *   Pad character
  293. 2750 ! # REOL       SEOL   *   End of line character (end of packet)
  294. 2760 ! # RQCTL$  *  SQCTL$     Prefix character for control characters
  295. 2770 !
  296. 2780 !                     OPEN SOURCE FILE
  297. 2790 !                     ----------------
  298. 2800 n,pc,st,k,SNPAD=0 @ RT$="" @ sr=15 @ rr=17 !    Initialise
  299. 2805 GOSUB open_read  @ IF f#0 THEN srexit !      Open file
  300. 2810 GOSUB dsend  @ ON KEY# 1 GOSUB abort  !       Display & set abort key
  301. 2815 !
  302. 2820 !                   SEND SEND_INIT PACKET
  303. 2830 !                   ---------------------
  304. 2840 send_init: n=0 @ T$=SI$ @ T=0 @ IBUFF$="" ! seq no, set type, clear buff
  305. 2845 GOSUB init_pack  @ OD$=IN$ !                Set up INIT packet data
  306. 2890 GOSUB send_pack  @ IF f#0 THEN srexit !     Send SEND-INIT
  307. 2900 !
  308. 2910 !           DECODE ACK PACKET TO GET SEND PARAMETERS
  309. 2920 !           ----------------------------------------
  310. 2930 GOSUB dcd_init  !                           Decode INIT data
  311. 3010 !
  312. 3020 !                       SEND FILE HEADER
  313. 3030 !                       ________________
  314. 3040 send_head: T$=SH$ @ T=1 @ OD$=DF$ !     Set packet type & data = file name
  315. 3050 GOSUB send_pack  @ IF f#0 THEN srexit ! Send packet, exit if error
  316. 3060 !
  317. 3070 !                     SEND DATA FROM FILE
  318. 3080 !                     -------------------
  319. 3090 T$=SD$ @ T=2 @ DB$="" @ e=0 @ MAXL=SMAXL-3 ! Set type and clear data buf
  320. 3100 MINL=IP (MAXL/2) @ IF MINL<1 THEN MINL=1 !   Set minimum packet length
  321. 3110 GOSUB get_data  @ IF f#0 THEN RETURN !       Get data
  322. 3120 IF OD$="" THEN send_eof !                    If no data send end of file
  323. 3130 GOSUB send_pack  @ IF f#0 THEN srexit !      Send packet
  324. 3135 IF LEN (ID$)=0 THEN 3110 !                   No term - get more data
  325. 3140 IF ID$[1,1]#"Z" AND ID$[1,1]#"X" THEN 3110 ! Get more data (unless stop)
  326. 3150 !
  327. 3160 !              SEND END OF FILE & BREAK PACKETS
  328. 3170 !              --------------------------------
  329. 3180 send_eof: T$=SE$ @ T=3 !                Set up type = send end of file
  330. 3190 GOSUB send_pack  @ IF f#0 THEN srexit ! Send packet
  331. 3200 T$=SB$ @ T=4 @ GOSUB send_pack  !       Set up type = break - send packet
  332. 3210 GOTO srexit  !                           Jump to exit routine
  333. 3510 !
  334. 3520 !                  REPORT FILENAME ERROR
  335. 3530 !                  ---------------------
  336. 3540 errfn: CP$="Filename error" @ RETURN !  Change command prompt & return
  337. 4000 ! ****************************************************************** !
  338. 4010 ! *                                                                * !
  339. 4020 ! *                    RECEIVE COMMAND                             * !
  340. 4030 ! *                                                                * !
  341. 4040 ! ****************************************************************** !
  342. 4050 !
  343. 4060 !              EXTRACT FILENAME (IF SPECIFIED)
  344. 4070 !              -------------------------------
  345. 4080 rec_file: S$=TRIM$ (S$) !  Strip leading & trailing blanks from params
  346. 4083 IF S$="?" THEN AWRITE 22,0,RS$ @ RETURN ! Display receive syntax
  347. 4085 sr=17 @ rr=15 @ st=1 @ GOSUB dsend  !           Initialise display
  348. 4090 p=FNfsplit(S$) @ IF p=0 THEN ft=1 @ GOTO 4200 ! Check if filename present
  349. 4100 DF$=TRIM$ (S$[2,p]) @ ft=0 !                    Get destination filename
  350. 4110 p=POS (DF$,DT$) @ IF p=0 THEN p=POS (DF$,CN$) ! Volume (.) or MSUS (:)
  351. 4120 IF p=0 THEN 4150 !                              If none skip
  352. 4130 VN$=DF$[p] @ IF p=1 OR LEN (VN$)>6 THEN errfn ! Get volume name & check
  353. 4140 DF$=DF$[1,p-1] !                                Get file name
  354. 4150 IF LEN (DF$)>10 THEN errfn !                    Check filename
  355. 4155 AWRITE 4,2,ST$(1)&" as '"&DF$&"'" !             Display name
  356. 4160 !
  357. 4170 !                RECEIVE SEND_INIT PACKET
  358. 4180 !                ------------------------
  359. 4200 rec_init: n,nf,pc,k=0 @ IBUFF$="" @ ON KEY# 1 GOSUB abort
  360. 4210 GOSUB init_pack  @ A$=SI$ @ T=0 !      Set INIT packet, Allowable type "S"
  361. 4220 GOSUB get_pack  @ IF f#0 THEN srexit ! Get SEND-INIT
  362. 4230 GOSUB dcd_init  !                      Decode SEND-INIT packet
  363. 4232 !
  364. 4234 !              RECEIVE FILE HEADER OR BREAK
  365. 4236 !              ----------------------------
  366. 4240 rec_head: A$="FBSZ" @ DB$="" !  Valid types F/B (S/Z prev), Clear buffer
  367. 4250 T=8 @ GOSUB get_pack  !         Get File header or Break packet
  368. 4260 IF RT$=SB$ OR f#0 THEN srexit ! If break received or error exit
  369. 4262 !
  370. 4264 !            EXTRACT FILE NAME, CONVERT & OPEN FILE
  371. 4266 !            --------------------------------------
  372. 4270 SF$=ID$ @ k=0 !                                Get Fn, reset byte count
  373. 4272 IF ft=0 THEN 4330 ELSE DF$=SF$ !               Skip if dest Fn specified
  374. 4275 l=LEN (DF$) @ p=POS (DF$,DT$) !                Get len, pos of '.'
  375. 4280 IF l=0 THEN DF$=DFN$&DFT$ @ GOTO 4275 !        Default Fn & Ft
  376. 4285 IF p=0 THEN 4330 !                             No '.' - no seperation
  377. 4290 IF p=l THEN DF$=DF$&DFT$ @ GOTO 4275 !         '.' at end add default Ft
  378. 4295 IF p=1 THEN DF$=DFN$&DF$ @ GOTO 4275 !         '.' at start add default Fn
  379. 4300 F$=DF$[1,p-1] @ IF LEN (F$)>6 THEN F$=F$[1,6] ! Fn - 6 chars
  380. 4310 S$=DF$[p+1,l] @ IF LEN (S$)>3 THEN S$=S$[1,3] ! Ft - 3 chars
  381. 4320 DF$=F$&SP$&S$ @ ft=LEN (F$)+1 !                 Fn Ft
  382. 4330 GOSUB open_write  @ IF f#0 THEN srexit !        Open file
  383. 4335 AWRITE 4,2,ST$(1)&" '"&SF$&"' as '"&DF$&"'" !   Display file names
  384. 4340 !
  385. 4350 !              RECEIVE DATA OR END OF FILE
  386. 4360 !              ---------------------------
  387. 4370 rec_data: A$="DZF" @ T=9 !                        Valid types D/Z (F prev)
  388. 4380 GOSUB get_pack  @ IF f#0 THEN srexit !               Get packet
  389. 4390 IF RT$=SE$ THEN GOSUB close_write  @ GOTO rec_head  ! If EOF close file
  390. 4400 GOSUB put_data  @ IF f#0 THEN srexit !               Store data in file
  391. 4410 GOTO rec_data  !                                     Get next data packet
  392. 5000 ! ***************************************************************** !
  393. 5010 ! *                                                               * !
  394. 5020 ! *                    SET/SHOW COMMANDS                          * !
  395. 5030 ! *                                                               * !
  396. 5040 ! ***************************************************************** !
  397. 5050 show_pars: IF S$="" THEN sa ! If no parameters after show - show all
  398. 5060 set: GOSUB split  @ S$=TRIM$ (S$) ! Split parameter string
  399. 5070 p=FNinlist(F$,SL$) !                Find if option is in list
  400. 5080 IF p<1 THEN DF$=F$ @ I$=IO$ @ GOTO 5150 ! Illegal option
  401. 5090 I$=FNxlist$(SL$,p) !                Get real option (ie not abbrev.)
  402. 5100 IF C=5 THEN 5140 !                  If show just show
  403. 5110 DF$=S$ @ O=p !                      Save option setting
  404. 5115 ! Set
  405. 5120 ON p GOSUB S0 ,S1 ,S2 ,S3 ,S4 ,S5 ,S6 ,S7 ,S8 ,S9 ,S10 ,S11 ,S12 ,S13 ,S14
  406. 5130 IF p<1 THEN 5150 ELSE p=O @ S$=DF$ ! If error or ? skip else get option
  407. 5135 ! Show
  408. 5140 ON p GOSUB s0 ,s1 ,s2 ,s3 ,s4 ,s5 ,s6 ,s7 ,s8 ,s9 ,s10 ,s11 ,s12 ,s13 ,s14
  409. 5150 IF p>-1 THEN AWRITE 22,0,I$&" - "&DF$
  410. 5160 RETURN
  411. 5500 ! ***************************************************************** !
  412. 5510 ! *                                                               * !
  413. 5520 ! *                          SET COMMAND                          * !
  414. 5530 ! *                                                               * !
  415. 5540 ! ***************************************************************** !
  416. 5550 S0: RTO=FNpval(S$,RTO) @ RETURN !               Timeout
  417. 5560 S1: RLIM=FNpval(S$,RLIM) @ RETURN !             Retry limit
  418. 5570 S2: ps=FNlset(S$,SC,OO$) @ RETURN !             Send conversion
  419. 5580 S3: db=FNlset(S$,db,OO$) @ RETURN !             Debug (ON/OFF)
  420. 5590 S4: p=0 @ IF LEN (S$)#1 THEN I$=IC$ @ RETURN !  Prefix
  421. 5600 SQCTL$=S$ @ RETURN
  422. 5610 S5: SEOL=FNpval(S$,SEOL) @ RETURN !             End of line
  423. 5620 S6: T=0 @ DB$="" !                              Record end marker
  424. 5630 GOSUB split  @ k=FNpval(F$,0) !                  Get no
  425. 5640 IF k=0 THEN RETURN !                             If illegal return
  426. 5650 DB$=DB$&CHR$ (k) @ T=T+1 !                       Add to string
  427. 5660 IF S$#"" AND T<4 THEN 5630 !                     If more get no
  428. 5670 RE=T @ RE$=DB$ @ p=7 @ RETURN !                  Set new value & return
  429. 5680 S7: FS=FNpval(S$,FS) @ NR=FS*1024/RL @ RETURN ! File size
  430. 5690 S8: RL=FNpval(S$,RL) @ NR=FS*1024/RL @ RETURN ! Record length
  431. 5700 S9: NR=FNpval(S$,NR) @ FS=NR*RL/1024 @ RETURN ! No of records
  432. 5710 S10: DX=FNlset(S$,DX,DX$) @ LE=DX @ GOTO 5760 ! Duplex
  433. 5720 S11: LE=FNlset(S$,LE,OO$) @ GOTO 5760 !         Local echo
  434. 5730 S12: FC=FNlset(S$,FC,FC$) @ IF FC#0 THEN HS=0 ! Flow control
  435. 5735 GOTO 5760
  436. 5740 S13: HS=FNlset(S$,HS,HS$) @ IF HS#0 THEN FC=0 ! Handshake
  437. 5745 GOTO 5760
  438. 5750 S14: PT=FNlset(S$,PT,PT$) !                     Parity
  439. 5760 GOSUB rs_set  @ RETURN !                         Reset RS232
  440. 5770 !
  441. 6000 ! ***************************************************************** !
  442. 6010 ! *                                                               * !
  443. 6020 ! *                         SHOW COMMAND                          * !
  444. 6030 ! *                                                               * !
  445. 6040 ! ***************************************************************** !
  446. 6110 sa: CLEAR !                                     Clear screen
  447. 6120 FOR N=0 TO 14 @ n=N+1 !                         For each set option
  448. 6130 AWRITE 2+N DIV 2,40*(N MOD 2),FNxlist$(SL$,n) ! Display option
  449. 6140 ON n GOSUB s0 ,s1 ,s2 ,s3 ,s4 ,s5 ,s6 ,s7 ,s8 ,s9 ,s10 ,s11 ,s12 ,s13 ,s14
  450. 6150 AWRITE 2+N DIV 2,15+40*(N MOD 2),DF$ !          Display value
  451. 6160 NEXT N
  452. 6170 RETURN
  453. 6200 s0: DF$=VAL$ (RTO) @ RETURN ! Timeout
  454. 6210 s1: DF$=VAL$ (RLIM) @ RETURN ! Retry limit
  455. 6220 s2: DF$=FNxlist$(OO$,SC+1) @ RETURN ! Send conversion
  456. 6230 s3: DF$=FNxlist$(OO$,db+1) @ RETURN ! Debug
  457. 6240 s4: DF$=SQCTL$ @ RETURN ! Prefix
  458. 6250 s5: DF$=VAL$ (SEOL) @ RETURN ! End of line
  459. 6260 s6: DF$="" ! Record end marker
  460. 6262 FOR I=1 TO RE @ DF$=DF$&VAL$ (NUM (RE$[I,I]))&SP$ @ NEXT I
  461. 6265 RETURN
  462. 6270 s7: DF$=VAL$ (FS)&"k" @ RETURN ! File size
  463. 6280 s8: DF$=VAL$ (RL) @ RETURN ! Record length
  464. 6290 s9: DF$=VAL$ (NR) @ RETURN ! No of records
  465. 6300 s10: DF$=FNxlist$(DX$,DX+1) @ RETURN ! Duplex
  466. 6310 s11: DF$=FNxlist$(OO$,LE+1) @ RETURN ! Local echo
  467. 6320 s12: DF$=FNxlist$(FC$,FC+1) @ RETURN ! Flow control
  468. 6330 s13: DF$=FNxlist$(HS$,HS+1) @ RETURN ! Handshake
  469. 6340 s14: DF$=FNxlist$(PT$,PT+1) @ RETURN ! Parity
  470. 10000 ! ***************************************************************** !
  471. 10010 ! *                                                               * !
  472. 10020 ! *               SEND & RECEIVE SUBROUTINES                      * !
  473. 10030 ! *                                                               * !
  474. 10040 ! ***************************************************************** !
  475. 10050 !
  476. 10060 !                  RECEIVE PACKET
  477. 10070 !                  --------------
  478. 10080 rec_pack: m=0 @ ID$="" !               Reset mark flag
  479. 10090 ON TIMER# 1,TMO GOTO rto  !            Set timeout limit
  480. 10100 b_chk: STATUS IBUFF$,1 ; S !           Get buffer status
  481. 10105 K$=KEY$  @ IF K$#"" THEN rto !         If key pressed treat like timeout
  482. 10110 IF S=0 THEN WAIT TMO/5 @ GOTO b_chk  ! If no data wait & check again
  483. 10120 ENTER IBUFF$ USING "#,#K" ; I$ !       Get buffers contents
  484. 10130 l=LEN (I$) @ i=1 !                     Data length & count
  485. 10140 n_chr: k$=I$[i,i] !                    Get character
  486. 10145 IF k$=MK$ THEN m=1 @ RP$="" @ j=0 !    If mark set flag, null packet etc
  487. 10150 IF m=0 THEN i_chr !                    Mark not reached yet skip
  488. 10160 IF k$=REOL$ THEN e_pck !               End line recieved
  489. 10170 RP$=RP$&k$ @ j=j+1 !                   Add char to packet inc count
  490. 10180 i_chr: i=i+1 @ IF i>l THEN b_chk ELSE n_chr ! if no data in buf get more
  491. 10190 e_pck: IF j<5 THEN 10100 !             packet not long enough get another
  492. 10200 OFF TIMER# 1 !                         Halt timer
  493. 10210 IF i<l THEN IBUFF$=I$[i+1,l]&IBUFF$ !  If data in I$ replace in buffer
  494. 10220 IF db=1 THEN AWRITE rr,rc,RP$ !        display packet if debug on
  495. 10230 c$=FNcbyte$(RP$[2,j-1]) !              Calculate check byte | if wrong
  496. 10240 IF c$#RP$[j,j] THEN RT$=FNstbit$(RP$[j]) @ bp=bp+1 @ RETURN ! set B7 type
  497. 10250 RT$=RP$[4,4] @ rn=FNunchar(RP$[3,3]) ! Get type & sequence number
  498. 10260 f=0 @ FOR i=5 TO j-1 @ k$=RP$[i,i] !   Get each charcter in data part
  499. 10270 IF f=0 THEN 10300 !                    If prefix flag off skip
  500. 10280 IF k$#RQCTL$ THEN k$=FNctl$(k$) !      If not prefix char change to ctrl
  501. 10290 f=0 @ GOTO 10310 !                     Skip to add to data string
  502. 10300 IF k$=RQCTL$ THEN f=1 @ GOTO 10320 !   If prefix char set flag next char
  503. 10310 ID$=ID$&k$ !                           Add char to data string
  504. 10320 NEXT i @ RETURN !                      Return
  505. 10330 rto: OFF TIMER# 1 !                    Disable timer
  506. 10333 IF m=1 THEN m=2 @ GOTO 10090 !         Packet is being transmitted wait
  507. 10335 IF HS#0 THEN RESUME 10 !               If handshake enable transmit
  508. 10338 tmo=tmo+1 @ RT$="T" @ RETURN !         Timeout type = "T"
  509. 10340 !
  510. 10350 !                         SEND PACKET
  511. 10360 !                         -----------
  512. 10370 send_pack: f=0 @ r=0 @ GOSUB c_pack  ! Set flag & retry, construct packet
  513. 10380 send1: s=T @ GOSUB disp_state  !            Display state
  514. 10390 IF db THEN AWRITE sr,0,RPT$ (SP$,320) @ AWRITE sr,sc,OP$ ! debug display
  515. 10400 GOSUB send_buff  @ IF f#0 THEN RETURN !     Send buffer out
  516. 10410 s=6 @ GOSUB disp_state  @ GOSUB rec_pack  ! Display, receive ACK/NAK
  517. 10415 IF RT$>DEL$ OR RT$=TM$ THEN 10450 !         Bad packet or timeout retry ?
  518. 10420 N=BINAND (rn-BINAND (n,63),63) @ f=0 !      Find seq no difference
  519. 10430 IF RT$=AK$ AND N=0 OR RT$=NK$ AND N=1 THEN pc,n=n+1 @ RETURN ! Ok return
  520. 10435 IF RT$=AK$ AND N=63 THEN 10410 !            Previous ACK - Ignore
  521. 10440 IF RT$#NK$ THEN f=4 @ RETURN ELSE nk=nk+1 ! If not nak - wrong packet
  522. 10450 r=r+1 @ IF r<RLIM THEN send1 !              If retry  < limit send again
  523. 10460 IF RT$=TM$ THEN f=1 @ RETURN !              Timeout error
  524. 10470 IF RT$=NK$ THEN f=2 ELSE f=3 !              NAK error
  525. 10480 RETURN
  526. 10510 !
  527. 10520 !                      CONSTRUCT PACKET
  528. 10530 !                      ----------------
  529. 10540 c_pack: OP$=FNchar$(BINAND (n,63))&T$&OD$ !  Add seq & type to data
  530. 10550 OP$=FNchar$(LEN (OP$)+1)&OP$ !               Add length to data
  531. 10560 OP$=MK$&OP$&FNcbyte$(OP$) !                  Add mark & check byte
  532. 10570 IF SNPAD>0 THEN OBUFF$=RPT$ (SPADC$,SNPAD) ! Add padding if needed
  533. 10580 OUTPUT OBUFF$ USING "#,K" ; OP$&CHR$ (SEOL) !  Output to buffer
  534. 10585 IF HS#0 THEN OUTPUT OBUFF$ USING "#,A" ; HC$ ! Output handshake
  535. 10590 STATUS OBUFF$,1 ; bl@ RETURN !               Get buffer length
  536. 10600 !
  537. 10610 !                 TRANSMIT BUFFER CONTENTS
  538. 10620 send_buff: !      ------------------------
  539. 10630 ON TIMER# 1,STM GOTO 10690 !    Set time limit for transfer
  540. 10640 CONTROL OBUFF$,1 ; bl !         Reset buffer fill pointer
  541. 10650 TRANSFER OBUFF$ TO  10 INTR !   Transfer buffer to RS232
  542. 10660 STATUS OBUFF$,1 ; S !           Get buffer status
  543. 10670 IF S>0 THEN 10660 !             Loop until buffer empty (ie all sent)
  544. 10673 IF HS=0 THEN 10680 !            Skip if no handshake
  545. 10675 STATUS 10,9 ; S@ S=BINAND (S,127) ! Clear bit 7 reg 9 (transmit disable)
  546. 10678 ABORTIO 10 @ CONTROL 10,9 ; S@ TRANSFER 10 TO  IBUFF$ INTR
  547. 10680 OFF TIMER# 1 @ IBUFF$="" !      Disable timer & clear input buffer
  548. 10685 RETURN
  549. 10690 f=5 @ OFF TIMER# 1 @ RETURN !    Set error flag
  550. 10700 !
  551. 10710 !                  RECEIVE PACKET WITH ACK
  552. 10720 !                  -----------------------
  553. 10730 get_pack: r=0
  554. 10740 s=T @ GOSUB disp_state  @ AWRITE rr,0,RPT$ (SP$,320) ! Display
  555. 10745 f,p=0 @ GOSUB rec_pack  !                  Receive packet
  556. 10750 IF RT$=TM$ THEN f=1 @ GOTO 10830 !         If timeout retry ?
  557. 10760 IF RT$>DEL$ THEN f=3 @ GOTO 10830 !        If checksum error retry
  558. 10770 p=POS (A$,RT$) @ N=BINAND (rn-n,63) !      Is received type valid
  559. 10780 IF N#0 AND N#63 OR p=0 THEN f=4 @ RETURN ! If not valid exit
  560. 10790 OD$="" @ IF RT$=SI$ THEN OD$=IN$ !         If SEND-INIT set INIT ACK
  561. 10800 T$=AK$ @ s=6 @ n=rn @ GOSUB c_pack  !      Construct ACK
  562. 10810 n=(n+1) MOD 64 @ GOTO 10850 !              Get next seq - Send ACK
  563. 10830 r=r+1 @ IF r>RLIM THEN RETURN !         If retry limit exceeded exit
  564. 10840 T$=NK$ @ s=7 @ OD$="" @ nk=nk+1 @ GOSUB c_pack  ! Construct NAK
  565. 10850 GOSUB disp_state  @ IF db THEN AWRITE sr,sc,OP$ !  Display state
  566. 10860 f=0 @ GOSUB send_buff  @ IF f#0 THEN RETURN !     Send ACK/NAK
  567. 10870 IF p#1 AND p#2 OR N#0 THEN 10740 !      If not valid get another packet
  568. 10880 pc=pc+1 @ RETURN !                      Inc packet count - return
  569. 11000 ! ***************************************************************** !
  570. 11010 ! *                                                               * !
  571. 11020 ! *           CONSTRUCT & DECODE INITIALISATION PACKETS           * !
  572. 11030 ! *                                                               * !
  573. 11040 ! ***************************************************************** !
  574. 11050 !
  575. 11060 !               SET UP SEND-INIT PACKET (S(0),Y(0))
  576. 11070 !               -----------------------------------
  577. 11080 init_pack: tmo,nk,bp=0 !                    Timeouts naks & bad packets
  578. 11090 TMO=RTO*1000 !                              Set timeout for receiving
  579. 11100 IN$=FNchar$(RMAXL) !                        Packet = maximum length
  580. 11110 IN$=IN$&FNchar$(STO) !                      + send timeout
  581. 11120 IN$=IN$&FNchar$(RNPAD)&FNctl$(RPADC$) !     + no of pad chars & char
  582. 11130 IN$=IN$&FNchar$(SEOL)&SQCTL$ !              + end of line & ctrl qoute
  583. 11140 SMAXL=80 @ SNPAD=0 @ SPADC$=NULL$ @ REOL=13 @ RQCTL$="#" ! Defaults
  584. 11150 RETURN
  585. 11160 !
  586. 11170 !       EXTRACT PARAMETERS FROM INIT PACKET (S(0),Y(0))
  587. 11180 !       -----------------------------------------------
  588. 11190 dcd_init: l=LEN (RP$)-5 @ IF l=0 THEN RETURN ! If no params return
  589. 11200 IF l<7 THEN ON l GOTO maxl ,tmo ,npad ,padc ,elc ,qctl  ! Change params
  590. 11210 qctl: IF RP$[10,10]#SP$ THEN RQCTL$=RP$[10,10] !        Prefix char
  591. 11220 elc: IF RP$[9,9]#SP$ THEN SEOL=FNunchar(RP$[9,9]) !     End of line
  592. 11230 padc: IF RP$[8,8]#SP$ THEN SPADC$=FNctl$(RP$[8,8]) !    Pad character
  593. 11240 npad: IF RP$[7,7]#SP$ THEN SNPAD=FNunchar(RP$[7,7]) !   No of pad chars
  594. 11250 tmo: IF RP$[6,6]#SP$ THEN RTO=FNunchar(RP$[6,6]) !      Receive timeout
  595. 11260 maxl: IF RP$[5,5]#SP$ THEN SMAXL=FNunchar(RP$[5,5]) !   Max packet length
  596. 11270 RETURN
  597. 12000 !
  598. 12010 !              EXIT ROUTINE FOR SEND & RECEIVE
  599. 12020 !              -------------------------------
  600. 12030 srexit: IF f=0 OR f=5 THEN 12080 !      If ok or send problem skip
  601. 12040 IF f#4 OR RT$#ER$ THEN 12060 !          If not error packet skip
  602. 12050 AWRITE 19,0,"Error message from remote - "&ID$ @ RETURN ! Display
  603. 12060 OD$=EM$(f) @ T$=ER$ @ T=5 !             Set up error packet
  604. 12070 GOSUB c_pack  @ GOSUB send_buff  !      Construct and send error packet
  605. 12080 AWRITE 19,0,EM$(f) !                    Display message (ok or error)
  606. 12082 BEEP (f#1)*20+20,200 !                  Beep (lower for error)
  607. 12085 IF f>6 AND f<23 THEN AWRITE 19,LEN (EM$(f))+1,"(error no - "&VAL$ (e)&")"
  608. 12090 RETURN !                                Return to command section
  609. 12100 !
  610. 12110 !                      ABORT TRANSFER
  611. 12120 !                      --------------
  612. 12130 abort: f=24 @ RETURN ! Set error flag to abort
  613. 20000 ! **************************************************************** !
  614. 20010 ! *                                                              * !
  615. 20020 ! *          FUNCTIONS FOR CODING & DECODING PACKETS             * !
  616. 20030 ! *                                                              * !
  617. 20040 ! **************************************************************** !
  618. 20050 !
  619. 20060 !             CONVERT NUMBER TO PRINTABLE CHARACTER
  620. 20070 !             -------------------------------------
  621. 20080 DEF FNchar$(n) = CHR$ (n+32) !  Character = no + 32
  622. 20090 !
  623. 20100 !                  CONVERT CHARACTER TO NUMBER
  624. 20110 !                  ---------------------------
  625. 20120 DEF FNunchar(c$[1]) = NUM (c$)-32 ! no = char - 32
  626. 20130 !
  627. 20140 !      SWAP BETWEEN CONTROL CHARACTER AND PRINTABLE CHARACTER
  628. 20150 !      ------------------------------------------------------
  629. 20160 DEF FNctl$(c$[1]) = CHR$ (BINEOR (NUM (c$),64)) ! xor bit 6
  630. 20170 !
  631. 20180 !               SET / RESET TOP BYTE OF CHARACTER
  632. 20190 !               ---------------------------------
  633. 20200 DEF FNstbit$(c$[1]) = CHR$ (BINEOR (NUM (c$),128)) ! xor bit 7
  634. 20210 !
  635. 20220 !                     CALCULATE CHECK BYTE
  636. 20230 !                     --------------------
  637. 20240 DEF FNcbyte$(S$[96])
  638. 20250 t=0 @ l=LEN (S$) @ FOR i=1 TO l @ t=t+NUM (S$[i,i]) @ NEXT i ! sum S$
  639. 20260 FNcbyte$=FNchar$(BINAND (t+BINAND (t,192)/64,63)) ! Fold bits 7 & 8
  640. 20270 FN END
  641. 30000 ! ******************************************************************** !
  642. 30010 ! *                                                                  * !
  643. 30020 ! *         ROUTINES FOR DISPLAYING CURRENT SENDING STATE            * !
  644. 30030 ! *                                                                  * !
  645. 30040 ! ******************************************************************** !
  646. 30050 ! #   The following variables are used by these routines
  647. 30060 ! #   S   - State (0/1) sending or waiting for ACK
  648. 30070 ! #   T   - Type of packet being sent (0-S,1-F,2-D,3-Z,4-B)
  649. 30080 ! #   n   - Current sequence number (not modulo 64)
  650. 30090 ! #   r   - No of retries for current packet
  651. 30100 ! #   nk  - No of NAKs received
  652. 30110 ! #   tm  - No of timeouts
  653. 30120 ! #   bp  - No of corrupted packets received
  654. 30130 ! #   k   - No of bytes sent
  655. 30140 ! #   SF$ - Source      file specifier
  656. 30150 ! #   DF$ - Destination  ''     ''
  657. 30260 !
  658. 30270 !             SET UP SCREEN FOR SEND DISPLAY
  659. 30280 !             ------------------------------
  660. 30290 dsend: CLEAR
  661. 30300 AWRITE 1,2,"HP86 Kermit - "&ST$(st)&" file"
  662. 30310 AWRITE 2,2,RPT$ ("-",LEN (ST$(st))+19)
  663. 30320 IF st=0 THEN AWRITE 4,2,ST$(st)&" "&SF$&" as "&DF$
  664. 30330 AWRITE 6,2,"Current action :" @ AWRITE 6,46,"Retries :"
  665. 30340 AWRITE 8,2,"Packets          :" @ AWRITE 8,40,"NAKs          :"
  666. 30350 AWRITE 9,2,"Bytes            :" @ AWRITE 9,40,"Timeouts      :"
  667. 30360 AWRITE 10,40,"Bad packets   :"
  668. 30370 AWRITE 8,10,st$(st) @ AWRITE 8,45,st$(1-st) @ AWRITE 9,8,st$(st)
  669. 30380 RETURN
  670. 30390 !
  671. 30400 !            DISPLAY SENDING STATE
  672. 30410 !            ---------------------
  673. 30420 disp_state: t=s>7 OR s=6 AND st=0 OR s=0 AND st=1 !  Wait or Send (1/0)
  674. 30425 IF t THEN D$="Wait for " ELSE D$="Send "
  675. 30427 AWRITE 6,18,RPT$ (SP$,26) !                     Clear old action
  676. 30430 AWRITE 6,18,D$&A$(s) @ AWRITE 6,56,VAL$ (r) !   Display action & Retries
  677. 30440 AWRITE 8,21,VAL$ (pc) @ AWRITE 8,56,VAL$ (nk) !  Packets & NAKs
  678. 30450 AWRITE 9,21,FNkb$(k) @ AWRITE 9,56,VAL$ (tmo) ! Bytes & timeouts
  679. 30460 AWRITE 10,56,VAL$ (bp) !                        Bad packets received
  680. 30470 RETURN
  681. 30500 DEF FNkb$(k) = VAL$ (IP (k/102.4)/10)&"k  "
  682. 40000 ! **************************************************************** !
  683. 40010 ! *                                                              * !
  684. 40020 ! *              SUBROUTINES FOR DISK ACCESS                     * !
  685. 40030 ! *                                                              * !
  686. 40040 ! **************************************************************** !
  687. 40050 !
  688. 40060 !                  OPEN FILE FOR READING
  689. 40070 !                  ---------------------
  690. 40080 open_read: ON ERROR GOTO fserr  @ ASSIGN# 1 TO  SF$ ! Try to open file
  691. 40090 OFF ERROR @ f=0 @ RETURN !                            If success return
  692. 40180 !
  693. 40190 !              GET PACKET OF DATA FROM FILE
  694. 40200 !              ----------------------------
  695. 40210 get_data: b=0 @ ON ERROR GOTO 40380 !            Set 8-bit data flag
  696. 40220 l=LEN (DB$) @ IF l>= MINL THEN 40330 !           If enough data output
  697. 40230 t=TYP (1) @ IF t#3 THEN 40250 !                  Not EOF get more data
  698. 40240 e=1 @ OFF ERROR !                                Error trap off
  699. 40245 IF l=0 THEN OD$="" @ RETURN ELSE 40335 !         Get any data left
  700. 40250 IF t=1 THEN 40320 !                              If number skip
  701. 40260 READ# 1 ; S$@ S$=S$&RE$ @ L=LEN (S$) @ k=k+L !   Read string variable
  702. 40270 FOR i=1 TO L @ k$=S$[i,i] !                      Get character
  703. 40280 IF k$ <= DEL$ THEN 40300 ELSE k$=FNstbit$(k$) !  If 8-bit reset b7
  704. 40290 IF b=0 THEN DISP "Eight bit data" @ BEEP @ b=1 ! Warn if first 8-bit
  705. 40300 IF k$<SP$ THEN DB$=DB$&SQCTL$ @ k$=FNctl$(k$) !  If ctrl prefix
  706. 40305 IF k$=SQCTL$ THEN DB$=DB$&k$ !                   If prefix prefix
  707. 40310 DB$=DB$&k$ @ NEXT i @ GOTO 40220 !               Add char to buffer
  708. 40320 IF SC=0 THEN f=23 @ RETURN !                     If no conversion - error
  709. 40323 READ# 1,S @ S$=VAL$ (S) !                       Convert no to string
  710. 40325 DB$=DB$&SP$&S$ @ k=k+LEN (S$)+1 @ GOTO 40220 !   Add no to buffer
  711. 40330 OFF ERROR !                                      Stop error trap
  712. 40335 IF l<= MAXL THEN OD$=DB$ @ DB$="" @ RETURN !     If amount<max output
  713. 40340 S=MAXL !                                         Get split position
  714. 40350 IF DB$[S,S]=SQCTL$ THEN S=S-1 @ GOTO 40350 !     If prefix move split
  715. 40360 OD$=DB$[1,S] @ DB$=DB$[S+1,l] !                  Split data save rest
  716. 40370 RETURN
  717. 40380 OFF ERROR @ IF ERRN =71 OR ERRN =72 THEN 40240 ! End of file
  718. 40390 IF ERRN =33 THEN f=23 @ RETURN !                 Data type error
  719. 40400 GOTO fserr  !                                    Goto error routine
  720. 40500 !
  721. 40510 !             CREATE & OPEN FILE FOR WRITING
  722. 40520 !             ------------------------------
  723. 40530 open_write: f=0 !                   Set error flag
  724. 40540 IF DF$#PF$ THEN nf=0 @ GOTO 40560 ! If new name reset count skip
  725. 40550 IF nf>99 THEN f=6 @ RETURN !        If cannot renumber -exit
  726. 40555 DF$=FNnofile$(DF$) !                Renumber file
  727. 40560 ON ERROR GOTO fserr  !              Set filing system error trap
  728. 40570 CREATE DF$,NR,RL !                  Try to create file
  729. 40580 ASSIGN# 1 TO  DF$ !                 If successfull open file
  730. 40585 OFF ERROR @ PF$=DF$ !               Save name
  731. 40590 RETURN
  732. 40600 !
  733. 40610 !                 WRITE DATA TO FILE
  734. 40620 !                 ------------------
  735. 40630 put_data: DB$=DB$&ID$ @ k=k+LEN (ID$) ! Place data in buffer
  736. 40635 ON ERROR GOTO fserr  !                  Set error trap
  737. 40640 p=POS (DB$,RE$) !                       Find end of record
  738. 40645 IF p=0 THEN OFF ERROR @ RETURN !        IF no EOR exit
  739. 40650 IF p>1 THEN S$=DB$[1,p-1] ELSE S$="" !  If data before EOR get it
  740. 40660 PRINT# 1 ; S$ @ l=LEN (DB$) !           Output to disk, find buff length
  741. 40670 IF l>p+(RE-1) THEN DB$=DB$[p+RE] ELSE DB$="" ! If any data left save
  742. 40680 GOTO 40640
  743. 40700 !
  744. 40710 !                     CLOSE FILE
  745. 40720 !                     ----------
  746. 40730 close_write: ON ERROR GOTO fserr  !           Set up error trap
  747. 40740 IF LEN (DB$)>0 THEN PRINT# 1 ; DB$ @ DB$="" ! Write any remaining data
  748. 40750 ASSIGN# 1 TO  * !                             Close file
  749. 40760 OFF ERROR
  750. 40770 RETURN
  751. 41000 !
  752. 41010 !             FILING SYSTEM ERROR HANDLING ROUTINE
  753. 41020 !             ------------------------------------
  754. 41030 fserr: e=ERRN  @ l=ERRL  @ OFF ERROR ! Get error no & line no
  755. 41040 IF e=63 AND l=40570 THEN 40550 !     If DUP NAME & CREATE -retry new name
  756. 41050 p=POS (FSE$,CHR$ (e)) !              Find pos of error in valid string
  757. 41060 IF p>0 THEN f=6+p @ RETURN !         If valid error - set falg & return
  758. 41070 RELEASE KEYBOARD @ DISP "UNEXPECTED ERROR !"
  759. 41080 DISP USING "6A,K,9A,K" ; "ERROR ",e," AT LINE ",l @ END
  760. 42000 !
  761. 42010 !                FUNCTION TO RENUMBER FILE
  762. 42020 !                 -------------------------
  763. 42030 DEF FNnofile$(F$)
  764. 42040 IF nf>0 THEN 42120 !                 If Not first numbering skip
  765. 42080 IF ft<2 THEN 42110 !                 If Not Fn Ft format skip
  766. 42090 np,p=ft @ IF np>5 THEN np=5 !        Find position of Ft
  767. 42100 F$[np]="00"&F$[p] @ GOTO 42130 !     Insert 00
  768. 42110 np=LEN (F$)+1 @ IF np>9 THEN np=9 !  Find position of no
  769. 42120 F$[np,np+1]=VAL$ (nf DIV 10)&VAL$ (nf MOD 10)
  770. 42130 nf=nf+1 @ FNnofile$=F$ !             Inc count return new name
  771. 42140 FN END
  772. 50000 ! **************************************************************** !
  773. 50001 ! *                                                              * !
  774. 50002 ! *                 MISCELANEOUS SUBROUTINES                     * !
  775. 50003 ! *                                                              * !
  776. 50004 ! **************************************************************** !
  777. 50005 !
  778. 50010 !                    SET UP RS232 INTERFACE
  779. 50015 !                    ----------------------
  780. 50020 rs_set: ABORTIO 10 !              Halt RS232 transfer
  781. 50025 IF BR=0 THEN S=2 ELSE S=6 !       Set baud to 110 or 300
  782. 50030 CONTROL 10,3 ; S !                Set baud rate
  783. 50035 IF PT=0 THEN S=3 ELSE S=2+((PT-1)*2+1)*8
  784. 50040 CONTROL 10,4 ; S !                Set parity (7 bits or 8 if no parity)
  785. 50045 IF FC=2 THEN S=48 ELSE S=0
  786. 50050 CONTROL 10,5 ; S !                Set flow control if DTR/RTS
  787. 50055 IF FC=1 OR HS#0 THEN S=128+64*(FC=1) ELSE S=0
  788. 50060 CONTROL 10,11 ; S !               Set XON(/XOFF) if required
  789. 50065 IF FC=2 THEN S=128 ELSE S=0
  790. 50070 CONTROL 10,16 ; S !               Set auto RTS enable if required
  791. 50075 IF HS#0 THEN S=4+HS*3+(HS=4) @ HC$=CHR$ (S) ELSE S=17
  792. 50080 CONTROL 10,15 ; S !               XON or handshake char (transmit enable)
  793. 50085 !
  794. 50090 CONTROL 10,9 ; 225 !               Strip nulls & bs  & enable
  795. 50100 CONTROL 10,14 ; 19 !               XOFF character
  796. 50110 !
  797. 50120 IOBUFFER IBUFF$ !                  Set up input buffer
  798. 50130 IOBUFFER OBUFF$ !                  Set up output buffer
  799. 50140 TRANSFER 10 TO  IBUFF$ INTR !      Start input from RS232 interface
  800. 50145 RETURN
  801. 50150 !
  802. 50160 !                     DUMMY SUBROUTINE
  803. 50170 !                     ----------------
  804. 50180 dummy: RETURN
  805. 50190 !
  806. 50200 !                SET UP KEYS TO DUMMY ROUTINE
  807. 50210 !                ----------------------------
  808. 50220 dkeys: FOR i=1 TO 14 @ ON KEY# i GOSUB dummy  @ NEXT i @ RETURN
  809. 50500 !
  810. 50510 !                  FUNCTION TO CHECK FOR "c..."
  811. 50520 !                  ----------------------------
  812. 50530 DEF FNfsplit(F$[80])
  813. 50540 p=0 @ l=LEN (F$) !                   Set p  get length of string
  814. 50545 IF l<3 THEN 50570 !                  Must be at least "?" (? - any char)
  815. 50550 IF F$[1,1]#Q$ THEN 50570 !           Must start with "
  816. 50560 p=POS (F$[2],Q$) @ IF p<2 THEN p=0 ! Find position of next " ("" invalid)
  817. 50570 FNfsplit=p !                         Return position
  818. 50580 FN END
  819. 51000 !
  820. 51001 !        FIND POSITION OF OPTION IN LIST OF VALID OPTIONS
  821. 51002 !        ------------------------------------------------
  822. 51010 DEF FNinlist(c$,l$[195])
  823. 51020 c$=UPC$ (c$) @ l,j=1 @ L=LEN (l$) !       c$ - uppercase, set count etc
  824. 51030 IF c$#"?" THEN 51100 !                    If not '?' skip
  825. 51040 j=-1 @ IF L<68 THEN P=L @ GOTO 51070 !    If list fits display
  826. 51045 AWRITE 22,0,RPT$ (SP$,160) !              Clear screen area
  827. 51050 p=POS (l$[l],", ") !                      Find ', '
  828. 51055 IF p=0 THEN P=L @ GOTO 51070 !            If end skip
  829. 51060 l=l+p @ IF l<68 THEN P=l-1 @ GOTO 51045 ! If fits get next
  830. 51070 AWRITE 22,0,"Options :- "&l$[1,P] @ IF P=L THEN 51150 ! display
  831. 51080 l$=l$[P+2] @ L=L-P-1 @ l=1
  832. 51085 AWRITE 23,0,"Press any key for more" !
  833. 51090 k$=KEY$  @ IF k$="" THEN 51090 ELSE 51045 !      wait for key
  834. 51100 cp=POS (l$[l],",") !                      Find pos of ','
  835. 51110 IF cp>0 THEN cp=cp+l-1 ELSE cp=L !        Adjust - if at end pos = end
  836. 51120 p=POS (l$[l,cp],c$) @ IF p=1 THEN 51150 ! Is c$ same as part of option
  837. 51130 j=j+1 @ l=cp+2 @ IF l<L THEN 51100 !      Find next option
  838. 51140 j=0 !                                     If no more illegal option
  839. 51150 FNinlist=j
  840. 51160 FN END
  841. 51200 !
  842. 51210 !              FUNCTION TO CONVERT STRING TO NO
  843. 51220 !              --------------------------------
  844. 51230 DEF FNpval(c$,o)
  845. 51240 IF c$#"?" THEN 51270 ! If not ? get value
  846. 51250 DF$="value" @ p=0 !    On return OPTION - value will be printed
  847. 51260 GOTO 51300
  848. 51270 c=NUM (c$) !  Check for numeric (0-9)
  849. 51280 IF c<48 OR c>58 THEN I$=IV$ @ p=0 @ GOTO 51300 ! Illegal value ?
  850. 51290 o=VAL (c$) !  Set new value
  851. 51300 FNpval=o !    Return value (If error then old value returned)
  852. 51310 FN END
  853. 51400 !
  854. 51410 !                      SET VARIABLE FROM LIST
  855. 51420 !                      ----------------------
  856. 51430 DEF FNlset(c$,o,l$[183])
  857. 51440 p=FNinlist(c$,l$) @ IF p<1 THEN I$=IO$ ELSE o=p-1
  858. 51450 FNlset=o @ FN END
  859. 52000 !
  860. 52010 !              DISPLAY OPTION FROM LIST
  861. 52020 !              ------------------------
  862. 52030 DEF FNxlist$(l$[183],p)
  863. 52040 j=1 @ l=1 @ L=LEN (l$) !                     Set count, last pos & length
  864. 52050 cp=POS (l$[l],", ") !                        Position of ', '
  865. 52060 IF cp>0 THEN cp=cp+l-2 ELSE cp=L !           Set cp to end of option
  866. 52070 IF j=p THEN FNxlist$=l$[l,cp] @ GOTO 52100 ! If position get option
  867. 52080 j=j+1 @ l=cp+3 @ IF l<L THEN 52050 !         Get next option
  868. 52090 FNxlist$="" !                                If end of list return null
  869. 52100 FN END
  870.