🚀 go-pugleaf

Submitted-by: munroe@dmc.com (Dick Munroe)
Posting-number: Volume 3, Issue 116
Archive-name: ubbs/part08
-+-+-+-+-+-+-+-+ START OF PART 8 -+-+-+-+-+-+-+-+
X`09KERMIT_OPENR = .TRUE.`09`09`09! Show file is open.
X`09RETURN
X
X9900`09CALL RMS_ERROR (MODULE_NAME)`09`09! Report the RMS error.
X`09KERMIT_OPENR = .FALSE.`09`09`09! Show file open failed.
X`09RETURN
X`09END
X`0C
X`09LOGICAL FUNCTION KERMIT_PACK (FBUFF, P_DATA, P_LEN)
XC
XC`09This function is used to pack the data a VAX file into a data
XC`09packet for transmission to the remote KERMIT.
XC
XC`09Inputs:
XC`09`09FBUFF`09The input file buffer.`09`09`09(By Descriptor)
XC`09`09P_DATA`09The data packet buffer.`09`09`09(By Reference)
XC`09`09P_LEN`09The packet data length.`09`09`09(By Reference)
XC`09`09RBYTES`09The current record count.`09`09(Global)
XC
XC`09Outputs:
XC`09`09Returns .TRUE./.FALSE. = Success/Failure.
XC
X`09IMPLICIT NONE
X`09INCLUDE 'kermit_inc.for'
X`09INCLUDE 'bbs_inc.for'
X
X`09LOGICAL`09KERMIT_READ
X`09CHARACTER*(*) FBUFF
X`09BYTE`09P_DATA (MAXDATASIZ)
X`09BYTE`09P_LEN
X
X`09BYTE`09C`09`09`09`09! The next file character.
X`09BYTE`09C7`09`09`09`09! 7-bit version of above.
X`09INTEGER F,`09`09`09`09! Index into file buffer.
X`091`09I`09`09`09`09! Index into packet data.
X
X`09IF (END_OF_FILE) THEN`09`09`09! If at end of file,
X`09    KERMIT_PACK = .FALSE.`09`09!   then return failure.
X`09    RETURN
X`09ENDIF
XC
XC`09Pack the file data into the data packet.
XC
X`09I = 1`09`09`09`09`09! Initialize packet index.
X`09P_LEN = 0`09`09`09`09! Initialize packet length.
X`09DO WHILE (I .LT. PACKET_LENGTH)`09`09! Do until packet limit.
X`09    IF (RBYTES .EQ. 0) THEN`09`09! More bytes is the buffer?
X`09`09F = 1`09`09`09`09! Initialize file buffer index.
X`09`09IF (.NOT. KERMIT_READ (FBUFF, RBYTES)) THEN
X`09`09    IF (P_LEN .NE. 0) THEN`09! Have a partial packet ?
X`09`09`09KERMIT_PACK = .TRUE.`09! Yes, send this packet.
X`09`09`09RETURN
X`09`09    ELSE
X`09`09`09KERMIT_PACK = .FALSE.`09! Else, show file is done.
X`09`09`09RETURN
X`09`09    ENDIF
X`09`09ENDIF
X`09    ENDIF
X`09    C = ICHAR (FBUFF(F:F))`09`09! Copy the next character.
X`09    C7 = C .AND. "177`09`09`09! 7-bit version of above.
X`09    IF ( (C7 .LT. SP) .OR. (C7 .EQ. RUB)
X`091`09`09`09.OR. (C7 .EQ. QCTLC) ) THEN
X`09`09IF (I+1 .GE. PACKET_LENGTH) THEN ! Too close to packet end?
X`09`09    KERMIT_PACK = .TRUE.`09! Yes, show packet ready.
X`09`09    RETURN
X`09`09ENDIF
X`09`09P_DATA(I) = QCTLC`09`09! Must quote this character.
X`09`09I = I + 1`09`09`09! Adjust the packet index.
X`09`09IF (C7 .EQ. QCTLC) THEN`09`09! If quote character,
X`09`09    P_DATA(I) = C`09`09!   copy the quote char.
X`09`09ELSE
X`09`09    P_DATA(I) = (C .XOR. 64)`09! Uncontolify the character.
X`09`09ENDIF
X`09`09I = I + 1`09`09`09! Point to next position.
X`09`09P_LEN = P_LEN + 2`09`09! Adjust the packet length.
X`09    ELSE
X`09`09P_DATA(I) = C`09`09`09! Copy normal character.
X`09`09I = I + 1`09`09`09! Point to next position.
X`09`09P_LEN = P_LEN + 1`09`09! Adjust the packet length.
X`09    ENDIF
X`09    F = F + 1`09`09`09`09! Adjust file buffer index.
X`09    RBYTES = RBYTES - 1`09`09`09! Adjust the record bytes.
X`09ENDDO
X`09KERMIT_PACK = .TRUE.`09`09`09! Yes, show packet ready.
X`09RETURN
X`09END
X`0C
X`09LOGICAL FUNCTION KERMIT_READ (FDATA, BYTES)
XC
XC`09This function used to read a record from the VAX file.
XC
XC`09Inputs:
XC`09`09FDATA`09The file read buffer.
XC`09`09BYTES`09Variable for bytes read.
XC
XC`09Outputs:
XC`09`09BYTES`09The number of bytes read.
XC
XC`09`09Returns .TRUE./.FALSE. = Success/Failure.
XC
X`09IMPLICIT NONE
X`09INCLUDE 'kermit_inc.for'
X`09INCLUDE 'bbs_inc.for'
X
X`09INTEGER BYTES
X`09CHARACTER*(*) FDATA, MODULE_NAME
X`09PARAMETER (MODULE_NAME = 'KERMIT_READ')
XC
XC`09Read a record from the VAX file.
XC
X`09BYTES = 0`09`09`09`09! Initialize byte count.
X`09DO WHILE (BYTES .EQ. 0)
X`09    READ (FILE_UNIT, 100, END=9910, ERR=9900) BYTES, FDATA
X100`09    FORMAT (Q, A)
X`09    CALL KERMIT_TOTALS (BYTES)`09`09! Update the file totals.
X`09    IF (FILE_TYPE.NE.BINARY) THEN`09`09! If ASCII file type,
X`09`09BYTES = BYTES + 1`09`09! Count carriage return.
X`09`09FDATA(BYTES:BYTES) = CHAR(CR)`09! Append carriage return.
X`09`09BYTES = BYTES + 1`09`09! Count the line feed.
X`09`09FDATA(BYTES:BYTES) = CHAR(LF)`09! Append the line feed.
X`09    ENDIF
X`09ENDDO
X`09KERMIT_READ = .TRUE.`09`09`09! Show read successful.
X`09RETURN
XC
XC`09We come here when an error occurs reading the input file.
XC
X9900`09CALL RMS_ERROR (MODULE_NAME)`09`09! Report the RMS error.
XC
XC`09We come here for end of file on input file.
XC
X9910`09CLOSE (UNIT=FILE_UNIT)`09`09`09! Close the input file.
X`09END_OF_FILE = .TRUE.`09`09`09! Show EOF or error.
X`09KERMIT_READ = .FALSE.`09`09`09! Show the read failed.
X`09RETURN
X`09END
X`0C
X`09SUBROUTINE KERMIT_TOTALS (BYTES)
XC
XC`09This routine is called after a record is successfully transmitted
XC`09to update the various counters.  Since the routine is called while
XC`09building a transmit packet from multiple input records, the record
XC`09display has a special entry which is called after transmitting the
XC`09current block.
XC
XC`09Inputs:
XC`09`09BYTES`09The number of record bytes.
XC
X`09IMPLICIT NONE
X`09INCLUDE 'kermit_inc.for'
X`09INCLUDE 'BBS_INC.FOR'
X
X`09INTEGER BYTES
X
X`09BYTE_COUNT = BYTE_COUNT + BYTES`09`09! Accumulate the byte count
X`09RECORD_COUNT = RECORD_COUNT + 1`09`09!`09and the record count.
X`09TOTAL_BYTES = TOTAL_BYTES + BYTES`09! Update the total byte count.
X`09TOTAL_RECORDS = TOTAL_RECORDS + 1`09!`09and the record count.
X`09RETURN
X
X`09ENTRY KERMIT_REPORT
X`09RETRY_COUNT = 0`09`09`09`09! Reinitialize retry counter.
X`09RETURN
X`09END
X`0C
X`09LOGICAL FUNCTION KERMIT_UNPACK (FBUFF, P_DATA, P_LEN)
XC
XC`09This function is used to unpack a data packet and write the data
XC`09to the the VAX file.
XC
XC`09Inputs:
XC`09`09FBUFF`09The output file buffer.`09`09`09(By Descriptor)
XC`09`09P_DATA`09The data packet buffer.`09`09`09(By Reference)
XC`09`09P_LEN`09The packet data length.`09`09`09(By Reference)
XC`09`09RBYTES`09The current record count.`09`09(Global)
XC
XC`09Outputs:
XC`09`09Returns .TRUE./.FALSE. = Success/Failure.
XC
X`09IMPLICIT NONE
X`09INCLUDE 'kermit_inc.for'
X`09INCLUDE 'bbs_inc.for'
X
X`09LOGICAL`09KERMIT_WRITE
X`09CHARACTER*(*) FBUFF
X`09BYTE`09P_DATA (MAXDATASIZ)
X`09BYTE`09P_LEN
X
X`09LOGICAL QUOTE_SEEN`09`09`09! Control quote seen flag.
X`09INTEGER F,`09`09`09`09! Index into file buffer.
X`091`09I`09`09`09`09! Index into packet data.
XC
XC`09Copy and decode the data packet.
XC
X`09F = RBYTES`09`09`09`09! Copy record byte count.
X`09QUOTE_SEEN = .FALSE.`09`09`09! Init the quote seen flag.
X`09DO I = 1, P_LEN
X`09  IF (QUOTE_SEEN) THEN
X`09    IF ((P_DATA(I) .AND. "177) .NE. QCTLC) THEN ! Quote of quote?
X`09      FBUFF(F:F) = CHAR(P_DATA(I) .XOR. 64) ! No convert control.
X`09    ELSE
X`09      FBUFF(F:F) = CHAR(P_DATA(I))`09! Copy the quote char.
X`09    ENDIF
X`09    QUOTE_SEEN = .FALSE.`09`09! Re-init quote flag.
XC
XC`09Check for carriage-return/line-feed sequence for record end.
XC
X`09    IF ( (FILE_TYPE.NE.BINARY) .AND. (F .GT. 1) ) THEN
X`09      IF ( (FBUFF(F-1:F-1) .EQ. CHAR(CR)) .AND.
X`091`09`09FBUFF(F:F) .EQ. CHAR(LF) ) THEN
X`09`09KERMIT_UNPACK = KERMIT_WRITE (FBUFF(1:F-2))
X`09`09F = 0`09`09`09`09! Reset buffer index.
X`09`09IF (.NOT. KERMIT_UNPACK) RETURN`09! Return failure status.
X`09      ENDIF
X`09    ELSEIF (F .EQ. 128) THEN
X`09      KERMIT_UNPACK = KERMIT_WRITE (FBUFF(1:F))
X`09      F = 0`09`09`09`09! Reset buffer index.
X`09      IF (.NOT. KERMIT_UNPACK) RETURN`09! Return failure status.
X`09    ENDIF
X`09  ELSE
X`09    F = F + 1`09`09`09`09! Point to next position.
X`09    FBUFF(F:F) = CHAR(P_DATA(I))`09! Copy the data character.
X`09    IF (P_DATA(I) .EQ. QCTLC) THEN`09! If quote character,
X`09      QUOTE_SEEN = .TRUE.`09`09!   show quote was seen.
X`09    ELSEIF ( (FILE_TYPE.EQ.BINARY) .AND. (F .EQ. 128) ) THEN
X`09      KERMIT_UNPACK = KERMIT_WRITE (FBUFF(1:F))
X`09      F = 0`09`09`09`09! Reset buffer index.
X`09      IF (.NOT. KERMIT_UNPACK) RETURN`09! Return failure status.
X`09    ENDIF
X`09  ENDIF
X`09ENDDO
X`09RBYTES = F`09`09`09`09! Copy the buffer index.
X`09KERMIT_UNPACK = .TRUE.`09`09`09! Show data unpacked OK.
X`09RETURN
X`09END
X`0C
X`09LOGICAL FUNCTION KERMIT_WRITE (FDATA)
XC
XC`09This function used to KERMIT packet data to the VAX file.
XC
XC`09Inputs:
XC`09`09FDATA`09The file data to write.
XC
XC`09Outputs:
XC`09`09Returns .TRUE./.FALSE. = Success/Failure.
XC
X`09IMPLICIT NONE
X`09INCLUDE 'kermit_inc.for'
X`09INCLUDE 'bbs_inc.for'
X
X`09CHARACTER*(*) FDATA, MODULE_NAME
X`09PARAMETER (MODULE_NAME = 'KERMIT_WRITE')
XC
XC`09Write the data to the output file.
XC
X`09WRITE (FILE_UNIT, 100, ERR=9900) FDATA
X100`09FORMAT (A)
X`09CALL KERMIT_TOTALS (LEN(FDATA))`09`09! Update file totals.
X`09CALL KERMIT_REPORT()`09`09`09! Update the screen.
X`09KERMIT_WRITE = .TRUE.`09`09`09! Show write successful.
X`09RETURN
X
X9900`09CALL RMS_ERROR (MODULE_NAME)`09`09! Report the RMS error.
X`09KERMIT_WRITE = .FALSE.`09`09`09! Show the write failed.
X`09RETURN
X`09END
X`0C
X`09INTEGER FUNCTION RECEIVE_PACKET (P_DATA, P_LEN, P_NUM)
XC
XC`09This function is used to receive a packet.
XC
XC`09Inputs:
XC`09`09P_DATA`09Buffer for received data.
XC`09`09P_LEN`09The data length.
XC`09`09P_NUM`09The packet number.
XC
XC`09Outputs:
XC`09`09The value returned is the packet type.
XC
XC`09`09The above inputs are filled on success.
XC
X`09IMPLICIT NONE
X`09INCLUDE 'kermit_inc.for'
X`09INCLUDE 'bbs_inc.for'
X
X`09BYTE`09P_DATA (MAXDATASIZ)
X`09BYTE`09P_NUM, P_LEN
X
X`09INTEGER CHECKSUM, I, PCHK, PACK_SIZE, STATUS
X`09INTEGER KERMIT_CHECKSUM, READ_BYTE, RAW_READ
XC
XC`09Packet Format:
XC
XC`09+------+-----------+-----------+------+--------------+-------+
XC`09`7C MARK `7C char(LEN) `7C char(SEQ) `7C TYPE `7C ... DATA ... `7C CHECK
V `7C
XC`09+------+-----------+-----------+------+--------------+-------+
XC`09       `7C<---- Packet Length / Check Calculation ---->`7C
X
XC
XC`09Wait for the start of a packet character.
XC
X`09PACKET(PMARK) = 0`09`09`09! Initialize mark field.
X`09DO WHILE (PACKET(PMARK) .NE. MARKC)`09! Loop until MARK detected.
X`09    IF (CONTROLC_TYPED) THEN`09`09! CTRL/C typed to abort?
X`09`09RECEIVE_PACKET = 'A'`09`09! Return an "Abort" code.
X`09`09RETURN
X`09    ENDIF
X`09    PACKET(PMARK) = READ_BYTE (TIMOUT)`09! Read start of packet.
X`09ENDDO
XC
XC`09Read the packet size.
XC
X`09PACKET(PLEN) = READ_BYTE (TIMOUT)`09! Read the packet size.
X`09IF (PACKET(PLEN) .NE. 0) THEN
X`09    PACK_SIZE = PACKET(PLEN) - 32`09! Copy the packet size.
X`09    PACK_SIZE = PACK_SIZE .AND. "177`09! Make sure not too big.
X`09    IF (PACK_SIZE .GT. PACKBUFSIZ) THEN
X`09`09PACK_SIZE = PACKBUFSIZ`09`09! Set maximum packet size.
X`09    ENDIF
X`09ELSE
X`09    RECEIVE_PACKET = .FALSE.`09`09! Timeout or error.
X`09    RETURN
X`09ENDIF
XC
XC`09Read the rest of the packet (+1 for end of line character).
XC
X`09STATUS = 0`09`09`09`09! Initialize status code.
X`09DO WHILE (.NOT. STATUS)
X`09    IF (CONTROLC_TYPED) THEN`09`09! CTRL/C typed to abort?
X`09`09RECEIVE_PACKET = 'A'`09`09! Return an "Abort" code.
X`09`09RETURN
X`09    ENDIF
X`09    STATUS = RAW_READ (PACKET(PSEQ), PACK_SIZE+1, TIMOUT, TPTR)
X`09    IF (.NOT. STATUS) THEN
X`09`09RECEIVE_PACKET = .FALSE.`09! Return failure status.
X`09`09RETURN
X`09    ENDIF
X`09ENDDO
XC
XC`09Decode the packet and validate the checksum.
XC
X`09CHECKSUM = KERMIT_CHECKSUM (PACKET(PLEN), PACK_SIZE)
X`09PCHK = (PACKET(PLEN) - 32) + TO_CHECK`09! Set offset to checksum.
XC
XC`09If the checksum matches return the received packet type, otherwise
XC`09return failure.
XC
X`09IF ( CHECKSUM .EQ. (PACKET(PCHK)-32) ) THEN ! If checksum matches,
X`09    P_LEN = PACKET(PLEN) - 32 - POVER`09! Copy the packet length.
X`09    P_NUM = PACKET(PSEQ) - 32`09`09! Copy the packet number.
X`09    DO I = 1, P_LEN
X`09`09P_DATA(I) = PACKET(PDATA+(I-1))`09! Copy the packet data.
X`09    ENDDO
X`09    RECEIVE_PACKET = PACKET(PTYPE)`09! Return the packet type.
X`09ELSE
X`09    RECEIVE_PACKET = .FALSE.`09`09! Return failure status.
X`09ENDIF
X`09RETURN
X`09END
X`0C
X`09INTEGER FUNCTION KSEND_PACKET (P_DATA, P_LEN, P_NUM, P_TYPE)
XC
XC`09This function is used to send a packet.
XC
XC`09Inputs:
XC`09`09P_DATA`09Data buffer to send.
XC`09`09P_LEN`09The data length.
XC`09`09P_NUM`09The packet number.
XC`09`09P_TYPE`09The packet type.
XC
XC`09Outputs:
XC`09`09None.
XC
X`09IMPLICIT NONE
X`09INCLUDE 'kermit_inc.for'
X
X`09BYTE`09P_DATA (MAXDATASIZ)
X`09BYTE`09P_LEN, P_NUM, P_TYPE
X
X`09INTEGER I, PBYTES, PSIZE, PCHK
X`09INTEGER KERMIT_CHECKSUM
XC
XC`09+------+-----------+-----------+------+--------------+-------+
XC`09`7C MARK `7C char(LEN) `7C char(SEQ) `7C TYPE `7C ... DATA ... `7C CHECK
V `7C
XC`09+------+-----------+-----------+------+--------------+-------+
XC`09       `7C<---- Packet Length / Check Calculation ---->`7C
X
XC
XC`09Send out required pad characters (if any).
XC
X`09DO I = 1, PAD
X`09    CALL SEND_BYTE (PADC)`09`09! Write the pad character.
X`09ENDDO
XC
XC`09Construct the packet to send.
XC
X`09PACKET(PMARK) = MARKC`09`09`09! Copy the MARK character.
X`09PACKET(PLEN) = P_LEN + POVER + 32`09! Set the packet size.
X`09PACKET(PSEQ) = P_NUM + 32`09`09! Set the packet number.
X`09PACKET(PTYPE) = P_TYPE`09`09`09! Set the packet type.
X`09DO I = 1, P_LEN
X`09    PACKET(PDATA+(I-1)) = P_DATA(I)`09! Copy packet data.
X`09ENDDO
X`09PSIZE = P_LEN + POVER`09`09`09! Set the packet size.
X`09PCHK = PSIZE + TO_CHECK`09`09`09! Set offset to checksum.
X`09PACKET(PCHK) = KERMIT_CHECKSUM (PACKET(PLEN), PSIZE) + 32
X`09PACKET(PCHK+1) = EOLC`09`09`09! Set end of line character.
X`09PBYTES = P_LEN + TOVER`09`09`09! Set total packet size.
X`09CALL RAW_WRITE (PACKET, PBYTES)`09`09! Write the packet.`09
X`09RETURN
X`09END
X`0C
X`09INTEGER FUNCTION DEFAULT_PARAMETERS
XC
XC`09This function setup the default init parameters.  These defaults
XC`09are used if the remote doesn't specify the parameter in its'
XC`09send-init packet (all parameters are optional).
XC
X`09IMPLICIT NONE
X`09INCLUDE 'kermit_inc.for'
X`09INCLUDE 'bbs_inc.for'
XC
XC`09Setup the default init parameters.
XC
X`09SPSIZ  = DEFMAXL`09`09! Set maximum packet length.
X`09TIMOUT = DEFTIME`09`09! Set timeout limit to use.
X`09PAD    = DEFNPAD`09`09! Set number of pad characters.
X`09PADC   = DEFPADC`09`09! Set pad character to use.
X`09EOLC   = DEFEOLC`09`09! Set end of line character.
X`09QCTLC  = DEFQCTL`09`09! Set control quote character.
X`09QBINC  = DEFQBIN`09`09! Set eight bit quote character.
X`09CHKTYP = DEFCHKT`09`09! Set the packet check type.
X`09REPTC  = DEFREPT`09`09! Set the repeat character.
X`09CAPAS  = DEFCAPAS`09`09! Set extended capabilities.
XC
XC`09Initialize other flags:
XC
X`09MARKC = SOH`09`09`09! Set the mark (start) character.
X`09IMAGE = .FALSE.`09`09`09! Presume not image mode.
X`09QBIN = .FALSE.`09`09`09! Set no eight bit quoting.
X`09REPEAT = .FALSE.`09`09! Set no repeat char processing.
X`09TURN = .FALSE.`09`09`09! Presume no turnaround char.
X`09FILNAMCNV = .FALSE.`09`09! Presume no filename convert.
XC
XC`09Set the KERMIT end of line character in the read terminator table.
XC
X`09CALL SET_TERMINATOR (TPTR, TTBL, EOLC)`09! Set EOL terminator.
X`09RETURN
X`09END
X`0C
X`09INTEGER FUNCTION RECEIVE_PARAMETERS (RDATA, RLEN)
XC
XC`09This function is used to set the receive init parameters.
XC
XC`09Inputs:
XC`09`09RDATA`09Buffer with the receive init parameters.
XC`09`09RLEN`09The number of parameters received.
XC
XC`09Outputs:
XC`09`09None.
XC
X`09IMPLICIT NONE
X`09INCLUDE 'kermit_inc.for'
X`09INCLUDE 'bbs_inc.for'
X
X`09BYTE`09RDATA (ISIZE), RLEN
XC
XC`09Copy the received init parameters (all params are optional).
XC
X`09IF (RLEN .GE. IMAXL) THEN
X`09    SPSIZ  = RDATA (IMAXL) - 32`09! Set maximum packet length.
X`09ENDIF
X`09IF (RLEN .GE. ITIME) THEN
X`09    TIMOUT = RDATA (ITIME) - 32`09! Set timeout limit to use.
X`09    IF (TIMOUT .EQ. 0) THEN
X`09`09TIMOUT = TIMEOUT_COUNT`09! Use our timeout count.
X`09    ENDIF
X`09ENDIF
X`09IF (RLEN .GE. INPAD) THEN
X`09    PAD    = RDATA (INPAD) - 32`09! Set number of pad characters.
X`09ENDIF
X`09IF (RLEN .GE. IPAD) THEN
X`09    PADC = RDATA (IPAD) .XOR. 64 ! Set pad character to use.
X`09ENDIF
X`09IF (RLEN .GE. IEOLC) THEN
X`09    EOLC   = RDATA (IEOLC) - 32`09! Set end of line character.
X`09ENDIF
X`09IF (RLEN .GE. IQCTL) THEN
X`09    QCTLC  = RDATA (IQCTL)`09! Set control quote character.
X`09    IF (QCTLC .EQ. 0) THEN
X`09`09QCTLC = DEFQCTL`09`09! Set the default quote char.
X`09    ENDIF
X`09ENDIF
X`09IF (RLEN .GE. IQBIN) THEN
X`09    QBINC  = RDATA (IQBIN)`09! Set eight bit quote character.
X`09ENDIF
X`09IF (RLEN .GE. ICHKT) THEN
X`09    CHKTYP = RDATA (ICHKT)`09! Set the packet check type.
X`09ENDIF
X`09IF (RLEN .GE. IREPT) THEN
X`09    REPTC  = RDATA (IREPT)`09! Set the repeat character.
X`09ENDIF
X`09IF (RLEN .GE. ICAPAS) THEN
X`09    CAPAS = RDATA (ICAPAS) - 32`09! Set extended capabilities.
X`09ENDIF
XC
XC`09Change the read terminator table if the end of line character
XC`09has been changed by the remote.
XC
X`09IF (EOLC .NE. DEFEOLC) THEN`09! If NE, different EOL char.
X`09    CALL SET_TERMINATOR (TPTR, TTBL, EOLC) ! Set new terminator.
X`09ENDIF
X`09RETURN
X`09END
X`0C
X`09INTEGER FUNCTION KSEND_PARAMETERS (SDATA)
XC
XC`09This function is used to set our init parameters.
XC
XC`09Inputs:
XC`09`09SDATA`09Buffer for our init parameters.
XC
XC`09Outputs:
XC`09`09None.
XC
X`09IMPLICIT NONE
X`09INCLUDE 'kermit_inc.for'
X`09INCLUDE 'bbs_inc.for'
X
X`09BYTE`09SDATA (ISIZE)
XC
XC`09Setup our init parameters.
XC
X`09SDATA (IMAXL) = PACKET_LENGTH + 32`09! Set maximum packet length.
X`09SDATA (ITIME) = TIMEOUT_COUNT + 32`09! Set timeout limit to use.
X`09SDATA (INPAD) = MYNPAD + 32`09`09! Set number of pad characters.
X`09SDATA (IPAD)  = MYPADC .XOR. 64`09`09! Set pad character to use.
X`09SDATA (IEOLC) = MYEOLC + 32`09`09! Set end of line character.
X`09SDATA (IQCTL) = MYQCTL`09`09`09! Set control quote character.
X`09SDATA (IQBIN) = MYQBIN`09`09`09! Set eight bit quote character.
X`09SDATA (ICHKT) = MYCHKT`09`09`09! Set the packet check type.
X`09SDATA (IREPT) = MYREPT`09`09`09! Set the repeat character.
X`09SDATA (ICAPAS) = MYCAPAS + 32`09`09! Set extended capabilities.
X`09RETURN
X`09END
X`0C
X`09SUBROUTINE UNEXPECTED_STATE (MODULE, BSTATE)
XC
XC`09This routine is called whenever an unexpected state is found
XC`09to report the current state to the user.
XC
XC`09Inputs:
XC`09`09MODULE`09The module name.`09`09`09(By Descriptor)
XC`09`09BSTATE`09The bad state detected.`09`09`09(By Reference)
XC
XC`09Outputs:
XC`09`09None.
XC
X`09IMPLICIT NONE
X`09INCLUDE 'kermit_inc.for'
X
X`09CHARACTER*(*) MODULE
X`09BYTE BSTATE
X
X`09CHARACTER*(*) SS
X`09PARAMETER (SS = CHAR(13)//CHAR(10))`09! Single space.
X
X`09CALL WRITE_USER (SS//
X`091`09'*** Unexpected state in module "'//MODULE//'", state = '//
X`092`09CHAR(BSTATE)//' ***'//SS)
X`09RETURN
X`09END
X`0C
X`09subroutine read_mail(mess,irec,status,nostop,next_mess)
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS subroutines
Xc`09This routine will read a message, display it on the screen,
Xc`09and then give the user a menu of options.
Xc
Xc`09Dale Miller - UALR
Xc
Xc
Xc`09Rev. 3.5  19-Jun-1986
Xc`09Rev. 4.5  29-Aug-1986
Xc`09Rev. 4.7  29-Nov-1986
Xc`09Rev. 5.5  19-Jan-1988
Xc`09Rev. 5.6  04-Mar-1988
Xc`09Rev. 6.1  08-Jun-1988
Xc`09Rev. 7.0  29-Aug-1988
Xc`09Rev. 7.3  20-Jan-1989
Xc`09Rev. 7.4  24-jul-1989
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for/nolist'
X`09include 'sys$library:foriosdef/nolist'
X
X`09external     bbs_get_input,bbs_put_output
X
X`09character    line*80,pm*14/' ** private **'/,xxx*4
X`09character    cdummy*1,zmail_to*30,zmail_from*30
X`09character    snum*6,qmail_to*30,yesno*3,string*30,lms*9
X`09character    zfirst_name*20,zlast_name*20,defcmd*1
X`09logical*1    flag,reprint,found,nostop,busy
X`09byte         dummyb
X        integer      status,err,next_mess,irec,mess,zz,istat
X`09integer      dummy1,dummy2,dummy3,ii,x,dummy,kstatus,spc
X        integer      hold_messnum,qq,jj
X`09integer      str$upcase,str$trim,sys$asctim,lbr$output_help
X`09integer      lib$wait
X
X`09record /userlog_structure/ zur
X
X`09record /mail_header_structure/ mh
X
X 1001`09format(a)
X 1011`09format(i<dummy>)
X 1013`09format(a,i2,'>')
X 1015`09format(a,i2,1x,a)
X 1019`09format(a,'Section #',i1,' - ',a)
X`09status=0
X`09err=0
X
Xc`09Step 1.  Get in the general area of the message
X`09found=.false.
X`09next_mess=0
X`09
X`09do while(.not.found)
X`09    irec=irec+20
X`09    if(irec.gt.last_header) found=.true.
X`09    read(2,rec=irec,iostat=ios)mh
X`09    if(ios.eq.for$ios_errdurrea) found = .true.
X`09    unlock(unit=2)
X`09    if(mh.mail_messnum.ge.mess) found=.true.
X`09    end do
X`09irec=irec-20
X
Xc`09We are now within 20 reads of the message
X
X`09found=.false.
X`09do while(.not.found)
X`09    if(irec.gt.last_header) found=.true.
X`09    read(2,rec=irec,iostat=ios,err=90600) mh
X`09    unlock(unit=2)
X`09    if(mh.mail_messnum.ge.mess) then
X`09`09found=.true.
X`09    else
X`09`09irec=irec+1
X`09    end if
X`09    end do
X`09if(mh.mail_messnum.gt.mess) then
X`09    next_mess=mh.mail_messnum
X`09    irec=irec-1
X`09    go to 20000
X`09    end if
X`09if(mh.mail_deleted.and.(.not.sysop)) go to 20000
X`09zz=mh.mail_section
X`09dummyb=2**zz
X`09istat=str$upcase(zmail_to,mh.mail_to)
X`09istat=str$upcase(zmail_from,mh.mail_from)
X
X`09if((zmail_to.ne.mail_name).and.
X`091   ((dummyb.and.ur.auth_sections).eq.0)) go to 20000
X
X`09if(mh.mail_messnum.eq.mess.and.mh.mail_private) then
X`09    if((mail_name.ne.zmail_to).and.
X`091`09(mail_name.ne.zmail_from).and.(.not.sysop)) then
X`09`09go to 20000
X`09`09end if
X`09    end if
X`09if(mh.mail_messnum.eq.mess) then
X`09    status=-1`09`09`09`09`09! We read it
X`09    istat=str$trim(mh.mail_from,mh.mail_from,dummy1)
X`09    istat=str$trim(mh.mail_to,mh.mail_to,dummy2)
X`09    istat=str$trim(mh.mail_subject,mh.mail_subject,dummy3)
X`09    if(dummy1.lt.1.or.dummy1.gt.30) dummy1=30
X`09    if(dummy2.lt.1.or.dummy2.gt.30) dummy2=30
X`09    if(dummy3.lt.1.or.dummy3.gt.30) dummy3=30
X`09    xxx = '    '
X`09    write(6,1019)crlf(:cl)//ffeed(:fl),mh.mail_section,
X`091`09secnam(mh.mail_section+1)
X`09    call ctrl_o_check(*21000,*10580)
X`09    call comint(mh.mail_messnum,lms)
X`09    write(6,1001)crlf(:cl)//'Message number:'//lms//' on '//
X`091`09mh.mail_date//' at '//mh.mail_time
X`09    call ctrl_o_check(*21000,*10580)
X`09    if(mh.mail_read) xxx = ' (X)'
X`09    if(mh.mail_private) then
X`09`09write(6,1001)crlf(:cl)//
X`091`09    '   From: '//mh.mail_from(1:dummy1)//pm
X`09    else
X`09`09write(6,1001)crlf(:cl)//'   From: '//mh.mail_from(1:dummy1)
X`09    end if
X`09    call ctrl_o_check(*21000,*10580)
X`09    write(6,1001)crlf(:cl)//'     To: '//Mh.mail_to(1:dummy2)//xxx
X`09    call ctrl_o_check(*21000,*10580)
X`09    if(mh.mail_reply_to.eq.0) then
X`09`09write(6,1001)crlf(:cl)//'Subject: '//mh.mail_subject(1:dummy3)
X`09    else
X`09`09call comint(mh.mail_reply_to,lms)
X`09`09write(6,1001)crlf(:cl)//'Subject: #'//lms//'-'//
X`091`09    mh.mail_subject(1:dummy3)
X`09    end if
X`09    if((sysop2).and..not.mh.mail_person) then
X`09`09istat=sys$asctim(,string,mh.mail_expire,)
X`09`09write(6,1001)' -- Expires on: '//string(1:11)
X`09`09end if
X`09    call ctrl_o_check(*21000,*10580)
X`09    if(mh.mail_deleted) write(6,1001)crlf(:cl)//'**** deleted ****'
X`09    write(6,1001)crlf(:cl)
X`09    do ii=mh.mail_first,mh.mail_last
X`09`09read(3,rec=ii,iostat=ios)line
X`09`09unlock(unit=3)
X`09`09call ctrl_o_check(*21000,*10580)
X`09`09istat=str$trim(line,line,x)
X`09`09write(6,1001)crlf(:cl)//line(1:x)
X`09`09end do
X`09    write(6,1001)crlf(:cl)
X`09    end if
X`09if((mh.mail_messnum.eq.mess).and.(.not.mh.mail_read).and.
X`091    (zmail_to.eq.mail_name)) then
X`09    read(2,rec=irec,iostat=ios,err=90600) mh
X`09    mh.mail_read=.true.
X`09    write(2,rec=irec,err=90600,iostat=ios) mh
X`09    read(1,key=ur.user_key,iostat=ios,err=90500)ur
X`09    ur.num_unread=ur.num_unread-1
X`09    if(ur.num_unread.lt.0) ur.num_unread=0
X`09    if(mess.gt.ur.last_message.and.area.ne.'marked')
X`091`09ur.last_message=mess
X`09    rewrite(1,err=90500)ur
X`09    end if
X`09if (area.eq.'marked') go to 10580
X`09if(mess.gt.ur.last_message) then
X10540`09    read(1,key=ur.user_key,iostat=ios,err=90500)ur
X`09    if(area.ne.'marked')ur.last_message=mess
X`09    rewrite(1,err=90500,iostat=ios)ur
X`09    end if
X10580`09continue
X`09if(nostop.and.(zmail_to.ne.mail_name)) return
X10590`09continue
X`09if(zmail_to.eq.mail_name) then
X`09    defcmd='K'
X`09else
X`09    defcmd='C'
X`09endif
X
X10591`09continue
X`09if(reprint) then
X`09    reprint=.false.
X`09    write(6,1001)crlf(:cl)//'(C)ontinue     (E)nd'
X`09    write(6,1001)crlf(:cl)//'(H)elp         (K)ill'
X`09    write(6,1001)crlf(:cl)//'(N)ostop       (R)eply'
X`09    write(6,1001)crlf(:cl)//crlf(:cl)//'Command? `5B'//defcmd//'`5D'
X`09else
X`09    write(6,1001)crlf(:cl)//
X`091`09'Command (C,E,H,K,N,R,?)? `5B'//defcmd//'`5D '
X`09end if
X`09dummy=1
X`09call get_uplow_string(cdummy,dummy)
X`09istat=str$upcase(cdummy,cdummy)
X`09if(dummy.eq.0) cdummy=defcmd
X`09if(cdummy.eq.'C') go to 20000
X`09if(cdummy.eq.'E') go to 21000
X`09if(cdummy.eq.'H') go to 22000
X`09if(cdummy.eq.'K') go to 22500
X`09if(cdummy.eq.'N') go to 23000
X`09if(cdummy.eq.'P'.and.sysop2) go to 22700`09! Make message private
X`09if(cdummy.eq.'R') go to 24000
X`09if(cdummy.eq.'U'.and.sysop2) go to 22600`09`09! undelete message
X`09if(cdummy.eq.'?') then
X`09    reprint=.true.
X`09    go to 10591
X`09    end if
X
X`09write(6,1001)crlf(:cl)//'That was not a valid command'
X`09go to 10591
X
X20000`09continue`09`09!Continue
X`09return
X
X21000`09continue`09`09!Exit
X`09status=3
X`09return
X
X22000`09continue`09`09!Help
X`09controlc_typed=.false.
X`09istat=lbr$output_help(bbs_put_output,,
X`091   'bbs_help retrieve','ubbs_data:helplib',,bbs_get_input)
X`09go to 10591
X
X
X22500`09continue`09`09!Kill message
X`09call kill_mess (irec,kstatus)
X`09if(kstatus.eq.1) go to 90500
X`09if(kstatus.eq.2) go to 90600
X`09DEFCMD='C'
X`09go to 10591
X
X22600`09continue`09`09!Unkill message
X`09read(2,rec=irec,iostat=ios,err=90600) mh
X
X`09mh.mail_deleted=.false.
X`09write(2,rec=irec,iostat=ios,err=90600) mh
X`09write(6,1001)crlf(:cl)//'Message restored'
X`09go to 10591
X
X22700`09continue`09`09!Make message private
X`09read(2,rec=irec,iostat=ios,err=90600) mh
X`09mh.mail_private= .not. mh.mail_private
X`09write(2,rec=irec,err=90600,iostat=ios) mh
X`09if(mh.mail_private) then
X`09    write(6,1001)crlf(:cl)//'Message is now private'
X`09else
X`09    write(6,1001)crlf(:cl)//'Message is now public'
X`09end if
X`09go to 10591
X
X23000`09continue`09`09!Nostop
X`09nostop=.true.
X`09return
X
X24000`09continue`09`09!Reply
X`09if (.not.approved_mail_send) go to 10591
X`09mh.mail_person=.true.
X`09mh.mail_private=.false.
X`09zmail_to=mh.mail_from
X`09istat=str$upcase(qmail_to,zmail_to)
X`09spc=index(qmail_to,' ')
X`09zfirst_name=qmail_to(1:spc-1)
X`09do ii=spc+1,30
X`09    if(zmail_to(ii:ii).ne.' ') go to 3010
X`09    end do
Xc`09no last name found.
X`09write(6,1001)crlf(:cl)//'There seems to be some problem here'//
X`091    crlf(:cl)//'This person does not exist!'
X`09go to 10591
X3010`09zlast_name=qmail_to(ii:30)
X`09zur.user_key=zlast_name//zfirst_name
X`09dummy=0
X`09hold_messnum=mh.mail_messnum
X`09mh.mail_private=.false.
X`09write(6,1001)crlf(:cl)//'Is this a private message? `5Bno`5D'
X`09dummy=3
X`09call get_upcase_string(yesno,dummy)
X`09if(yesno(1:1).eq.'Y') mh.mail_private=.true.
X`09ii=20
X`09call enter_message(ii,*3040,0)
X`09mh.mail_read=.false.
X`09mh.mail_deleted=.false.
X`09mh.mail_to=zmail_to
X`09mh.mail_from=mail_name
X`09call modify_mail_info(mh,*3040)
X
X 3020`09read(2,rec=1,iostat=ios,err=90500)last_header, last_data,
X`091   first_mnum,last_mnum,busy
X`09if(busy) then
X`09    unlock(unit=2)
X`09    dummy=lib$wait(1.0)
X`09    go to 3020
X`09    end if
X`09last_header=last_header+1
X`09last_mnum=last_mnum+1
X`09write(2,rec=1)last_header,last_data+ii,first_mnum,last_mnum
X`09call date(mh.mail_date)
X`09call time(mh.mail_time)
X`09mh.mail_reply_to=mh.mail_messnum
X`09mh.mail_messnum=last_mnum
X`09mh.mail_first=last_data+1
X`09mh.mail_last=last_data+ii
X`09do qq=1,10
X`09    mh.mail_replys(qq)=0
X`09    end do
X
Xc`09write the header
X`09write(2,rec=last_header,err=90600,iostat=ios) mh
X
Xc`09and the message
X`09do jj=1,ii
X`09    write(3,rec=last_data+jj)message(jj)
X`09    end do
X
Xc`09now, set up for read thread
X`09read(2,rec=irec,iostat=ios,err=90600) mh
X`09qq=1
X`09do while(mh.mail_replys(qq).ne.0.and.qq.lt.11)
X`09    qq=qq+1
X`09    end do
X`09if(qq.le.10.and.mh.mail_replys(qq).eq.0) mh.mail_replys(qq)=last_mnum
X`09write(2,rec=irec,iostat=ios,err=90600) mh
X
Xc`09tell him about it
X`09call comint(last_mnum,lms)
X`09write(6,1001)crlf(:cl)//' Message number'//lms//
X`091   ' sent.'//bell//bell
X
Xc`09tell reciever he has mail
X`09if(.not.mh.mail_person) go to 10591
X
X`09read(1,key=zur.user_key,iostat=ios,err=10591)zur
X`09zur.num_unread = zur.num_unread+1
X`09rewrite(1,err=90500,iostat=ios)zur
X
X`09go to 10591`09`09`09!Ask him for another command
X
Xc`09Come here if he aborted reply to fix up header again.
X3040`09read(2,rec=irec,iostat=ios,err=90600) mh
X`09go to 10591
X
X90500`09status=1`09!error on userlog
X`09return
X
X90600`09status=2`09!error on message files
X`09return
X
X`09end
X
X`0C
X`09subroutine modify_mail_info (mh,*)
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS subroutines
Xc`09This routine will allow a user to change the parameters on a message
Xc`09before sending it.
Xc
Xc`09Dale Miller - UALR
Xc
Xc
Xc`09Rev. 5.6  04-Mar-1988
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for/nolist'
X`09include '($foriosdef)'
X
X`09character    cdummy*1,zmail_subject*30,zmail_to*30,qmail_to*30,yesno*3
X`09character    zlast_name*20,zfirst_name*20,pdummy*3,dummy_20*20
X`09character    string*20
X`09logical      dummyl
X`09real*8       right_now,rdummy,day_31
X`09integer      dummy,ii,namln,istat,spc,kk,sect,compquad
X`09integer      str$upcase,sys$gettim,sys$asctim,sys$bintim,str$trim
X
X`09record /userlog_structure/     zur
X`09record /mail_header_structure/ mh
X
X 1001`09format(a)
X 1011`09format(i1)
X 1020`09format(a,i1,' - ',a)
X
X`09istat = sys$bintim('18-DEC-1858 00:00:00',day_31)
X 0010`09write(6,1001)crlf(:cl)//
X`091   'Options: (S)end, (M)odify, (A)bort `5Bsend`5D?'
X`09dummy=1
X`09call get_upcase_string(cdummy,dummy)
X`09if(dummy.eq.0.or.cdummy.eq.'S') then
X`09    return
X`09else if(cdummy.eq.'A') then
X`09    write(6,1001)crlf(:cl)//'Message send aborted'
X`09    return 1
X`09else if(cdummy.ne.'M') then
X`09    write(6,1001)crlf(:cl)//bell//
X`091`09'Unrecognized option -- please try again'
X`09    go to 0010
Xc`09He has elected to change this message.  Step through the possibilities
X`09end if
X
X`09write(6,1001)crlf(:cl)//crlf(:cl)//'Message is to: `5B'//
X`091  mh.mail_to//'`5D'
X`09namln=30
X`09call get_uplow_string(zmail_to,namln)
X`09istat=str$upcase(qmail_to,zmail_to)
X`09if(namln.eq.0.or.zmail_to.eq.mh.mail_to) then
X`09    go to 0200`09`09`09`09! No change, that's easy.
X`09    end if
X`09mh.mail_to = zmail_to
X`09mh.mail_person = .true.`09`09`09! Assume an individual
X`09spc=index(qmail_to,' ')
X`09zfirst_name=qmail_to(1:spc-1)`09
X`09do ii=spc+1,30
X`09    if(zmail_to(ii:ii).ne.' ') go to 0110
X`09    end do
Xc`09No last name found.  This must be a public message
X`09mh.mail_person=.false.
X`09go to 0200`09!no need to check further
X
X 0110`09zlast_name=qmail_to(ii:30)
X`09zur.user_key=zlast_name//zfirst_name
X`09read(1,key=zur.user_key,iostat=ios)zur
X`09unlock(unit=1)
X`09if(ios.ne.0) mh.mail_person=.false.`09`09!Error on read
X
X 0200`09write(6,1001)crlf(:cl)//'      Subject: `5B'//mh.mail_subject//'`5D'
X`09dummy=20
X`09call get_uplow_string(zmail_subject,dummy)
X`09if(dummy.eq.0.or.zmail_subject.eq.mh.mail_subject) then
X`09    continue
X`09else
X`09    mh.mail_subject = zmail_subject
X`09end if
X`09if(.not.mh.mail_person) then
X 3031`09    continue
X`09    right_now = mh.mail_expire
X`09    istat=sys$asctim(,dummy_20,right_now,)
X`09    mh.mail_private=.false.
X`09    write(6,1001)crlf(:cl)//
X`091`09'What is the expiration date for this message? `5B'//
X`092`09dummy_20(:11)//'`5D'
X`09    dummy=11
X`09    call get_uplow_string(string,dummy)
X`09    istat=str$upcase(string,string)
X`09    if(dummy.eq.0) then
X`09`09mh.mail_expire=right_now
X`09    else
X`09`09istat=sys$bintim(string(:11)//' 00:00:00',mh.mail_expire)
X`09    end if
X`09    dummy=compquad(mh.mail_expire,right_now)
X`09    if(dummy.eq.-1) then
X`09`09write(6,1001)crlf(:cl)//
X`091`09    'That is not a valid date.  Dates must be of the'//
X`092`09    crlf(:cl)//'form dd-mmm-yyyy (e.g. 01-Jan-1986)'
X`09`09go to 3031
X`09    end if
X`09    call addquad(right_now,day_31,rdummy)
X`09    dummy=compquad(rdummy,mh.mail_expire)
X`09    if(dummy.eq.-1) then
X`09`09write(6,1001)crlf(:cl)//
X`091`09    'Your expiration date may be no more than 1 month in'//
X`092`09    crlf(:cl)//'the future.  Please try again'
X`09`09go to 3031
X`09    end if
X`09    istat=sys$asctim(,string,mh.mail_expire,)
X`09else
X`09    if(mh.mail_private) then
X`09`09pdummy='Yes'
X`09    else
X`09`09pdummy='No'
X`09    end if
X`09    write(6,1001)crlf(:cl)//'Is this a private message?'//
X`091`09' `5B'//pdummy//'`5D'
X`09    dummy=3
X`09    call get_upcase_string(yesno,dummy)
X`09    if(yesno(1:1).eq.'Y') mh.mail_private=.true.
X`09    if(yesno(1:1).eq.'N') mh.mail_private=.false.
X`09end if
X
X 3080`09sect=mh.mail_section
X`09istat = str$trim(secnam(sect+1),secnam(sect+1),dummy)
X`09write(6,1001)crlf(:cl)//'Section number? (enter 9 for list)'//
X`091   '`5B'//char(sect+48)//' - '//secnam(sect+1)(:dummy)//'`5D'
X`09dummy=1
X`09dummyl=.false.
X`09call get_number(string,dummy,dummyl)
X`09if(string.eq.'9') then
X`09    do kk=0,7
X`09`09call ctrl_o_check(*3080,*3080)
X`09`09write(6,1020)crlf(:cl),kk,secnam(kk+1)
X`09`09end do
X`09    go to 3080
X`09else if (dummy.eq.0) then
X`09    go to 0010
X`09    end if
X`09read(string,1011)sect
X`09if(sect.gt.7) then
X`09    write(6,1001)crlf(:cl)//'Invalid section number'
X`09    go to 3080
X`09    end if
X`09mh.mail_section=sect
X`09go to 0010
X
X 0300`09continue
X`09return
X`09end
X`0C
X`09subroutine ubbs_files_section
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS subroutines
Xc`09This routine handles all of the UBBS file transfer.
Xc`09Dale Miller - UALR
Xc
Xc
Xc`09Rev. 3.5  19-Jun-1986
Xc`09Rev. 3.6  24-Jun-1986
Xc`09Rev. 4.0  27-Jun-1986
Xc`09Rev. 4.1  07-Jul-1986
Xc`09Rev. 4.2  20-Jul-1986
Xc       Rev. 4.6  09-Nov-1986
Xc`09Rev. 4.7  29-Nov-1986
Xc`09Rev. 4.10 11-Feb-1987
Xc`09Rev. 4.13 04-Jul-1987
Xc`09Rev. 4.14 12-Sep-1987
Xc`09Rev. 5.5  05-Jan-1988
Xc`09Rev. 5.6  03-Mar-1988
Xc`09Rev. 6.0  06-Jun-1988
Xc`09Rev. 6.1  08-Jun-1988
Xc`09Rev. 6.3  23-Aug-1988
Xc`09Rev. 7.0  29-Aug-1988
Xc`09Rev. 7.1  19-Sep-1988
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for/nolist'
X`09include 'sys$library:foriosdef/nolist'
X`09include '($rmsdef)'
X`09character cdummy*1,darea*3
X`09character filename*50,filnam*80,disk*4,line*200,ftyp*7
X`09character binasc*4,zfilnam*20,term*5,cdate*9,types*1,cdate2*11
X`09character space*30/'                    '/
X`09logical*1 reprint,dummyl
X`09integer i,istat,per,spc,length,flen
X`09integer dummy,dummy1,dummy2
X`09integer get_xmodem,send_xmodem,find_file,find_next
X`09integer kermit_send,kermit_receive
X`09integer fsize,rev_date(2),back_date(2)
X`09logical get_vaxfile
X`09integer lib$delete_file,str$trim,lib$find_file
X`09integer lbr$output_help,str$upcase,sys$gettim
X`09external getsize,bbs_put_output,bbs_get_input,uopen
X
X`09record /userlog_structure/ zur
X`09record/file_description/ fd
X
X`09common/filesize/fsize,rev_date,back_date
X
X 1001`09format(a)
X 1003`09format(q,a)
X 1004`09format('$!',a3,'=',a18,i3,1x,a)
X 1019`09format(a1,'file_',i6.6,'.dat')
X 1024   format(i5.5)
X
X`09ldesc.dsc$w_maxstrlen = buffer_size
X`09ldesc.dsc$a_pointer   = %loc(lbuffer)
X`09rdesc.dsc$w_maxstrlen = buffer_size
X`09rdesc.dsc$a_pointer   = %loc(rbuffer)
X`09xdesc.dsc$w_maxstrlen = buffer_size
X`09xdesc.dsc$a_pointer   = %loc(xbuffer)
X
X
Xc`09Start the whole thing off
X 4000`09continue
X`09call date(cdate)
X`09write(6,1001)crlf(:cl)//
X`091   '(D)ownload, (U)pload, (H)elp or (E)xit? `5Bexit`5D '
X`09dummy=1
X`09call get_upcase_string(cdummy,dummy)
X`09if(cdummy.eq.'E'.or.dummy.eq.0) go to 4900
X`09if(cdummy.eq.'D') go to 4100
X`09if(cdummy.eq.'U') go to 4700
X`09if(cdummy.eq.'H') then
X`09    controlc_typed=.false.
X`09    istat=lbr$output_help(bbs_put_output,,
X`091`09'bbs_help file_transfer','ubbs_data:helplib',,bbs_get_input)
X`09    go to 4000
X`09    end if
X`09write(6,1001)crlf(:cl)//'Invalid selection.  Please try again.'
X`09go to 4000
X
X 4100`09continue`09`09!Download
X`09area='download'
X`09if (.not.approved_file_down) then
X`09    write(6,1001)crlf(:cl)//bell//
X`091`09'You are not yet approved for the download section.'
X`09    write(6,1001)crlf(:cl)//'Sorry.'
X`09    return
X`09    end if
X`09flow=to_remote
X`09if(reprint.or.(.not.ur.xpert)) then
X`09    reprint=.false.
X`09    call type_file('ubbs_files:`5B000000`5Ddownload.areas')
X 4101`09    write(6,1001)crlf(:cl)//crlf(:cl)//
X`091`09'Enter area of interest? `5Bexit`5D'
X`09else
X`09    write(6,1001)crlf(:cl)//'Area? '
X`09end if
X`09dummy=3`09    `09   `20
X`09call get_uplow_string(darea,dummy)
X`09istat = str$upcase(darea,darea)
X`09if(dummy.eq.0.or.darea.eq.'EXI') go to 4900
X`09if(darea.eq.'?') then
X`09    reprint=.true.
X`09    go to 4100
X`09    end if
X`09dummy=0
X`09if (lib$find_file('ubbs_files:`5B'//darea//'`5Dallow.down',
X`091   filename,dummy).ne.rms$_normal) then
X`09    write(6,1001)crlf(:cl)//
X`091`09'That is not a valid area.  Please try again'
X`09    reprint=.true.
X`09    go to 4100
X`09    end if
Xc`09Offer to print the SYSOP bulletin, if it exists
X`09filnam = 'ubbs_files:`5B'//darea//'.asc`5Dsysop.bulletin'
X`09open(unit=4,file=filnam,status='old',readonly,
X`091   useropen=getsize,iostat=istat)
X
X`09if(istat.eq.0)then
X`09    call sys$asctim(,cdate2,rev_date,)
X`09    cdate2(5:5) = char(ichar(cdate2(5:5))+32)
X`09    cdate2(6:6) = char(ichar(cdate2(6:6))+32)
X`09    write(6,1001)crlf(:cl)//crlf(:cl)//
X`091`09'View FILE SYSOP bulletin - Rev. '//
X`092`09cdate2//'? `5Bno`5D'
X`09    dummy=1
X`09    call get_upcase_string(cdummy,dummy)
X`09    if(cdummy.eq.'Y') then
X`09`09call type_file(filnam)
X`09`09end if
X`09else
X`09    write(6,1001)crlf(:cl)//crlf(:cl)//
X`091`09'No FILE SYSOP bulletin today - please press <return>'
X`09    dummy=1
X`09    call get_upcase_string(cdummy,dummy)
X`09    end if
X
X 4150`09continue
Xc!`09Process users group areas separately
Xc!`09if(darea.eq.'CUG') goto 4160
X`09write(6,1001)crlf(:cl)//crlf(:cl)//
X`091'Enter name of file to download, ? for list, ?? to search,'
X`09write(6,1001)crlf(:cl)//'or <cr> to exit. '
X`09dummy=30
X`09call get_uplow_string(filename,dummy)
X`09istat=str$upcase(filename,filename)
X`09if(dummy.eq.0) go to 4900
X`09if(filename.eq.'?') then
X`09    call listcat(darea)
X`09    go to 4150`09   `20
X`09    end if
X`09if(filename.eq.'??') then
X`09    call searchcat(darea)
X`09    go to 4150`09   `20
X`09    end if
X`09if(filename.eq.'ABC.XYZ') go to 5000
X`09per=index(filename,'.')
X`09if(per.eq.0) then
X`09    spc=index(filename,' ')
X`09    filename(spc:spc)='.'
X`09    end if
X`09file_type=ascii`09`09`09!make assumption
X`09filnam='ubbs_files:`5B'//darea//'.asc`5D'//filename
X`09dummyl=get_vaxfile(filnam)
X`09if(dummyl) go to 4170
X`09file_type=binary`09`09!wrong assumption, try again
X`09filnam='ubbs_files:`5B'//darea//'.bin`5D'//filename
X`09dummyl=get_vaxfile(filnam)
X`09if(dummyl) go to 4170
Xc`09See if it is archived
X`09open(unit=4,`09`09shared,
X`091   file='ubbs_files:`5B'//darea//'`5Dfiles.idx',
X`092   status='old',`09organization='indexed',
X`093   access='keyed',`09form='unformatted',
X`094   recl=192,`09`09recordtype='variable',
X`095`09`09`09key=(1:18:character),
X`096   useropen=uopen)
X
X`09fd.file_name=filename
X`09istat=str$trim(fd.file_name,fd.file_name,dummy)
X`09if(fd.file_name(dummy:dummy).eq.'.') fd.file_name(dummy:dummy)=' '
X`09read(4,key=fd.file_name,iostat=ios)fd
X`09close(unit=4)
X`09if(fd.archived.and.(ios.eq.0)) then
X`09    write(6,1001)crlf(:cl)//'That file is currently stored off-line.'
X`09    write(6,1001)crlf(:cl)//'Files are restored each weeknight at'//
X`091`09' midnight.'
X`09    write(6,1001)crlf(:cl)//crlf(:cl)//
X`091`09'Do you wish to request a restore? `5BNo`5D'
X`09    dummy=1
X`09    call get_upcase_string(cdummy,dummy)
X
X`09    if(cdummy.eq.'Y') then
X`09`09open(unit=4,file='ubbs_data:to_restore.dat',
X`091`09    shared,access='append',carriagecontrol='list',
X`092`09    status='unknown')
X`09`09if(fd.file_type.eq.'A'.or.fd.file_type.eq.'U') then
X`09`09    write(4,1001)'`5B'//darea//'.ASC`5D'//filename
X`09`09else
X`09`09    write(4,1001)'`5B'//darea//'.BIN`5D'//filename
X`09`09end if
X`09`09close(unit=4)
X`09`09end if
X
X`09    go to 4150
X`09    end if
X`09write(6,1001)crlf(:cl)//bell//
X`091   'That is not a valid filename.  Try again.'
X`09go to 4150
X
X 4170`09if(file_type.eq.binary) then
X`09    protocol=asciid
X`09    write(6,1001)crlf(:cl)//'Binary files must be transferred via'
X`09    write(6,1001)crlf(:cl)//'Xmodem, Ymodem or Kermit'
X`09    protocol=unknown
X`09    do while(protocol.eq.unknown)
X`09`09write(6,1001)crlf(:cl)//
X`091`09    '(K)ermit (X)modem or (Y)modem transfer `5Bexit`5D'
X`09`09dummy=1
X`09`09call get_upcase_string(cdummy,dummy)
X`09`09if(dummy.eq.0.or.cdummy.eq.'E') go to 4150
X`09`09if(cdummy.eq.'K') protocol=kermit
X`09`09if(cdummy.eq.'X') protocol=xmodem
X`09`09if(cdummy.eq.'Y') protocol=ymodem
X`09`09end do
X`09else
X`09    protocol=unknown
X`09    do while(protocol.eq.unknown)
X`09`09write(6,1001)crlf(:cl)//
X`091`09    '(A)scii, (K)ermit (X)modem or (Y)modem transfer? `5Bexit`5D'
X`09`09dummy=1
X`09`09call get_upcase_string(cdummy,dummy)
X`09`09if(dummy.eq.0.or.cdummy.eq.'E') go to 4150
X`09`09if(cdummy.eq.'A') protocol=asciid
X`09`09if(cdummy.eq.'K') protocol=kermit
X`09`09if(cdummy.eq.'X') protocol=xmodem
X`09`09if(cdummy.eq.'Y') protocol=ymodem
X`09`09end do
X`09    end if
X
Xc
Xc`09File is open, protocol is selected.  Do it to it.
Xc
Xc! 4177`09continue
X`09if (protocol.eq.xmodem .or. protocol.eq.ymodem) then
X`09    call clear_counts()
X`09    timeout_count=10
X`09    retry_limit=5
X`09    bitmask=eightbit_mask
X`09    write(6,1001)crlf(:cl)//
X`091`09'Beginning Xmodem/Ymodem download -- Ctrl-x to abort.'
X`09    call init_timer(file_timer)
X`09    dummyl=send_xmodem()
X`09    bitmask=sevenbit_mask
X`09    call waitabit('10')
X`09    call elapsed_time(file_timer)`09!Display elapsed time
X`09    call report_totals()`09`09!Report final stats
X`09else if(protocol.eq.kermit) then
X`09    call clear_counts()
X`09    call default_parameters()
X`09    timeout_count=10
X`09    retry_limit=5
X`09    write(6,1001)crlf(:cl)//
X`091`09'Beginning Kermit download.'
X`09    call waitabit('2')
X`09    remote_file = filename
X`09    call init_timer(file_timer)
X`09    dummyl = kermit_send(ldesc, rbuffer, xbuffer)
X`09    call waitabit('10')
X`09    call elapsed_time(file_timer)`09!Display elapsed time
X`09    call report_totals()`09`09!Report final stats
X`09else`09`09!ascii dump
X`09    write(6,1001)crlf(:cl)//'Control-c to abort download'
X`09    write(6,1001)crlf(:cl)//'Open your capture buffer now.'
X`09    call waitabit('10')
X`09    call init_timer(file_timer)
X`09    dummyl = .false.
X`09    read(file_unit,1003,iostat=ios)length,line
X`09    do while(ios.eq.0)
X`09`09call out(line(1:length),*4200)
X`09`09read(file_unit,1003,iostat=ios)length,line
X`09`09end do
X`09    dummyl = .true.
X 4200`09    close (unit=file_unit)
X`09    call waitabit('10')
X`09    call elapsed_time(file_timer)
X`09end if
X
X`09if(dummyl) then
X`09    write(6,1001)crlf(:cl)//'Successful transfer'
X`09    ur.down_files=ur.down_files+1
X`09    read(1,key=ur.user_key)zur
X`09    rewrite(1,err=4150)ur
X
Xc`09Update the directory entry for this file.
X
X`09    open(unit=4,`09`09shared,
X`091   file='ubbs_files:`5B'//darea//'`5Dfiles.idx',
X`092   status='old',`09organization='indexed',
X`093   access='keyed',`09form='unformatted',
X`094   recl=192,`09`09recordtype='variable',
X`095`09`09`09key=(1:18:character),
X`096   useropen=uopen)
X
X`09    fd.file_name=filename
X`09    istat=str$trim(fd.file_name,fd.file_name,dummy)
X`09    if(fd.file_name(dummy:dummy).eq.'.') fd.file_name(dummy:dummy)=' '
X
X`09    read(4,key=fd.file_name,iostat=ios)fd
X
X`09    fd.times_down=fd.times_down+1
X`09    call sys$gettim(fd.download_date)
X
X`09    rewrite(4,iostat=ios)fd
X`09
X`09    close(unit=4)
X`09else
X`09    write(6,1001)crlf(:cl)//'Transfer failed.'//bell
X`09end if
X`09go to 4150
X
X
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vccc
X
X 4700`09continue`09`09!Upload
X`09area='upload'
X`09if (.not.approved_file_up) then
X`09    write(6,1001)crlf(:cl)//bell//
X`091`09'You are not yet approved for the upload section.'
X`09    write(6,1001)crlf(:cl)//'Sorry.'
X`09    return
X`09    end if
X`09if(reprint.or.(.not.ur.xpert)) then
X`09    reprint=.false.
X`09    call type_file('ubbs_files:`5B000000`5Dupload.areas')
X 4701`09    write(6,1001)crlf(:cl)//'Enter area of interest? `5Bexit`5D'
X`09else
X`09    write(6,1001)crlf(:cl)//'Area? '
X`09end if
X`09dummy=3`09    `09   `20
X`09call get_uplow_string(darea,dummy)
X`09istat = str$upcase(darea,darea)
X`09if(dummy.eq.0.or.darea.eq.'EXI') go to 4900
X`09if(darea.eq.'?') then
X`09    reprint=.true.
X`09    go to 4700
X`09    end if
X
X`09dummy=0
X`09if (lib$find_file('ubbs_files:`5B'//darea//'`5Dallow.up',
X`091   filename,dummy).ne.rms$_normal) then
X`09    write(6,1001)crlf(:cl)//
X`091`09'That is not a valid area.  Please try again'
X`09    reprint=.true.
X`09    go to 4700
X`09    end if
X`09write(6,1001)crlf(:cl)//'(A)scii, (B)inary, (H)elp, (E)xit? `5Bexit`5D'
X`09dummy=1
X`09call get_upcase_string(cdummy,dummy)
X`09if (cdummy.eq.'E'.or.dummy.eq.0) go to 4900
X`09if (cdummy.eq.'A') then
X`09    file_type = ascii
X`09    ftyp='Ascii '
X`09    fd.file_type='U'
X`09    binasc='.asc'
X`09else if (cdummy.eq.'B') then
X`09    file_type=binary
X`09    fd.file_type='V'
X`09    ftyp='Binary'
X`09    binasc='.bin'
X`09else if (cdummy.eq.'H') then
X`09    controlc_typed=.false.
X`09    istat=lbr$output_help(bbs_put_output,,
X`091`09'bbs_help file','ubbs_data:helplib',,bbs_get_input)
X`09    go to 4700
X`09else
X`09    write(6,1001)crlf(:cl)//'Invalid selection. Please try again'
X`09    go to 4700
X`09end if
X
X`09if(file_type.eq.binary) then
X`09    protocol=unknown
X`09    do while(protocol.eq.unknown)
X`09`09write(6,1001)crlf(:cl)//'Binary transfers must be by Xmodem,'
X`09`09write(6,1001)crlf(:cl)//'Ymodem or Kermit protocol.'
X`09`09write(6,1001)crlf(:cl)//
X`091`09    '(K)ermit or (X)modem/Ymodem protocol? `5Bexit`5D '
X`09`09dummy=1
X`09`09call get_upcase_string(cdummy,dummy)
X`09`09if(cdummy.eq.'E'.or.dummy.eq.0) go to 4900
X`09`09if(cdummy.eq.'K') protocol=kermit
+-+-+-+-+-+-+-+-  END  OF PART 8 +-+-+-+-+-+-+-+-