NetNews Usenet Archive 1992 #18

home *** CD-ROM | disk | FTP | other *** search

/ NetNews Usenet Archive 1992 #18 / NN_1992_18.iso / spool / vmsnet / sources / 307 < prev next >

Wrap

Internet Message Format | 1992-08-21 | 46.8 KB

Path: sparky!uunet!elroy.jpl.nasa.gov!swrinde!mips!mips!munnari.oz.au!network.ucsd.edu!mvb.saic.com!vmsnet-sources From: munroe@dmc.com (Dick Munroe) Newsgroups: vmsnet.sources Subject: UBBS, part 05/12 Message-ID: <7868468@MVB.SAIC.COM> Date: 21 Aug 92 20:20:10 GMT Organization: Doyle, Munroe Consultants, Inc., Hudson, MA Lines: 1590 Approved: Mark.Berryman@Mvb.Saic.Com 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 +-+-+-+-+-+-+-+-