home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
DP Tool Club 19
/
CD_ASCQ_19_010295.iso
/
dos
/
prg
/
bas
/
pcl4b42
/
xymodem.bas
< prev
next >
Wrap
BASIC Source File
|
1994-09-03
|
9KB
|
335 lines
' -- XYMODEM.BAS --
'
' This program is donated to the Public
' Domain by MarshallSoft Computing, Inc.
' It is provided as an example of the use
' of the Personal Communications Library.
'
DEFINT A-Z
'$INCLUDE: 'XYPACKET.BI'
'$INCLUDE: 'TERM_IO.BI'
'$INCLUDE: 'MODEM_IO.BI'
'$INCLUDE: 'PCL4B.BI'
'$INCLUDE: 'XYMODEM.BI'
CONST NAK = &H15, CAN = &H18
CONST FALSE = 0, TRUE = NOT FALSE
FUNCTION FetchName (Filename$)
FetchName = TRUE
IF LEN(Filename$) = 0 THEN
CALL WriteMsg("Enter filename: ", 1)
CALL ReadMsg(Filename$, 16, 20)
IF LEN(Filename) = 0 THEN
FetchName = FALSE
END IF
END IF
END FUNCTION
FUNCTION RxyModem (BYVAL Port, Filename$, BYVAL NCGbyte, BYVAL BatchFlag)
ON LOCAL ERROR GOTO RxyTrap
ErrorFlag = FALSE
EOTflag = FALSE
CALL WriteMsg("XYMODEM Receive: Waiting for Sender ", 1)
'clear comm port
Code = SioRxFlush(Port)
'Send NAKs or 'C's
IF NOT RxStartup(Port, NCGbyte) THEN
RxyModem = FALSE
EXIT FUNCTION
END IF
'open file unless BatchFlag is on
IF BatchFlag THEN
FirstPacket = 0
ELSE
FirstPacket = 1
'Open file for write
FileNbr = FREEFILE
OPEN Filename$ FOR BINARY ACCESS WRITE AS FileNbr
PRINT "Opening "; Filename$
END IF
'get each packet in turn
FOR Packet = FirstPacket TO 32767
'user aborts ?
AnyKey$ = INKEY$
IF AnyKey$ = STR$(CAN) THEN
TxCAN (Port)
CALL WriteMsg("*** Canceled by USER ***", 1)
RxyModem = FALSE
EXIT FUNCTION
END IF
'issue message
Message$ = "Packet " + STR$(Packet)
CALL WriteMsg(Message$, 1)
PacketNbr = Packet AND 255
'get next packet (RxPacket will allocate Buffer$)
Buffer$ = ""
IF NOT RxPacket(Port, Packet, Buffer$, BufferSize, NCGbyte, EOTflag) THEN
RxyModem = FALSE
EXIT FUNCTION
END IF
'packet 0 ?
IF Packet = 0 THEN
IF LEFT$(Buffer$, 1) = CHR$(0) THEN
CALL WriteMsg("Batch transfer complete", 1)
RxyModem = TRUE
EXIT FUNCTION
END IF
'construct filename
I = 1
Filename$ = ""
Byte$ = STRING$(1, 0)
DO
Byte$ = MID$(Buffer$, I, 1)
IF Byte$ = CHR$(0) THEN
EXIT DO
END IF
Filename$ = Filename$ + Byte$
I = I + 1
LOOP
'get file size
I = I + 1
Temp$ = ""
DO
Byte$ = MID$(Buffer$, I, 1)
IF Byte$ = CHR$(0) THEN
EXIT DO
END IF
Temp$ = Temp$ + Byte$
I = I + 1
LOOP
FileBytes& = VAL(Temp$)
END IF
'all done if EOT was received
IF EOTflag THEN
CLOSE FileNbr
CALL WriteMsg("Transfer completed", 1)
RxyModem = TRUE
EXIT FUNCTION
END IF
'process the packet
IF Packet = 0 THEN
'open file using filename in packet 0
FileNbr = FREEFILE
OPEN Filename$ FOR BINARY ACCESS WRITE AS FileNbr
PRINT "Opening "; Filename$
'must restart after packet 0
Flag = RxStartup(Port, NCGbyte)
ELSE
'Packet > 0 ==> write Buffer$
PUT FileNbr, , Buffer$
END IF
NEXT Packet
CLOSE FileNbr
EXIT FUNCTION
RxyTrap:
SELECT CASE ERR
CASE 52
Message$ = "Cannot open " + Filename$ + " for write"
CALL WriteMsg(Message$, 1)
CASE ELSE
PRINT "RX Error: "; ERROR$; " ("; ERR; ")"
END SELECT
RxyModem = FALSE
EXIT FUNCTION
END FUNCTION
FUNCTION TxyModem (BYVAL Port, Filename$, BYVAL OneKflag, BYVAL BatchFlag)
'''PRINT "TxyModem: Filename$=";Filename$;" ,LEN=";LEN(Filename$)
ON LOCAL ERROR GOTO TxyTrap
Number128& = 0
Number1K& = 0
NCGbyte = NAK
EOTflag = FALSE
EmptyFlag = FALSE
IF BatchFlag THEN
IF LEN(Filename$) = 0 THEN
EmptyFlag = TRUE
END IF
END IF
IF NOT EmptyFlag THEN
FileNbr = FREEFILE
OPEN Filename$ FOR BINARY ACCESS READ AS FileNbr
PRINT "Opening "; Filename$
END IF
CALL WriteMsg("XYMODEM: waiting for receiver ", 1)
'compute # blocks
IF EmptyFlag THEN
'empty file
Number128& = 0
Number1K& = 0
ELSE
'filename is not empty. compute file length
FileBytes& = LOF(FileNbr)
RemainingBytes& = FileBytes&
IF OneKflag THEN
Number1K& = FileBytes& \ 1024
ELSE
Number1K& = 0
END IF
Number128& = (FileBytes& - 1024 * Number1K&) \ 128
IF (128 * Number128& + 1024 * Number1K&) < FileBytes& THEN
Number128& = Number128& + 1
END IF
Message$ = STR$(Number1K&) + " 1K & " + STR$(Number128&) + " 128-byte packets"
CALL WriteMsg(Message$, 1)
PRINT Message$
END IF
'clear comm port (there may be several NAKs queued up)
Code = SioRxFlush(Port)
'get receivers start up NAK or 'C'
IF NOT TxStartup(Port, NCGbyte) THEN
TxyModem = FALSE
EXIT FUNCTION
END IF
'loop over all packets
IF BatchFlag THEN
FirstPacket = 0
ELSE
FirstPacket = 1
END IF
'transmit each packet in turn
FOR Packet = FirstPacket TO Number1K& + Number128&
'user aborts ?
AnyKey$ = INKEY$
IF AnyKey$ = STR$(CAN) THEN
TxCAN (Port)
CALL WriteMsg("*** Canceled by USER ***", 1)
TxyModem = FALSE
EXIT FUNCTION
END IF
'issue message
Message$ = "Packet " + STR$(Packet)
CALL WriteMsg(Message$, 1)
'load up internal buffer
IF Packet = 0 THEN
'packet = 0. Init Buffer$ to 128 zeros.
BlockSize = 128
Buffer$ = STRING$(128, 0)
IF EmptyFlag THEN
'send empty buffer
ELSE
'not empty: copy filename to buffer
K = 1
L = LEN(Filename$)
MID$(Buffer$, K, L) = Filename$
K = K + L + 1
'copy file length to buffer
Temp$ = STR$(FileBytes&)
L = LEN(Temp$)
MID$(Buffer$, K, L) = Temp$
K = K + L + 1
END IF
ELSE
'DATA Packet: use 1K or 128-byte blocks ?
IF BatchFlag AND (Packet <= Number1K&) THEN
BlockSize = 1024
ELSE
BlockSize = 128
END IF
'compute # bytes to read
IF RemainingBytes& < BlockSize THEN
ReadSize = RemainingBytes&
ELSE
ReadSize = BlockSize
END IF
'read next block from disk
Buffer$ = STRING$(ReadSize, 0)
GET FileNbr, , Buffer$
RemainingBytes& = RemainingBytes& - ReadSize
'pad short buffer with ^Z
IF ReadSize < BlockSize THEN
Buffer$ = Buffer$ + STRING$(BlockSize - ReadSize, &H1A)
END IF
END IF
'Send this packet
IF NOT TxPacket(Port, Packet, Buffer$, BlockSize, NCGbyte) THEN
TxyModem = FALSE
EXIT FUNCTION
END IF
Code = SioDelay(5)
'must 'restart' after non null packet 0
IF (NOT EmptyFlag) AND (Packet = 0) THEN
Flag = TxStartup(Port, NCGbyte)
END IF
NEXT Packet
'done if empty packet 0
IF EmptyFlag THEN
CALL WriteMsg("Batch transfer completed", 1)
TxyModem = TRUE
EXIT FUNCTION
END IF
'all done. send EOT up to 10 times
IF NOT TxEOT(Port) THEN
PRINT "EOT not acknowledged"
TxyModem = FALSE
EXIT FUNCTION
END IF
CLOSE FileNbr
CALL WriteMsg("Transfer completed", 1)
TxyModem = TRUE
EXIT FUNCTION
TxyTrap:
SELECT CASE ERR
CASE 52
Message$ = "Cannot open " + Filename$ + " for read"
CALL WriteMsg(Message$, 1)
CASE ELSE
PRINT "TX Error: "; ERROR$; " ("; ERR; ")"
END SELECT
TxyModem = FALSE
EXIT FUNCTION
END FUNCTION
FUNCTION XmodemRx (BYVAL Port, Filename$, BYVAL NCGbyte)
IF FetchName(Filename$) THEN
XmodemRx = RxyModem(Port, Filename$, NCGbyte, FALSE)
ELSE
XmodemRx = FALSE
END IF
END FUNCTION
FUNCTION XmodemTx (BYVAL Port, Filename$, BYVAL OneKflag)
IF FetchName(Filename$) THEN
XmodemTx = TxyModem(Port, Filename$, OneKflag, FALSE)
ELSE
XmodemTx = FALSE
END IF
END FUNCTION
FUNCTION YmodemRx (BYVAL Port, Filename$, BYVAL NCGbyte)
YmodemRx = TRUE
DO
AnyKey$ = INKEY$
IF AnyKey$ <> "" THEN
CALL WriteMsg("Aborted by user", 1)
EXIT DO
END IF
CALL WriteMsg("Ready for next file", 1)
Filename$ = ""
IF NOT RxyModem(Port, Filename$, NCGbyte, TRUE) THEN
YmodemRx = FALSE
EXIT FUNCTION
END IF
'empty filename ?
IF Filename$ = "" THEN
EXIT FUNCTION
END IF
LOOP
END FUNCTION
FUNCTION YmodemTx (BYVAL Port, Filename$, BYVAL OneKflag)
IF FetchName(Filename$) THEN
YmodemTx = TxyModem(Port, Filename$, OneKflag, TRUE)
'send empty filename to terminate
Filename$ = ""
YmodemTx = TxyModem(Port, Filename$, OneKflag, TRUE)
ELSE
YmodemTx = FALSE
END IF
END FUNCTION