🚀 go-pugleaf

Submitted-by: munroe@dmc.com (Dick Munroe)
Posting-number: Volume 3, Issue 113
Archive-name: ubbs/part05
-+-+-+-+-+-+-+-+ START OF PART 5 -+-+-+-+-+-+-+-+
X`09`09istat=str$upcase(mail_name,mail_name)
X`09`09fd.upload_text(31:60)=mail_name
X`09`09done=.false.
X`09`09end if
X`09    end do
X`09rewrite(unit=4)fd
X`09close(unit=4)
X`09return
X 1003`09format(q,a)
X`09end
X`0C
X`09subroutine archive_files
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS subroutines - ARCHIVE_FILES
Xc`09This routine reads all of the FILES.IDX files and deletes and sets
Xc`09the ARCHIVED flag for all those which have not been accessed since a
Xc`09Specified date.
Xc`09Dale Miller - UALR
Xc
Xc`09Rev. 7.1  19-Sep-1988
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for'
X`09include '($rmsdef)'
X`09include 'sys$library:foriosdef.for/nolist'
X`09character filnam1*100,filnam2*100,darea*3,tempfile*50,dsp*1
X`09character*30 my_date,time
X`09integer*4 long_ago(2)
X`09integer d1,d2,dummy,istat,fc1,fc2,du1,du2,i,length
X`09integer lib$find_file,lib$delete_file
X`09integer fsize,rev_date(2),back_date(2),total_size
X`09integer str$trim,str$upcase,sys$gettim,compquad
X`09integer sys$bintim,sys$asctim
X`09external uopen,getsize
X
X`09common/filesize/ fsize,rev_date,back_date
X`09record/file_description/ fd
X
X 0009`09print*,'Enter date of interest (dd-mmm-yyyy)'
X`09read(5,1001)my_date
X 1001`09format(a)
X`09istat=str$upcase(my_date,my_date)
X `09my_date=my_date(:11)//' 00:00:00.00'
X`09istat = sys$bintim(my_date,long_ago)
X`09istat = sys$asctim(length,time,long_ago,)
X`09print*,'Date is:'//time(:length)//'.  Is this correct?'
X`09read(5,1001)dsp
X`09istat=str$upcase(dsp,dsp)
X`09if(dsp.ne.'Y') go to 9
X
X`09filnam1='ubbs_files:`5B000000`5D*.dir;*'
X`09call str$trim(filnam1,filnam1,dummy)
X`09fc1=0
X`09total_size = 0
X`09tempfile=filnam1
X`09istat=rms$_nmf
X`09istat=lib$find_file(tempfile,filnam1,fc1)
X`09do while (istat.ne.rms$_nmf)
X`09    d1=1
X`09    do while(d1.ne.0)
X`09`09d1=index(filnam1,'`5D')
X`09`09filnam1=filnam1(d1+1:)
X`09`09end do
X`09    d2=index(filnam1,'.')-1
X`09    darea=filnam1(:d2)
X`09    write(6,*)' AF - Beginning '//darea
Xc
Xc Get the index file.
Xc
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=char(0)
X`09read(4,keygt=fd.file_name,iostat=ios)fd
X`09do while(ios.ne.for$ios_attaccnon)
X`09    if(fd.file_name.eq.'$Header') go to 8888
X`09    if(fd.archived) go to 8888
X
X`09    dummy = compquad(long_ago,fd.download_date)
X`09    if(dummy.eq.1) then
Xc`09`09Check to make sure it has been backed up.
X`09`09if(fd.file_type.eq.'A'.or.fd.file_type.eq.'U') then
X`09`09    filnam2='ubbs_files:`5B'//darea//'.ASC`5D'//fd.file_name
X`09`09else
X`09`09    filnam2='ubbs_files:`5B'//darea//'.BIN`5D'//fd.file_name
X`09`09end if
X`09`09if(index(fd.file_name,'.').eq.0) then
X`09`09    call str$trim(filnam2,filnam2,dummy)
X`09`09    filnam2(dummy+1:dummy+1)='.'
X`09`09    end if
X`09`09open(unit=17,file=filnam2,status='old',readonly,
X`091`09    useropen=getsize)
X`09`09close(unit=17)
X`09`09dummy = compquad(back_date,rev_date)
X`09`09if(dummy.ne.1) then
X`09`09    print*,'File has not been backed up, archiving '//
X`091`09`09'not possible:'//darea//' '//fd.file_name
X`09`09    go to 8888
X`09`09    end if
X`09`09print*,'Deleting '//fd.file_name//' Size=',fd.file_size
X`09`09total_size = total_size + fd.file_size
X`09`09istat=lib$delete_file(filnam2)
X`09`09fd.archived = .true.
X`09`09rewrite(unit=4) fd
X`09`09end if
X
X
X 8888`09    read(4,keygt=fd.file_name,iostat=ios)fd
X`09    end do
X`09    close(unit=4)
X
Xc`09Now, go on to the next directory.
X`09    istat=lib$find_file(tempfile,filnam1,fc1)
X`09    end do
X`09print*,'Total size of deleted files=',total_size
X`09stop
X`09end
$ CALL UNPACK SYSOP.FOR;168 425261894
$ create 'f'
X`09subroutine cancel_io
XC
XC`09This routine is used to cancel the local I/O.
XC
XC`09The status return from the SYS$CANCEL's are not checked
XC`09since this routine is called from the error routine.
XC
X`09implicit none
X`09include 'bbs_inc.for'
X`09integer status
X`09integer sys$cancel
XC
XC`09Cancel the local I/O (if any).
XC
X`09status = sys$cancel(%val(lchan_in))
X`09status = sys$cancel(%val(lchan_out))
X`09call check_status('cancel_local',status)
X`09return
X`09end
X`0C
X`09subroutine wake_up
XC
XC`09Subroutine to wake up hibernate state.
XC
X`09implicit none
X`09integer*4 status, sys$wake, check_status
X
X`09status = sys$wake(,)`09! Wake us up.
X`09call check_status('wake_up',status)
X`09return
X`09end
X`0C
X`09subroutine init_timer(timer_pointer)
XC
XC`09The subroutine simply calls LIB$INIT_TIMER.
XC
X`09implicit none
X
X`09integer status, lib$init_timer, timer_pointer
X
X`09status = lib$init_timer(timer_pointer)
X`09call check_status('init_timer',status)
X`09return
X`09end
X`0C
X`09subroutine elapsed_time(timer_pointer)
XC
XC`09This routine is called at the end of file transmission to output
XC`09the elapsed time.  The LIB$INIT_TIMER must have been called previous
XC`09to calling this routine.
XC
X`09implicit none
X`09integer*4 timer_pointer
X
X`09external write_elapsed
X
X`09call lib$show_timer(timer_pointer,,write_elapsed,)
X`09return
X`09end
X`0C
X`09subroutine write_elapsed (time)
XC
XC`09This routine is used to write the elapsed time.
XC
X`09implicit integer*4 (a-z)
X`09INCLUDE 'BBS_INC.FOR/NOLIST'
X
X`09CHARACTER*(*) TIME
X`09INTEGER TIME_SIZE, INDEX
X
X`09TIME_SIZE = LEN(TIME)`09`09`09! Get the time string size.
X`09TIME_SIZE = INDEX (TIME, '  BUFIO:')
X`09CALL WRITE_USER('***'//TIME(1:TIME_SIZE)//'***'//crlf(:cl))
X`09RETURN
X`09END
X`0C
X`09INTEGER FUNCTION CHECK_STATUS(FACILITY_NAME,STATUS_CODE)
XC
XC`09Subroutine to check status from a System Service.
XC
XC`09Inputs:
XC`09`09FACILITY_NAME - Subroutine name.
XC`09`09STATUS_CODE - Status code.
XC
XC`09Outputs:
XC`09`09Returns the status code passed in.
XC
X`09implicit integer*4 (a-z)
X`09INCLUDE 'BBS_INC.FOR/NOLIST'
XC
XC`09Setup the error message.
XC
X`09CHARACTER*(*) FACILITY_NAME, ERROR_MESSAGE
X`09PARAMETER (ERROR_MESSAGE = ss//
X`091 '*** VAXNET Terminated with ERROR ***'//BELL//ss)
X`09CHARACTER*80 MESS_TXT
X`09INTEGER*4 STATUS_CODE
X
X`09CHECK_STATUS = STATUS_CODE`09! Pass back the status code.
X
X`09IF (STATUS_CODE .EQ. SS$_NORMAL) RETURN
XC
XC`09If the error is exceeded quota (probably buffered I/O quota),
XC`09cancel the outstanding I/O so the write of the error message
XC`09will complete successfully.
XC
X`09IF (STATUS_CODE .EQ. SS$_EXQUOTA) THEN
X`09`09CALL CANCEL_IO()`09! Cancel the outstanding I/O.
X`09ENDIF
XC
XC`09Report error message to the terminal.
XC
XC`09Set flags for GETMSG for:
XC`09`09- Include text of message.
XC`09`09- Include message identifier.
XC`09`09- Include severity indicator.
XC`09`09- Do not include facility name.
XC
X`09FLAGS = "7`09`09`09! Set up the flags.
X`09CALL SYS$GETMSG(%VAL(STATUS_CODE),MSGLEN,MESS_TXT,%VAL(FLAGS),)
XC
X`09write(6,*)crlf(:cl)//'%'//facility_name//'-'//mess_txt(2:msglen)
X`091   //bell//crlf(:cl)
XC
XC`09If the modem hangs up, show it was hungup, and insure a file
XC`09transfer (if any) gets aborted.
XC
X`09IF (STATUS_CODE .EQ. SS$_HANGUP) THEN
X`09`09CONTROLC_TYPED = .TRUE.`09! Set flag to abort transmission.
X`09ENDIF
X`09CALL HANGUP_MODEM()`09`09! Make sure modem is hungup.
X`09CALL SYS$EXIT(%VAL(STATUS_CODE)) ! Exit with the status code.
X`09END
X`0C
X`09LOGICAL FUNCTION GET_VAXFILE(FILE)
XC
XC`09This function is used to get the file name of the file
XC`09on the VAX and then open it for either read or write.
XC
XC`09Inputs:
XC`09`09FILE - string descriptor with the file name (if any).
XC
X`09implicit integer*4 (a-z)
X`09INCLUDE 'BBS_INC.FOR/NOLIST'
X`09INCLUDE '($RMSDEF)/NOLIST'
X
X
X`09CHARACTER*(*) FILE, MODULE_NAME
X
X`09character cc*4
X`09PARAMETER (MODULE_NAME = 'GET_VAXFILE')
X
X`09GET_VAXFILE = .FALSE.`09`09! Initialize to bad return.
XC
XC`09If we were passed a file name, use it.
XC
X`09VAX_FILE = FILE`09`09! Copy the file name
X`09VSIZE = LEN(FILE)`09!    and the file size.
XC
XC`09Sending a file to the remote.
XC
XC`09Vaxnet> SEND vax_file remote_file
XC
X200`09IF (FLOW .EQ. TO_VAX) GO TO 500`09`09! Send a file to the VAX.
XC
XC
XC`09Open the file for read.
XC
X400`09OPEN (UNIT=FILE_UNIT, TYPE='OLD', READONLY, SHARED,
X`091`09`09`09FILE=VAX_FILE(1:VSIZE), ERR=9900)
X`09GET_VAXFILE = .TRUE.`09`09`09! Return success.
X`09RETURN
XC
XC`09Getting a file from the REMOTE.
XC
XC`09Vaxnet> GET remote_file vax_file
XC
XC
XC`09Open the file for write.
XC
X500`09continue
X`09if (file_type.eq.binary) then
X`09    cc='none'
X`09else
X`09    cc='list'
X`09endif
X
X`09OPEN (UNIT=FILE_UNIT, TYPE='NEW', NAME=VAX_FILE(1:VSIZE),
X`091`09`09RECORDSIZE=OUT_SIZE, CARRIAGECONTROL=cc,
X`091`09`09BUFFERCOUNT=2, ERR=9900)
X`09GET_VAXFILE = .TRUE.`09`09`09! Return success.
X`09RETURN
X
X9900`09continue
Xc`09CALL RMS_ERROR (MODULE_NAME)`09`09! Report the RMS error.
X`09RETURN
X`09END
X`0C
X`09SUBROUTINE UPDATE_TOTALS (NBYTES)
XC
XC`09This routine is called after a record is successfully transmitted
XC`09to update the various counters.
XC
X`09implicit integer*4 (a-z)
X`09INCLUDE 'BBS_INC.FOR'
X`09include 'kermit_inc.for'
X
X`09RETRY_COUNT = 0`09`09`09`09! Reinitialize retry counter.
X`09BYTE_COUNT = BYTE_COUNT + NBYTES`09! Accumulate the byte count
X`09RECORD_COUNT = RECORD_COUNT + 1`09`09!`09and the record count.
X`09TOTAL_BYTES = TOTAL_BYTES + NBYTES`09! Update the total byte count.
X`09TOTAL_RECORDS = TOTAL_RECORDS + 1`09!`09and the record count.
X`09RETURN
X
X`09ENTRY CLEAR_COUNTS
XC
XC`09Entry to initialize counts.
XC
X`09BYTE_COUNT = 0`09`09`09`09! Clear byte count.
X`09RECORD_COUNT = 0`09`09`09! Clear record count.
X`09TOTAL_BYTES = 0`09`09`09`09! Clear total bytes.
X`09TOTAL_RECORDS = 0`09`09`09! Clear total records.
X`09ERROR_COUNT = 0`09`09`09`09! Clear error count.
X`09ERROR_RECORD = 0`09`09`09! Clear error record #.
X`09PARITY_ERRORS = 0`09`09`09! Initialize
X`09OVERRUN_ERRORS = 0`09`09`09!      the
X`09TIMEOUTS = 0`09`09`09`09!        various
X`09FRAMING_ERRORS = 0`09`09`09!          counters.
X`09RETRY_COUNT = 0`09`09`09`09!          `20
X`09FILE_COUNT = 0`09`09`09`09! Number of file transfered.
X`09BLOCK_COUNT = 0`09`09`09`09! Number of blocks transfered.
X`09BLOCK_RECEIVED = 0`09`09`09! Received block number.
X`09BLOCK_XMITTED = 0`09`09`09! Transmitted block number.
X`09PACKET_COUNT = 0`09`09`09! Number of data packets.
X`09TOTAL_PACKETS = 0`09`09`09! Total data packet count.
X`09RETURN
X
X`09ENTRY COUNT_FILES
XC
XC`09This routine is called after each file transmission to reset
XC`09some counters and to update the files copied count.
XC
X`09BYTE_COUNT = 0`09`09`09`09! Clear the byte count,
X`09RECORD_COUNT = 0`09`09`09!`09the record count,
X`09ERROR_COUNT = 0`09`09`09`09!`09the error count and,
X`09ERROR_RECORD = 0`09`09`09!`09the error record number,
X`09BLOCK_COUNT = 0`09`09`09`09!`09the data block count,
X`09PACKET_COUNT = 0`09`09`09! `09the data packet count.
X`09FILE_COUNT = FILE_COUNT + 1`09`09! Count number of files copied.
X`09RETRY_COUNT = 0`09`09`09`09! Reinitialize retry counter.
X`09RETURN
X
X`09ENTRY REPORT_TOTALS
XC
XC`09Entry to report the final statistics.
XC
X`09IF (PROTOCOL .EQ. XMODEM) THEN
X`09    CALL SYS$FAO ('!/XMODEM Status Report:!/'//
X`091`09'Total blocks:!7UL, total records:!7UL, total bytes:!8UL!/'//
X`091`09'Parity errors:!6UL,      overruns:!7UL,    timeouts:!8UL!/',
X`091`09`09SIZE, SCRATCH,
X`091`09%VAL(BLOCK_COUNT), %VAL(RECORD_COUNT), %VAL(BYTE_COUNT),
X`091`09%VAL(PARITY_ERRORS), %VAL(FRAMING_ERRORS),%VAL(OVERRUN_ERRORS))
X`09ELSEIF (PROTOCOL .EQ. KERMIT) THEN
X`09    CALL SYS$FAO ('!/KERMIT Status Report:!/'//
X`091`09'Total packets:!7UL, total records:!7UL, total bytes:!8UL!/'//
X`091`09'Parity errors:!7UL,      overruns:!7UL,    timeouts:!8UL!/',
X`091`09`09SIZE, SCRATCH,
X`091`09%VAL(TOTAL_PACKETS), %VAL(TOTAL_RECORDS), %VAL(TOTAL_BYTES),
X`091`09%VAL(PARITY_ERRORS), %VAL(FRAMING_ERRORS),%VAL(OVERRUN_ERRORS))
X`09ENDIF
X`09CALL WRITE_USER (SCRATCH(1:SIZE))
X`09END
X`0C
X`09LOGICAL FUNCTION REPORT_ERROR(DISPLAY)
XC
XC`09This routine is used to report a transmission error.  If the retry
XC`09limit is exceeded, the function returns failure.
XC
XC`09Inputs:
XC`09`09DISPLAY - Controls whether the error should be displayed.
XC
X`09implicit integer*4 (a-z)
X`09INCLUDE 'BBS_INC.FOR/NOLIST'
X
X`09LOGICAL DISPLAY
X`09CHARACTER*(*) RETRY_MSG
X`09PARAMETER (RETRY_MSG = ss//
X`091 '*** Retry limit exceeded, aborting file transmission ***'
X`091 //BELL//ss)
X
X`09REPORT_ERROR = .TRUE.`09`09`09! Presume limit not exceeded.
X`09ERROR_COUNT = ERROR_COUNT + 1`09`09! Bump the error count.
X`09ERROR_RECORD = RECORD_COUNT + 1`09`09! Save the error record number.
X`09RETRY_COUNT = RETRY_COUNT + 1`09`09! Bump the retry count.
X
X`09IF (RETRY_COUNT .GE. RETRY_LIMIT) THEN
X`09`09REPORT_ERROR = .FALSE.`09`09! Show retry limit exceeded.
XC`09`09CALL WRITE_USER(RETRY_MSG)`09! Tell the user what happened.
X`09ENDIF
X`09RETURN
X`09END
X`0C
X`09SUBROUTINE REPORT_SUCCESS
X`09implicit integer*4 (a-z)
X`09include 'bbs_inc.for/nolist'
XC
XC`09Routine to display a successful transmission.
XC
X`09CALL CHECK_DISPLAY()
X`09CALL SYS$FAO ('*** File "!AS" successfully transferred. ***!/',
X`091   SIZE, SCRATCH, VAX_FILE(1:VSIZE))
X`09CALL WRITE_USER (SCRATCH(1:SIZE))
X`09RETURN
X
X`09ENTRY REPORT_ABORT
XC
XC`09Routine to display a aborted transmission.
XC
X`09CALL CHECK_DISPLAY()
X`09CALL WRITE_USER('*** Transmission of file "'//VAX_FILE(1:VSIZE)//
X`091`09`09'" aborted. ***'//crlf(:cl))
X`09RETURN
X`09END
X`0C
X`09SUBROUTINE CHECK_DISPLAY
XC
XC`09This routine simply writes single spacing to the local terminal
XC`09if record information was displayed on the screen.
XC
X`09implicit integer*4 (a-z)
X`09INCLUDE 'BBS_INC.FOR/NOLIST'
X
X`09IF (RECORD_COUNT .GE. DISPLAY_RECORD) THEN
X`09    CALL WRITE_TTY (crlf(:cl))
X`09    ENDIF
X`09RETURN
X`09END
X`0C
X`09subroutine setup_local(interactive)
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS subroutines - SETUP_LOCAL
Xc
Xc`09This routine is used to setup the local terminal characteristics.
Xc
Xc`09Inputs:
Xc`09`09INTERACTIVE - logical .TRUE. for interactive mode.
Xc`09`09`09`09else .FALSE. for normal mode.
Xc
Xc`09Dale Miller - UALR
Xc
Xc`09Rev. 4.8  03-Feb-1987
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09include 'bbs_inc.for/nolist'
X`09include '($ttdef)/nolist'
X`09include '($tt2def)/nolist'
X
X`09logical interactive
X`09character*(*) module_name
X`09parameter (module_name = 'setup_local')
X`09integer sys$qiow
X`09integer check_status,status
X
Xc`09Get the local terminal characteristics and set the terminal
Xc`09to full duplex to allow simultanious reads and writes.
X
X`09status = sys$qiow(%val(lefn_in),%val(lchan_in),
X`091   %val(io$_sensemode),liosb,,,local_char,%val(12),,,,)
X`09if (.not. check_status(module_name,status)) return
X
Xc`09For interactive mode, we must enable full duplex (if not enabled)
Xc`09and put the terminal in binary passall mode.  The terminal must
Xc`09be in passall mode to prevent control characters (CTRL/C, CTRL/S,
Xc`09CTRL/Q, CTRL/X, and CTRL/Y) from being processed by the terminal
Xc`09driver when a read is not active.
X
X`09if (interactive) then
X`09    local_char(3) = local_char(3) .or. tt2$m_pasthru
X`09    local_char(2) = local_char(2) .and. (.not. tt$m_halfdup)
X`09    local_char(2) = local_char(2) .or. tt$m_eightbit
X`09    local_char(2) = local_char(2) .and. (.not. tt$m_ttsync)
X`09else
X`09    local_char(3) = local_char(3) .and. (.not. tt2$m_pasthru)
X`09    local_char(2) = local_char(2) .and. (.not. tt$m_eightbit)
X`09    local_char(2) = local_char(2) .or. tt$m_ttsync
X`09    if((ur.editor.and.7) .eq. 7) then
X`09`09local_char(2) = local_char(2) .or. (tt$_vt100 * 2**8)
X`09`09local_char(3) = local_char(3) .or. tt2$m_ansicrt
X`09`09local_char(3) = local_char(3) .or. tt2$m_deccrt
X`09    else if ((ur.editor.and.3) .eq. 3) then
X`09`09local_char(2) = local_char(2) .or. (tt$_vt52 * 2**8)
X`09    end if
X`09endif
X
Xc`09The CTRL/S state must be cleared before going into passall mode,
Xc`09otherwise the read never completes because the CTRL/Q used to clear
Xc`09the suspended state get put in the input buffer.  This results in
Xc`09VAXNET getting hung in a hibernate even though reads are active.
X
X`09local_char(3) = local_char(3) .or. tt2$m_xon
X`09status = sys$qiow(%val(lefn_in),%val(lchan_in),
X`091   %val(io$_setmode),liosb,,,local_char,%val(12),,,,)
X`09call check_status(module_name,status)
X`09return
X`09end
X`0C
X`09subroutine clear_typeahead
Xc
Xc`09Clears the typeahead buffer on the local channel.
Xc`09Also sets up the local typeahead buffer.
Xc
X`09implicit integer*4 (a-z)
X`09include 'bbs_inc.for/nolist'
X
X`09status = sys$qiow(%val(lefn_in),%val(lchan_in),
X`091`09%val(io$_readlblk + io$m_purge),
X`092`09liosb,,,rbuffer,%val(0),,,,)
X`09call check_status('clear_typeahead',status)
X`09tnext=1
X`09return
X`09end
X`0C
X`09SUBROUTINE WAITABIT(SECONDS)
XC
XC`09This subroutine just waits a little then returns.
XC
X`09implicit integer*4 (a-z)
X`09INCLUDE 'BBS_INC.FOR/NOLIST'
X
X`09CHARACTER*(*) SECONDS
X`09INTEGER*4 DELTA(2)
X
X`09STATUS = SYS$BINTIM('0 00:00:'//SECONDS,DELTA)
X`09IF (.NOT. CHECK_STATUS('WAITABIT(BINTIM)',STATUS)) RETURN
X`09STATUS = SYS$SETIMR(%VAL(TIMER_EFN),DELTA,,)
X`09IF (.NOT. CHECK_STATUS('WAITABIT(SETIMR)',STATUS)) RETURN
X`09STATUS = SYS$WAITFR(%VAL(TIMER_EFN))
X`09CALL CHECK_STATUS('WAITABIT(WAITFR)',STATUS)
X
XC`09STATUS = SYS$SCHDWK(,,DELTA,,)`09! Schedule wakeup.
XC`09IF (.NOT. CHECK_STATUS('WAITABIT(SCHDWK)',STATUS)) RETURN
XC`09STATUS = SYS$HIBER()`09`09! Go into hibernation.
X`09RETURN
X`09END
X`0C
X`09LOGICAL FUNCTION CVT_DTB(STR,NUM)
XC
XC`09This routine is used to convert an ASCII string of numbers to
XC`09an integer.
XC
XC`09Inputs:
XC`09`09STR - string descriptor.
XC`09`09NUM - integer to return number to.
XC
XC`09Outputs:
XC`09`09.TRUE./.FALSE. = success/failure.
XC
X`09CHARACTER*(*) STR
X`09INTEGER*4 NUM
X
X`09CVT_DTB = LIB$CVT_DTB(%VAL(LEN(STR)),%REF(STR),NUM)
X`09RETURN
X`09END
X`0C
X`09INTEGER FUNCTION GET_EFN(EVENT_FLAG)
XC
XC`09Get an event flag.
XC
X`09IMPLICIT NONE
X`09INTEGER*4 EVENT_FLAG, CHECK_STATUS, LIB$GET_EF, STATUS
X
X`09STATUS = LIB$GET_EF(EVENT_FLAG)`09! Local input event flag.
X`09CALL CHECK_STATUS('LIB$GET_EF',STATUS)
X`09RETURN
X`09END
X`0C
X`09integer function read_byte (seconds)
Xc
Xc`09This routine is used to read a single byte.
Xc`09If any characters are in the local typeahead, they are used first.
Xc
Xc`09Inputs:
Xc`09`09SECONDS = The timeout in seconds.
Xc
X`09implicit integer*4 (a-z)
X`09include 'bbs_inc.for/nolist'
X
X`09integer seconds
X`09logical*1 buff(1)
X
X`09if(tnext.gt.1) then
X`09    read_byte = tbuffer(1)
X`09    cbuffer=cbuffer(2:tnext)
X`09    tnext=tnext-1
X`09    return
X`09else
X`09    call raw_read (buff, 1, seconds, noterm)
X`09    read_byte = buff(1) .and. bitmask
X`09    return
X`09endif
X`09end
X`0C
X`09SUBROUTINE SEND_BYTE (BUFFER)
XC
XC`09This routine is used to write a single byte.
XC
X`09implicit integer*4 (a-z)
X`09INCLUDE 'BBS_INC.FOR/NOLIST'
X
X`09LOGICAL*1 BUFFER(1), BUFF(1)
X
X`09BUFF(1) = BUFFER(1) .AND. BITMASK
X`09CALL RAW_WRITE (BUFF(1),1)
X`09RETURN
X`09END
X`0C
X`09INTEGER FUNCTION RAW_READ (BUFFER, BYTES, SECONDS, termin)
XC
XC`09This routine is used to read raw data (no interpretation).
XC
XC`09Inputs:
XC`09`09BUFFER = The buffer to read into.
XC`09`09BYTES = The number of bytes to read.
XC`09`09SECONDS = The timeout in seconds.
Xc`09`09TERMIN  = The read terminator table
XC
X`09implicit integer*4 (a-z)
X`09INCLUDE 'BBS_INC.FOR/NOLIST'
X
X`09CHARACTER*(*) MODULE_NAME
X`09PARAMETER (MODULE_NAME = 'RAW_READ')
X
X`09LOGICAL*1 BUFFER(1)
X`09integer*4 termin(2)
X`09INTEGER BYTES, SECONDS, STATUS
X
X`09STATUS = SYS$QIOW (%VAL(LEFN_IN),%VAL(LCHAN_IN),
X`091`09`09%VAL(IO$_TTYREADALL + IO$M_NOECHO + IO$M_TIMED),
X`091`09`09LIOSB,,,BUFFER,%VAL(BYTES),
X`091`09`09%VAL(SECONDS),termin,,)
X
X`09RAW_READ = STATUS`09`09! Copy the directive status.
X`09IF (.NOT. CHECK_STATUS (MODULE_NAME, STATUS)) RETURN
X`09RAW_READ = LIOSB(1)`09`09! Pass back I/O status.
X`09RBYTE_COUNT = LIOSB(2)`09`09! Save the byte count.
XC
XC`09Check for various errors:
XC
X`09IF     (LIOSB(1) .EQ. SS$_TIMEOUT) THEN`09`09! Timeout error ?
X`09`09TIMEOUTS = TIMEOUTS + 1`09`09`09! Yes, count it.
X`09`09GO TO 200`09`09`09`09! And continue ...
X`09ELSEIF (LIOSB(1) .EQ. SS$_PARITY) THEN`09`09! Parity error ?
X`09`09PARITY_ERRORS = PARITY_ERRORS + 1`09! Yes, count it,
X`09`09GO TO 200`09`09`09`09! And continue ...
X`09ELSEIF (LIOSB(1) .EQ. SS$_DATAOVERUN) THEN`09! Data overrun ?
X`09`09OVERRUN_ERRORS = OVERRUN_ERRORS + 1`09! Yes, count it.
X`09`09GO TO 200`09`09`09`09! And continue ...
X`09ELSEIF (LIOSB(1) .NE. SS$_ABORT) THEN`09`09! CTRL/C to abort.
X`09`09CALL CHECK_STATUS (MODULE_NAME, RAW_READ)
X`09ENDIF
X`09RETURN
XC
XC`09Here for timeout and hardware errors.
XC
X200`09BUFFER(1) = 0`09`09`09`09! Force bad transmission
X`09RBYTE_COUNT = 0`09`09`09`09!  by clearing buffer & BC.
X`09RETURN
X`09END
X`0C
X`09SUBROUTINE RAW_WRITE (BUFFER, BYTES)
XC
XC`09This routine is used to write raw data (no interpretation).
XC
XC`09Inputs:
XC`09`09BUFFER - The buffer to write.
XC`09`09BYTES - The number of bytes to write.
XC
X`09implicit integer*4 (a-z)
X`09INCLUDE 'BBS_INC.FOR/NOLIST'
X
X`09CHARACTER*(*) MODULE_NAME
X`09PARAMETER (MODULE_NAME = 'RAW_WRITE')
X
X`09LOGICAL*1 BUFFER(1)
X`09INTEGER BYTES, STATUS
X
Xc`09CALL WRITE_DEBUG (MODULE_NAME, BUFFER, BYTES)
X`09STATUS = SYS$QIOW (%VAL(LEFN_OUT),%VAL(LCHAN_OUT),
X`091`09`09%VAL(IO$_WRITELBLK + IO$M_NOFORMAT),
X`091`09`09XIOSB,,,BUFFER,%VAL(BYTES),,,,)
X`09CALL CHECK_STATUS (MODULE_NAME, STATUS)
X`09RETURN
X`09END
X`0C
X`09SUBROUTINE XMODEM_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 buffer from multiple input records, the record
XC`09display has a special entry which is called after tranmitting the
XC`09current block.
XC
X`09implicit integer*4 (a-z)
X`09INCLUDE 'BBS_INC.FOR/NOLIST'
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`09RETURN
X`09END
X`0C
X`09SUBROUTINE WRITE_USER(MSG)
XC
XC`09Write a buffer to the user and the log file if open.
XC
XC`09Inputs:
XC`09`09MSG - string descriptor with message.
XC
X`09implicit integer*4 (a-z)
X`09INCLUDE 'BBS_INC.FOR/NOLIST'
X
X`09CHARACTER*(*) MSG
X`09INTEGER SIZE, STATUS
X
X`09SIZE = LEN(MSG)
X`09GO TO 100
X
X`09ENTRY WRITE_BUFF (MSG)
XC
XC`09Entry to write to the log file and the terminal.
XC
X`09SIZE = LEN(MSG)
X`09GO TO 100
X
X`09ENTRY WRITE_TTY (MSG)
XC
XC`09Entry to write to the terminal only.
XC
X`09SIZE = LEN(MSG)
X100`09STATUS = SYS$QIOW(%VAL(LEFN_OUT),%VAL(LCHAN_OUT),
X`091    %VAL(IO$_WRITELBLK + IO$M_NOFORMAT),
X`091    LIOSB,,,%REF(MSG),%VAL(SIZE),,,,)
X`09IF (.NOT. STATUS) THEN
X`09    CALL LIB$SIGNAL(%VAL(STATUS))
X`09    CALL SYS$EXIT(%VAL(STATUS))
X`09    ENDIF
X`09RETURN
X`09END
X`0C
X`09SUBROUTINE RMS_ERROR (MODULE)
XC
XC`09This routine is called to report an RMS error.
XC
XC`09CALL ERRSNS(num,rmssts,rmsstv,iunit,)
XC
XC`09Where:`09num = fortran error code,
XC`09`09rmssts = RMS completion status code.
XC`09`09rmsstv = RMS status code.
XC`09`09iunit = logical unit number.
XC
X`09IMPLICIT NONE
X
X`09INTEGER*4 FERR, RMSSTS, RMSSTV, LUN, CHECK_STATUS, ERROR
X`09CHARACTER*(*) MODULE
X
X`09CALL ERRSNS (FERR,RMSSTS,RMSSTV,LUN,)`09! Get the last error code.
X`09ERROR = RMSSTS`09`09`09`09! Copy the RMS error code.
X`09IF (ERROR .EQ. 0) ERROR = FERR`09`09! Use the FORTRAN error code.
X`09CALL CHECK_STATUS (MODULE, ERROR)`09! Go report the error message.
X`09RETURN
X`09END
X`0C
X`09SUBROUTINE WRITE_REMOTE (BUFFER, NBYTES)
XC
XC`09This subroutine is used to write a buffer to the remote.
XC
X`09implicit integer*4 (a-z)
X`09INCLUDE 'BBS_INC.FOR/NOLIST'
X
X`09LOGICAL*1 BUFFER(1)
X
X`09BYTES = NBYTES + 1`09`09! Adjust the byte count.
X`09BUFFER(BYTES) = CR`09`09! Append Terminator.
X`09GO TO 100`09`09`09! And continue ...
XC
XC`09The next entry is used to write the buffer without appending
XC`09a carriage return to the end of the message.
XC
X`09ENTRY WRITE_BYTE (BUFFER, NBYTES)
X`09BYTES = NBYTES`09`09`09! Copy the byte count.
X
X100`09STATUS = SYS$QIOW(%VAL(LEFN_OUT),%VAL(LCHAN_OUT),
X`091`09`09%VAL(IO$_WRITELBLK + IO$M_NOFORMAT),
X`091`09`09XIOSB,,,BUFFER,%VAL(BYTES),,,,)
X`09CALL CHECK_STATUS('WRITE_REMOTE',STATUS)
X`09RETURN
X`09END
X`0C
X`09SUBROUTINE HANGUP_MODEM
XC
XC`09This routine is called to hangup the modem.
XC
X`09implicit integer*4 (a-z)
X`09INCLUDE 'BBS_INC.FOR/NOLIST'
X
X`09LOCAL_STATUS = SYS$QIOW(%VAL(LEFN_IN),%VAL(LCHAN_IN),
X`091   %VAL(IO$_SETMODE + IO$M_HANGUP),LIOSB,,,,,,,,)
X`09RETURN
X`09END
X`0C
X`09subroutine fake_vaxnet
Xc`09This code was surgically removed from VAXNET, and appears here
Xc`09in a somewhat mangled, but usuable state.
X`09implicit integer*4 (a-z)
X`09include 'bbs_inc.for/nolist'
X`09bitmask=sevenbit_mask
Xc`09set up event flags
X`09call get_efn(lefn_in)`09`09! Local input event flag
X`09call get_efn(lefn_out)`09`09! Local output event flag
XC
XC`09Translate SYS$COMMAND, and assign a channel for QIO's.
XC
X`09I = 11`09`09`09`09! Size of SYS$COMMAND
X`09LOCAL_DEVICE = 'SYS$COMMAND'
X10`09STATUS = SYS$TRNLOG(LOCAL_DEVICE(1:I),I,LOCAL_DEVICE,,,)
X`09IF (STATUS .NE. SS$_NOTRAN) GO TO 10
XC
XC`09Note in the following that I contains the true length, and remember
XC`09that TRNLOG puts a stupid 4-byte header on the translations of
XC`09SYS$INPUT/OUTPUT specifically.  This header only exists if the
XC`09first byte starts with an escape character.
XC
X`09IF (LOCAL_DEVICE(1:1) .EQ. CHAR(esc)) THEN
X`09`09S = 5`09`09`09! Point past header.
X`09ELSE
X`09`09S = 1`09`09`09! Use entire string.
X`09ENDIF
X`09STATUS = SYS$ASSIGN(LOCAL_DEVICE(S:I),LCHAN_IN,,)
X`09IF (.NOT. STATUS) THEN
X`09`09CALL LIB$SIGNAL(%VAL(STATUS))
X`09`09CALL SYS$EXIT(%VAL(STATUS))
X`09ENDIF
X`09STATUS = SYS$ASSIGN(LOCAL_DEVICE(S:I),LCHAN_OUT,,)
X
X`09return
X`09END
X`0C
X`09subroutine ctrl_o_check(*,*)
Xc`09this routine will stick anything other than `5Ec, `5Eq, `5Es, and `5Eo
Xc`09into the local typeahead buffer.
Xc`09and take alternate returns for `5Eo or `5Ec
Xc
X`09implicit none
X`09include 'bbs_inc.for/nolist'
X`09logical*1 temp1(1)
X
X`09timeouts=0
X`09call raw_read(temp1,1,0,noterm)
X`09temp1(1) = temp1(1) .and. bitmask
X`09do while(temp1(1).ne.0)
X`09    if(temp1(1).eq.03) return 1`09!Control-c return statement
X`09    if(temp1(1).eq.15) return 2`09!Control-o return statement
X`09    if(temp1(1).eq.21.or.temp1(1).eq.24) tnext=1   !`5Ex/`5Eu
X`09    if(temp1(1).eq.19) then
X`09`09do while(temp1(1).ne.3.and.temp1(1).ne.17
X`091`09    .and.temp1(1).ne.15)
X`09`09    call raw_read(temp1,1,60,noterm)
X`09`09    temp1(1) = temp1(1) .and. bitmask
X`09`09    if(timeouts.gt.4) call finish_timeout
X`09`09    if(tnext.lt.1024) then
X`09`09`09tbuffer(tnext)=temp1(1)
X`09`09`09tnext=tnext+1
X`09`09    else
X`09`09`09write(6,1001)bell
X`09`09    endif
X`09`09    end do
X`09`09if(temp1(1).eq.03) return 1
X`09`09if(temp1(1).eq.15) return 2
X`09`09if(temp1(1).eq.17) return
X`09`09end if
X`09    if(tnext.lt.1024) then
X`09`09tbuffer(tnext)=temp1(1)
X`09`09tnext=tnext+1
X`09`09temp1(1)=0
X`09    else
X`09`09write(6,1001)bell
X`09`09temp1(1)=0
X`09    endif
X`09    timeouts=0
X`09    call raw_read(temp1,1,0,noterm)
X`09    temp1(1) = temp1(1) .and. bitmask
X`09    end do
X`09return
X 1001`09format(a)
X`09end
X`0C
X`09subroutine kill_mess (irec,status)
X`09implicit integer*4 (a-z)
X`09include 'bbs_inc.for/nolist'
X`09include 'sys$library:foriosdef/nolist'
Xc
X`09character cdummy*1,zmail_to*30,zmail_from*30
X`09character snum*6,qmail_to*30,yesno*3,string*30
X`09character zfirst_name*20,zlast_name*20
X`09byte dummyb
X`09logical*1 reprint,found,nostop
X
X`09record /userlog_structure/ zur
X
X`09record /mail_header_structure/ mh
X
X 1001`09format(a)
X
X`09status=0
X10000`09read(2,rec=irec,iostat=ios,err=90600) mh
X`09unlock(unit=2)
X`09istat = str$upcase(mh.mail_to,mh.mail_to)
X`09if(mail_name.ne.mh.mail_to.and.mail_name.ne.mh.mail_from
X`091   .and.(.not.sysop2)) then
X`09    write(6,1001)crlf(:cl)//'That is not your message.'
X`09    return
X`09    end if
X
X`09write(6,1001)crlf(:cl)//'Are you sure? `5BYes`5D '
X`09dummy=3
X`09call get_upcase_string(yesno,dummy)
X`09if(dummy.gt.0.and.yesno(1:1).eq.'N') then
X`09    return
X`09    end if
X`09read(2,rec=irec,iostat=ios,err=90600) mh
X`09mh.mail_deleted=.true.
X`09write(2,rec=irec,iostat=ios,err=90600) mh
X`09if(mh.mail_person.and..not.mh.mail_read) then
X`09    istat=str$upcase(qmail_to,mh.mail_to)
X`09    spc=index(qmail_to,' ')
X`09    zfirst_name=qmail_to(1:spc-1)`09
X`09    do ii=spc+1,30
X`09`09if(zmail_to(ii:ii).ne.' ') go to 10200
X`09`09end do
X
X10200`09    zlast_name=qmail_to(ii:30)
X`09    zur.user_key=zlast_name//zfirst_name
X`09    read(1,key=zur.user_key,iostat=ios,err=10400)zur
X`09    zur.num_unread=zur.num_unread-1
X`09    if (zur.num_unread.lt.0) zur.num_unread=0
X`09    rewrite(1,err=90500)zur
X`09    end if
X
X10400`09write(6,1001)crlf(:cl)
X`09istat=str$trim(mh.mail_from,mh.mail_from,dummy1)
X`09istat=str$trim(mh.mail_to,mh.mail_to,dummy2)
X`09if(dummy1.lt.1.or.dummy1.gt.30) dummy1=30
X`09if(dummy2.lt.1.or.dummy2.gt.30) dummy2=30
X`09write(6,1001)crlf(:cl)//'Message from '//mh.mail_from(1:dummy1)//
X`091    ' to '//mh.mail_to(1:dummy2)//' deleted.'//bell
X`09return
X
X90500`09status=1`09!error on userlog
X`09return
X
X90600`09status=2`09!error on message files
X`09return
X`09end
X`0C
X`09subroutine finish_timeout
X*`09this routine is called in case of a timeout.
X`09implicit integer*4 (a-z)
X`09include 'bbs_inc.for'
X`09write(6,1001)crlf(:cl)//'Your terminal has been idle too long.'
X`09write(6,1001)crlf(:cl)//'UBBS is signing off now.'
X`09read(1,key=ur.user_key,iostat=ios,err=90500)ur
X`09ur.seconds_today = current_units
X`09rewrite(1,iostat=ios,err=90500)ur
X90500`09continue`09`09!graceful non-handling of errors
X`09close(unit=1)
X`09close(unit=2)
X`09close(unit=3)
X`09interactive=.false.`09`09!reset before exiting
X`09call setup_local(interactive)
X`09write(6,1001)crlf(:cl)
X`09close(unit=6)
X`09call exit
X 1001`09format(a)
X`09end
X`0C
X`09integer function uopen(fab,rab,lun)
X`09implicit none
X
X`09include '($rabdef)'
X`09include '($fabdef)'
X
X`09record /rabdef/ rab
X`09record /fabdef/ fab
X`09integer sys$open,sys$connect
X
X`09integer lun,status
X`09
Xc`09modify the rab to simplify things
X`09rab.rab$l_rop = ibset(rab.rab$l_rop, rab$v_wat)
X
Xc`09actually open the file
X`09status=sys$open(fab)
X`09if(status) status=sys$connect(rab)
Xc`09return the status
X`09uopen=status
X`09return
X`09end
X`0C
X`09integer function getsize(fab,rab,lun)
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS subroutines - GETSIZE
Xc`09This is a user open procedure to determine file size and file
Xc`09revision date.
Xc`09Dale Miller - UALR
Xc
Xc`09Rev. 6.1  08-Jun-1988
Xc`09Rev. 7.1  19-Sep-1988
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc`09This user open finds out the file size.
X
X`09implicit none
X
X`09include '($rabdef)'
X`09include '($fabdef)'
X`09include '($xabdef)'
X`09include '($xabdatdef)'
X
X`09structure /xxx/
X`09    union
X`09`09map
X`09`09    record /xabdef/ xab
X`09`09end map
X`09`09map
X`09`09    record /xabdatdef/ dat
X`09`09end map
X`09    end union
X`09end structure
X
X`09record /xxx/ xabdat
X`09record /rabdef/ rab
X`09record /fabdef/ fab
X`09integer sys$open,sys$connect
X`09
X`09integer lun,status,fsize,rev_date(2),back_date(2)
X`09common/filesize/fsize, rev_date, back_date
X`09
Xc`09Initialize FAB block and set up link to XAB.
X`09fab.fab$b_bid = fab$c_bid
X`09fab.fab$b_bln = fab$c_bln
X`09fab.fab$l_xab = %loc(xabdat.xab.xab$b_cod)
X
Xc`09Set up the XAB block to be a XABDAT block.
X`09xabdat.xab.xab$b_cod = xab$c_dat
X`09xabdat.xab.xab$b_bln = xab$c_datlen
X`09xabdat.xab.xab$l_nxt = 0
X
Xc`09Actually open the file
X`09status=sys$open(fab)
X`09if(status) status=sys$connect(rab)
Xc`09Return the status
X`09getsize=status
Xc`09Store the size
X`09fsize=fab.fab$l_alq
Xc`09Store the revision date
X`09rev_date(1) = xabdat.xab.xab$q_rdt(1)
X`09rev_date(2) = xabdat.xab.xab$q_rdt(2)
Xc`09Store the backup date
X`09back_date(1) = xabdat.dat.xab$q_bdt(1)
X`09back_date(2) = xabdat.dat.xab$q_bdt(2)
X`09return
X`09end
X`0C
X`09INTEGER FUNCTION FIND_FILE (FILE,SIZE)
XC
XC`09This function is used to lookup a file spec containing wildcards.
XC
XC`09Inputs:
XC`09`09FILE - The file spec to lookup.
XC`09`09SIZE - The file spec size.
XC
XC`09Outputs:
XC`09`09Any error from LIB$FIND_FILE.
XC
X`09implicit integer*4 (a-z)
X`09INCLUDE 'bbs_inc.for'
X`09INCLUDE '($RMSDEF)/NOLIST'
X
X`09CHARACTER*(*) FILE, MODULE_NAME
X`09CHARACTER*128 FILE_NAME
X
X`09PARAMETER (MODULE_NAME = 'FIND_FILE')
X`09LOGICAL WILD_CARDS
X`09INTEGER FIND_CONTEXT, FILE_SIZE, SIZE, DFLAG, SON
X
X`09FILE_NAME = FILE(1:SIZE)`09! Copy the file specification.
X`09FILE_SIZE = SIZE`09`09! Copy the file size.
X`09FIND_CONTEXT = 0`09`09! Initialize the file context.
XC
XC`09Set flag to determine if device and/or directory is specified.
XC
X`09GO TO 100`09`09`09! Go find the specified file(s).
X
X`09ENTRY FIND_NEXT (FILE, SIZE)
XC
XC`09Find the first/next file name.
XC
X`09FIND_NEXT = RMS$_NMF`09`09! Initialize to "No more files"
X
X100`09STATUS = LIB$FIND_FILE (FILE_NAME(1:FILE_SIZE), FILE, FIND_CONTEXT)
X`09FIND_NEXT = STATUS`09`09! Pass back the status.
X
X`09SIZE = INDEX (FILE, ' ') - 1`09! End of expanded file name.
XC
XC`09Return the file name size minus the spaces it's padded with.
XC
X`09SIZE = INDEX (FILE, ' ') - 1`09! Return the file name size.
X`09IF (.NOT. STATUS) THEN
X`09    IF (STATUS .NE. RMS$_NMF) THEN
X`09`09    IF (STATUS .EQ. RMS$_PRV) THEN
X`09`09`09GO TO 100`09! Next file on privilege violation.
X`09`09    ENDIF
X`09    ELSE
X`09`09VAX_WILD = .FALSE.`09! Wildcards are no longer active.
X`09    ENDIF
X`09ENDIF
X`09RETURN
X`09END
X`0C
X`09subroutine type_file(filename)
X`09implicit none
X`09include 'bbs_inc.for'
X`09character*(*) filename
X`09character*512 record
X`09integer length
X
X`09open(unit=4,file=filename,status='old',readonly,
X`091   shared,err=0020)
X`09read(4,1002,iostat=ios)length,record
X`09do while (.not.ios)
X`09    call ctrl_o_check(*10,*10)
X`09    write(6,1001)crlf(:cl)//record(1:length)
X`09    read(4,1002,iostat=ios)length,record
X`09    end do
X 0010`09close(unit=4)
X 0020`09return
X 1001`09format(a)
X 1002`09format(q,a)
X`09end
X`0C
X`09subroutine make_readable(instring,length,outstring)
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS subroutines - MAKE_READABLE
Xc`09This routine takes an input string and translates control characters
Xc`09to a displayable representation.
Xc`09Dale Miller - UALR
Xc
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X`09implicit none
X`09character*(*) instring,outstring
X`09integer*4 length,i,j,temp
X`09character*3 text(33)
X`09integer*4 ltxt(33)
X`09data text/'NUL','SOH','STX','ETX','EOT','ENQ','ACK','BEL',
X`091`09  'BS ','HT ','LF ','VT ','FF ','CR ','SO ','SI ',
X`092`09  'DLE','DC1','DC2','DC3','DC4','NAK','SYN','ETB',
X`093`09  'CAN','EM ','SUB','ESC','FS ','GS ','RS ','US ','SP '/
X
X`09data ltxt/8*3,8*2,9*3,2,2*3,5*2/
X
X`09j=0
X`09do i=1,length
X`09    temp=ichar(instring(i:i))+1
X`09    if(temp.le.33) then
X`09`09outstring=outstring(1:j)//'<'//text(temp)(1:ltxt(temp))//'>'
X`09`09j=j+2+ltxt(temp)
X`09    else if(temp.eq.128) then
X`09`09outstring=outstring(1:j)//'<DEL>'
X`09`09j=j+5
X`09    else
X`09`09outstring=outstring(1:j)//instring(i:i)
X`09`09j=j+1
X`09    end if
X`09    end do
X`09length=j
X`09return
X`09end
X`0C
X`09integer function bbs_put_output(msg_str)
Xc
Xc`09This routine mimics lib$put_output for the bbs to allow it to use
Xc`09its own carriage control and interrupt routines
Xc
X`09implicit none
X`09include 'bbs_inc.for'
X`09character*(*) msg_str
X
X`09bbs_put_output = ss$_normal
X
X`09if (controlc_typed) return
X`09call ctrl_o_check(*10,*10)
X`09write(6,1001)crlf(:cl)//msg_str
X`09return
X
X 0010`09controlc_typed = .true.
X`09return
X
X 1001`09format(a)
X`09end
X`0C
X`09integer function bbs_get_input(get_str,prompt_str,out_len)
Xc
Xc`09This routine mimics lib$get_input for the bbs to allow it to use
Xc`09its own carriage control, typeahead buffer, and interrupt routines
Xc
X`09implicit none
X`09include 'bbs_inc.for'
X`09character*(*) get_str,prompt_str
X`09integer*2 out_len
X
X`09bbs_get_input = ss$_normal
X
X`09if (controlc_typed) go to 10
X
X`09call ctrl_o_check(*10,*10)
X`09write(6,1001)crlf(:cl)//prompt_str
X`09out_len=50
X`09call get_uplow_string(get_str,out_len)
X`09return
X
X 0010`09controlc_typed = .true.
X`09get_str=' '
X`09out_len=0
X`09return
X
X 1001`09format(a)
X 1002`09format(q,a)
X`09end
X`0C
X`09subroutine out(msg_str,*)
Xc
Xc`09This routine provides a convienient way to output a line and
Xc`09check the status on return.
Xc
X`09implicit none
X`09include 'bbs_inc.for'
X`09character*(*) msg_str
X
X`09call ctrl_o_check(*10,*10)
X`09write(6,1001)crlf(:cl)//msg_str
X`09return
X
X 0010`09return 1
X
X 1001`09format(a)
X`09end
X`0C
X`09subroutine add_elapsed_time(*)
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS subroutines
Xc
Xc`09This routine is called at each entry to the main or mail menu.  It`20
Xc`09will add the time so far to the user's time and check it against
Xc`09the total allowed.  The LIB$INIT_TIMER must have been called previous
Xc`09to calling this routine.
Xc
Xc`09Rev. 3.6  25-Jun-1986
Xc`09Rev. 4.1  07-Jul-1986
Xc`09Rev. 4.4  15-Aug-1986
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
X
X`09implicit none
X`09include 'bbs_inc.for/nolist'
X`09character cdate*9,ctime*8
X`09real*8 systime,qdummy,mill10
X`09integer*4 zone,daynum,oldzone,istat
X`09integer*4 syst(2),hours
X`09integer lib$day_of_week,lib$stat_timer
X`09equivalence(systime,syst)
X`09data mill10/'ffffffffff676980'x/`09!Quadword -10,000,000
X`09
X 1001`09format(a)
X 1002`09format(i2)
X
Xc`09See if the date has changed.
X`09call date(cdate)
X`09if(cdate.ne.ur.current_day) then
X`09    read(1,key=ur.user_key,iostat=ios,err=90500)ur
X`09    ur.current_day=cdate
X`09    ur.seconds_today=0
X`09    rewrite(1,iostat=ios,err=90500)ur
X`09    initial_units=0
X`09    current_units=0
X`09    call init_timer(user_timer)
X`09    write(6,1001)crlf(:cl)//crlf(:cl)//'Your timer has been reset.'//
X`091`09crlf(:cl)//bell
X`09    end if
Xc
Xc`09Find out how badly to hit him.
X`09zone=lib$day_of_week(,daynum)
X`09call time(ctime)
X`09read(ctime,1002)hours
X`09zone=1
X`09if(hours.gt.18)zone=2
X`09if(hours.lt.08.or.daynum.ge.6)zone=4
X`09if(zone.ne.oldzone) then
X`09    read(1,key=ur.user_key,err=90500)ur
X`09    ur.seconds_today = current_units
X`09    rewrite(1,err=90500)ur
X`09    call init_timer(user_timer)
X`09    initial_units=ur.seconds_today
X`09    oldzone=zone
X`09    endif
X
Xc`09Return his time used as a quadword.
X`09istat=lib$stat_timer(1,qdummy,user_timer)
X
Xc`09Divide the system time by -10,000,000 to get seconds
X`09call ediv(qdummy,mill10,systime)
X
X`09current_units=syst(1)/zone+initial_units
X`09if(current_units.gt.allowable_units) return 1
X`09if(current_units.gt.ur.seconds_today+60) then
X`09    read(1,key=ur.user_key,iostat=ios,err=90500)ur
X`09    ur.seconds_today = current_units
X`09    rewrite(1,iostat=ios,err=90500)ur
X`09    endif
X`09return
X
X90500`09continue
X`09return 1
X`09end
X`0C
X`09subroutine arklug_files_section
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vcccc
Xc
Xc`09UBBS subroutines
Xc`09This routine takes care of the ARKLUG files section
Xc`09Dale Miller - UALR
Xc
Xc
Xc`09Rev. 3.5  19-Jun-1986
Xc`09Rev. 3.6  25-Jun-1986
Xc`09Rev. 6.1  08-Jun-1988
Xc`09Rev. 7.1  19-Sep-1988
Xc
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
X`09character space*30/'                    '/
X`09logical*1 reprint,dummyl
X`09integer i,istat,per,spc,length,flen
X`09integer file_character/65/`09! The value of 'A' in decimal
X`09integer dummy,dummy1
X`09integer get_xmodem,send_xmodem
X`09integer fsize,rev_date(2),back_date(2)
X`09integer sflags/4/
X`09logical get_vaxfile,kermit_receive
X`09integer lib$spawn,lib$delete_file,str$trim,sys$setddir
X`09integer lbr$output_help,str$upcase,sys$trnlog,lib$set_logical
X`09real*8  noprivs/'000000000000000'x/
X`09external getsize,bbs_put_output,bbs_get_input
X`09record /userlog_structure/ zur
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
Xc`09Start the whole thing off
X 4000`09continue
X`09call date(cdate)
X`09write(term,1024)user_number`09! set up terminal name for Kermit
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`09if (.not.approved_file_down) then
X`09    write(6,1001)crlf(:cl)//bell//
X`091`09'You are not yet approved for the files section.'
X`09    write(6,1001)crlf(:cl)//'Sorry.'
X`09    return
X`09    end if
X`09area='download'
X`09write(6,1001)crlf(:cl)//
X`091   'You are now entering DCL. You may move freely thru the DECUS'
X`09write(6,1001)crlf(:cl)//
X`091   'directory with DCL commands.  Kermit and Xmodem are available'
X`09write(6,1001)crlf(:cl)//'for downloading.'
X`09write(6,1001)crlf(:cl)//
X`091   'Note: You have only read permissions on all files.'//crlf(:cl)
X`09istat= sys$trnlog('SYS$DISK',,line,,,)
X`09istat=lib$set_logical('SYS$DISK','DUA10:')
X`09istat=sys$setddir('`5Bdecus`5D',dummy,filnam)
X`09call setup_local(.false.)
X`09istat=lib$spawn(,,,sflags,,,,,,,)
X`09call setup_local(.true.)
X`09istat=sys$setddir(filnam(1:dummy),,)
X`09istat=str$trim(line,line,dummy)
X`09istat=lib$set_logical('SYS$DISK',line(1:dummy))
X`09return
Xcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
Vccc
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 files 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 out(crlf(:cl)//'The following upload areas'//
X`091`09' are available:',*4701)
X`09    call out('VAX - VAX/VMS',*4701)
X`09    call out('PDP - PDP 11 series',*4701)
X`09    call out('RNB - Rainbow',*4701)
X`09    call out('MIS - Miscellaneous files',*4701)
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`09if( (darea.ne.'VAX') .and. (darea.ne.'PDP') .and.
X`091   (darea.ne.'RNB') .and. (darea.ne.'MIS')) 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    binasc='.asc'
X`09else if (cdummy.eq.'B') then
X`09    file_type=binary
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    write(6,1001)crlf(:cl)//'Binary transfers must be by xmodem'
X`09    write(6,1001)crlf(:cl)//'or Kermit protocol.'
X`09    write(6,1001)crlf(:cl)//'(K)ermit or (X)modem protocol? `5Bexit`5D '
X`09    dummy=1
X`09    call get_upcase_string(cdummy,dummy)
X`09    if(cdummy.eq.'E'.or.dummy.eq.0) go to 4900
X`09    if(cdummy.eq.'K') protocol=kermit
X`09    if(cdummy.eq.'X') protocol=xmodem
X`09    if(protocol.eq.unknown) go to 4720
X`09else
X 4720`09    write(6,1001)crlf(:cl)//'(A)scii, (K)ermit or'//
X`091`09' (X)modem protocol? `5Bexit`5D '
X`09    dummy=1
X`09    call get_upcase_string(cdummy,dummy)
X`09    if(cdummy.eq.'E'.or.dummy.eq.0) go to 4900
X`09    if(cdummy.eq.'A') protocol=asciid
X`09    if(cdummy.eq.'K') protocol=kermit
X`09    if(cdummy.eq.'X') protocol=xmodem
X`09    if(protocol.eq.unknown) go to 4720
X`09end if`09
Xc`09get the file name
X`09write(6,1001)crlf(:cl)//
X`091   'File names may consist of a-z, 0-9, underscore,'
X`09write(6,1001)crlf(:cl)//
X`091   'and at most 1 period.  Names may be 1-18 characters.'
X`09write(6,1001)crlf(:cl)//'File name? `5Bexit`5D'
X`09flen=18
X`09call get_filnam_string(filename,flen)
X`09if(flen.eq.0) go to 4900
Xc
Xc`09compute a dummy file name
Xc
X`09write(zfilnam,1019)char(file_character),user_number
X`09filnam='ubbs_files:`5Bupl`5D'//zfilnam
X`09file_character=file_character+1
Xc
Xc`09if he has made it this far, we are ready to upload.
Xc
X`09if(protocol.eq.xmodem) then
X`09    write(6,1001)crlf(:cl)//
X`091`09'Beginning xmodem upload -- Ctrl-d to abort.'
X`09    call init_timer(file_timer)
X`09    call clear_counts()
X`09    timeout_count=10
X`09    retry_limit=5
X`09    flow=to_vax
X`09    bitmask=eightbit_mask
X`09    dummyl=get_vaxfile(filnam)
X`09    dummyl=get_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`09    if(dummyl) then
X`09`09write(6,1001)crlf(:cl)//'Successful upload!'
X`09`09go to 4800
X`09    else
X`09`09write(6,1001)crlf(:cl)//'Upload failed'
X 4730`09`09istat = lib$delete_file(filnam//';*')
X`09    end if
X`09elseif (protocol.eq.kermit) then
+-+-+-+-+-+-+-+-  END  OF PART 5 +-+-+-+-+-+-+-+-