home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 19 / CD_ASCQ_19_010295.iso / dos / prg / bas / pcl4b42 / xymodem.bas < prev    next >
BASIC Source File  |  1994-09-03  |  9KB  |  335 lines
  1. ' -- XYMODEM.BAS --
  2. '
  3. ' This program is donated to the Public
  4. ' Domain by MarshallSoft Computing, Inc.
  5. ' It is provided as an example of the use
  6. ' of the Personal Communications Library.
  7. '
  8.  
  9. DEFINT A-Z
  10.  
  11. '$INCLUDE: 'XYPACKET.BI'
  12. '$INCLUDE: 'TERM_IO.BI'
  13. '$INCLUDE: 'MODEM_IO.BI'
  14. '$INCLUDE: 'PCL4B.BI'
  15. '$INCLUDE: 'XYMODEM.BI'
  16.  
  17.  CONST NAK = &H15, CAN = &H18
  18.  CONST FALSE = 0, TRUE = NOT FALSE
  19.  
  20.  
  21. FUNCTION FetchName (Filename$)
  22.   FetchName = TRUE
  23.   IF LEN(Filename$) = 0 THEN
  24.     CALL WriteMsg("Enter filename: ", 1)
  25.     CALL ReadMsg(Filename$, 16, 20)
  26.     IF LEN(Filename) = 0 THEN
  27.       FetchName = FALSE
  28.     END IF
  29.   END IF
  30. END FUNCTION
  31.  
  32. FUNCTION RxyModem (BYVAL Port, Filename$, BYVAL NCGbyte, BYVAL BatchFlag)
  33.   ON LOCAL ERROR GOTO RxyTrap
  34.   ErrorFlag = FALSE
  35.   EOTflag = FALSE
  36.   CALL WriteMsg("XYMODEM Receive: Waiting for Sender ", 1)
  37.   'clear comm port
  38.   Code = SioRxFlush(Port)
  39.   'Send NAKs or 'C's
  40.   IF NOT RxStartup(Port, NCGbyte) THEN
  41.     RxyModem = FALSE
  42.     EXIT FUNCTION
  43.   END IF
  44.   'open file unless BatchFlag is on
  45.   IF BatchFlag THEN
  46.     FirstPacket = 0
  47.   ELSE
  48.     FirstPacket = 1
  49.     'Open file for write
  50.     FileNbr = FREEFILE
  51.     OPEN Filename$ FOR BINARY ACCESS WRITE AS FileNbr
  52.     PRINT "Opening "; Filename$
  53.   END IF
  54.   'get each packet in turn
  55.   FOR Packet = FirstPacket TO 32767
  56.     'user aborts ?
  57.     AnyKey$ = INKEY$
  58.     IF AnyKey$ = STR$(CAN) THEN
  59.       TxCAN (Port)
  60.       CALL WriteMsg("*** Canceled by USER ***", 1)
  61.       RxyModem = FALSE
  62.       EXIT FUNCTION
  63.     END IF
  64.     'issue message
  65.     Message$ = "Packet " + STR$(Packet)
  66.     CALL WriteMsg(Message$, 1)
  67.     PacketNbr = Packet AND 255
  68.     'get next packet (RxPacket will allocate Buffer$)
  69.     Buffer$ = ""
  70.     IF NOT RxPacket(Port, Packet, Buffer$, BufferSize, NCGbyte, EOTflag) THEN
  71.       RxyModem = FALSE
  72.       EXIT FUNCTION
  73.     END IF
  74.     'packet 0 ?
  75.     IF Packet = 0 THEN
  76.       IF LEFT$(Buffer$, 1) = CHR$(0) THEN
  77.         CALL WriteMsg("Batch transfer complete", 1)
  78.         RxyModem = TRUE
  79.         EXIT FUNCTION
  80.       END IF
  81.       'construct filename
  82.       I = 1
  83.       Filename$ = ""
  84.       Byte$ = STRING$(1, 0)
  85.       DO
  86.         Byte$ = MID$(Buffer$, I, 1)
  87.         IF Byte$ = CHR$(0) THEN
  88.           EXIT DO
  89.         END IF
  90.         Filename$ = Filename$ + Byte$
  91.         I = I + 1
  92.       LOOP
  93.       'get file size
  94.       I = I + 1
  95.       Temp$ = ""
  96.       DO
  97.         Byte$ = MID$(Buffer$, I, 1)
  98.         IF Byte$ = CHR$(0) THEN
  99.           EXIT DO
  100.         END IF
  101.         Temp$ = Temp$ + Byte$
  102.         I = I + 1
  103.       LOOP
  104.       FileBytes& = VAL(Temp$)
  105.     END IF
  106.     'all done if EOT was received
  107.     IF EOTflag THEN
  108.       CLOSE FileNbr
  109.       CALL WriteMsg("Transfer completed", 1)
  110.       RxyModem = TRUE
  111.       EXIT FUNCTION
  112.     END IF
  113.     'process the packet
  114.     IF Packet = 0 THEN
  115.       'open file using filename in packet 0
  116.       FileNbr = FREEFILE
  117.       OPEN Filename$ FOR BINARY ACCESS WRITE AS FileNbr
  118.       PRINT "Opening "; Filename$
  119.       'must restart after packet 0
  120.       Flag = RxStartup(Port, NCGbyte)
  121.     ELSE
  122.       'Packet > 0  ==> write Buffer$
  123.       PUT FileNbr, , Buffer$
  124.     END IF
  125.   NEXT Packet
  126.   CLOSE FileNbr
  127.   EXIT FUNCTION
  128. RxyTrap:
  129.   SELECT CASE ERR
  130.     CASE 52
  131.       Message$ = "Cannot open " + Filename$ + " for write"
  132.       CALL WriteMsg(Message$, 1)
  133.     CASE ELSE
  134.       PRINT "RX Error: "; ERROR$; " ("; ERR; ")"
  135.     END SELECT
  136.     RxyModem = FALSE
  137.     EXIT FUNCTION
  138. END FUNCTION
  139.  
  140. FUNCTION TxyModem (BYVAL Port, Filename$, BYVAL OneKflag, BYVAL BatchFlag)
  141. '''PRINT "TxyModem: Filename$=";Filename$;" ,LEN=";LEN(Filename$)
  142.   ON LOCAL ERROR GOTO TxyTrap
  143.   Number128& = 0
  144.   Number1K& = 0
  145.   NCGbyte = NAK
  146.   EOTflag = FALSE
  147.   EmptyFlag = FALSE
  148.   IF BatchFlag THEN
  149.     IF LEN(Filename$) = 0 THEN
  150.       EmptyFlag = TRUE
  151.     END IF
  152.   END IF
  153.   IF NOT EmptyFlag THEN
  154.     FileNbr = FREEFILE
  155.     OPEN Filename$ FOR BINARY ACCESS READ AS FileNbr
  156.     PRINT "Opening "; Filename$
  157.   END IF
  158.   CALL WriteMsg("XYMODEM: waiting for receiver ", 1)
  159.   'compute # blocks
  160.   IF EmptyFlag THEN
  161.     'empty file
  162.     Number128& = 0
  163.     Number1K& = 0
  164.   ELSE
  165.     'filename is not empty. compute file length
  166.     FileBytes& = LOF(FileNbr)
  167.     RemainingBytes& = FileBytes&
  168.     IF OneKflag THEN
  169.       Number1K& = FileBytes& \ 1024
  170.     ELSE
  171.       Number1K& = 0
  172.     END IF
  173.     Number128& = (FileBytes& - 1024 * Number1K&) \ 128
  174.     IF (128 * Number128& + 1024 * Number1K&) < FileBytes& THEN
  175.       Number128& = Number128& + 1
  176.     END IF
  177.     Message$ = STR$(Number1K&) + " 1K & " + STR$(Number128&) + " 128-byte packets"
  178.     CALL WriteMsg(Message$, 1)
  179.     PRINT Message$
  180.   END IF
  181.   'clear comm port (there may be several NAKs queued up)
  182.   Code = SioRxFlush(Port)
  183.   'get receivers start up NAK or 'C'
  184.   IF NOT TxStartup(Port, NCGbyte) THEN
  185.     TxyModem = FALSE
  186.     EXIT FUNCTION
  187.   END IF
  188.   'loop over all packets
  189.   IF BatchFlag THEN
  190.     FirstPacket = 0
  191.   ELSE
  192.     FirstPacket = 1
  193.   END IF
  194.   'transmit each packet in turn
  195.   FOR Packet = FirstPacket TO Number1K& + Number128&
  196.     'user aborts ?
  197.     AnyKey$ = INKEY$
  198.     IF AnyKey$ = STR$(CAN) THEN
  199.       TxCAN (Port)
  200.       CALL WriteMsg("*** Canceled by USER ***", 1)
  201.       TxyModem = FALSE
  202.       EXIT FUNCTION
  203.     END IF
  204.     'issue message
  205.     Message$ = "Packet " + STR$(Packet)
  206.     CALL WriteMsg(Message$, 1)
  207.     'load up internal buffer
  208.     IF Packet = 0 THEN
  209.       'packet = 0. Init Buffer$ to 128 zeros.
  210.       BlockSize = 128
  211.       Buffer$ = STRING$(128, 0)
  212.       IF EmptyFlag THEN
  213.         'send empty buffer
  214.       ELSE
  215.         'not empty: copy filename to buffer
  216.         K = 1
  217.         L = LEN(Filename$)
  218.         MID$(Buffer$, K, L) = Filename$
  219.         K = K + L + 1
  220.         'copy file length to buffer
  221.         Temp$ = STR$(FileBytes&)
  222.         L = LEN(Temp$)
  223.         MID$(Buffer$, K, L) = Temp$
  224.         K = K + L + 1
  225.       END IF
  226.     ELSE
  227.       'DATA Packet: use 1K or 128-byte blocks ?
  228.       IF BatchFlag AND (Packet <= Number1K&) THEN
  229.         BlockSize = 1024
  230.       ELSE
  231.         BlockSize = 128
  232.       END IF
  233.       'compute # bytes to read
  234.       IF RemainingBytes& < BlockSize THEN
  235.         ReadSize = RemainingBytes&
  236.       ELSE
  237.         ReadSize = BlockSize
  238.       END IF
  239.       'read next block from disk
  240.       Buffer$ = STRING$(ReadSize, 0)
  241.       GET FileNbr, , Buffer$
  242.       RemainingBytes& = RemainingBytes& - ReadSize
  243.       'pad short buffer with ^Z
  244.       IF ReadSize < BlockSize THEN
  245.         Buffer$ = Buffer$ + STRING$(BlockSize - ReadSize, &H1A)
  246.       END IF
  247.     END IF
  248.     'Send this packet
  249.     IF NOT TxPacket(Port, Packet, Buffer$, BlockSize, NCGbyte) THEN
  250.       TxyModem = FALSE
  251.       EXIT FUNCTION
  252.     END IF
  253.     Code = SioDelay(5)
  254.     'must 'restart' after non null packet 0
  255.     IF (NOT EmptyFlag) AND (Packet = 0) THEN
  256.       Flag = TxStartup(Port, NCGbyte)
  257.     END IF
  258.   NEXT Packet
  259.   'done if empty packet 0
  260.   IF EmptyFlag THEN
  261.     CALL WriteMsg("Batch transfer completed", 1)
  262.     TxyModem = TRUE
  263.     EXIT FUNCTION
  264.   END IF
  265.   'all done. send EOT up to 10 times
  266.   IF NOT TxEOT(Port) THEN
  267.     PRINT "EOT not acknowledged"
  268.     TxyModem = FALSE
  269.     EXIT FUNCTION
  270.   END IF
  271.   CLOSE FileNbr
  272.   CALL WriteMsg("Transfer completed", 1)
  273.   TxyModem = TRUE
  274.   EXIT FUNCTION
  275. TxyTrap:
  276.   SELECT CASE ERR
  277.     CASE 52
  278.       Message$ = "Cannot open " + Filename$ + " for read"
  279.       CALL WriteMsg(Message$, 1)
  280.     CASE ELSE
  281.       PRINT "TX Error: "; ERROR$; " ("; ERR; ")"
  282.     END SELECT
  283.     TxyModem = FALSE
  284.     EXIT FUNCTION
  285. END FUNCTION
  286.  
  287. FUNCTION XmodemRx (BYVAL Port, Filename$, BYVAL NCGbyte)
  288.   IF FetchName(Filename$) THEN
  289.     XmodemRx = RxyModem(Port, Filename$, NCGbyte, FALSE)
  290.   ELSE
  291.     XmodemRx = FALSE
  292.   END IF
  293. END FUNCTION
  294.  
  295. FUNCTION XmodemTx (BYVAL Port, Filename$, BYVAL OneKflag)
  296.   IF FetchName(Filename$) THEN
  297.     XmodemTx = TxyModem(Port, Filename$, OneKflag, FALSE)
  298.   ELSE
  299.     XmodemTx = FALSE
  300.   END IF
  301. END FUNCTION
  302.  
  303. FUNCTION YmodemRx (BYVAL Port, Filename$, BYVAL NCGbyte)
  304.   YmodemRx = TRUE
  305.   DO
  306.     AnyKey$ = INKEY$
  307.     IF AnyKey$ <> "" THEN
  308.       CALL WriteMsg("Aborted by user", 1)
  309.       EXIT DO
  310.     END IF
  311.     CALL WriteMsg("Ready for next file", 1)
  312.     Filename$ = ""
  313.     IF NOT RxyModem(Port, Filename$, NCGbyte, TRUE) THEN
  314.       YmodemRx = FALSE
  315.       EXIT FUNCTION
  316.     END IF
  317.     'empty filename ?
  318.     IF Filename$ = "" THEN
  319.       EXIT FUNCTION
  320.     END IF
  321.   LOOP
  322. END FUNCTION
  323.  
  324. FUNCTION YmodemTx (BYVAL Port, Filename$, BYVAL OneKflag)
  325.   IF FetchName(Filename$) THEN
  326.     YmodemTx = TxyModem(Port, Filename$, OneKflag, TRUE)
  327.     'send empty filename to terminate
  328.     Filename$ = ""
  329.     YmodemTx = TxyModem(Port, Filename$, OneKflag, TRUE)
  330.   ELSE
  331.     YmodemTx = FALSE
  332.   END IF
  333. END FUNCTION
  334.  
  335.