' $linesize:132 ' $title: 'RBBSSUB3.BAS CPC17.2B, Copyright 1986 - 89 by D. Thomas Mack' ' Copyright 1989 by D. Thomas Mack, all rights reserved. ' Name ...............: RBBSSUB3.BAS ' Written by .........: D. Thomas Mack ' First Released .....: May 28, 1989 ' Subsequent Releases.: 05-28-89 ' Copyright ..........: 1986 - 1989 ' Purpose.............: The Remote Bulletin Board System for the IBM PC, ' RBBS-PC.BAS utilizes a lot of common subroutines. Those that do not ' require error trapping are incorporated within RBBSSUB 2-5 as ' separately callable subroutines in order to free up as much ' code as possible within the 64K code segment used by RBBS-PC.BAS. ' Parameters..........: Most parameters are passed via a COMMON statement. ' ' Subroutine Line Function of Subroutine ' Name Number ' ALLCAPS 58060 Convert a string to all upper case characters ' AMORPM 41498 Calculate the current time as AM or PM ' ASKGRAPH 43004 Determine users graphic default ' BADFILE 20741 Check for system crash attempt with bad device name ' CARRIER 42000 Test for Carrier present ' CHECKRATIO 20096 Test upload/download ratio ' CHECKTIM 58070 Test to insure that users don't exceed their time ' CHKNEWBUL 58110 Check for new bulletins based on their file creation date ' CHKTREMAIN 41008 Set up to log off if time exceeded ' COMMINFO 44020 Get users baud rate and parity in a string format ' CTLINES 58160 Count categories a file can be classified into ' CTNEWFILES 58150 Check for number of files uploaded after a specific date ' DELAYIT 50495 Wait number of seconds specified before returning ' DISPCALL 57001 Display callers file ' DISPLAYTR 41032 Compute and display time remaining ' DISUPDIR 58165 Display the shared directory of the FMS mng. sys. ' FILELOCK 21993 Allow files to be shared among multiple RBBS-PC's ' FINDFUNC 30595 Handle local keyboard's function & SYSOP's keys ' FINDLAST 58600 Finds last occurence of a string in a string ' FINDTIME 58050 Calculate the number of seconds since midnight ' GRAPHIC 43031 Determines whether graphic version of file exists ' HASHRBBS 58080 "Hash" to a user's record in the USERS file ' INITFMS 58162 Initialize the RBBS-PC's File Management System ' INITIBM 30000 Open/create NETBIOS semaphore file ' INSCOMMA 58130 Format commands in the command prompt ' LIBRARY 21105 Provide support for "library" drives ' LINESNFIL 58161 Counts lines in a file ' LOADNEW 58140 Find the latest uploads ' MODEMPUT 52070 Write a modem command string to the modem ' OPENMSG 30500 Open the messages file as file number 1 ' PAGEUP 33202 Display user info. on local screen for SYSOP ' READPROF 44000 Read user's profile on return from a "door" ' SAVEPROF 43068 Save the user's provile when exiting to "doors" or DOS ' SENDNAME 20293 Send filename via EXEC-PC protocol during autodownload ' SETOPTS 58100 Set correct prompt line for each subsystem ' SRTSTRNG 58120 Sort characters in a string ' TESTUSER 20310 Check if user's software can do auto downloading ' TIMEREMAIN 41010 Compute time remaining in minutes ' UPDTUPLOAD 20705 Updates upload directory file ' WILDFILE 20290 Determines whether string matches a pattern ' XFERTYPE 21600 Identify the file transfer protocol ' ' $INCLUDE: 'RBBS-VAR.BAS' ' 20290 ' $SUBTITLE: 'WILDFILE -- Matches file to a filespec' ' $PAGE ' NAME -- WILDFILE ' ' INPUTS -- PARAMETER MEANING ' PATTERN$ PATTERN TO CHECK AGAINST ' ITEM.TO.MATCH$ FILE NAME TO MATCH ' ' OUTPUTS -- DOES.MATCH WHETHER MATCHES ' ' PURPOSE Determine whether a file name is an instance of ' a file specification. Exactly like DOS except that ? must have a ' character. ' SUB WILDFILE (PATTERN$,ITEM.TO.MATCH$,DOES.MATCH) STATIC IF PATTERN$ <> PREV.PATTERN$ THEN _ CALL BRKFNAME (PATTERN$,PDR$,PPREFIX$,PEXT$,FALSE) : _ PREV.PATTERN$ = PATTERN$ CALL BRKFNAME (ITEM.TO.MATCH$,IDR$,IPREFIX$,IEXT$,FALSE) DOES.MATCH = FALSE IF PDR$ <> "" AND PDR$ <> IDR$ THEN _ EXIT SUB CALL WILDCARD (PPREFIX$,IPREFIX$) IF NOT OK THEN _ EXIT SUB CALL WILDCARD (PEXT$,IEXT$) DOES.MATCH = OK END SUB 20293 ' $SUBTITLE: 'SENDNAME - send FILENAME using EXEC-PC protocol' ' $PAGE ' ' NAME -- SENDNAME ' ' INPUTS -- PARAMETER MEANING ' B$() ARRAY OF FILENAME FOR AUTODOWNLOAD ' DWN.INDEX INDEX OF FILENAME TO TRANSFER ' ' OUTPUTS -- ABORT -1 FOR AN ABORTED ATTEMPT ' ' PURPOSE -- Send the download filename to user during an autodownload ' SUB SENDNAME STATIC ' ' ' * TRANSFER FILENAME TO USER ' * PROCESS - SEND USER THE "ALERT" CHARACTER SEQUENCE -- OD ' * THEN THIS IS FOLLOWED BY CHARACTER-BY-CHARACTER ' * TRANSMISSION OF THE FILENAME WITH ECHO. IF ANY OF THE ' * CHARACTERS OF THE FILENMAE ARE GARBLED A SERIES OF ' * ARE SENT, OTHERWISE AN IS SENT AT ' * COMPLETION AND FILE TRANSFER BEGINS. ' ' ABORT = FALSE ' RESET ABORT FLAG ATTEMPTS = 0 ' RESET COUNT FOR # OF TRANS ATTEMPTS 20295 CALL DELAYIT (1) ' ONE SECOND DELAY 20296 CALL FLUSHCOM(Y$) ' CLEAR THE COMM BUFFER OF GARBAGE IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB CALL PUTCOM (ESCAPE$+"OD") ' SEND "ALERT" STRING IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB IF ABORT = TRUE THEN _ GOTO 20306 CALL LPRNT("Sending FILENAME -- ",1) CALL LPRNT(RETURN.LINE.FEED$ + CHR$(9),0) CALL DELAYIT (1) ' WAIT 1 SECOND FOR SETUP ' ' SEND ONE CHARACTER AT A TIME ' CALL BRKFNAME (B$(DWN.INDEX),X$,A$,Y$,TRUE) A$ = A$ + Y$ + "=X" FOR X = 1 TO LEN(A$) CALL PUTCOM (MID$(A$,X,1)) ' SEND 1 CHARACTER IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB IF ABORT = TRUE THEN _ GOTO 20306 CALL LPRNT(MID$(A$,X,1),0) ' DISPLAY IF NEEDED IF TIMER < 86390! THEN _ DELAY! = TIMER + 10 _ ELSE DELAY! = TIMER - 86400! + 10 ' SET MAXIMUM TIME TO WAIT FOR REPLY CHAR% = TRUE WHILE CHAR% = -1 IF TIMER > DELAY! THEN _ GOTO 20300 ' IF NO ECHO, CANCEL FILENAME TRANSFER CALL EOFCOMM (CHAR%) WEND ' JUMP OUT IF CHARACTER IS RECEIVED 20298 CALL FLUSHCOM(Y$) ' COLLECT CHARACTER(S) USER ECHOED IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB IF MID$(A$,X,1) = Y$ THEN _ GOTO 20305 ' IF CORRECTLY ECHOED, THEN CONTINUE IF INSTR(Y$,CANCEL$) THEN _ ABORT = TRUE : _ GOTO 20306 ' CHECK FOR USER ABORT 20300 CALL PUTCOM (STRING$(5,24)) ' TELL USER THAT FILE NAME IS GARBLED IF SUBROUTINE.PARAMETER = - 1 THEN _ EXIT SUB IF ABORT = TRUE THEN _ GOTO 20306 CALL LPRNT("Name Trans Failure",1) ' DISPLAY FAILURE ON SCREEN ATTEMPTS = ATTEMPTS + 1 ' INCREMENT COUNTER FOR # OF TRIES IF ATTEMPTS < 6 THEN _ ' TRY IT FIVE TIMES, THEN GIVE UP GOTO 20295 CALL PUTCOM (STRING$(50,24)) ' GUARANTEE CANCELLATION OF USER IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB IF ABORT = TRUE THEN _ GOTO 20306 IF SNOOP THEN _ CALL LPRNT("ABORTING AUTODOWNLOAD!",1) : _ ABORT = TRUE : _ GOTO 20306 ' 20305 NEXT ' LOOP BACK FOR NEXT CHARACTER ' CALL PUTCOM (ACKNOWLEDGE$) ' WHEN FILENAME SENT, ACKNOWLEDGE IF SUBROUITNE.PARAMETER = -1 THEN _ EXIT SUB CALL SKIPLINE(1) ' CLEAN UP SYSOP'S DISPLAY ' ' COMPLETION OF AUTODOWNLOAD FILENAME TRANSFER ' 20306 END SUB 20310 ' $SUBTITLE: 'TESTUSER - interrogate user for AUTO-DOWNLOADING support' ' $PAGE ' ' NAME -- TESTUSER ' ' INPUTS -- NONE ' ' OUTPUTS -- AUTODOWNLOAD.AVAILABLE -1 IF USER'S COMMUNICATION ' SOFTWARE CAN DO AUTODOWNLOADING ' ' AUTODOWNLOAD.VERIFIED TRUE IF COMMUNICATIONS PGM ' EVER CHECKED ' ' PURPOSE -- Send the user an and if response ' is a recognized package, set appropriate flag. ' SUB TESTUSER STATIC ' ' ' * TEST FOR COMMUNICATIONS USING N,8,1 PROTOCOL AND EXECPC TALK VER 2.0+ ' * TO SEE IF CALLER CAN USE THE AUTODOWNLOAD FEATURE ' ' ABORT = FALSE AUTODOWNLOAD.VERIFIED = TRUE CALL FLUSHCOM(Y$) ' FLUSH THE COMM BUFFER IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB CALL PUTCOM (ESCAPE$ + XON$) IF ABORT = TRUE THEN _ GOTO 20315 CALL DELAYIT (2) ' WAIT TWO SECONDS FOR REPLY 20313 CALL FLUSHCOM(Y$) ' GET CONTENTS OF COMM BUFFER IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB IF INSTR(Y$,"EXECPC") THEN _ COM.PROGRAM = 1 IF INSTR(Y$,"PIBTERM") THEN _ COM.PROGRAM = 2 IF INSTR(Y$,"PROCOMM") THEN _ COM.PROGRAM = 3 IF INSTR(Y$,"QMODEM") THEN _ COM.PROGRAM = 4 AUTODOWNLOAD.AVAILABLE = (COM.PROGRAM > 0 AND COM.PROGRAM < 3) 20315 END SUB 20705 ' $SUBTITLE: 'UPDTUPLOAD -- Updates upload directory' ' $PAGE ' NAME -- UPDTUPLOAD ' ' INPUTS -- PARAMETER MEANING ' FILE.NAME$ ' UPLOAD.DIRECTORY$ ' FILE.NAME.HOLD$ ' SHARE.IT ' FMS.DIRECTORY$ ' Q! ' TCA! ' ' OUTPUTS -- BYTES.IN.FILE# ' SECONDS.PER.SESSION! ' ' PURPOSE -- Upon a successful upload, add entry to the upload ' directory and give any session time credit. ' SUB UPDTUPLOAD (CATEGORY.NAME$(1),CATEGORY.CODE$(1), LINES.IN.DESC) STATIC IF GET.EXT.DESC THEN _ GOTO 20723 GOSUB 20734 CALL TIMEREMAIN (TIME.REMAINING!) IF PRIVATE.DOOR THEN _ X! = UPLOAD.TIME.FACTOR! * Q! _ ELSE X! = UPLOAD.TIME.FACTOR! * (TCA! - Q!) CALL BRKFNAME (FILE.NAME$,PRE$,BODY$,EXT$,FALSE) X$ = DISK.FOR.DOS$ + "T" + EXT$ + ".BAT" CALL FINDIT (X$) IF NOT OK THEN _ GOTO 20708 CALL QTPUT1 ("Verifying file integrity...") : _ CALL READDIR (2,1) IF EOF(2) THEN _ X$ = A$ : _ GSR.ARA$(1) = FILE.NAME$ : _ GSR.ARA$(2) = NODE.WORK.FILE$ _ ELSE X$ = X$ + " " + _ FILE.NAME$ + " " + NODE.WORK.FILE$ CALL SHELLEXIT (X$) CALL FINDIT (NODE.WORK.FILE$) IF OK THEN _ IF LOF(2) > 2 THEN _ BYTES.IN.FILE# = 0.0 : _ X$ = "Deleting BAD upload " + FILE.NAME.HOLD$ : _ CALL QTPUT1 (X$) : _ CALL UPDTCALR (X$,2) : _ CALL KILLWORK (FILE.NAME$) : _ EXIT SUB 20708 X$ = DISK.FOR.DOS$ + "C" + EXT$ + DEFAULT.EXTENSION$ + ".BAT" CALL FINDIT (X$) IF NOT OK THEN _ GOTO 20709 A$ = "Converting" IF EXT$ = DEFAULT.EXTENSION$ THEN _ A$ = "Re-" + A$ CALL QTPUT1 (A$ + " upload to "+DEFAULT.EXTENSION$+". Please wait...") CALL READDIR (2,1) IF EOF(2) THEN _ X$ = A$ GSR.ARA$(1) = FILE.NAME$ CALL BRKFNAME (FILE.NAME$,PRE$,BODY$,EXT$,TRUE) FILE.NAME.HOLD$ = BODY$ + "." + DEFAULT.EXTENSION$ B$(0) = FILE.NAME$ FILE.NAME$ = PRE$ + FILE.NAME.HOLD$ CALL SHELLEXIT (X$ + " " + BODY$ + " " + NODE.ID$) CALL FINDIT (FILE.NAME$) IF NOT OK THEN _ FILE.NAME$ = GSR.ARA$(1) : _ CALL FINDIT (FILE.NAME$) : _ FILE.NAME.HOLD$ = BODY$ + EXT$ : _ IF OK THEN _ GOTO 20709 GOSUB 20736 20709 CALL QTPUT1 ("Upload successful") X$ = DATE$ Z$ = LEFT$(X$,6) + _ RIGHT$(X$,2) STREW.TO$ = "" UCAT$ = "" 20710 CALL QTPUT1 ("Describe " + FILE.NAME.HOLD$ + _ " (Begin with '/' if for SYSOP only)") CALL QTPUT1 (LEFT$(" |----+--Min<..-+---2+0---+---3+0---+---4+0---+-", _ MAX.DESC.LEN - 4) + "..Max>") CALL QTPUT ("? ",0) A$ = "" SUBROUTINE.PARAMETER = 1 PARSE.OFF = TRUE CALL TGET CALL CARRIER IF SUBROUTINE.PARAMETER = -1 THEN _ B$ = "": _ GOTO 20712 IF LEN(B$) > MAX.DESC.LEN OR LEN(B$) < 10 THEN _ CALL QTPUT1 ("10 chars min," + STR$(MAX.DESC.LEN) + " max") : _ GOTO 20710 20712 OK = 0 CALL CHECKNOVELL (OK) IF OK <> -1 THEN _ CALL SETSHAREDATTR (FILE.NAME$, OK) : _ IF OK <> 0 THEN _ CALL PSCRN ("Error setting shared attribute") DESC$ = B$ IF NOT LIMIT.SEARCH.TO.FMS THEN _ IF FMS.DIRECTORY$ <> UPLOAD.DIRECTORY$ THEN _ IF LEFT$(B$,1) = "/" THEN _ CALL UPDTCALR (B$,2) : _ GOTO 20726_ ELSE GOTO 20717 20715 IF LEFT$(B$,1) = "/" THEN _ UCAT$ = "***" : _ GOTO 20722 UCAT$ = DEFAULT.CATEGORY.CODE$ 20717 IF SUBROUTINE.PARAMETER = -1 OR _ USER.SECURITY.LEVEL < SL.CATEGORIZE.UPLOADS THEN _ GOTO 20722 20719 CALL BUFFILE (UPCAT.HELP$,X) 20720 A$= "Upload best fits what category (D=default,H=help)" ' KG072201 SUBROUTINE.PARAMETER = 1 CALL TGET CALL ALLCAPS (B$(1)) ' KG072201 IF SUBROUTINE.PARAMETER = -1 OR B$(1) = "D" THEN _ ' KG072201 B$ = DEFAULT.CATEGORY.CODE$ : _ GOTO 20722 IF Q = 0 THEN _ GOTO 20719 ' KG072201 IF B$(1) = "H" OR _ B$(1) = "*" OR _ B$(1) = "?" THEN _ GOTO 20719 CALL CHKNARY (B$(1),CATEGORY.NAME$(),NUM.CATEGORIES,FOUND) IF FOUND > 0 THEN _ UCAT$ = CATEGORY.CODE$(FOUND) : _ IF LEN(UCAT$) > 0 AND LEN(UCAT$) < 4 AND INSTR(UCAT$,",") = 0 THEN _ GOTO 20722 UCAT$ = "" IF NOT LIMIT.SEARCH.TO.FMS THEN _ STREW.TO$ = DIRECTORY.PATH$ + _ B$(1) + _ "." + _ DIRECTORY.EXTENTION$ : _ CALL FINDIT (STREW.TO$) : _ IF OK THEN _ ' KG072201 GOTO 20722 _ ' KG072201 ELSE CALL WORDINFILE (UPCAT.HELP$,B$(1),OK) : _ ' KG072201 IF OK THEN _ ' KG072201 GOTO 20722 ' KG072201 STREW.TO$ = "" ' KG072201 CALL QTPUT1 ("No such category " + B$(1)) GOTO 20719 20722 IF USER.SECURITY.LEVEL >= ASK.EXTENDED.DESC AND _ MAX.EXTENDED.LINES > 0 AND SUBROUTINE.PARAMETER <> -1 THEN _ A$ = "Add an EXTENDED DESCRIPTION of " + _ FILE.NAME.HOLD$ + " ([Y],N)" : _ TURBO.KEY = -TURBO.KEY.USER : _ SUBROUTINE.PARAMETER = 1 : _ CALL TGET : _ IF SUBROUTINE.PARAMETER <> -1 THEN _ IF NOT NO THEN _ GET.EXT.DESC = TRUE : _ EXIT SUB 20723 B$ = DESC$ X$ = DATE$ Z$ = LEFT$(X$,6) + _ RIGHT$(X$,2) EN$ = STREW.TO$ GOSUB 20730 EN$ = ALWAYS.STREW.TO$ GOSUB 20730 20725 EN$ = UPLOAD.DIRECTORY$ GOSUB 20730 20726 DF$ = " >> uploaded << " UPLOADS = UPLOADS + 1 GLOBAL.UPLOADS = GLOBAL.UPLOADS + 1 ULBYTES! = ULBYTES! + BYTES.IN.FILE# GLOBAL.ULBYTES! = GLOBAL.ULBYTES! + BYTES.IN.FILE# CALL MUZAK (7) CALL TIMEREMAIN (TIME.REMAINING!) TIME.CREDITS! = TIME.CREDITS! + X! SECONDS.PER.SESSION! = SECONDS.PER.SESSION! + X! IF PRIVATE.DOOR THEN _ X! = (X! - Q!) / 60.0 _ ELSE X! = (X! - TCA! + Q!)/60.0 X$ = STR$(FIX(X!*10.0)) X$ = LEFT$(X$,LEN(X$)-1) + "." + RIGHT$(X$,1) IF X! > 1.0 THEN _ CALL QTPUT1 ("Uploads are appreciated here. For today your") : _ CALL QTPUT1 ("SESSION & DAILY time limits increased by"+X$+" minutes") GET.EXT.DESC = FALSE EXIT SUB 20730 ' ---[ lock file ]--- IF EN$ = "" THEN _ RETURN FMS.FORMAT = FALSE IF EN$ = FMS.DIRECTORY$ OR LIMIT.SEARCH.TO.FMS THEN _ FMS.FORMAT = TRUE _ ELSE CALL FINDIT (EN$) : _ IF OK THEN _ CALL READDIR (2,1) : _ IF EC = 0 THEN _ FMS.FORMAT = (LEFT$(A$,4) = "\FMS") IF NOT FMS.FORMAT THEN _ READ.BACKWARDS = FALSE : _ FIXED.LEN = 0 : _ B$ = DESC$ _ ELSE FIXED.LEN = 34 + MAX.DESC.LEN : _ B$ = DESC$ + _ SPACE$(MAX.DESC.LEN - LEN(DESC$)) + _ UCAT$ + _ SPACE$(3 - LEN(UCAT$)) : _ READ.BACKWARDS = TRUE : _ CALL FINDIT (EN$) : _ IF OK THEN _ CALL READDIR (2,1) : _ IF EC = 0 THEN _ READ.BACKWARDS = (INSTR(A$," TOP ") = 0) CALL LOCKAPPND IF EC <> 0 THEN _ GOTO 20731 ' ---[ append ]--- IF GET.EXT.DESC THEN _ IF READ.BACKWARDS THEN _ FOR I = LINES.IN.DESC TO 1 STEP -1 : _ GOSUB 20732 : _ NEXT PRINT #2,USING "\ \######## & &"; _ FILE.NAME.HOLD$; _ BYTES.IN.FILE#; _ Z$; _ B$ IF GET.EXT.DESC THEN _ IF NOT READ.BACKWARDS THEN _ FOR I = 1 TO LINES.IN.DESC : _ GOSUB 20732 : _ NEXT 20731 CALL UNLKAPPND FIXED.LEN = 0 RETURN 20732 X$ = A$(I) CALL TRIM (X$) IF X$ = "" THEN _ RETURN IF NOT FMS.FORMAT THEN _ PRINT #2," ";A$(I) : _ RETURN IF FIXED.LEN > LEN(A$(I)) THEN _ X$ = SPACE$(FIXED.LEN - 1 - LEN(A$(I))) + "." _ ELSE X$ = "" PRINT #2, " ";LEFT$(A$(I),FIXED.LEN);X$ RETURN 20734 CALL FINDIT (FILE.NAME$) 20736 IF NOT OK THEN _ BYTES.IN.FILE# = 0.0_ ELSE BYTES.IN.FILE# = LOF(2) IF BYTES.IN.FILE# < 2.0 THEN _ EXIT SUB RETURN END SUB 20741 ' $SUBTITLE: 'BADFILE - subroutine to find bad file names' ' $PAGE ' ' NAME -- BADFILE ' ' INPUTS -- PARAMETER MEANING ' VIOLATION$ ' VIOLATIONS.THIS.SESSION ' FILNAME$ NAME OF FILE ' ' OUTPUTS -- RESULT 1 = FILE NAME IS OK ' 2 = CHARACTER NOT ALLOWED ' 3 = SYSTEM CRASH ATTEMPT ' VIOLATIONS.THIS.SESSION NUMBER OF VIOLATIONS ' FILNAME$ Gets capitalized ' ' PURPOSE -- To protect RBBS-PC against the use of bad file names ' to either crash the system or to breach RBBS-PC's security. ' SUB BADFILE (FILNAME$,RESULT) STATIC ' ' ' * TEST FOR INVALID CHARACTERS IN FILENAME ' ' RESULT = 2 IF LEN(FILNAME$) < 1 THEN _ EXIT SUB CALL BADFILECHAR (FILNAME$,OK) IF NOT OK THEN _ EXIT SUB IF RIGHT$(FILNAME$,1) = "." THEN _ EXIT SUB CALL ALLCAPS (FILNAME$) XX = INSTR(FILNAME$,".") IF XX > 0 THEN _ XX = INSTR(XX + 1,FILNAME$,".") : _ IF XX > 0 THEN _ EXIT SUB XX = LEN(FILNAME$) IF XX => 3 THEN _ IF INSTR("PRN:CON:AUX:NUL:",FILNAME$) THEN _ GOTO 20742 IF XX => 4 THEN _ IF INSTR("COM1:COM2:LPT1:LPT2:LPT3:SCRN:KYBD:CONS:",FILNAME$) THEN _ GOTO 20742 CALL BRKFNAME (FILNAME$,PRE$,BODY$,EXT$,FALSE) IF LEN(PRE$) > 64 OR LEN(BODY$) > 8 OR LEN(BODY$) < 1 OR LEN(EXT$) > 3 THEN _ EXIT SUB XX = LEN(BODY$) IF XX => 3 THEN _ IF INSTR("PRN:CON:AUX:NUL:",BODY$) THEN _ GOTO 20742 IF XX => 4 THEN _ IF INSTR("COM1:COM2:LPT1:LPT2:LPT3:SCRN:KYBD:CONS:",BODY$) THEN _ GOTO 20742 RESULT = 1 EXIT SUB 20742 VIOLATIONS.THIS.SESSION = MAXIMUM.VIOLATIONS VIOLATION$ = VIOLATION$ + _ FILNAME$ RESULT = 3 END SUB ' 21105 ' $SUBTITLE: 'LIBRARY - sub to support Library downloads' ' $PAGE ' ' NAME -- LIBRARY ' ' INPUTS -- PARAMETER MEANING ' SUBROUTINE.PARAMETER 1 = DISPLAY ACTIVE AREA ' 2 = CHANGE ACTIVE AREA ' 3 = DISPLAY PC-SIG ' DISCLAIMER ' 4 = ARCHIVE LIBRARY DISK ' 5 = DOWNLOAD COMPLETED ' LIBRARY.TYPE 0 = NO LIBRARY ACTIVE ' 1 = LIBRARY FROM PC-SIG ' LIBRARY.DRIVE$ LIBRARY DRIVE ID ' ' OUTPUTS -- NONE ' ' PURPOSE -- To provide access support for library drives ' SUB LIBRARY STATIC STATIC LIBRARY.SUBDIR.NAME$(1) STATIC DISK.TITLE$ EC = 0 IF LIBRARY.TYPE = 0 THEN _ EXIT SUB IF LIBRARY.DISK.CHAR$ = "" THEN _ LIBRARY.DISK.CHAR$ = "0000" ON SUBROUTINE.PARAMETER GOTO 21110, 21115, 21130, 21140, 21159 21110 IF LIBRARY.DISK.CHAR$ = "0000" THEN _ A$ = "No Library disk currently selected" _ ELSE A$ = "Library disk " + _ LIBRARY.DISK.CHAR$ + _ " selected - " + _ DISK.TITLE$ CALL QTPUT1 (A$) IF LIBRARY.DISK.ARCHIVE$ = "" THEN _ EXIT SUB FOR LIBRARY.DISPLAY.COUNT = 0 TO LIBRARY.LOOP.COUNT - 1 IF LIBRARY.SUBDIR.NAME$(LIBRARY.DISPLAY.COUNT) <> "" THEN _ CALL QTPUT1 (LIBRARY.SUBDIR.NAME$(LIBRARY.DISPLAY.COUNT) + _ "." + DEFAULT.EXTENSION$ + " ready for transmission!") NEXT EXIT SUB 21115 IF Q = 1 THEN _ A$ = "Change Library disk from " + _ LIBRARY.DISK.CHAR$ + _ " to (1 -" + _ STR$(LIBRARY.MAX.DISK) + _ ")" : _ SUBROUTINE.PARAMETER = 1 : _ CALL TGET : _ IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB _ ELSE IF Q = 0 THEN _ LIBRARY.DISK.CHAR$ = "0000" : _ CHDIR.LIBRARY$ = LIBRARY.DRIVE$ + _ "\" : _ GOTO 21126 21117 IF VAL(B$(Q)) < 1 OR VAL(B$(Q)) > LIBRARY.MAX.DISK THEN _ Q = 1 : _ GOTO 21115 21120 LIBRARY.DISK.CHAR$ = B$(Q) CLOSE 2 LIBRARY.DISK.CHAR$ = RIGHT$("0000" + LIBRARY.DISK.CHAR$,4) 21121 CALL FINDIT("RBBS-CDR.DEF") IF EC <> 0 THEN _ EXIT SUB 21122 IF EOF(2) THEN _ LIBRARY.DISK.CHAR$ = "" : _ EXIT SUB INPUT #2,WORK.SUBDIR$,CHDIR.LIBRARY$ LINE INPUT #2,DISK.TITLE$ IF LIBRARY.DISK.CHAR$ = WORK.SUBDIR$ THEN _ CHDIR.LIBRARY$ = LIBRARY.DRIVE$ + _ CHDIR.LIBRARY$ : _ GOTO 21126 GOTO 21122 21126 EC = 0 CALL CHANGEDIR (CHDIR.LIBRARY$) IF EC <> 0 THEN _ LIBRARY.DISK.CHAR$ = "0000" : _ CHDIR.LIBRARY$ = LIBRARY.DRIVE$ + _ "\" : _ GOTO 21126 EXIT SUB 21130 IF LIBRARY.TYPE <> 1 THEN _ EXIT SUB CALL SKIPLINE(1) A$ = "PC-SIG Library is being accessed. The file that you are about" CALL QTPUT1 (A$) A$ = "to download can also be obtained by ordering DISK " + _ LIBRARY.DISK.CHAR$ CALL QTPUT1 (A$) A$ = "from PC-SIG, 1030D East Duane Ave. Sunnyvale, Ca. 94086" CALL QTPUT (A$,2) EXIT SUB 21140 IF LIBRARY.DISK.CHAR$ = "0000" THEN _ CALL QTPUT1 ("You must select a LIBRARY disk first!") : _ EXIT SUB A$ = "Archive contents of Library disk - " + _ LIBRARY.DISK.CHAR$ + _ " for data transmission (Y/[N])" SUBROUTINE.PARAMETER = 1 CALL TGET IF NOT LOCAL.USER THEN _ IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB IF NOT YES THEN _ EXIT SUB 21145 CALL KILLWORK (LIBRARY.WORK.DISK.PATH$ + _ LIBRARY.NODE.ID$ + _ "DK*." + DEFAULT.EXTENSION$) 21150 CALL QTPUT1 ("Work/RAM disk has been purged") CALL QTPUT1 ("Beginning archive using " + _ LIBRARY.ARCHIVE.PROGRAM$ + _ " Please be patient!") REDIM LIBRARY.SUBDIR.NAME$(10) LIBRARY.SUBDIR.CHAR$ = "" LIBRARY.LOOP.COUNT = 0 GOSUB 21157 A$ = "Contents of Library disk - " + _ LIBRARY.DISK.CHAR$ + _ " now archived for data transmission" CALL QTPUT1 (A$) A$ = "Searching for Sub-directories" CALL QTPUT1 (A$) GOSUB 21158 LIBRARY.DISK.ARCHIVE$ = LIBRARY.DISK.CHAR$ ' ' SEARCH AND ARCHIVE ANY SUBDIRECTORIES ' TREEDIR$ = LIBRARY.WORK.DISK.PATH$ + _ LIBRARY.NODE.ID$ + _ "DKDIR.LST" DIRCMD$ = "DIR " + _ LIBRARY.DRIVE$ + _ " | FIND " + _ CHR$(34) + _ " " + _ CHR$(34) + _ " > " + _ TREEDIR$ 21151 SHELL DIRCMD$ CALL SKIPLINE (2) LOCATE 24,1 EC = 0 21152 CLOSE 2 21153 CALL OPENWORK (2,TREEDIR$) LIBRARY.SUBDIR.COUNT = 0 WHILE NOT EOF(2) LINE INPUT #2, DIRREC$ IF LEFT$(DIRREC$,1) <> "." THEN _ LIBRARY.SUBDIR.COUNT = LIBRARY.SUBDIR.COUNT + 1 : _ LIBRARY.SUBDIR.NAME$(LIBRARY.SUBDIR.COUNT) = _ LEFT$(DIRREC$,8) WEND CLOSE 2 LIBRARY.LOOP.COUNT = 1 IF LIBRARY.SUBDIR.COUNT = 0 THEN _ GOTO 21156 A$ = "There are" + STR$(LIBRARY.SUBDIR.COUNT) + _ " Subdirectories on LIBRARY disk - " + _ LIBRARY.DISK.CHAR$ CALL QTPUT1 (A$) FOR LIBRARY.LOOP.COUNT = 1 TO LIBRARY.SUBDIR.COUNT IF NOT LOCAL.USER THEN _ CALL CARRIER : _ IF SUBROUTINE.PARAMETER THEN _ GOTO 21155 LIBRARY.SUBDIR.CHAR$ = MID$("ABCDEFGHI",LIBRARY.LOOP.COUNT,1) A$ = "Creating " + _ LIBRARY.NODE.ID$ + _ "DK" + _ LIBRARY.DISK.CHAR$ + _ LIBRARY.SUBDIR.CHAR$ + _ ".ARC using " + LIBRARY.ARCHIVE.PROGRAM$ CALL QTPUT1 (A$) CHDIR CHDIR.LIBRARY$ + _ "\" + _ LIBRARY.SUBDIR.NAME$(LIBRARY.LOOP.COUNT) GOSUB 21157 A$ = "Disk - " + _ LIBRARY.DISK.CHAR$ + _ "; Subdirectory" + _ " -" + _ STR$(LIBRARY.LOOP.COUNT) + _ " has been archived for data transmission" CALL QTPUT1 (A$) GOSUB 21158 21155 NEXT LIBRARY.LOOP.COUNT 21156 CALL CARRIER A$ = "" EXIT SUB 21157 LIBRARY.ARCHIVE$ = LIBRARY.ARCHIVE.PATH$ + _ LIBRARY.ARCHIVE.PROGRAM$ + _ " " + _ LIBRARY.WORK.DISK.PATH$ + _ LIBRARY.NODE.ID$ + _ "DK" + _ LIBRARY.DISK.CHAR$ + _ LIBRARY.SUBDIR.CHAR$ + _ " " + _ LIBRARY.DRIVE$ + _ "*.*" IF USE.DEVICE.DRIVER$ <> "" AND FOSSIL THEN _ LIBRARY.ARCHIVE$ = DISK.FOR.DOS$ + _ "COMMAND /C " + _ LIBRARY.ARCHIVE$ + _ " > " + _ USE.DEVICE.DRIVER$ SHELL LIBRARY.ARCHIVE$ CALL SKIPLINE (2) LOCATE 24,1 RETURN 21158 LIBRARY.SUBDIR.NAME$(LIBRARY.LOOP.COUNT) = LIBRARY.NODE.ID$ + _ "DK" + _ LIBRARY.DISK.CHAR$ + _ LIBRARY.SUBDIR.CHAR$ RETURN 21159 FOR LIBRARY.DISPLAY.COUNT = 0 TO LIBRARY.LOOP.COUNT - 1 IF LIBRARY.SUBDIR.NAME$(LIBRARY.DISPLAY.COUNT) = A$ THEN _ LIBRARY.SUBDIR.NAME$(LIBRARY.DISPLAY.COUNT) = "" NEXT END SUB 21598 ' $SUBTITLE: 'XFERTYPE - sub to identify file xfer protocol' ' $PAGE ' ' NAME -- XFERTYPE ' ' INPUTS -- PARAMETER MEANING ' A$ ' B$(1) ' Q ' RELIABLE.MODE ' TRANSFER.OPTIONS$ ' USER.TRANSFER.DEFAULT$ ' XFER.SUPPORT ' ' OUTPUTS -- CHECKSUM ' FLEN ' FT$ ' ' PURPOSE -- To identify the file transfer protocol (either ' from the user's default or via explicit selection) ' SUB XFERTYPE(INDEX,SKIP.HELP) STATIC IF TRANSFER.OPTIONS$ = "" OR USER.SECURITY.LEVEL <> PREV.USL THEN _ CALL PROTOCOL : _ PREV.USL = USER.SECURITY.LEVEL X$ = A$ + "Protocol" ON INDEX GOTO 21600,21620 ' ' ' * MANUAL SELECT OF TRANSFER PROTOCOL ' ' 21600 IF SKIP.HELP THEN _ GOTO 21604 21602 CALL BUFFILE (HELP.PATH$ + "UF" + HELP.EXTENSION$,X) IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB 21604 CALL QTPUT1 (X$) STOP.INTERRUPTS = TRUE CALL BUFSTRNG (TRANSFER.OPTIONS$,4096,X) CALL QTPUT (MID$("?!",1-TURBO.KEY.USER,1)+" ",0) A$ = "" TURBO.KEY = -TURBO.KEY.USER SUBROUTINE.PARAMETER = 1 MACRO.MIN = 2 CALL TGET IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB IF Q = 0 THEN _ GOTO 21604 Z$ = B$(1) ' ' ' * DEFAULT SELECT OF TRANSFER PROTOCOL ' ' 21610 CALL ALLCAPS (Z$) IF INSTR("H?",Z$) > 0 THEN _ GOTO 21602 FF = INSTR(DFLTXFER$,Z$) IF FF < 1 THEN _ GOTO 21600 21612 FT$ = MID$(DFLTXFER$,FF,1) INTERNAL.PROTO$ = MID$(INTERNAL.EQUIV$,FF,1) GOTO 21621 21620 FF = -1 IF COMMAND.TRANSFER$ <> "" THEN _ Z$ = COMMAND.TRANSFER$ : _ GOTO 21610 X = INSTR(DFLTXFER$,USER.TRANSFER.DEFAULT$) IF X > 0 THEN _ IF MID$(INTERNAL.EQUIV$,X,1) <> "N" THEN _ Z$ = USER.TRANSFER.DEFAULT$ : _ GOTO 21610 PROTO.PROMPT$ = "None" FF = 0 EXIT SUB 21621 IF FF = PREV.FF AND PREV.PROTO.DEF$ = PROTO.DEF$ THEN _ PROTO.PROMPT$ = PREV.PROTO.PROMPT$ : _ EXIT SUB PREV.FF = FF PREV.PROTO.DEF$ = PROTO.DEF$ INTERNAL.PROTO$ = MID$(INTERNAL.EQUIV$,FF,1) CHECKSUM = (INTERNAL.PROTO$ = "X") CALL FINDIT (PROTO.DEF$) IF OK THEN _ GOTO 21623 X = INSTR("AXCYN",INTERNAL.PROTO$) IF X < 1 THEN _ INTERNAL.PROTO$ = "N" PROTO.PROMPT$ = MID$("Ascii Xmodem Xmodem/CRCYmodem None",10*INSTR("AXCYN",INTERNAL.PROTO$)-9,10) CALL TRIMTRAIL (PROTO.PROMPT$," ") CHECKSUM = (INTERNAL.PROTO$ = "X") FLEN = 128 - 896 * (INTERNAL.PROTO$ = "Y") BLOCK.SIZE = FLEN IF INTERNAL.PROTO$ = "Y" THEN _ SPEED.FACTOR! = 0.87 _ ELSE IF INTERNAL.PROTO$ = "A" THEN _ SPEED.FACTOR! = 0.92 _ ELSE SPEED.FACTOR! = 0.78 GOTO 21625 21623 CALL READPARMS (WORK.ARA$(),13,FF) IF EC > 0 THEN _ FF = LEN(DFLTXFER$) : _ EXIT SUB PROTO.PROMPT$ = WORK.ARA$(1) IF LEN(PROTO.PROMPT$) > 2 THEN _ IF MID$(PROTO.PROMPT$,2,1) = ")" THEN _ PROTO.PROMPT$ = LEFT$(PROTO.PROMPT$,1) + MID$(PROTO.PROMPT$,3) X = INSTR(PROTO.PROMPT$+CRLF$,CRLF$) PROTO.PROMPT$ = LEFT$(PROTO.PROMPT$,X-1) CALL TRIM (PROTO.PROMPT$) PROTO.METHOD$ = LEFT$(WORK.ARA$(3),1) CALL ALLCAPS (PROTO.METHOD$) REQ.8.BIT = (LEFT$(WORK.ARA$(4),1) = "8") DOWN.TEMPLATE$ = WORK.ARA$(12) UP.TEMPLATE$ = WORK.ARA$(13) X$ = WORK.ARA$(11) X = INSTR(X$,"=") ADVANCE.PROTO.WRITE = FALSE IF X < 2 OR X >= LEN(X$) THEN _ FAILURE.PARM = 4 : _ FAILURE.STRING$ = "F" _ ELSE FAILURE.PARM = VAL(LEFT$(X$,X-1)) : _ FAILURE.STRING$ = MID$(X$,X+1) : _ X = INSTR(FAILURE.STRING$,"=") : _ IF X > 0 THEN _ ADVANCE.PROTO.WRITE = (MID$(FAILURE.STRING$,X) = "=A") : _ FAILURE.STRING$ = LEFT$(FAILURE.STRING$,X-1) PROTO.MACRO$ = WORK.ARA$(10) FAKE.XRPT = (LEFT$(WORK.ARA$(8),1) = "F") BATCH.PROTO = (LEFT$(WORK.ARA$(6),1) = "B") SPEED.FACTOR! = VAL(WORK.ARA$(9)) IF SPEED.FACTOR! < 0.1 THEN _ SPEED.FACTOR! = 0.87 BLOCK.SIZE = VAL(WORK.ARA$(7)) FLEN = BLOCK.SIZE IF FLEN < 1 THEN _ FLEN = 128 21625 PREV.PROTO.PROMPT$ = PROTO.PROMPT$ END SUB 21993 ' $SUBTITLE: 'FILELOCK - subroutine to share RBBS-PC files' ' $PAGE ' ' NAME -- FILELOCK ' ' INPUTS -- PARAMETER MEANING ' SUBROUTINE.PARAMETER = 1 UNLOCK USERS AND MESSAGES ' 2 FLUSH MESSAGE RECORD TO DISK ' AND UNLOCK MESSAGES ' 3 LOCK MESSAGE FILE ' 4 UNLOCK MESSAGE FILE ' 5 LOCK USER FILE ' 6 LOCK 4 RECORD BLOCK IN USER ' FILE ' 7 UNLOCK USER FILE ' 8 UNLOCK 4 RECORD BLOCK IN USER ' FILE ' 9 LOCK UPLOAD DIRECTORY OR ' COMMENTS FILE ' 10 UNLOCK UPLOAD DIRECTORY OR ' COMMENTS FILE ' ACTIVE.MESSAGE FILE$ NAME OF MESSAGE FILE ' ACTIVE.USER.FILE$ NAME OF USER FILE ' CONFIG.FILE.NAME$ FILE NAME TO FLUSH RECORD FROM ' EN$ UPLOAD DIRECTORY OR COMMENTS ' FILE NAME TO LOCK/UNLOCK ' NETWORK.TYPE TYPE OF NETWORK LOCKING TO USE ' ' OUTPUTS -- SUBROUTINE.PARAMETER = -1 TERMINATE RBBS-PC IMMEDATELY ' BLK ' LOCK.DRIVE ' LOCK.FILE.NAME$ ' LOCK.STATUS$ ' MESSAGE.FILE.LOCK ' USER.BLOCK.LOCK ' USER.FILE.LOCK ' USER.FILE.INDEX ' ' PURPOSE -- To lock and unlock the shared RBBS-PC files when ' multiple copies of RBBS-PC are sharing the same ' files in either a multi-tasking DOS environment or ' in a local area network environment ' SUB FILELOCK STATIC ON SUBROUTINE.PARAMETER GOSUB 21995,21996,22000,25000,26000, _ 26500,27000,27500,29000,29500 EXIT SUB ' ' ' * UNLOCK USERS AND MESSAGES ' ' 21995 GOSUB 27000 GOSUB 25000 RETURN ' ' ' * FLUSH MESSAGE FILE DATA TO DISK BY OPENING DUMMY FILE # 1 ' ' 21996 CLOSE 1 IF SHARE.IT THEN _ OPEN CONFIG.FILENAME$ FOR INPUT SHARED AS #1 _ ELSE OPEN "I",1,CONFIG.FILENAME$ ' ' ' * UNLOCK MESSAGES ' ' GOSUB 25000 CALL OPENMSG RETURN ' ' ' * LOCK MESSAGE FILE ' ' 22000 IF MESSAGE.FILE.LOCK = TRUE THEN _ RETURN MESSAGE.FILE.LOCK = TRUE MID$(LOCK.STATUS$,1,2) = "LM" SUBROUTINE.PARAMETER = 2 CALL LINE25 LOCK.FILE.NAME$ = ACTIVE.MESSAGE.FILE$ ON NETWORK.TYPE GOTO 22100,22200,22300,22400,22500,29700 RETURN ' ' ' * LOCK MESSAGE FILE (MULTI-LINK) ' ' 22100 AX = &H0 BX = &H1 IF MULTI.LINK.PRESENT > 0 THEN _ CALL RBBSML(AX,BX) RETURN ' ' ' * LOCK MESSAGE FILE (OMNINET) ' ' 22200 CALL BRKFNAME (ACTIVE.MESSAGE.FILE$,DRV$,FPREFIX$,EXT$,FALSE) CC$ = CHR$(1) + _ LEFT$(FPREFIX$ + SPACE$(8),8) GOSUB 28000 IF CT = 0 THEN _ RETURN CALL DELAYIT (1) GOTO 22200 ' ' ' * LOCK MESSAGE FILE (ORCHID PC-NET) ' * LOCK USER FILE (ORCHID PC-NET) ' * LOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ (ORCHID PC-NET) ' ' 22300 GOSUB 28100 CALL LPLKIT(LOCK.DRIVE,LOCK.FILE.NAME$,A) RETURN ' ' ' * LOCK SYSTEM (DESQview) ' ' 22400 CALL DVLOCK("MESSAGE") RETURN ' ' ' * LOCK MESSAGE FILE (10 NET) ' * LOCK USER FILE (10 NET) ' * LOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ (10 NET) ' ' 22500 GOSUB 28100 CALL LPLK10(LOCK.DRIVE,LOCK.FILE.NAME$,A) RETURN ' ' ' * UNLOCK MESSAGE FILE ' ' 25000 IF NOT MESSAGE.FILE.LOCK THEN _ RETURN MESSAGE.FILE.LOCK = FALSE MID$(LOCK.STATUS$,1,2) = "UM" SUBROUTINE.PARAMETER = 2 CALL LINE25 LOCK.FILE.NAME$ = ACTIVE.MESSAGE.FILE$ ON NETWORK.TYPE GOTO 25100,25200,25300,25400,25500,29800 RETURN ' ' ' * UNLOCK MESSAGE FILE (MULTI-LINK) ' ' 25100 AX = &H100 BX = &H1 IF MULTI.LINK.PRESENT > 0 THEN _ CALL RBBSML(AX,BX) RETURN ' ' ' * UNLOCK MESSAGE FILE (OMNINET) ' ' 25200 CALL BRKFNAME (ACTIVE.MESSAGE.FILE$,DRV$,FPREFIX$,EXT$,FALSE) CC$ = CHR$(17) + _ LEFT$(FPREFIX$ + SPACE$(8),8) GOSUB 28000 IF CT = 128 THEN _ RETURN CALL DELAYIT (1) GOTO 25200 ' ' ' * UNLOCK MESSAGE FILE (ORCHID PC-NET) ' * UNLOCK USER FILE (ORCHID PC-NET) ' * UNLOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ (ORCHID PC-NET) ' ' 25300 GOSUB 28100 CALL UNLOKIT(LOCK.DRIVE,LOCK.FILE.NAME$,A) RETURN ' ' ' * UNLOCK MESSAGE FILE (DESQVIEW) ' ' 25400 CALL DVUNLOCK("MESSAGE") RETURN ' ' ' * UNLOCK MESSAGE FILE (10 NET) ' * UNLOCK USER FILE (10 NET) ' * UNLOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ (10 NET) ' ' 25500 GOSUB 28100 CALL UNLOK10(LOCK.DRIVE,LOCK.FILE.NAME$,A) RETURN ' ' ' * LOCK USER FILE ' ' 26000 IF USER.FILE.LOCK = TRUE THEN _ RETURN USER.FILE.LOCK = TRUE MID$(LOCK.STATUS$,4,2) = "LU" SUBROUTINE.PARAMETER = 2 CALL LINE25 LOCK.FILE.NAME$ = ACTIVE.USER.FILE$ ON NETWORK.TYPE GOTO 26100,26200,22300,26300,22500,29720 RETURN ' ' ' * LOCK USER FILE (MULTI-LINK) ' ' 26100 AX = &H0 BX = &H2 IF MULTI.LINK.PRESENT > 0 THEN _ CALL RBBSML(AX,BX) RETURN ' ' ' * LOCK USER FILE (OMNINET) ' ' 26200 CALL BRKFNAME (ACTIVE.USER.FILE$,DRV$,FPREFIX$,EXT$,FALSE) CC$ = CHR$(1) + _ LEFT$(FPREFIX$ + SPACE$(8),8) GOSUB 28000 IF CT = 0 THEN _ RETURN CALL DELAYIT (1) GOTO 26200 ' ' ' * LOCK USER FILE (DESQVIEW) ' ' 26300 CALL DVLOCK("USER") RETURN ' ' ' * LOCK 4 RECORD BLOCK IN USER FILE ' ' 26500 IF USER.BLOCK.LOCK = TRUE THEN _ RETURN USER.BLOCK.LOCK = TRUE BLK = (USER.FILE.INDEX / 4) + .26 MID$(LOCK.STATUS$,7,2) = "LB" SUBROUTINE.PARAMETER = 2 CALL LINE25 ON NETWORK.TYPE GOTO 26600,26700,26800,26750,26900,29730 RETURN ' ' ' * LOCK 4 RECORD BLOCK IN USER FILE (MULTI-LINK) ' ' 26600 AX = &H0 BX = BLK + 10 IF MULTI.LINK.PRESENT > 0 THEN _ CALL RBBSML(AX,BX) RETURN ' ' ' * LOCK 4 RECORD BLOCK IN USER FILE (OMNINET) ' ' 26700 CC$ = CHR$(1) + _ "BLK" + _ RIGHT$("0000" + MID$(STR$(BLK),2),5) GOSUB 28000 IF CT = 0 THEN _ RETURN CALL DELAYIT (1) GOTO 26700 ' ' ' * LOCK 4 RECORD BLOCK IN USER FILE (DESKVIEW) ' ' 26750 CALL DVLOCK("BLK" + RIGHT$("0000" + MID$(STR$(BLK),2),5)) RETURN ' ' ' * LOCK 4 RECORD BLOCK IN USER FILE (ORCHID PC-NET) ' ' 26800 LOCK.FILE.NAME$ = LEFT$(ACTIVE.USER.FILE$,2) + _ "BLK" + _ RIGHT$("0000" + MID$(STR$(BLK),2),5) GOTO 22300 ' ' ' * LOCK 4 RECORD BLOCK IN USER FILE (10 NET) ' ' 26900 LOCK.FILE.NAME$ = LEFT$(ACTIVE.USER.FILE$,2) + _ "BLK" + _ RIGHT$("0000" + MID$(STR$(BLK),2),5) GOTO 22500 ' ' ' * UNLOCK USER FILE ' ' 27000 IF NOT USER.FILE.LOCK THEN _ RETURN USER.FILE.LOCK = FALSE MID$(LOCK.STATUS$,4,2) = "UU" SUBROUTINE.PARAMETER = 2 CALL LINE25 LOCK.FILE.NAME$ = ACTIVE.USER.FILE$ ON NETWORK.TYPE GOTO 27100,27200,25300,27300,25500,29820 RETURN ' ' ' * UNLOCK USER FILE (MULTI-LINK) ' ' 27100 AX = &H100 BX = &H2 IF MULTI.LINK.PRESENT > 0 THEN _ CALL RBBSML(AX,BX) RETURN ' ' ' * UNLOCK USER FILE (OMNINET) ' ' 27200 CALL BRKFNAME (ACTIVE.USER.FILE$,DRV$,FPREFIX$,EXT$,FALSE) CC$ = CHR$(17) + _ LEFT$(FPREFIX$ + SPACE$(8),8) GOSUB 28000 IF CT = 128 THEN _ RETURN CALL DELAYIT (1) GOTO 27200 ' ' ' * UNLOCK USER FILE (DESQVIEW) ' ' 27300 CALL DVUNLOCK("USER") RETURN ' ' ' * UNLOCK 4 RECORD BLOCK IN USER FILE ' ' 27500 IF NOT USER.BLOCK.LOCK THEN _ RETURN USER.BLOCK.LOCK = FALSE BLK = (USER.FILE.INDEX / 4) + .26 MID$(LOCK.STATUS$,7,2) = "UB" SUBROUTINE.PARAMETER = 2 CALL LINE25 ON NETWORK.TYPE GOTO 27600,27700,27800,27750,27900,29830 RETURN ' ' ' * UNLOCK 4 RECORD BLOCK IN USER FILE (MULTI-LINK) ' ' 27600 AX = &H100 BX = BLK + 10 IF MULTI.LINK.PRESENT > 0 THEN _ CALL RBBSML(AX,BX) RETURN ' ' ' * UNLOCK 4 RECORD BLOCK IN USER FILE (OMNINET) ' ' 27700 CC$ = CHR$(17) + _ "BLK" + _ RIGHT$("0000" + MID$(STR$(BLK),2),5) GOSUB 28000 IF CT = 128 THEN _ RETURN CALL DELAYIT (1) GOTO 27700 ' ' ' * UNLOCK 4 RECORD BLOCK IN USER FILE (DESQVIEW) ' ' 27750 CALL DVUNLOCK("BLK" + RIGHT$("0000" + MID$(STR$(BLK),2),5)) RETURN ' ' ' * UNLOCK 4 RECORD BLOCK IN USER FILE (ORCHID PC-NET) ' ' 27800 LOCK.FILE.NAME$ = LEFT$(ACTIVE.USER.FILE$,2) + _ "BLK" + _ RIGHT$("0000" + MID$(STR$(BLK),2),5) GOTO 25300 ' ' ' * UNLOCK 4 RECORD BLOCK IN USER FILE (10-NET) ' ' 27900 LOCK.FILE.NAME$ = LEFT$(ACTIVE.USER.FILE$,2) + _ "BLK" + _ RIGHT$("0000" + MID$(STR$(BLK),2),5) GOTO 25500 ' ' ' * CORVUS OMNINET INTERFACE ' ' 28000 CC$ = LINE.FEED$ + _ CHR$(0) + _ CHR$(11) + _ CC$ CALL CDSEND(CC$) CALL CDRECV(CN$) CT = ASC(MID$(CN$,3,1)) IF CT => 128 THEN _ CALL LPRNT("CORVUS LOCK FAIL",1) : _ SUBROUTINE.PARAMETER = -1 28010 CT = ASC(MID$(CN$,4,1)) IF CT => 129 THEN _ CALL LPRNT("CORVUS FULL",1) : _ SUBROUTINE.PARAMETER = -1 RETURN ' ' ' * ORCHID PC-NET & 10 NET INTERFACE ' ' 28100 CALL ALLCAPS (LOCK.FILE.NAME$) LOCK.DRIVE = ASC(LEFT$(LOCK.FILE.NAME$,1)) - ASC("A") LOCK.FILE.NAME$ = LOCK.FILE.NAME$ + _ STRING$(32 - LEN(LOCK.FILE.NAME$),0) A = 0 RETURN ' ' ' * LOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ ' ' 29000 IF LOCKED.EN$ = EN$ THEN _ RETURN LOCKED.EN$ = EN$ MID$(LOCK.STATUS$,10,2) = "LD" SUBROUTINE.PARAMETER = 2 CALL LINE25 LOCK.FILE.NAME$ = EN$ ON NETWORK.TYPE GOTO 29100,29010,22300,29300,22500,29710 29010 RETURN ' ' ' * LOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ (MULTI-LINK) ' ' 29100 AX = &H0 BX = &H3 IF MULTI.LINK.PRESENT > 0 THEN _ CALL RBBSML(AX,BX) RETURN ' ' ' * LOCK UPLOAD DIRECTORY AND COMMENTS (DESQVIEW) ' ' 29300 CALL DVLOCK("MISC") RETURN ' ' ' * UNLOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ ' ' 29500 IF LOCKED.EN$ <> EN$ THEN _ RETURN LOCKED.EN$ = "" MID$(LOCK.STATUS$,10,2) = "UD" SUBROUTINE.PARAMETER = 2 CALL LINE25 LOCK.FILE.NAME$ = EN$ ON NETWORK.TYPE GOTO 29600,29510,25300,29650,25500,29810 29510 RETURN ' ' ' * UNLOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ (MULTI-LINK) ' ' 29600 AX = &H100 BX = &H3 IF MULTI.LINK.PRESENT > 0 THEN _ CALL RBBSML(AX,BX) EXIT SUB ' ' ' * UNLOCK UPLOAD DIRECTORY AND COMMENTS (DESQVIEW) ' ' 29650 CALL DVUNLOCK("MISC") RETURN ' ' ' * NETBIOS SEMAPHORE LOCK MECHANISM ' * Only the USERS file is actually locked. All other files are locked ' * by means of the semaphore file IBMFLAGS. Each IBMFLAGS record is a ' * file semaphore as follows: ' * RECORD 1 = MESSAGES file lock status ' * RECORD 2 = Comments/Upload dir locked ' * RECORD 3 = entire USERS file lock ' ' ' * Lock MESSAGES 29700 CALL NETBIOS (1,6,1) RETURN ' * Lock Comments/Upload dir 29710 CALL NETBIOS (1,6,2) RETURN ' * Lock USERS file 29720 CALL NETBIOS (1,6,3) RETURN ' * Lock single USERS record 29730 CALL NETBIOS (1,6,3) RETURN ' * UNLOCK MESSAGES 29800 CALL NETBIOS (0,6,1) RETURN ' * UNLOCK Comments/Upload dir 29810 CALL NETBIOS (0,6,2) RETURN ' * UNLOCK USERS file 29820 CALL NETBIOS (0,6,3) RETURN ' * UNLOCK single USERS record 29830 CALL NETBIOS (0,6,3) RETURN END SUB 30000 ' $SUBTITLE: 'INITIBM - sub to create/open NETBIOS semaphore file' ' $PAGE ' ' NAME -- INITIBM (Written by Doug Azzarito) ' ' INPUTS -- NONE ' ' OUTPUTS -- SUBROUTINE.PARAMETER = -1 ABORT RBBS ' ' PURPOSE -- Open semaphore file "IBMFLAGS" on default drive as file #6 ' Create file if it does not exits. ' SUB INITIBM STATIC ' ' ' * SEE IF FILE EXISTS ' ' SHARE.IT = TRUE FOR I = LEN(MAIN.MESSAGE.FILE$) TO 0 STEP -1 IF I = 0 THEN _ GOTO 30010 IF MID$(MAIN.MESSAGE.FILE$,I,1) = ":" OR _ MID$(MAIN.MESSAGE.FILE$,I,1) = "\" THEN _ GOTO 30010 NEXT 30010 IBM.FLAG.FILE$ = LEFT$(MAIN.MESSAGE.FILE$,I) + _ "IBMFLAGS" CALL FINDIT (IBM.FLAG.FILE$) CLOSE 2 IF OK THEN _ GOTO 30020 ' ' ' * CREATE A NEW FILE, EACH RECORD IS A SEMAPHORE ' ' OPEN IBM.FLAG.FILE$ ACCESS WRITE AS #6 LEN=2 FIELD 6, 2 AS LOCKBUF$ LSET LOCKBUF$ = MKI$(0) FOR I = 1 TO 3 PUT 6 NEXT CLOSE #6 30020 OPEN IBM.FLAG.FILE$ ACCESS READ WRITE SHARED AS #6 LEN=2 END SUB 30500 ' $SUBTITLE: 'OPENMSG - open the MESSAGES file' ' $PAGE ' ' NAME -- OPENMSG ' ' INPUTS -- PARAMETER MEANING ' ACTIVE.MESSAGE.FILE$ ' SHARE.IT ' ' OUTPUTS -- MESSAGE.RECORD$ ' SUB OPENMSG STATIC ' ' ' * OPEN AND DEFINE MESSAGE FILE ' ' CLOSE 1 IF SHARE.IT THEN _ OPEN ACTIVE.MESSAGE.FILE$ ACCESS READ WRITE SHARED AS #1 _ ELSE OPEN "R",1,ACTIVE.MESSAGE.FILE$ FIELD 1,128 AS MESSAGE.RECORD$ END SUB 30595 ' $SUBTITLE: 'FINDFUNC - sub to handle local keyboard functions' ' $PAGE ' ' NAME -- FINDFUNC ' ' INPUTS -- PARAMETER MEANING ' ACTIVE.MENU$ INDICATOR OF ACTIVE MENU ' ADJUSTED.SECURITY SWITCH INDICATING TEMP. SECURITY CHANGE ' AUTODOWNLOAD.DESIRED USER'S PREFERENCE FOR AUTODOWNLOADING ' CALLERS.FILE$ NAME OF CALLERS FILE ' CHAT.AVAILABLE TOGGLE INDICATING IF SYSOP WILL CHAT ' CHECK.BULLETIN.LOGON USER'S PREFERENCE FOR BULLETIN CHECK ' CONFERENCE.MODE INDICATOR THAT USER IS IN A CONFERENCE ' CURSOR.LINE LINE THAT THE CURSOR IS AT ' CURSOR.ROW ROW THAT THE CURSOR IS AT ' DISK.FOR.DOS$ DISK TO LOAD COMMAND.COM FROM ' DISKFULL.GO.OFFLINE INDICATOR OF WHAT TO DO WHEN DISK FULL ' EXIT.TO.DOORS FLAG INDICATING EXITING TO DOORS ' EXPERT.USER FLAG FOR EXPERT/NOVICE USER MODE ' FIRST.NAME$ LOGGED ON USER'S FIRST NAME ' F1.KEY FUNCTION KEY ONE VALUE ' F10.KEY FUNCTION KEY TEN VALUE ' GR GRAPHICS PREFERENCE OF USER ' LINE.FEEDS SWTICH FOR USER'S LINE FEED PREFERENCE ' LOCAL.USER FLAG INDICATING USER IS LOCAL ' MINIMUM.LOGON.SECURITY MINIMUM SECURITY TO LOGON ' MODEM.GO.OFFHOOK.COMMAND$ COMMAND TO TAKE MODEM OFF-HOOK ' MODEM.INIT.BAUD$ BAUD TO INITIALIZE MODEM AT ' NODE.ID$ NODE IDENTIFIER ' NODE.RECORD.INDEX NODE RECORD INDEX FOR THIS NODE ' NULLS SWITCH FOR USER'S PREFERENCE FOR NULLS ' PRINTER TOGGLE INDICATING PRINTER IS AVAILABLE ' PROMPT.BELL USER'S PREFERENCE FOR BELLS ON PROMPTS ' SECONDS.PER.SESSION TIME LEFT IN CURRENT USER SESSION ' SKIP.FILES.LOGON USER'S LOGON NOTIFICIATION PREFERENCE ' SNOOP TOGGLE INDICATING SNOOP STATUS ' SUBROUTINE.PARAMETER -8 = SYSOP'S OPTION 6 REMOTELY ' -9 = GOT TO DOS ' -10 = SYSOP GET'S SYSTEM NEXT ' SYSOP INDICATOR THAT USER IS SYSOP ' SYSOP.ANNOY TOGGLE INDICATING SYSOP IS AVAILABLE ' SYSOP.NEXT TOGGLE SO SYSOP GETS SYSTEM NEXT ' UPPER.CASE USER'S PREFERENCE FOR UPPER/LOWER CASE ' USER.FILE.INDEX INDEX INTO THE USER FILE FOR CALLER ' USER.SECURITY.LEVEL USER'S SECURITY LEVEL ' USERT.TRANSFER.DEFAULT USER'S FILE TRANSFER DEFAULT PREFERENCE ' ' OUTPUTS -- ' ADJUSTED.SECURITY SWITCH INDICATING TEMP. SECURITY CHANGE ' CHAT.AVAILABLE TOGGLE INDICATING IF SYSOP WILL CHAT ' FUNCTION.KEY VALUE 1 TO 10 CORRESPONDING TO ' THE FUNCTION KEY THAT WAS PRESSED ' KEY.PRESSED$ CHARACTER STRING GENERATED BY KEY ' PRINTER TOGGEL INDICATING PRINTER IS AVAILABLE ' SNOOP TOGGLE INDICATING SNOOP STATUS ' SYSOP INDICATOR THAT USER IS SYSOP ' SYSOP.ANNOY TOGGLE INDICATING SYSOP IS AVAILABLE ' SYSOP.NEXT TOGGLE SO SYSOP GETS SYSTEM NEXT ' SUBROUTINE.PARAMETER -1 CARRIER LOST ' -2 CHAT MODE ACTIVATED ' -3 FORCE CALLER ON-LINE ' -4 EXIT TO SYSTEM IMMEDIATELY ' -5 EXIT TO SYSTEM AFTER MULTI-LINK CALL ' -6 TELL USER ACCESS IS DENIED ' -7 UPDATE CALLERS FILE AND DENY ACCESS ' USER.SECURITY.LEVEL USER'S SECURITY LEVEL ' ' PURPOSE -- To determine if a function has been pressed on ' the PC'S keyboard that is running RBBS-PC. ' SUB FINDFUNC STATIC LOOKUP = SUBROUTINE.PARAMETER IF SUBROUTINE.PARAMETER < -1 THEN _ SUBROUTINE.PARAMETER = 0 : _ IF LOOKUP = - 8 THEN _ GOTO 33070 _ ELSE IF LOOKUP = - 9 THEN _ GOTO 31000 _ ELSE IF LOOKUP = - 10 THEN _ GOTO 33090 ' ' ' * TEST FOR FUNCTION KEY PRESSED ' ' 30600 IF KEYBOARD.STACK$ = "" THEN _ KEY.PRESSED$ = INKEY$ _ ELSE KEY.PRESSED$ = KEYBOARD.STACK$ : _ KEYBOARD.STACK$ = "" FUNCTION.KEY = 0 IF LEN(KEY.PRESSED$) <> 2 THEN _ GOTO 33970 KEY.PRESSED = ASC(RIGHT$(KEY.PRESSED$,1)) IF LOCAL.USER AND NOT SYSOP THEN _ ' RM060404 KEY.PRESSED$ = "" : _ GOTO 33970 IF KEY.PRESSED => F1.KEY AND _ KEY.PRESSED <= F10.KEY THEN _ FUNCTION.KEY = KEY.PRESSED - 58 : _ GOTO 30610 IF KEY.PRESSED = 117 THEN _ 'Ctrl-End FUNCTION.KEY = 11 IF KEY.PRESSED = 73 THEN _ 'PgUp FUNCTION.KEY = 12 IF KEY.PRESSED = 72 THEN _ 'up arrow FUNCTION.KEY = 13 IF KEY.PRESSED = 80 THEN _ 'Down arrow FUNCTION.KEY = 14 IF KEY.PRESSED = 81 THEN _ 'PgDn FUNCTION.KEY = 15 IF KEY.PRESSED = 75 THEN _ 'left arrow FUNCTION.KEY = 16 IF KEY.PRESSED = 77 THEN _ 'Right arrow FUNCTION.KEY = 17 IF KEY.PRESSED = 141 THEN _ 'CTRL-up arrow FUNCTION.KEY = 18 IF KEY.PRESSED = 132 THEN _ 'CTRL-PgUp (same as CTRL-UP) FUNCTION.KEY = 18 IF KEY.PRESSED = 145 THEN _ 'CTRL-down arrow FUNCTION.KEY = 19 IF KEY.PRESSED = 118 THEN _ 'CTRL-PgDn (same as CTRL-DOWN) FUNCTION.KEY = 19 IF KEY.PRESSED = 115 THEN _ 'CTRL-left arrow FUNCTION.KEY = 20 IF KEY.PRESSED = 116 THEN _ 'CTRL-right arrow FUNCTION.KEY = 21 30610 KEY.PRESSED$ = "" IF FUNCTION.KEY < 1 OR FUNCTION.KEY > 21 THEN _ GOTO 33970 IF FUNCTION.KEY < 10 AND (FUNCTION.KEY <> 8) THEN _ GOTO 30620 IF TOGGLE.ONLY THEN _ SUBROUTINE.PARAMETER = 1 : _ GOTO 33970 30620 ON FUNCTION.KEY GOTO 31000, _ ' 1 = F1 32000, _ ' 2 = F2 33000, _ ' 3 = F3 33040, _ ' 4 = F4 33060, _ ' 5 = F5 33070, _ ' 6 = F6 33090, _ ' 7 = F7 33110, _ ' 8 = F8 33130, _ ' 9 = F9 33150, _ ' 10 = F10 31398, _ ' 11 = CTRL END 33200, _ ' 12 = PGUP 33170, _ ' 13 = UP ARROW 33180, _ ' 14 = DOWN ARROW 33220, _ ' 15 = PGDN 33240, _ ' 16 = LEFT ARROW 33250, _ ' 17 = RIGHT ARROW 33170, _ ' 18 = CTRL-UP ARROW 33180, _ ' 19 = CTRL-DOWN 33245, _ ' 20 = CTRL-LEFT 33255 ' 21 = CTRL-RIGHT ' ' ' * F1 - COMMAND FROM LOCAL KEYBOARD (IMMEDIATE EXIT TO DOS) ' ' 31000 SUBROUTINE.PARAMETER = -10 CALL CARRIER IF SUBROUTINE.PARAMETER = 0 THEN _ GOTO 33970 CALL BRKFNAME(CALLERS.FILE$,X$,Y$,Z$,TRUE) FILE.NAME$ = X$ + "RBBS" + NODE.FILE.ID$ + "F1.DEF" CLOSE 2 CALL OPENOUTW (FILE.NAME$) PRINT #2,MID$(FILE.NAME$,3,7) IF EXIT.TO.DOORS THEN _ SUBROUTINE.PARAMETER = -4 : _ GOTO 33970 CALL OPENCOM(MODEM.INIT.BAUD$,",N,8,1") CALL MODEMPUT (MODEM.GO.OFFHOOK.COMMAND$) CALL DELAYIT (2) SUBROUTINE.PARAMETER = -5 GOTO 33970 ' ' ' * END KEY - FORCE CURRENT USER OFF AND LOCK THEM OUT ' ' 31398 IF NOT LOCAL.USER THEN _ CALL CARRIER : _ IF SUBROUTINE.PARAMETER = -1 THEN _ GOTO 33970 FUNCTION.KEY = 0 IF INSTR("MUF",ACTIVE.MENU$) > 0 THEN _ GOTO 31399 CURSOR.LINE = CSRLIN CURSOR.ROW = POS(0) LOCATE 25,1 D$ = SPACE$(79) GOSUB 33210 LOCATE 25,1 D$ ="Cannot FORCE OFF until user reaches MAIN menu" GOSUB 33210 CALL DELAYIT (1) LOCATE CURSOR.LINE,CURSOR.ROW SUBROUTINE.PARAMETER = 1 CALL LINE25 GOTO 33970 31399 CALL QTPUT1 (FIRST.NAME$ + ", goodbye and don't call back") IF USER.FILE.INDEX < 1 THEN _ SUBROUTINE.PARAMETER = -6 : _ GOTO 33970 USER.SECURITY.LEVEL = MINIMUM.LOGON.SECURITY - 1 CALL DENYACCESS SUBROUTINE.PARAMETER = -7 GOTO 33970 ' ' ' * F2 - COMMAND FROM LOCAL KEYBOARD (SYSOP EXIT TO DOS AND RETURN) ' ' 32000 IF NOT LOCAL.USER THEN _ CALL SKIPLINE (1) : _ CALL QTPUT1 ("Sysop exiting to DOS. Please wait...") : _ FUNCTION.KEY = 0 : _ CALL DELAYIT (3) CALL SHELLEXIT (DISK.FOR.DOS$ + "COMMAND") ' KG052802 'SHELL DISK.FOR.DOS$ + _ ' "COMMAND" CLS IF NOT LOCAL.USER THEN _ CALL CARRIER : _ IF SUBROUTINE.PARAMETER = -1 THEN _ GOTO 33970 SUBROUTINE.PARAMETER = 2 CALL LINE25 CALL QTPUT1 ("Sysop back from DOS. Returning control to you.") COMMPORT.STACK$ = CARRIAGE.RETURN$ GOTO 33970 ' ' ' * F3 - COMMAND FROM LOCAL KEYBOARD (PRINTER TOGGLE) ' ' 33000 PRINTER = NOT PRINTER CHANGE.VALUE = PRINTER FIELD.POSITION = 38 GOTO 33950 ' ' ' * F4 - COMMAND FROM LOCAL KEYBOARD (SYSOP ANNOY) ' ' 33040 SYSOP.ANNOY = NOT SYSOP.ANNOY CHANGE.VALUE = SYSOP.ANNOY FIELD.POSITION = 34 GOTO 33950 ' ' ' * F5 - COMMAND FROM LOCAL KEYBOARD (FORCE CALLER ONLINE) ' ' 33060 FUNCTION.KEY = 0 SUBROUTINE.PARAMETER = -3 GOTO 33970 ' ' ' * F6 - COMMAND FROM LOCAL KEYBOARD (SYSOP AVAILABLE TOGGLE) ' * 6 - COMMAND FROM SYSOP MENU (SYSOP AVAILABLE TOGGLE) ' ' 33070 SYSOP.AVAILABLE = NOT SYSOP.AVAILABLE CHANGE.VALUE = SYSOP.AVAILABLE FIELD.POSITION = 32 GOTO 33950 ' ' ' * F7 - COMMAND FROM LOCAL KEYBOARD (SYSOP GETS SYSTEM NEXT) ' ' 33090 IF ERR=61 AND NOT DISKFULL.GO.OFFLINE THEN _ GOTO 33970 SYSOP.NEXT = NOT SYSOP.NEXT CHANGE.VALUE = SYSOP.NEXT FIELD.POSITION = 36 GOTO 33950 ' ' ' * F8 - COMMAND FROM LOCAL KEYBOARD (ASSIGN USER TEMPORARY SYSOP SECURITY) ' ' 33110 SYSOP = NOT SYSOP CURSOR.LINE = CSRLIN CURSOR.ROW = POS(0) LOCATE 25,1 D$ = SPACE$(79) NUM.RETURNS = 0 CALL LPRNT (D$,NUM.RETURNS) LOCATE 25,1 USER.SECURITY.LEVEL = (1 + SYSOP) * _ USER.SECURITY.SAVE - _ SYSOP * _ SYSOP.SECURITY.LEVEL D$ = "SYSOP Privileges " + FNOFFON$(SYSOP) CALL LPRNT (D$,NUM.RETURNS) CALL DELAYIT (3) LOCATE CURSOR.LINE,CURSOR.ROW SUBROUTINE.PARAMETER = 1 CALL LINE25 CALL CALLOPT GOTO 33970 ' ' ' * F9 - COMMAND FROM LOCAL KEYBOARD (SNOOP TOGGLE) ' ' 33130 IF NOT SNOOP THEN _ SNOOP = TRUE : _ LOCATE 24,1,0 : _ D$ = "SNOOP ON" : _ NUM.RETURNS = 0 : _ CALL LPRNT (D$,NUM.RETURNS) : _ SUBROUTINE.PARAMETER = 2 : _ CALL LINE25 _ ELSE LOCATE ,,0 : _ SNOOP = FALSE : _ CLS 33140 CHANGE.VALUE = SNOOP FIELD.POSITION = 58 GOTO 33950 ' ' ' * F10 - COMMAND FROM LOCAL KEYBOARD (FORCE CHAT WITH USER) ' ' 33150 GOTO 33160 33155 SUBROUTINE.PARAMETER = 1 CALL LINE25 GOTO 33970 33160 CALL UPDTCALR ("Sysop began chat",1) PAGE.STATUS$ = "" CALL SKIPLINE (1) CALL QTPUT1 ("Hi " + _ FIRST.NAME$ + _ ", this is " + _ SYSOP.FIRST.NAME$ + _ " " + _ SYSOP.LAST.NAME$ + _ " Sorry to break in to CHAT but..") CALL SYSOPCHAT COMMPORT.STACK$ = CHR$(13) GOTO 33155 ' ' ' * UP / CTRL-UP: INCREASE THE ON-LINE USER'S SECURITY BY ONE / FIVE ' ' 33170 USER.SECURITY.LEVEL = USER.SECURITY.LEVEL + _ 1 - 4 * (FUNCTION.KEY = 18) GOTO 33190 ' ' ' * DOWN / CTRL-DOWN: DECREASE THE ON-LINE USER'S SECURITY BY ONE / FIVE ' ' 33180 USER.SECURITY.LEVEL = USER.SECURITY.LEVEL - _ 1 + 4 * (FUNCTION.KEY = 19) 33190 ADJUSTED.SECURITY = TRUE USER.SECURITY.SAVE = USER.SECURITY.LEVEL IF (NOT CONFERENCE.MODE) AND (NOT SUB.BOARD) THEN _ ' KG052104 ORIG.SECURITY = USER.SECURITY.LEVEL : _ ' KG052104 SUBROUTINE.PARAMETER = 2 CALL LINE25 CALL CALLOPT GOTO 33970 ' ' ' * PGUP DISPLAY USER PROFILE ' ' 33200 IF NOT LOCAL.USER THEN _ CALL CARRIER : _ IF SUBROUTINE.PARAMETER = -1 THEN _ GOTO 33970 IF VOICE.TYPE <> 0 THEN _ TALK.ALL = TRUE CALL PAGEUP D$ = MID$("NoviceExPERT",1 -6 * EXPERT.USER,6) GOSUB 33210 D$ = "GRAPHICS: " + _ MID$("None AsciiColor",GR * 5 + 1,5) GOSUB 33210 D$ = "PROTOCOL : " + _ USER.TRANSFER.DEFAULT$ GOSUB 33210 D$ = "UPPER CASE " + _ MID$("and lowerONLY", 1 - 9 * UPPER.CASE,9) GOSUB 33210 D$ = "Line Feeds " + FNOFFON$(LINE.FEEDS) GOSUB 33210 D$ = "Nulls " + FNOFFON$(NULLS) GOSUB 33210 D$ = "Prompt Bell " + FNOFFON$(PROMPT.BELL) GOSUB 33210 D$ = MID$("SKIP CHECK",1 -5 * CHECK.BULLETIN.LOGON,5) + _ " old BULLETINS on logon." GOSUB 33210 D$ = MID$("CHECKSKIP ",1 -5 * SKIP.FILES.LOGON,5) + _ " new files on logon." GOSUB 33210 D$ = "Autodownload " + FNOFFON$(AUTODOWNLOAD.DESIRED) GOSUB 33210 TALK.ALL = FALSE GOTO 33970 33210 NUM.RETURNS = 1 CALL LPRNT(D$,NUM.RETURNS) RETURN ' ' ' * PGDN CLEAR DISPLAY OF USER'S PROFILE ' ' 33220 IF NOT LOCAL.USER THEN _ CALL CARRIER : _ IF SUBROUTINE.PARAMETER = -1 THEN _ GOTO 33970 CLS GOTO 33155 ' ' ' * LEFT ARROW - DECREASE THE ON-LINE USER'S TIME BY ONE MINUTE ' ' 33240 IF SECONDS.PER.SESSION! > 120 THEN _ SECONDS.PER.SESSION! = SECONDS.PER.SESSION! - 60 GOTO 33970 ' ' ' * CTRL-LEFT ARROW - DECREASE THE ON-LINE USER'S TIME BY FIVE MINUTES ' ' 33245 IF SECONDS.PER.SESSION! > 360 THEN _ SECONDS.PER.SESSION! = SECONDS.PER.SESSION! - 300 GOTO 33970 ' ' ' * RIGHT ARROW - INCREASE THE ON-LINE USER'S TIME BY ONE MINUTE ' ' 33250 IF SECONDS.PER.SESSION! < 86280 THEN _ SECONDS.PER.SESSION! = SECONDS.PER.SESSION! + 60 TIME.LOCK.SET = 0 GOTO 33970 ' ' ' * CTRL-RIGHT ARROW - INCREASE THE ON-LINE USER'S TIME BY FIVE MINUTES ' ' 33255 IF SECONDS.PER.SESSION! < 86040 THEN _ SECONDS.PER.SESSION! = SECONDS.PER.SESSION! + 300 TIME.LOCK.SET = 0 GOTO 33970 ' ' ' * UPDATE NODE RECORD WITH LOCAL FUNCTION KEY ACTIVITY ' ' 33950 IF SNOOP THEN _ SUBROUTINE.PARAMETER = 1 : _ CALL LINE25 33960 IF CONFERENCE.MODE = TRUE THEN _ IF LOCAL.USER THEN _ GOTO 33970 _ ELSE D$ = "Cannot change status during Conference!" : _ GOSUB 33210 : _ GOTO 33970 SUBROUTINE.PARAMETER = 3 CALL FILELOCK IF SUBROUTINE.PARAMETER = -1 THEN _ GOTO 33970 CALL OPENMSG FIELD 1,128 AS MESSAGE.RECORD$ GET 1,NODE.RECORD.INDEX MID$(MESSAGE.RECORD$,FIELD.POSITION,2) = STR$(CHANGE.VALUE) CALL SAVEPROF (2) FIELD 1, 128 AS MESSAGE.RECORD$ 33970 END SUB 33990 ' $SUBTITLE: 'PAGEUP - Display user profile to SYSOP' ' $PAGE ' ' NAME -- PAGEUP ' ' INPUTS -- PARAMETER MEANING ' ACTIVE.USER.NAME$ CURRENT USER NAME ' DOWNLOADS # OF FILES DOWNLOADED ' EXPIRATION.DATE$ REGISTRATION EXPIRATION ' LAST.DATE.TIME.ON.SAVE$ LAST DATE & TIME ON SYSTEM ' LAST.MESSAGE.READ LAST MESSAGE READ BY USER ' PASSWORD.SAVE$ USERS PASSWORD ' TIMES.LOGGED.ON TIMES USER HAS LOGGED ON ' UPLOADS # OF FILES UPLOADED ' USER.SECURITY.SAVE USERS SECURITY LEVEL ' ' OUTPUTS -- MESSAGE.RECORD$ ' SUB PAGEUP STATIC CALL LPRNT (" ",1) CALL LPRNT ("USER NAME : " + ACTIVE.USER.NAME$,1) CALL LPRNT ("SECURITY :" + STR$(USER.SECURITY.SAVE),1) CALL LPRNT ("PASSWORD :" + PASSWORD.SAVE$,1) CALL LPRNT ("READ MSG. :" + STR$(LAST.MESSAGE.READ),1) CALL LPRNT ("TIMES ON :" + STR$(TIMES.LOGGED.ON),1) CALL LPRNT ("LAST ON :" + LAST.DATE.TIME.ON.SAVE$,1) CALL LPRNT ("DOWNLOADS :" + STR$(DOWNLOADS),1) CALL LPRNT ("UPLOADS :" + STR$(UPLOADS),1) IF ENFORCE.UPLOAD.DOWNLOAD.RATIOS THEN _ CALL LPRNT ("DL-BYTES :" + STR$(DLBYTES!),1) : _ CALL LPRNT ("UL-BYTES :" + STR$(ULBYTES!),1) IF RESTRICT.BY.DATE THEN _ CALL LPRNT ("EXPIRATION: " + EXPIRATION.DATE$,1) CALL LPRNT ("User's Profile",1) END SUB 41008 ' $SUBTITLE: 'CHKTREMAIN - Kicks off if no time remaining' ' $PAGE ' ' NAME -- CHKTREMAIN ' ' INPUTS -- PARAMETER MEANING ' TIME.LEFT! ' OUTPUTS -- PARAMETER MEANING ' TIME.LEFT! TIME IN MINUTES LEFT IN SESSION ' TCA! TIME USED IN SECONDS ' SUBROUTINE.PARAMETER -1 if no time left ' SUB CHKTREMAIN (TIME.LEFT!) STATIC CALL TIMEREMAIN (TIME.LEFT!) IF BYPASS.TIME.CHECK THEN _ EXIT SUB IF TIME.LEFT! < 0.1 THEN _ SUBROUTINE.PARAMETER = -1 END SUB 41010 ' $SUBTITLE: 'TIMEREMAIN - calculates time remaining in a session' ' $PAGE ' ' NAME -- TIMEREMAIN ' ' INPUTS -- PARAMETER MEANING ' USER.LOGON.TIME! ' SECONDS.PER.SESSION! ' BYPASS.TIME.CHECK ' OUTPUTS -- ' TIME.REMAINING! TIME IN MINUTES LEFT IN SESSION ' TCA! TIME USED IN SECONDS ' SUB TIMEREMAIN (TIME.REMAINING!) STATIC TOA! = FRE("A") IF BYPASS.TIME.CHECK THEN _ TIME.REMAINING! = SECONDS.PER.SESSION! /60 : _ EXIT SUB CALL FINDTIME (TI!) ROLLOVER = FALSE IF TI! > USER.LOGON.TIME! THEN _ TCA! = TI! - USER.LOGON.TIME! : _ GOTO 41020 ROLLOVER = TRUE TCA! = TI! + 86400! - USER.LOGON.TIME! 41020 IF TIME.TO.DROP.TO.DOS! = 0 OR _ OLD.DAT$ = DATE$ THEN _ GOTO 41030 IF NOT ROLLOVER AND _ USER.LOGON.TIME! + SECONDS.PER.SESSION! => TIME.TO.DROP.TO.DOS! THEN _ SECONDS.PER.SESSION! = (TIME.TO.DROP.TO.DOS! - USER.LOGON.TIME!) : _ SHORTENED = TRUE IF ROLLOVER AND _ USER.LOGON.TIME! + SECONDS.PER.SESSION! - 86400 => TIME.TO.DROP.TO.DOS! THEN _ SECONDS.PER.SESSION! = TIME.TO.DROP.TO.DOS! : _ SHORTENED = TRUE IF SHORTENED AND NOT TOLD.SHORT THEN _ TOLD.SHORT = TRUE : _ A$ = "Time shortened for scheduled event" : _ CALL RINGCALLER 41030 TIME.REMAINING! = (SECONDS.PER.SESSION!-TCA!) / 60 TIME.REMAINING! = -(TIME.REMAINING! > 0.0)*TIME.REMAINING! END SUB 41032 ' $SUBTITLE: 'DISPLAYTR - Display users time remaining' ' $PAGE ' ' NAME -- DISPLAYTR ' ' INPUTS -- PARAMETER MEANING ' TIME.REMAINING! ' ' OUTPUTS -- PARAMETER MEANING ' TIME.REMAINING! TIME IN MINUTES LEFT IN SESSION ' SUB DISPLAYTR (TIME.REMAINING!) STATIC CALL TIMEREMAIN (TIME.REMAINING!) CALL QTPUT1 (STR$(INT(TIME.REMAINING!)) + " min left") END SUB 41498 ' $SUBTITLE: 'AMORPMTD - give time of day in AM/PM format' ' $PAGE ' ' NAME -- AMORPMTD ' ' INPUTS -- PARAMETER MEANING ' ' OUTPUTS -- CURRENT.DATE$ CURRENT DATE (MM-DD-YY) ' TIM$ CURRENT TIME (I.E. 1:13 PM) ' TIME.LOGGEND.ON$ TIME USER LOGGED ON (HH:MM:SS) ' ' PURPOSE -- To set the time and date and ' describe the time as "AM" or "PM." ' SUB AMORPMTD STATIC ' KG061203 ' ' ' * CALCULATE CURRENT TIME FOR AM OR PM ' ' 41500 TIME.LOGGED.ON$ = TIME$ CURRENT.DATE$ = DATE$ CURRENT.DATE$ = LEFT$(CURRENT.DATE$ ,6) + _ RIGHT$(CURRENT.DATE$ ,2) CALL AMORPM ' KG061203 END SUB SUB AMORPM STATIC ' KG061203 41510 TIM$ = TIME$ IF VAL(MID$(TIM$,1,2)) = 12 THEN _ MID$(TIM$,1,2) = RIGHT$(STR$(VAL(MID$(TIM$,1,2))),2) : _ TIM$ = LEFT$(TIM$,5) + _ " PM" : _ EXIT SUB IF VAL(MID$(TIM$,1,2)) > 11 THEN _ MID$(TIM$,1,2) = RIGHT$(STR$(VAL(MID$(TIM$,1,2))-12),2) : _ TIM$ = LEFT$(TIM$,5) + _ " PM" : _ EXIT SUB TIM$ = LEFT$(TIM$,5) + _ " AM" END SUB ' KG061203 42000 ' $SUBTITLE: 'CARRIER - sub to monitor carrier on comm. port' ' $PAGE ' ' NAME -- CARRIER ' ' INPUTS -- PARAMETER MEANING ' LOCAL.USER = 0 REMOTE USER ' LOCAL.USER = -1 LOCAL KEYBOARD USER ' MODEM.STATUS.REGISTER ADDRESS OF THE COMMUNI- ' CATIONS PORT'S REGISTER ' SUBROUTINE.PARAMETER = -9 DON'T WRITE TO CALLERS ' SUBROUTINE.PARAMETER = -10 SAME AS -9, BUT DON'T ' DELAY ' ' OUTPUTS -- SUBROUTINE.PARAMETER = 0 CARRIER STILL PRESENT ' SUBROUTINE.PARAMETER = -1 CARRIER NOT PRESENT ' ' PURPOSE -- To test if carrier is present (i.e. the user ' is still on line). ' SUB CARRIER STATIC IF AUTO.LOGOFF THEN _ ' KG061203 SUBROUTINE.PARAMETER = -1 : _ ' KG061203 EXIT SUB ' KG061203 CALL CHKCARRIER ' KG061203 END SUB ' KG061203 SUB CHKCARRIER STATIC ' KG061203 IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB SPEEDY = SUBROUTINE.PARAMETER SUBROUTINE.PARAMETER = 0 ' ' ' * TEST FOR CARRIER PRESENT (DROP CALLER IF CARRIER NOT PRESENT) ' ' IF LOCAL.USER THEN _ EXIT SUB IF FOSSIL THEN _ CALL FOSSTATUS(COMPORT%,STATUS%) : _ STATUS% = STATUS% AND &H0080 : _ IF STATUS% = &H0080 THEN _ EXIT SUB _ ELSE GOTO 42015 42010 IF INP(MODEM.STATUS.REGISTER) > 127 THEN _ EXIT SUB ' ' ' * IN CASE USER IS 2400 BAUD, PAUSE A SECOND AND CHECK AGAIN FOR CARRIER ' * DETECT. SOME 2400 BAUD MODEMS TAKE A WHILE TO SYNCHRONIZE THE CARRIER, ' * HENCE A THREE-SECOND PAUSE BEFORE CHECKING AGAIN. ' ' 42015 IF SPEEDY = -10 THEN _ GOTO 42020 CALL DELAYIT (MODEM.INIT.WAIT.TIME) IF FOSSIL THEN _ CALL FOSSTATUS(COMPORT%,STATUS%) : _ STATUS% = STATUS% AND &H0080 : _ IF STATUS% = &H0080 THEN _ EXIT SUB IF INP(MODEM.STATUS.REGISTER) > 127 THEN _ EXIT SUB 42020 SUBROUTINE.PARAMETER = -1 IF SPEEDY < -8 THEN _ EXIT SUB IF ALREADY.WRITTEN = -9 THEN _ EXIT SUB CALL MODEMPUT (MODEM.GO.OFFHOOK.COMMAND$) CALL DELAYIT (MODEM.COMMAND.DELAY.TIME) MODEM.OFFHOOK = -1 ALREADY.WRITTEN = -9 CALL UPDTCALR ("Carrier dropped",1) END SUB 43004 ' $SUBTITLE: 'ASKGRAPH -- sub to ask users graphic preference' ' $PAGE ' ' NAME -- ASKGRAPH ' ' INPUTS -- PARAMETER MEANING ' UGD$ USER GRAPHIC DEFAULT ' ' OUTPUTS -- ' ' PURPOSE -- To determine users graphics default ' SUB ASKGRAPH (UGD$) STATIC IF EXPERT.USER THEN _ GOTO 43007 43006 FILE.NAME$ = HELP$(9) CALL BUFFILE (FILE.NAME$,X) IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB 43007 CALL QTPUT1 ("GRAPHICS for text files and menus") A$ = "Change from " + MID$("NAC",GR+1,1) + " to N)one, A)scii-IBM, C)olor-IBM, H)elp" + PRESS.ENTER.EXPERT$ SUBROUTINE.PARAMETER = 1 TURBO.KEY = -TURBO.KEY.USER CALL TGET IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB IF Q = 0 THEN _ CALL QTPUT1 ("Unchanged") : _ EXIT SUB CALL ALLCAPS (B$(1)) GR = INSTR("NAC",B$(1)) IF GR = 2 AND NOT EIGHT.BIT THEN _ CALL QTPUT1 ("Ascii unavailable. Requires 8 bit") : _ GOTO 43007 IF GR = 0 THEN _ GOTO 43006 GR = GR - 1 CALL SETUGD (GR,UGD$) END SUB ' 43031 ' $SUBTITLE: 'GRAPHIC - sub to find graphic version of a file' ' $PAGE ' ' NAME -- GRAPHIC ' ' INPUTS -- PARAMETER MEANING ' DEFAULT$ USERS GRAPHIC DEFAULT ' GR WHETHER GRAPHICS ARE AVAILABLE ' FILNAME$ FILE TO CHECK ' ' OUTPUTS -- FILNAME$ SUBSTITUTES NAME OF GRAPHICS ' FILE (IF IT EXISTS). ' ' PURPOSE -- Checks whether there is a graphics version of ' a file, based on users graphics perference. ' Sets file name to graphcis file if it exists, ' Otherwise leaves file name intact. Returns file ' name to use. ' SUB GRAPHICX (DEFAULT$,FILNAME$,FILNUM) STATIC ' KG061001 OK = FALSE IF GR THEN _ CALL BRKFNAME (FILNAME$,DR$,X$,EXTENTION$,TRUE) : _ IF LEN(X$) < 8 THEN _ DF$ = DR$ + _ X$ + _ DEFAULT$ + _ EXTENTION$ : _ CALL FINDITX (DF$,FILNUM) : _ ' KG061001 IF OK THEN _ FILNAME$ = DF$ : _ IF DEFAULT$ = "C" THEN _ LINES.PRINTED = 0 IF NOT OK THEN _ CALL FINDITX (FILNAME$,FILNUM) ' KG061001 END SUB SUB GRAPHIC (DEFAULT$,FILNAME$) STATIC ' KG061001 CALL GRAPHICX (DEFAULT$,FILNAME$,2) ' KG061001 END SUB 43068 ' $SUBTITLE: 'SAVEPROF - subroutine to read a user profile' ' $PAGE ' ' NAME -- SAVEPROF ' ' INPUTS -- PARAMETER MEANING ' BPS ' EIGHT.BIT ' EXIT.TO.DOORS ' GR ' MESSAGE.RECORD$ ' NODE.RECORD.INDEX ' SYSOP ' UPPER.CASE ' TIME.LOGGED.ON$ ' PRIVATE.DOOR ' RELIABLE.MODE ' ' OUTPUTS -- NONE ' ' PURPOSE -- Saves a user's options and communications parameters ' in the node record when a user exits to a "door" so ' that he is in the same status as when he exited. ' SUB SAVEPROF(IPARM) STATIC ON IPARM GOTO 43070,43080 ' KG072501 43070 ACTIVE.MESSAGE.FILE$ = ORIG.MESSAGE.FILE$ SUBROUTINE.PARAMETER = 3 CALL FILELOCK CALL OPENMSG FIELD 1, 128 AS MESSAGE.RECORD$ GET 1,NODE.RECORD.INDEX IF GLOBAL.SYSOP THEN _ MID$(MESSAGE.RECORD$,1,30) = "SYSOP" + SPACE$(25) MID$(MESSAGE.RECORD$,40,2) = STR$(EXIT.TO.DOORS) MID$(MESSAGE.RECORD$,42,2) = STR$(EIGHT.BIT) MID$(MESSAGE.RECORD$,44,2) = STR$(BPS) MID$(MESSAGE.RECORD$,46,2) = STR$(UPPER.CASE) MID$(MESSAGE.RECORD$,48,5) = MKS$(NUM.DWN.BYTS!) + MID$(STR$(-BATCH.TRANSFER),2) MID$(MESSAGE.RECORD$,53,2) = STR$(GR) MID$(MESSAGE.RECORD$,55,2) = STR$(SYSOP) MID$(MESSAGE.RECORD$,65,3) = CHR$(VAL(LEFT$(TIME.LOGGED.ON$,2))) + _ CHR$(VAL(MID$(TIME.LOGGED.ON$,4,2))) + _ CHR$(VAL(MID$(TIME.LOGGED.ON$,7,2))) MID$(MESSAGE.RECORD$,72,2) = STR$(PRIVATE.DOOR) MID$(MESSAGE.RECORD$,74,1) = MID$(STR$(TRANSFER.FUNCTION),2,1) MID$(MESSAGE.RECORD$,75,1) = FT$ MID$(MESSAGE.RECORD$,76,2) = MKI$(CINT(TIME.CREDITS!)/60) ' KG072501 MID$(MESSAGE.RECORD$,79,8) = LEFT$(DOORED.TO$+" ",8) MID$(MESSAGE.RECORD$,91,2) = STR$(RELIABLE.MODE) CALL BRKFNAME (CURRENT.PUI$,A$,B$,Z$,FALSE) MID$(MESSAGE.RECORD$,93,8) = B$ + SPACE$(8 - LEN(B$)) MID$(MESSAGE.RECORD$,101,2) = STR$(LOCAL.USER) MID$(MESSAGE.RECORD$,103,2) = STR$(LOCAL.USER.MODE) GRN$ = LEFT$(GRN$,INSTR(GRN$ + " "," ") - 1) MID$(MESSAGE.RECORD$,105,8) = GRN$ + SPACE$(8 - LEN(GRN$)) MID$(MESSAGE.RECORD$,117,2) = STR$(MENU.INDEX) MID$(MESSAGE.RECORD$,119,2) = LEFT$(DATE$,2) MID$(MESSAGE.RECORD$,121,2) = MID$(DATE$,4,2) MID$(MESSAGE.RECORD$,123,2) = RIGHT$(DATE$,2) MID$(MESSAGE.RECORD$,125,2) = LEFT$(TIME$,2) MID$(MESSAGE.RECORD$,127,2) = MID$(TIME$,4,2) 43080 PUT 1,NODE.RECORD.INDEX SUBROUTINE.PARAMETER = 2 CALL FILELOCK CALL OPENMSG END SUB 44000 ' $SUBTITLE: 'READPROF - subroutine to restore a user profile' ' $PAGE ' ' NAME -- READPROF ' ' INPUTS -- PARAMETER MEANING ' NODE.RECORD.INDEX NODE RECORD TO USE ' SYSOP.PASSWORD.1$ SYSOP'S PSEUDONYM 1 ' SYSOP.PASSWORD.2$ SYSOP'S PSEUDONYM 2 ' ' OUTPUTS -- USER'S OPTIONS AND COMMUNICATIONS PARAMETERS ' UPON EXITING RBBS-PC TO A "DOOR" ' ' PURPOSE -- Reset a user's options and communications parameters ' that were saved in the node record when a user exited ' to a "door" so that he is in the same status as when ' he exited. ' SUB READPROF STATIC ' KG072501 LOCATE 24,1 CALL LPRNT("NODE INDEX" + STR$(NODE.RECORD.INDEX),1) FIELD 1, 128 AS MESSAGE.RECORD$ GET 1,NODE.RECORD.INDEX RELIABLE.MODE = VAL(MID$(MESSAGE.RECORD$,91,2)) MID$(MESSAGE.RECORD$,40,2) = "00" EIGHT.BIT = VAL(MID$(MESSAGE.RECORD$,42,2)) BPS = VAL(MID$(MESSAGE.RECORD$,44,2)) CALL COMMINFO BAUD.TEST = VAL(MID$(" 300 450 1200 2400 4800 960019200",(-5 * BPS),5)) UPPER.CASE = VAL(MID$(MESSAGE.RECORD$,46,2)) NUM.DWN.BYTS! = CVS(MID$(MESSAGE.RECORD$,48,4)) BATCH.TRANSFER = (MID$(MESSAGE.RECORD$,52,1) = "1") GR = VAL(MID$(MESSAGE.RECORD$,53,2)) HOUR.LOGGED.ON$ = RIGHT$("0"+MID$(STR$(ASC(MID$(MESSAGE.RECORD$,65,1))),2),2) ' KP061804 MIN.LOGGED.ON$ = RIGHT$("0"+MID$(STR$(ASC(MID$(MESSAGE.RECORD$,66,1))),2),2) ' KP061804 SEC.LOGGED.ON$ = RIGHT$("0"+MID$(STR$(ASC(MID$(MESSAGE.RECORD$,67,1))),2),2) ' KP061804 TIME.LOGGED.ON$ = HOUR.LOGGED.ON$ + _ ' KP061804 ":" + _ ' KP061804 MIN.LOGGED.ON$ + _ ' KP061804 ":" + _ ' KP061804 SEC.LOGGED.ON$ ' KP061804 TRANSFER.FUNCTION = VAL(MID$(MESSAGE.RECORD$,74,1)) FT$ = MID$(MESSAGE.RECORD$,75,1) TIME.CREDITS! = 60*CVI(MID$(MESSAGE.RECORD$,76,2)) ' KG072501 DOORED.TO$ = MID$(MESSAGE.RECORD$,79,8) CALL TRIM (DOORED.TO$) IF EXIT.TO.DOORS AND DOORED.TO$ <> "" THEN _ CALL OPENWORK (2,DOORS.DEF$) : _ IF EC = 0 THEN _ CALL READPARMS (A$(),8,1) : _ WHILE EC = 0 AND A$(1) <> DOORED.TO$ : _ CALL READPARMS (A$(),8,1) : _ WEND : _ IF A$(1) = DOORED.TO$ THEN _ DOOR.SKIPS.PASSWORD = TRUE : _ CALL BUFFILE (A$(7),X) EC = 0 MENU.INDEX = VAL(MID$(MESSAGE.RECORD$,117,2)) CURRENT.PUI$ = MID$(MESSAGE.RECORD$,93,8) CALL REMOVE (CURRENT.PUI$," ") IF CURRENT.PUI$ <> "" THEN _ CALL BRKFNAME (MAIN.PUI$,A$,B$,Z$,TRUE) : _ CURRENT.PUI$ = A$ + CURRENT.PUI$ + Z$ CUSTOM.PUI = (CURRENT.PUI$ <> "") LOCAL.USER = VAL(MID$(MESSAGE.RECORD$,101,2)) LOCAL.USER.MODE = VAL(MID$(MESSAGE.RECORD$,103,2)) HOME.CONFERENCE$ = MID$(MESSAGE.RECORD$,105,8) CALL TRIM (HOME.CONFERENCE$) IF REQUIRED.RINGS > 0 AND _ INSTR(MODEM.INIT.COMMAND$,"S0=255") THEN _ COLOR 7,0,0 _ ELSE COLOR FG,BG,BORDER IF LOCAL.USER.MODE THEN _ GOTO 44003 CALL SETBAUD 44003 USER.LOGON.TIME! = VAL(HOUR.LOGGED.ON$) * 3600 + _ ' KP061804 VAL(MIN.LOGGED.ON$) * 60 + _ ' KP061804 VAL(SEC.LOGGED.ON$) ' KP061804 HOUR.LOGGED.ON$ = "" ' KP061804 MIN.LOGGED.ON$ = "" ' KP061804 SEC.LOGGED.ON$ = "" ' KP061804 IF MINUTES.PER.SESSION! < 1 THEN _ MINUTES.PER.SESSION! = 3 IF NOT EIGHT.BIT THEN _ OUT LINE.CONTROL.REGISTER,&H1A IF LEFT$(MESSAGE.RECORD$,7) = "SYSOP " THEN _ ACTIVE.USER.NAME$ = SYSOP.PASSWORD.1$ + " " + SYSOP.PASSWORD.2$ _ ELSE FIRST.NAME.END = INSTR(MESSAGE.RECORD$," ") : _ LAST.NAME.END = INSTR(FIRST.NAME.END + 1,MESSAGE.RECORD$ + " "," ") : _ FIRST.NAME$ = LEFT$(MESSAGE.RECORD$,FIRST.NAME.END-1) : _ LAST.NAME$ = MID$(MESSAGE.RECORD$,FIRST.NAME.END + 1,LAST.NAME.END - (FIRST.NAME.END + 1)) : _ ACTIVE.USER.NAME$ = MID$(FIRST.NAME$ + " " + LAST.NAME$,1,31) Z$ = FIRST.NAME$ END SUB 44020 ' $SUBTITLE: 'COMMINFO - sub for variable of users baud/parity' ' $PAGE ' ' NAME -- COMMINFO ' ' INPUTS -- PARAMETER MEANING ' BPS BAUD RATE INDICATOR ' EIGHT.BIT INDICATE FOR N/8/1 ' ' OUTPUTS -- BAUD.PARITY$ ' ' PURPOSE -- Create a string that shows a users baud rate and parity ' SUB COMMINFO STATIC ' ' ' * DETERMINE BAUD AND PARITY ' ' IF RELIABLE.MODE THEN _ RELIABLE.MODE$ = "-R," _ ELSE RELIABLE.MODE$ = "," BAUD.PARITY$ = MID$(" 300 450 1200 2400 4800 960019200",(-5 * BPS),5) + _ " BAUD" + _ RELIABLE.MODE$ + _ MID$("N,8,1E,7,1",6 + 5 * EIGHT.BIT,5) BAUD.TEST = VAL(BAUD.PARITY$) END SUB 50495 ' $SUBTITLE: 'DELAYIT - sub to wait number of seconds specified' ' $PAGE ' ' NAME -- DELAYIT ' ' INPUTS -- PARAMETER MEANING ' DELAY.TIME NUMBER OF SECONDS TO DELAY ' (0 TO 3,600) ' ' OUTPUTS -- NONE ' ' PURPOSE -- To wait the number of seconds indicated before ' returning control to the calling routine. ' SUB DELAYIT (DELAY.TIME) STATIC IF DELAY.TIME < 1 THEN _ EXIT SUB CALL FINDTIME (DELAY!) DELAY! = DELAY.TIME + DELAY! IF DELAY! < 86400! THEN _ GOTO 50520 50500 CALL FINDTIME (TI!) IF TI! > DELAY.TIME THEN _ ' IF SECONDS TO DELAY IS PAST GOTO 50500 ' MIDNIGHT WAIT FOR THE CLOCK TO WRAP AROUND DELAY! = DELAY! - 86400! ' TO PAST MIDNIGHT AND ADJUST THE DELAY 50520 CALL FINDTIME (TI!) IF TI! < DELAY! THEN _ GOTO 50520 END SUB 52070 ' $SUBTITLE: 'MODEMPUT - sub to write modem commands to modem' ' $PAGE ' ' SUBROUTINE NAME -- MODEMPUT ' ' INPUT PARAMETERS -- PARAMETER MEANING ' STRNG$ MODEM COMMAND ' COMMANDS.BETWEEN.RINGS INDICATOR TO WAIT FOR ' MODEM TO STOP RINGING ' BEFORE ISSUING COMMANDS ' DUMB.MODEM INDICATOR THAT MODEM WOULD ' NOT UNDERSTAND COMMANDS ' ' OUTPUT PARAMETERS -- NONE ' ' SUBROUTINE PURPOSE -- TO ISSUE MODEM COMMANDS TO THE MODEM ' SUB MODEMPUT (STRNG$) STATIC ' ' ' * SEND MODEM COMMAND ' ' IF DUMB.MODEM THEN _ EXIT SUB IF NOT COMMANDS.BETWEEN.RINGS OR _ NOT (INP(MODEM.STATUS.REGISTER) AND &H40) THEN _ GOTO 52080 CALL SETABORT (CONNECT.DELAY!,7) 52072 IF (INP(MODEM.STATUS.REGISTER) AND &H40) > 0 THEN _ CALL FINDTIME (TI!) : _ IF TI! > CONNECT.DELAY! OR _ (ABS(CONNECT.DELAY! - TI!) > 30 AND _ (TI! + 86400 > CONNECT.DELAY!)) THEN _ GOTO 52080 GOTO 52072 52080 CALL DELAYIT (MODEM.COMMAND.DELAY.TIME) CALL COMMPUT (STRNG$) END SUB 57001 ' $SUBTITLE: 'DISPCALL - subroutine to display callers file' ' $PAGE ' ' NAME -- DISPCALL ' ' INPUTS -- PARAMETER MEANING ' ' OUTPUTS -- (NONE) ' ' PURPOSE -- Displays callers file to sysops and callers ' SUB DISPCALL STATIC IF CALLERS.FILE.PREFIX$ = "" THEN _ EXIT SUB CALL SKIPLINE (1) CALLERS.FILE.INDEX.TEMP! = CALLERS.FILE.INDEX! CLOSE 4 IF SHARE.IT THEN _ OPEN CALLERS.FILE$ FOR RANDOM SHARED AS #4 LEN=64 _ ELSE OPEN "R",4,CALLERS.FILE$,64 FIELD 4,64 AS CALLERS.RECORD$ 57005 IF CALLERS.FILE.INDEX.TEMP! < 1 OR RET THEN _ EXIT SUB 57010 GET 4,CALLERS.FILE.INDEX.TEMP! A$ = CALLERS.RECORD$ IF LEFT$(A$,3) = " " OR _ INSTR(A$,"on at") = 0 THEN _ GOTO 57030 57025 CALLERS.FILE.INDEX.TEMP! = CALLERS.FILE.INDEX.TEMP! - 1 GET 4,CALLERS.FILE.INDEX.TEMP! Z = INSTR(CALLERS.RECORD$,"{") IF Z < 1 OR Z > 15 THEN _ Z = 15 IF SYSOP OR _ LEFT$(A$,3) <> " " THEN _ A$ = A$ + LEFT$(CALLERS.RECORD$,Z - 1) GOSUB 57100 IF SYSOP THEN _ A$ = MID$(CALLERS.RECORD$,Z) : _ GOSUB 57100 GOTO 57045 57030 IF SYSOP THEN _ GOSUB 57100 57045 CALLERS.FILE.INDEX.TEMP! = CALLERS.FILE.INDEX.TEMP! -1 GOTO 57005 57100 IF INSTR(A$,"LOGON DENIED") THEN _ IF NOT SYSOP THEN _ RETURN CALL QTPUT1 (A$) CALL ASKMORE ("",TRUE,TRUE,X,FALSE) IF NO OR SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB RETURN END SUB 58050 ' $SUBTITLE: 'FINDTIME - sub to calculate seconds since midnight' ' $PAGE ' ' NAME -- FINDTIME ' ' INPUTS -- PARAMETER MEANING ' SECONDS! VARIABLE TO RETURN RESULTS WITH ' ' OUTPUTS -- SECONDS! SECONDS SINCE MIDNIGHT ' ' PURPOSE -- To calculate the number of seconds that elapsed since midnight ' SUB FINDTIME (SECONDS!) STATIC SECONDS! = TIMER END SUB 58060 ' $SUBTITLE: 'ALLCAPS - sub to convert string to upper case' ' $PAGE ' ' NAME -- ALLCAPS ' ' INPUTS -- PARAMETER MEANING ' CONVERT.FIELD$ STRING TO MAKE UPPER CASE ' ' OUTPUTS -- CONVERT.FIELD$ CONVERTED STRINGS ' ' PURPOSE -- Subroutine to convert a string to upper case ' SUB ALLCAPS (CONVERT.FIELD$) STATIC IF TURBO.RBBS THEN _ CALL RBBSULC (CONVERT.FIELD$) : _ EXIT SUB FOR Z = 1 TO LEN(CONVERT.FIELD$) IF MID$(CONVERT.FIELD$,Z,1) > "@" THEN _ MID$(CONVERT.FIELD$,Z,1) = CHR$(ASC(MID$(CONVERT.FIELD$,Z,1)) AND 223) NEXT END SUB 58070 ' $SUBTITLE: 'CHECKTIM - sub to see if time has elasped' ' $PAGE ' ' NAME -- CHECKTIM ' ' INPUTS -- PARAMETER MEANING ' MAX.TIME! NUMBER OF SECONDS PAST MIDNIGHT ' NOT TO EXCEED ' ' OUTPUTS -- SUBROUTINE.PARAMETER = 1 CURRENT TIME IS LESS THAN ' MAX.TIME! ' SUBROUTINE.PARAMETER = 2 CURRENT TIME IS GREATER THAN ' OR EQUAL TO MAX.TIME! ' ' PURPOSE -- Subroutine to check if the current time is greater ' than or equal to the time allowed ' SUB CHECKTIM (MAX.TIME!) STATIC SUBROUTINE.PARAMETER = 1 CALL FINDTIME (TI!) IF MAX.TIME! < 86400 AND TI! < MAX.TIME! THEN _ EXIT SUB IF MAX.TIME! < 86400 AND TI! => MAX.TIME! THEN _ SUBROUTINE.PARAMETER = 2 : _ EXIT SUB TEST.TIME! = MAX.TIME! - 86400 IF TEST.TIME! - TI! <= 0 THEN _ EXIT SUB IF TI! => TEST.TIME! THEN _ SUBROUTINE.PARAMETER = 2 END SUB 58080 ' $SUBTITLE: 'HASHRBBS - sub to determine where to look for user' ' $PAGE ' ' NAME -- HASHRBBS ' ' INPUTS -- PARAMETER MEANING ' STRNG.TO.HASH$ USER NAME TO LOCATE ' MAX.POSITION MAXIMUM # USERS ' ' OUTPUTS -- PRIME.HASH WHERE TO LOOK FIRST ' SECOND.HASH LOOK THIS FAR AHEAD ' ' PURPOSE -- Where to look for a user in users file ' Look first at prime position, then add ' SECOND.HASH until find or find unused record ' SUB HASHRBBS (STRNG.TO.HASH$,MAX.POSITION,PRIME.HASH,SECOND.HASH) STATIC SECOND.HASH = (ASC(MID$(STRNG.TO.HASH$,2,1)) * 10 + 7) MOD _ MAX.POSITION PRIME.HASH = _ ((ASC(STRNG.TO.HASH$) * 100 + _ ASC(MID$(STRNG.TO.HASH$,(LEN(STRNG.TO.HASH$) / 2) + .1,1)) * _ 10 + _ ASC(RIGHT$(STRNG.TO.HASH$,1))) _ MOD MAX.POSITION) + 1 END SUB 58100 ' $SUBTITLE: 'SETOPTS - sub to set prompts based on user security' ' $PAGE ' ' NAME -- SETOPTS ' ' INPUTS -- PARAMETER MEANING ' FIRST POSITION WHERE START LOOKING ' LAST POSITION WHERE QUIT LOOKING ' USER.SECURITY.LEVEL SECURITY OF USER ' ' OUTPUTS -- OPTIONS$ LIST OF COMMANDS USER CAN DO ' ' PURPOSE -- String together what commands user can do in a section ' SUB SETOPTS (OPTIONS$,INVALID.OPTIONS$,FIRST,LAST) STATIC OPTIONS$ = "" INVALID.OPTIONS$ = "" FOR I = FIRST TO LAST IF USER.SECURITY.LEVEL < OPT.SEC(I) THEN _ INVALID.OPTIONS$ = INVALID.OPTIONS$ + _ MID$(ALL.OPTS$,I,1) _ ELSE IF MID$(ALL.OPTS$,I,1) <> " " THEN _ OPTIONS$ = OPTIONS$ + _ MID$(ALL.OPTS$,I,1) NEXT CALL SRTSTRNG (OPTIONS$) CALL SRTSTRNG (INVALID.OPTIONS$) END SUB 58110 ' $SUBTITLE: 'CHKNEWBUL - sub to check whether got new bulletins' ' $PAGE ' ' NAME -- CHKNEWBUL ' ' INPUTS -- PARAMETER MEANING ' LAST.ON$ LAST DATE OF LOGON ' FORMAT MM/DD/YY ' ACTIVE.BULLETINS # OF BULLETING ' BULLETIN.PREFIX$ FILESPEC FOR BULLETINS ' ' OUTPUTS -- NUM.NEW.BULLETS NUMBER OF NEW BULLETINS ' NEW.BULLETS$ LIST OF NEW BULLET #'S ' Q WHERE LAST BULLETIN STORED ' IN B$() ' B$() BULLETINS #'S THAT ARE NEW ' (2,3,4,...) ' ' PURPOSE -- Checks how many bulletins have system date ' at or later than date caller last logged on ' SUB CHKNEWBUL (LAST.ON$,NUM.NEW.BULLETS,NEW.BULLETS$) STATIC NUM.NEW.BULLETS = 0 NEW.BULLETS$ = ": " BASE.DATE# = VAL(MID$(LAST.ON$,4,2)) + (100 * VAL(MID$(LAST.ON$,1,2))) + _ (10000# * (1900 + VAL(MID$(LAST.ON$,7,2)))) CALL FINDIT (BULLETIN.PREFIX$ + ".FCK") X = 0 CALL QTPUT ("Checking new bulletins",0) IF OK THEN _ WHILE NOT EOF(2) : _ LINE INPUT #2,Y$ : _ GOSUB 58112 : _ WEND _ ELSE FOR I = 1 TO ACTIVE.BULLETINS : _ Y$ = MID$(STR$(I),2) : _ GOSUB 58112 : _ NEXT Q = NUM.NEW.BULLETS + 1 IF NUM.NEW.BULLETS < 1 THEN _ NEW.BULLETS$ = "" EXIT SUB 58112 X$ = BULLETIN.PREFIX$ + _ Y$ + _ CHR$(0) CALL MARKTIME (X) CALL RBBSFIND (X$,IX,YY,MM,DD) IF IX = 0 THEN _ FDATE# = DD + (100 * MM) + (10000# * (YY + 1980)) : _ IF BASE.DATE# <= FDATE# THEN _ NUM.NEW.BULLETS = NUM.NEW.BULLETS + 1 : _ B$(NUM.NEW.BULLETS + 1) = Y$ : _ NEW.BULLETS$ = NEW.BULLETS$ + _ " " + _ Y$ RETURN END SUB 58120 ' $SUBTITLE: 'SRTSTRNG - sub to sort characters in a string' ' $PAGE ' ' NAME -- SRTSTRNG ' ' INPUTS -- PARAMETER MEANING ' STRNG$ STRING TO SORT ' ' OUTPUTS -- STRNG$ SORTED STRING ' ' PURPOSE -- Sorts characters in passed string. ' SUB SRTSTRNG (STRNG$) STATIC S0 = LEN(STRNG$) S1 = S0 X$ = "!" 58122 S1 = S1\2 IF S1 = 0 THEN _ EXIT SUB S2 = S0 - S1 FOR S3 = 1 TO S2 S4 = S3 58124 S5 = S4 + S1 IF MID$(STRNG$,S4,1) > MID$(STRNG$,S5,1) THEN _ LSET X$ = MID$(STRNG$,S4,1) : _ MID$(STRNG$,S4,1) = MID$(STRNG$,S5,1) : _ MID$(STRNG$,S5,1) = X$ : _ S4 = S4 - S1 : _ IF S4 > 0 THEN _ GOTO 58124 NEXT GOTO 58122 END SUB 58130 ' $SUBTITLE: 'INSCOMMA - sub to format commands in command prompt' ' $PAGE ' ' NAME -- INSCOMMA ' ' INPUTS -- PARAMETER MEANING ' STRNG$ STRING TO REPLACE ' ' OUTPUTS -- STRNG$ REPLACED STRING ' ' PURPOSE -- Inserts commands between each letter in STRNG$ ' and encloses in pointed brackets ' SUB INSCOMMA (STRNG$) STATIC L = LEN(STRNG$) IF L < 1 THEN _ EXIT SUB LSET LINEMES$ = " <" + _ LEFT$(STRNG$,1) FOR K = 2 TO L MID$(LINEMES$,2 * K,2) = "," + _ MID$(STRNG$,K,1) NEXT STRNG$ = LEFT$(LINEMES$,2 * L + 1) + _ ">" END SUB 58140 ' $SUBTITLE: 'LOADNEW - subroutine to get latest uploads' ' $PAGE ' ' NAME -- LOADNEW ' ' INPUTS -- PARAMETER MEANING ' UPLOAD.DIRECTORY$ LIST OF FILES UPLOADED ' ' OUTPUTS -- A$ LATEST UPLOADS ' ' PURPOSE -- Loads table of most recent number of uploads by date ' SUB LOADNEW (ARA(2)) STATIC IF FMS.DIRECTORY$ = "" THEN _ EXIT SUB PREV.BASE$ = "" IF PREV.LOADNEW$ = FMS.DIRECTORY$ THEN _ ARA(1,1) = 0 : _ EXIT SUB PREV.LOADNEW$ = FMS.DIRECTORY$ CALL OPENFMS (LAST.REC) FIELD 2, 23 AS PRE.DATE$, _ 2 AS MM$, _ 1 AS FILL1$, _ 2 AS DD$, _ 1 AS FILL2$, _ 2 AS YY$, _ (2 + MAX.DESC.LEN) AS FILL3$, _ 3 AS CATEGORY$, _ 2 AS FILL4$ MAX.RECS = UBOUND(ARA,1) IF MAX.RECS < 1 THEN _ MAX.RECS = 1 _ ELSE IF MAX.RECS > 23 THEN _ MAX.RECS = 23 L = 0 K = LAST.REC WHILE K > 0 AND L < MAX.RECS GET #2,K IF INSTR("\= ",LEFT$(PRE.DATE$,1)) > 0 THEN _ GOTO 58142 IF (CAN.DOWNLOAD.FROM.UP OR CATEGORY$ <> DEFAULT.CATEGORY.CODE$) THEN _ L = L + 1 : _ ARA(L,1) = 372 * (VAL(YY$) - 80) + 31 * VAL(MM$) + VAL(DD$) IF NOT CAN.DOWNLOAD.FROM.UP THEN _ X = MIN.SEC.TO.VIEW _ ELSE IF CATEGORY$ = "***" THEN _ X = SYSOP.SECURITY.LEVEL _ ELSE IF CATEGORY$ = DEFAULT.CATEGORY.CODE$ THEN _ X = MIN.SEC.TO.VIEW _ ELSE X = OPT.SEC(19) ARA(L,2) = X 58142 K = K - 1 WEND CLOSE 2 END SUB 58150 ' $SUBTITLE: 'CTNEWFILES - sub to count how many files new' ' $PAGE ' ' NAME -- CTNEWFILES ' ' INPUTS -- PARAMETER MEANING ' LAST.ON$ Date of last logon ' UPLDS$ Latest uploads ' ' OUTPUTS -- NUM.NEW.FILES How many after last logon ' RPT.PREFIX$ Set to "At least " if ' above is a minimum ' ' PURPOSE -- Checks how many files in UPLDS$ were uploaded on or ' after date of last logon that the user can download ' SUB CTNEWFILES (LAST.ON$,UPLDS(2),NUM.USER.FILES,RPT.PREFIX$) STATIC BASE.DATE = 372 * (VAL(MID$(LAST.ON$,7,2)) - 80) + _ 31 * (VAL(MID$(LAST.ON$,1,2))) + _ VAL(MID$(LAST.ON$,4,2)) NUM.NEW.FILES = 1 NUM.USER.FILES = 0 WHILE (BASE.DATE <= UPLDS(NUM.NEW.FILES,1) AND _ UPLDS(NUM.NEW.FILES,1) > 0 AND _ NUM.NEW.FILES < UBOUND(UPLDS,1)) IF USER.SECURITY.LEVEL => UPLDS(NUM.NEW.FILES,2) THEN _ NUM.USER.FILES = NUM.USER.FILES + 1 NUM.NEW.FILES = NUM.NEW.FILES + 1 WEND IF UPLDS(NUM.NEW.FILES,1) < 1 THEN _ NUM.NEW.FILES = NUM.NEW.FILES - 1 IF BASE.DATE <= UPLDS(NUM.NEW.FILES,1) THEN _ RPT.PREFIX$ = "At least " _ ELSE RPT.PREFIX$ = "" END SUB 58160 ' $SUBTITLE: 'CTLINES - sub to determine file categories ' ' $PAGE ' ' NAME -- CTLINES ' ' INPUTS -- PARAMETER MEANING ' DIR.CATEGORY.FILE$ NAME OF THE FILE THAT HAS THE ' NUMBER OF CATEGORIES IN IT. ' ' OUTPUTS -- MAX.ENTRIES NUMBER OF FILE CATEGORIES ' ' PURPOSE -- Subroutine to count the number of categories that a ' file can be classified into. ' SUB CTLINES (MAX.ENTRIES) STATIC CALL LINESNFIL (DIR.CATEGORY.FILE$,MAX.ENTRIES) MAX.ENTRIES = MAX.ENTRIES + 3 IF MAX.ENTRIES < 10 THEN _ MAX.ENTRIES = 10 END SUB 58161 ' $SUBTITLE: 'CTLINES - sub to determine file categories ' ' $PAGE ' ' NAME -- LINESNFIL ' ' INPUTS -- PARAMETER MEANING ' FILNAME$ Name of file to use ' ' OUTPUTS -- LKNT Count of # of lines in file ' ' PURPOSE -- Subroutine to count the number of categories that a ' file can be classified into. ' SUB LINESNFIL (FILNAME$,LKNT) STATIC CALL FINDIT (FILNAME$) LKNT = 0 IF OK THEN _ WHILE NOT EOF(2) : _ LKNT = LKNT + 1 : _ LINE INPUT #2,A$ : _ WEND CLOSE 2 END SUB 58162 ' $SUBTITLE: 'INITFMS - sub to initialize file management system' ' $PAGE ' ' NAME -- INITFMS ' ' INPUTS -- PARAMETER MEANING ' FMS.DIRECTORY$ ' ' OUTPUTS -- CATEGORY.NAME$() ELEMENTS 1,2, POSSIBLY MORE ' CATEGORY.CODE$() ELEMENTS 1,2, POSSIBLY MORE ' CATEGORY.DESC$() ELEMENTS 1,2, POSSIBLY MORE ' CATEGORY.INDEX COUNT OF # ELEMENTS IN THE FILE ' MANAGMENT SYSTEM ' ' PURPOSE -- Subroutine to initialize the RBBS-PC File Management System ' SUB INITFMS (CATEGORY.NAME$(1),CATEGORY.CODE$(1), _ CATEGORY.DESC$(1),CATEGORY.INDEX) STATIC BLNK$ = " " CATEGORY.INDEX = 0 IF FMS.DIRECTORY$ <> "" THEN _ CATEGORY.INDEX = CATEGORY.INDEX + 1 : _ CATN$ = CATEGORY.NAME$(CATEGORY.INDEX) : _ CALL BRKFNAME (FMS.DIRECTORY$,DRVPATH$,CATN$,EXTENSION$,FALSE) : _ CATEGORY.NAME$(CATEGORY.INDEX) = CATN$ : _ CATEGORY.CODE$(CATEGORY.INDEX) = "" : _ CATEGORY.DESC$(CATEGORY.INDEX) = "All uploads"_ ELSE LIMIT.SEARCH.TO.FMS = FALSE : _ EXIT SUB IF LIMIT.SEARCH.TO.FMS OR MASTER.DIRECTORY.NAME$ = MAIN.FMS.DIRECTORY$ THEN _ CATEGORY.INDEX = CATEGORY.INDEX + 1 : _ CATEGORY.NAME$(CATEGORY.INDEX) = "ALL" : _ CATEGORY.CODE$(CATEGORY.INDEX) = "" : _ CATEGORY.DESC$(CATEGORY.INDEX) = "All files" CALL FINDIT (DIR.CATEGORY.FILE$) IF NOT OK THEN _ EXIT SUB WHILE NOT EOF(2) CALL READPARMS (WORK.ARA$(),3,1) IF EC > 0 THEN _ EC = 0 : _ CALL PSCRN (DIR.CATEGORY.FILE$+" invalid. Line" + STR$(CATEGORY.INDEX) + " needs 3 parms") : _ CALL DELAYIT (4) _ ELSE CATEGORY.INDEX = CATEGORY.INDEX + 1 : _ CATEGORY.NAME$(CATEGORY.INDEX) = WORK.ARA$(1) : _ CATEGORY.CODE$(CATEGORY.INDEX) = WORK.ARA$(2) : _ CATEGORY.DESC$(CATEGORY.INDEX) = WORK.ARA$(3) : _ CATR$ = CATEGORY.CODE$(CATEGORY.INDEX) : _ CALL REMOVE (CATR$,BLNK$) : _ CATEGORY.CODE$(CATEGORY.INDEX) = CATR$ WEND CLOSE 2 END SUB 58165 ' $SUBTITLE: 'DISUPDIR - sub to display upload direcotry' ' $PAGE ' ' NAME -- DISUPDIR ' ' INPUTS -- PARAMETER MEANING ' PASSED.CATEGORIES$ FILE "CATEGORIES" TO BE INCLUDED IN ' THE SEARCH. ' SEARCH.STRING$ STRING TO SEARCH ON WITHIN THE ' FILE "CATEGORIES" SELECTED ' SEARCH.DATE$ DATE EQUAL TO OR GREATER THAN TO BE ' SEARCHED FOR WITH THE "CATEGORIES" ' AND THE STRING TO SEARCH. ' DOWNLOAD.FLAG SET TO RECORD # OF LINE TO BEGIN ' VIEWING - 0 IF AT END ' ' OUTPUTS -- DOWNLOAD.FLAG WHENEVER DOWNLOAD REQUESTED, SETS ' TO NEXT RECORD TO VIEW. OTHERWISE ' LEAVES AT ZERO ' PURPOSE -- Display the files that meet the criteria selected in ' RBBS-PC upload management system on the users screen. ' SUB DISUPDIR (PASSED.CATEGORIES$,SEARCH.STRING$, _ SEARCH.DATE$,DOWNLOAD.FLAG,ABORT.INDEX) STATIC CALL ALLCAPS (SEARCH.STRING$) BLNK$ = " " STOP.INTERRUPTS = FALSE CATEGORIES$ = "," + _ PASSED.CATEGORIES$ + _ "," CAN.DOWNLOAD = (USER.SECURITY.LEVEL => OPT.SEC(19)) GOSUB 58185 IF DOWNLOAD.FLAG > 0 THEN _ UPLOAD.INDEX = DOWNLOAD.FLAG : _ DOWNLOAD.FLAG = 0 : _ GOTO 58180 EXTRA.PRMPT$ = ",V)iew" IF CAN.DOWNLOAD THEN _ IF TURBO.KEY.USER THEN _ EXTRA.PRMPT$ = EXTRA.PRMPT$ + ",D)ownload" _ ELSE EXTRA.PRMPT$ = EXTRA.PRMPT$ + ", or file(s) to download" MAX.PRINT = PAGE.LENGTH - 1 BELOW.MIN.SEC = (USER.SECURITY.LEVEL < MIN.SEC.TO.VIEW) NON.STOP = NON.STOP OR (PAGE.LENGTH < 1) CHECK.POINT = 0 WILD.SEARCH = (INSTR(SEARCH.STRING$,"?") > 0) _ OR (INSTR(SEARCH.STRING$,"*") > 0) 58168 UPLOAD.INDEX = UPLOAD.INDEX + UPINC IF UPLOAD.INDEX = CUTOFF.REC THEN _ GOTO 58182 GET #2,UPLOAD.INDEX CHECK.POINT = CHECK.POINT + 1 ON INSTR("\* =",LEFT$(PART.TO.PRINT$,1)) GOTO 58168,58171,58170,58169 GOTO 58172 58169 A = VAL(MID$(PART.TO.PRINT$,34)) IF USER.SECURITY.LEVEL < A THEN _ LAST.OK = FALSE : _ GOTO 58168 MID$(PART.TO.PRINT$,1,13) = MID$(PART.TO.PRINT$,2,12) + " " A = LEN(STR$(A)) MID$(PART.TO.PRINT$,34) = MID$(PART.TO.PRINT$,34 + A) + SPACE$(A) GOTO 58172 58170 IF EXTENDED.OFF THEN _ GOTO 58168 _ ELSE IF LAST.OK THEN _ GOTO 58175 _ ELSE IF SEARCH.STRING$ <> "" AND (NOT WILD.SEARCH) AND FAILED.SEARCH THEN _ A$ = PART.TO.PRINT$ : _ CALL ALLCAPS (A$) : _ HIGHLITE.POS = INSTR(A$,SEARCH.STRING$) : _ IF HIGHLITE.POS > 0 THEN _ HIGHLITE.REC = UPLOAD.INDEX : _ UPLOAD.INDEX = LAST.FNAME : _ GET 2,UPLOAD.INDEX :_ _ GOTO 58175 _ ELSE GOTO 58168 _ ELSE GOTO 58168 58171 IF CATEGORY$ = "***" THEN _ GOTO 58176 _ ELSE KEE$ = "," + CATEGORY$ + "," : _ IF INSTR(CATEGORIES$,KEE$) > 0 THEN _ GOTO 58176 _ ELSE GOTO 58168 58172 LAST.OK = FALSE FAILED.SEARCH = FALSE LAST.FNAME = UPLOAD.INDEX IF CATEGORY$ = "***" THEN _ IF NOT SYSOP THEN _ GOTO 58178 IF CATEGORY$ = DEFAULT.CATEGORY.CODE$ THEN _ IF BELOW.MIN.SEC THEN _ GOTO 58178 58173 IF LEN(CATEGORIES$) > 2 THEN _ KEE$ = "," + _ CATEGORY$ + _ "," : _ CALL REMOVE (KEE$,BLNK$) : _ IF INSTR(CATEGORIES$,KEE$) = 0 THEN _ GOTO 58178 IF SEARCH.STRING$ <> "" THEN _ A$ = PART.TO.PRINT$ : _ IF WILD.SEARCH THEN _ CALL WILDFILE (SEARCH.STRING$,LEFT$(PART.TO.PRINT$,INSTR(PART.TO.PRINT$," ")-1),OK) : _ IF OK THEN _ GOTO 58175 _ ELSE GOTO 58178 _ ELSE CALL ALLCAPS (A$) : _ HIGHLITE.POS = INSTR(A$,SEARCH.STRING$) : _ IF HIGHLITE.POS > 0 THEN _ HIGHLITE.REC = UPLOAD.INDEX _ ELSE FAILED.SEARCH = TRUE : _ GOTO 58178 58174 IF SEARCH.DATE$ <> "" THEN _ KEE$ = MID$(PART.TO.PRINT$,30,2) + _ MID$(PART.TO.PRINT$,24,2) + _ MID$(PART.TO.PRINT$,27,2) : _ IF KEE$ < SEARCH.DATE$ THEN _ IF DATE.ORDERED.FMS THEN _ GOTO 58183 _ ELSE GOTO 58168 ' ' ' * Allow the FMS to be both fast and interruptable if a local ' * user or there is nothing in the input buffer by using QTPUT. ' ' 58175 LAST.OK = TRUE 58176 A = END.DESC IF LEFT$(PART.TO.PRINT$,5) = " " THEN _ GOTO 58178 WHILE MID$(PART.TO.PRINT$,A,1) = " " A = A - 1 WEND A$ = LEFT$(PART.TO.PRINT$,A) CALL COLORDIR (A$,"Y") IF UPLOAD.INDEX = HIGHLITE.REC THEN _ HIGHLITE.REC = -1 : _ HIGHLITE.POS = 0 : _ CALL CHKCOLOR (A$,SEARCH.STRING$,"") 58177 IF LOCAL.USER THEN _ CALL QTPUT1 (A$) : _ GOTO 58178 CALL EOFCOMM (CHAR%) IF CHAR% = -1 THEN _ CALL QTPUT1 (A$) _ ELSE SUBROUTINE.PARAMETER = 5 : _ CALL TPUT : _ IF RET THEN _ GOTO 58183 58178 IF LINES.PRINTED <= MAX.PRINT AND CHECK.POINT < 1000 THEN _ GOTO 58168 CALL CHKCARRIER ' KG061203 IF SUBROUTINE.PARAMETER = -1 THEN _ GOTO 58183 CALL TIMEREMAIN (TIME.REMAINING!) IF TIME.REMAINING! < 0.1 THEN _ SUBROUTINE.PARAMETER = -1 : _ GOTO 58183 IF NON.STOP THEN _ GOTO 58168 IF LINES.PRINTED <= MAX.PRINT THEN _ CALL QTPUT1 (EMPHASIZE.OFF$ + "Files checked thru " + MID$(PART.TO.PRINT$,24,8)) 58180 TURBO.KEY = -TURBO.KEY.USER CALL ASKMORE (EXTRA.PRMPT$, TRUE, FALSE,ABORT.INDEX,FALSE) IF SUBROUTINE.PARAMETER = -1 THEN _ GOTO 58183 IF NO THEN _ GOTO 58183 CALL ALLCAPS (B$(1)) IF B$(1) = "V" THEN _ CALL GETARC : _ A = UPLOAD.INDEX : _ GOSUB 58185 : _ UPLOAD.INDEX = A : _ GOTO 58180 IF B$(1) = "D" THEN _ A$ = "Download what file(s)" : _ SUBROUTINE.PARAMETER = 1 : _ CALL TGET : _ IF Q = 0 THEN _ GOTO 58180 IF LEN(B$(1)) > 2 THEN _ IF NOT YES AND CAN.DOWNLOAD THEN _ CALL SKIPLINE (1) : _ DOWNLOAD.FLAG = UPLOAD.INDEX : _ EXIT SUB IF NON.STOP THEN IF UPLOAD.INDEX > 999 THEN _ IF (SEARCH.DATE$ = "" OR NOT EXPERT.USER) THEN _ A$ = STR$(UPLOAD.INDEX) + _ " lines left to search. Really go non-stop? (Y/[N])" : _ NO.ADVANCE = TRUE : _ TURBO.KEY = -TURBO.KEY.USER : _ SUBROUTINE.PARAMETER = 1 : _ CALL TGET : _ CALL WIPELINE (79) : _ NON.STOP = YES ' KG072301 CHECK.POINT = 0 GOTO 58168 58182 IF CHAINED.DIR$ <> "" THEN _ ACTIVE.FMS.DIRECTORY$ = CHAINED.DIR$ : _ GOSUB 58185 : _ GOTO 58168 58183 CLOSE 2 NON.STOP = (PAGE.LENGTH < 1) STOP.INTERRUPTS = FALSE A$ = "" EXIT SUB 58185 CALL OPENFMS (UPLOAD.INDEX) END.DESC = 33 + MAX.DESC.LEN FIELD 2, END.DESC AS PART.TO.PRINT$, _ 3 AS CATEGORY$, _ 2 AS FILLER$ PREV.FMS$ = ACTIVE.FMS.DIRECTORY$ IF UPINC = -1 THEN _ CUTOFF.REC = 0 : _ UPLOAD.INDEX = UPLOAD.INDEX + 1 _ ELSE CUTOFF.REC = UPLOAD.INDEX + 1 : _ UPLOAD.INDEX = 0 RETURN END SUB