' $linesize:132 ' $title: 'RBBSSUB3.BAS CPC17-1D Copyright 1986 - 89 by D. Thomas Mack' ' Copyright 1987 by D. Thomas Mack, all rights reserved. ' Name ...............: RBBSSUB3.BAS ' Written by .........: D. Thomas Mack ' First Released .....: September 18, 1988 ' Subsequent Releases.: OCTOBER 30 1988 ' Copyright ..........: 1986, 1987, 1988 ' 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 RBBSSUB2.BAS, RBBSSUB3.BAS, ' RBBSSUB4.BAS and RBBSSUB5.BAS 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 41500 Calculate the current time as AM or PM ' ASKGRAPH 43306 Determine users graphic default ' BADFILE 20741 Check for system crash attempt with bad device name ' CALLOPT 58090 Set prompts based on the user's security ' 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 44000+ 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 50500 Wait number of seconds specified before returning ' DISPCALL 57001 Display callers file ' DISPLAYTR 41010+ Compute and display time remaining ' DISUPDIR 58165 Display the shared directory of the FMS mng. sys. ' FILELOCK 21995 Allow files to be shared among multiple RBBS-PC's ' FINDFUNC 30600 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 58160+ 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 ' 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 43070 Save the user's provile when exiting to "doors" or DOS ' SENDNAME 20295 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' ' ' $SUBTITLE: 'WILDFILE -- Matches file to a filespec' ' $PAGE ' SUBROUTINE NAME -- WILDFILE ' ' INPUT PARAMETERS -- PARAMETER MEANING ' PATTERN$ PATTERN TO CHECK AGAINST ' ITEM.TO.MATCH$ FILE NAME TO MATCH ' ' OUTPUT PARAMETERS DOES.MATCH WHETHER MATCHES ' ' SUBROUTINE PURPOSE DETERMINE WHETHER A FILE NAME IS AN INSTANCE OF ' A FILE SPECIFICATION. EXACTLY LIKE DOS EXCEPT THAT ? MUST HAVE A ' CHARACTER. ' 20290 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 ' $SUBTITLE: 'SENDNAME - send FILENAME using EXEC-PC protocol' ' $PAGE ' ' SUBROUTINE NAME -- SENDNAME ' ' INPUT PARAMETERS -- PARAMETER MEANING ' B$() ARRAY OF FILENAME FOR AUTODOWNLOAD ' DWN.INDEX INDEX OF FILENAME TO TRANSFER ' ' OUTPUT PARAMETERS -- ABORT -1 FOR AN ABORTED ATTEMPT ' ' SUBROUTINE 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 20296 20298 20300 20305 20306 20310 20313 20315 END SUB ' $SUBTITLE: 'UPDTUPLOAD -- Updates upload directory' ' $PAGE ' SUBROUTINE NAME -- UPDTUPLOAD ' ' INPUT PARAMETERS -- PARAMETER MEANING ' FILE.NAME$ ' UPLOAD.DIRECTORY$ ' FILE.NAME.HOLD$ ' SHARE.IT ' FMS.DIRECTORY$ ' Q! ' TCA! ' ' OUTPUT PARAMETERS -- BYTES.IN.FILE# ' SECONDS.PER.SESSION! ' ' SUBROUTINE 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,FF) STATIC '<=== ON FF GOTO 20710,20724,20723,20722 20710 ABORT = FALSE ' PE ABORT MOD CALL QTPUT("Describe " + FILE.NAME.HOLD$ +CRLF$ + _ " (Begin with / if for SYSOP only) or enter ABORT to cancel",1) CALL QTPUT(LEFT$(" |----+--Min<..-+---2+0---+---3+0---+---4+0---+-", _ MAX.DESC.LEN - 4) + "..Max>",1) A$ = "" SUBROUTINE.PARAMETER = 1 PARSE.OFF = TRUE CALL TGET CALL CARRIER IF SUBROUTINE.PARAMETER = -1 THEN _ B$ = "": _ GOTO 20712 IF B$ = "ABORT" OR B$ = "abort" THEN _ ABORT = TRUE : _ EXIT SUB IF LEN(B$) > MAX.DESC.LEN OR LEN(B$) < 5 THEN _ CALL QTPUT (" Description must be 5 chars min," + STR$(MAX.DESC.LEN) + " chars max",1) : _ CALL QTPUT (" ENTER the word ABORT to cancel transfer....",1) : _ GOTO 20710 20712 DESC$ = B$ IF NOT LIMIT.SEARCH.TO.FMS THEN _ IF FMS.DIRECTORY$ <> UPLOAD.DIRECTORY$ THEN _ IF LEFT$(B$,1) = "/" THEN _ GOTO 20722_ ELSE GOTO 20717 ' 20715 IF LEFT$(B$,1) = "/" OR LEFT$(B$,1) = "\" THEN _ B$ = MID$(B$(1),2) : _ 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 (H=help)" SUBROUTINE.PARAMETER = 1 CALL TGET IF SUBROUTINE.PARAMETER = -1 THEN _ B$ = DEFAULT.CATEGORY.CODE$ : _ GOTO 20722 IF Q = 0 THEN _ GOTO 20719 CALL ALLCAPS (B$(1)) 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 NOT OK THEN _ STREW.TO$ = "" _ ELSE GOTO 20722 CALL QTPUT ("No such category " + B$(1),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 YES THEN _ CALL SKIPLINE (2):_ CALL QTPUT (CHR$(7)+ " Description will be Entered AFTER the UPLOAD is Completed",2) : _ CALL DELAYIT (2) :_ GET.EXT.DESC = TRUE: _ EXIT SUB 'CALL AUTOLOGOFF 'Pe 04/09/89 EXIT SUB ' ********* routine AFTER the Upload is successfull and Extended = True ***** 20723 IF NOT LIMIT.SEARCH.TO.FMS THEN _ STREW.TO$ = DIRECTORY.PATH$ + _ B$(1) + _ "." + _ DIRECTORY.EXTENTION$ CALL FINDIT (STREW.TO$) IF NOT OK THEN _ STREW.TO$ = "" B$ = DESC$ X$ = DATE$ Z$ = LEFT$(X$,6) + _ RIGHT$(X$,2) EN$ = STREW.TO$ GOSUB 20730 EN$ = ALWAYS.STREW.TO$ GOSUB 20730 GOTO 20726 'CHANGE from 20725 to 20726 ' '***** ENTRY POINT WHEN UPLOAD is Finished *********** ' 20724 CALL FINDIT (FILE.NAME$) IF NOT OK THEN _ BYTES.IN.FILE# = 0.0 _ ELSE BYTES.IN.FILE# = LOF(2) IF BYTES.IN.FILE# < 2.0 THEN _ EXIT SUB '************************8 New Convert code begins here 8******************* ' Orig mods by Warren Muldrow ' ' Zip Convert code. Does the following: ' ' .EXE files are retained as is (for self-extracting files) ' ' .ZIP, .ARC, .PAK, .ZOO, and .LZH are unzrc'ed and then Zipped ' ' All other files are Zipped ' ' PKUNZIP, PKZIP, PKUNPAK, PAK, LHARC, ZOO.BAT, WHAT.EXE, and LOOZ.EXE ' should be in the DOS path or the RBBS directory. WHAT is used by ' ZOO.BAT and is included in this archive. ' ' The Library work path (Config parm # 304) is used for a work area ' IF ABORT = TRUE THEN _ 'Corrects aborted uploads EXIT SUB 'corrects aborted uploads ' ' Allows SYSOP and users with security level to add new DIR entry ' the option to convert or not ' Pe 05/31/89 updated 06/12/89 ' IF SYSOP OR USER.SECURITY.LEVEL > = ADD.DIR.SECURITY THEN A$ = " Convert or verify " + FILE.NAME$ + " ([Y],N) " SUBROUTINE.PARAMETER = 1 CALL TGET IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB IF NO THEN _ GOTO 20725 END IF 'End of 05/31/89 mod ' CALL BRKFNAME (FILE.NAME$, DR$, ZZ$, X$, TRUE) IF X$ = ".EXE" OR X$ = "" OR EXT$ = ".SFX" THEN _ GOTO 20725 IF X$ = ".ZIP" THEN _ CALL QTPUT (FILE.NAME.HOLD$ +" Now being verified and re-Zipped Please wait!",1) : _ Z$ = "PKUNZIP -x " + FILE.NAME$ + " " _ ELSE _ CALL QTPUT (FILE.NAME.HOLD$ +" Now being converted to .ZIP format. Please wait!",1) : _ IF X$ = ".ARC" OR X$ = ".PAK" THEN _ Z$ = "PAK e " + FILE.NAME$ + " " : _ ELSE IF X$ = ".LZH" THEN _ Z$ = "LHARC e " + FILE.NAME$ + " " : _ ELSE IF X$ = ".ZOO" THEN _ Z$ = "ZOO.BAT " + FILE.NAME$ + " " : _ ELSE _ SHELL "PKZIP -m -ex " + DR$ + ZZ$ + " " + FILE.NAME$ : _ Z$ = "" : IF Z$ <> "" THEN _ SHELL "MD " + LIBRARY.WORK.DISK.PATH$ + NODE.ID$ : _ SHELL Z$ + " " + LIBRARY.WORK.DISK.PATH$ + NODE.ID$ + "\" : _ SHELL "DEL " + FILE.NAME$ : _ SHELL "PKZIP -m -ex " + DR$ + ZZ$ + " " + _ LIBRARY.WORK.DISK.PATH$ + NODE.ID$ + "\*.*" : _ SHELL "RD " + LIBRARY.WORK.DISK.PATH$ + NODE.ID$ FILE.NAME.HOLD$ = ZZ$ + ".ZIP" FILE.NAME$ = DR$ + FILE.NAME.HOLD$ ' ' ' Comment code added here ' CALL FINDIT (FILE.NAME$) IF OK THEN CLOSE 2 COMMENT.NAME$ = UPLOAD.SUBDIR$ +"\UPLOAD.CMT ADDCMT1$ =CRLF$ +"Uploaded to "+ RBBS.NAME$ +" By: "+ACTIVE.USER.NAME$ ADDCMT2$ = CRLF$ +"Description: " + DESC$ ADDCOMMENT$ = ADDCMT1$ + ADDCMT2$ + CRLF$ CALL OPENOUTW (COMMENT.NAME$) PRINT #2, ADDCOMMENT$ CLOSE 2 ADDCMT$ = LIBRARY.ARCHIVE.PATH$+"PKZIP -z<"+COMMENT.NAME$+" "+ FILE.NAME$ SHELL ADDCMT$ END IF CALL FINDIT (FILE.NAME$) IF NOT OK THEN _ BYTES.IN.FILE# = 0.0 _ ELSE BYTES.IN.FILE# = LOF(2) CLOSE 2 IF BYTES.IN.FILE# < 2.0 THEN _ EXIT SUB 20725 CALL QTPUT(CX$(5)+"Upload successful,Thanks for the file "+CX$(2) + FIRST.NAME$+CX$(7),1) IF GET.EXT.DESC THEN _ EXIT SUB X$ = DATE$ Z$ = LEFT$(X$,6) + RIGHT$(X$,2) STREW.TO$ = "" B$ = DESC$ EN$ = ALWAYS.STREW.TO$ GOSUB 20730 EN$ = STREW.TO$ GOSUB 20730 ' 'VVVV NEW LINE NUMBER ONLY--- was 20725 'vvvv 20726 IF FMS.DIRECTORY$ <> UPLOAD.DIRECTORY$ THEN _ IF LEFT$(B$,1) = "/" OR LEFT$(B$,1) = "\" THEN _ CALL UPDTCALR (B$,2): _ GOTO 20727 '****************** End of Convert mods 05/10/89 ************** EN$ = UPLOAD.DIRECTORY$ GOSUB 20730 20727 DF$ = " >> uploaded << " UPLOADS = UPLOADS + 1 GLOBAL.UPLOADS = GLOBAL.UPLOADS + 1 ULBYTES! = ULBYTES! + BYTES.IN.FILE# GLOBAL.ULBYTES! = GLOBAL.ULBYTES! + BYTES.IN.FILE# CALL TIMEREMAIN (TIME.REMAINING!) IF PRIVATE.DOOR THEN _ ' KG101505 X! = UPLOAD.TIME.FACTOR! * Q! _ ' KG101505 ELSE X! = UPLOAD.TIME.FACTOR! * (TCA! - Q!) ' KG101505 TIME.CREDITS! = TIME.CREDITS! + X! SECONDS.PER.SESSION! = SECONDS.PER.SESSION! + X! IF PRIVATE.DOOR THEN _ ' KG101505 X! = (X! - Q!) / 60.0 _ ' KG101505 ELSE X! = (X! - TCA! + Q!)/60.0 ' KG101505 X$ = STR$(FIX(X!*10.0)) ' KG110505 X$ = LEFT$(X$,LEN(X$)-1) + "." + RIGHT$(X$,1) ' KG110505 IF X! > 1.0 THEN _ CALL QTPUT ("Uploads are appreciated here. For today your",1) : _ CALL QTPUT ("SESSION & DAILY time limits increased by "+X$+" minutes",1) X$ = "" 'PE11/14/88 GET.EXT.DESC = FALSE IF AUTO.END = 1 THEN _ FILESYS.PARAMETER = 7 : _ 'Pe 02/05/89 DOWNLOAD.COMPLETED = TRUE 'Pe 02/06/89 Fixes the fix 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 (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 (1) : _ IF EC = 0 THEN _ READ.BACKWARDS = (INSTR(A$," TOP ") = 0) BX = &H4 SUBROUTINE.PARAMETER = 9 CALL FILELOCK '* ------[ first line different ]------ EC = 0 ' KG103001 CALL OPENWRKA (EN$) ' KG102506 IF EC <> 0 THEN _ ' KG103001 GOTO 20731 ' KG103001 ' ---[ 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 CLOSE 2 'KG1030001 ' ---[ unlock ]--- BX = &H4 SUBROUTINE.PARAMETER = 10 CALL FILELOCK 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 END SUB ' $SUBTITLE: 'BADFILE - subroutine to find bad file names' ' $PAGE ' ' SUBROUTINE NAME -- BADFILE ' ' INPUT PARAMETERS -- PARAMETER MEANING ' VIOLATION$ ' VIOLATIONS.THIS.SESSION ' FILNAME$ NAME OF FILE ' ' OUTPUT PARAMETERS -- RESULT 1 = FILE NAME IS OK ' 2 = CHARACTER NOT ALLOWED ' 3 = SYSTEM CRASH ATTEMPT ' VIOLATIONS.THIS.SESSION NUMBER OF VIOLATIONS ' FILNAME$ Gets capitalized ' ' SUBROUTINE 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 * ' * ' 20741 RESULT = 2 IF LEN(FILNAME$) < 1 THEN _ EXIT SUB CALL ALLCAPS (FILNAME$) IF INSTR(FILNAME$,"?") OR _ INSTR(FILNAME$,"*") OR _ INSTR(FILNAME$," ") OR _ INSTR(3,FILNAME$,":") OR _ INSTR(FILNAME$,".DEF") OR _ INSTR(FILNAME$,".MNU") OR _ INSTR(FILNAME$,".OLD") OR _ INSTR(FILNAME$,".PUI") OR _ MID$(FILNAME$,LEN(FILNAME$),1) = "." THEN _ EXIT SUB 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 ' ' $SUBTITLE: 'LIBRARY - subroutine to support Library downloads' ' $PAGE ' ' SUBROUTINE NAME -- LIBRARY ' ' INPUT PARAMETERS -- 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 ' ' OUTPUT PARAMETERS -- NONE ' ' SUBROUTINE PURPOSE -- TO PROVIDE ACCESSS SUPPORT FOR LIBRARY DRIVES ' SUB LIBRARY STATIC STATIC LIBRARY.SUBDIR.NAME$(1) STATIC DISK.TITLE$ EC = 0 21105 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 QTPUT (A$,1) 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 QTPUT (LIBRARY.SUBDIR.NAME$(LIBRARY.DISPLAY.COUNT) + _ ".ARC ready for transmission!",1) 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 _ ' JM120601 EXIT SUB _ ' JM120601 ELSE IF Q = 0 THEN _ ' JM120601 LIBRARY.DISK.CHAR$ = "0000" : _ ' JM120601 CHDIR.LIBRARY$ = LIBRARY.DRIVE$ + _ ' JM120601 "\" : _ ' JM120601 GOTO 21126 ' JM120601 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 QTPUT (A$,1) A$ = "to download can also be obtained by ordering DISK " + _ LIBRARY.DISK.CHAR$ CALL QTPUT (A$,1) 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 QTPUT ("You must select a LIBRARY disk first!",1) : _ 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 _ 'JM120601 EXIT SUB IF NOT YES THEN _ EXIT SUB 21145 CALL KILLWORK (LIBRARY.WORK.DISK.PATH$ + _ LIBRARY.NODE.ID$ + _ "DK*.ARC") 21150 CALL QTPUT ("Work/RAM disk has been purged",1) CALL QTPUT ("Beginning archive using " + _ LIBRARY.ARCHIVE.PROGRAM$ + _ " Please be patient!",1) 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 QTPUT (A$,1) A$ = "Searching for Sub-directories" CALL QTPUT (A$,1) 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 (TREEDIR$) ' LP102201 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 QTPUT(A$,1) 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 QTPUT(A$,1) 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 QTPUT(A$,1) 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 _ ' JM110901 LIBRARY.ARCHIVE$ = DISK.FOR.DOS$ + _ ' JM110901 "COMMAND /C " + _ ' JM110901 LIBRARY.ARCHIVE$ + _ ' JM110901 " > " + _ ' JM110901 USE.DEVICE.DRIVER$ ' JM110901 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 ' $SUBTITLE: 'XFERTYPE - subroutine to identify file xfer protocol' ' $PAGE ' ' SUBROUTINE NAME -- XFERTYPE ' ' INPUT PARAMETERS -- PARAMETER MEANING ' A$ ' B$(1) ' KERMIT.SUPPORT ' Q ' RELIABLE.MODE ' TRANSFER.OPTIONS$ ' USER.TRANSFER.DEFAULT$ ' XWMODEM.SUPPORT ' XFER.SUPPORT ' ' OUTPUT PARAMETERS -- CHECKSUM ' FLEN ' FT$ ' ' SUBROUTINE PURPOSE -- TO IDENTIFY THE FILE TRANSFER PROTOCOL (EITHER ' FROM THE USER'S DEFAULT OR VIA EXPLICIT SELECTION) ' SUB XFERTYPE(INDEX,SKIP.HELP) STATIC IF 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 QTPUT (X$,1) STOP.INTERRUPTS = TRUE CALL BUFSTRNG (TRANSFER.OPTIONS$,4096,X) A$ = "" TURBO.KEY = -TURBO.KEY.USER SUBROUTINE.PARAMETER = 1 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) 'JM110802 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 ' $SUBTITLE: 'FILELOCK - subroutine to share RBBS-PC files' ' $PAGE ' ' SUBROUTINE NAME -- FILELOCK ' ' INPUT PARAMETERS -- 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 ' ' OUTPUT PARAMETERS -- 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 ' ' SUBROUTINE 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) ' KG121102 CC$ = CHR$(1) + _ LEFT$(FPREFIX$ + SPACE$(8),8) ' KG121102 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") ' JM102401 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) ' KG121102 CC$ = CHR$(17) + _ LEFT$(FPREFIX$ + SPACE$(8),8) ' KG121102 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") ' JM102401 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 ' JM102401 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) ' KG121102 CC$ = CHR$(1) + _ LEFT$(FPREFIX$ + SPACE$(8),8) ' KG121102 GOSUB 28000 IF CT = 0 THEN _ RETURN CALL DELAYIT (1) GOTO 26200 ' ' * ' * LOCK USER FILE (DESQVIEW) * ' * ' 26300 CALL DVLOCK("USER") ' JM102401 RETURN ' JM102401 ' ' * ' * 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 ' JM102401 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)) ' JM102401 RETURN ' JM102401 ' ' * ' * 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 ' JM102401 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) ' KG121102 CC$ = CHR$(17) + _ LEFT$(FPREFIX$ + SPACE$(8),8) ' KG121102 GOSUB 28000 IF CT = 128 THEN _ RETURN CALL DELAYIT (1) GOTO 27200 ' ' * ' * UNLOCK USER FILE (DESQVIEW) * ' * ' 27300 CALL DVUNLOCK("USER") ' JM102401 RETURN ' JM102401 ' ' * ' * 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 ' JM102401 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)) ' JM102401 RETURN ' JM102401 ' ' * ' * 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 (ORCHID PC-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 ' JM102401 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") ' JM102401 RETURN ' JM102401 ' ' * ' * 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 ' JM102401 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") ' JM102401 RETURN ' JM102401 ' ' * ' * 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) ' JM110802 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) ' JM110802 RETURN END SUB ' $SUBTITLE: 'INITIBM - subroutine to create/open NETBIOS semaphore file' ' $PAGE ' ' SUBROUTINE NAME -- INITIBM (Written by Doug Azzarito) ' ' INPUT PARAMETERS -- NONE ' ' OUTPUT PARAMETERS -- SUBROUTINE.PARAMETER = -1 ABORT RBBS ' ' SUBROUTINE PURPOSE -- OPEN SEMAPHORE FILE "IBMFLAGS" ON DEFAULT DRIVE ' AS FILE #6 ' IF FILE DOES NOT EXIST, IT IS CREATED. ' SUB INITIBM STATIC ' ' * ' * SEE IF FILE EXISTS * ' * ' 30000 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 ' $SUBTITLE: 'OPENMSG - open the MESSAGES file' ' $PAGE ' ' SUBROUTINE NAME -- OPENMSG ' ' INPUT PARAMETERS -- PARAMETER MEANING ' ACTIVE.MESSAGE.FILE$ ' SHARE.IT ' ' OUTPUT PARAMETERS -- MESSAGE.RECORD$ ' SUB OPENMSG STATIC ' ' * ' * OPEN AND DEFINE MESSAGE FILE * ' * ' 30500 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 ' $SUBTITLE: 'FINDFUNC - subroutine to handle local keyboard functions' ' $PAGE ' ' SUBROUTINE NAME -- FINDFUNC ' ' INPUT PARAMETERS -- ' 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 'DA011205 ' 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 ' ' OUTPUT PARAMETERS -- ' 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 ' ' SUBROUTINE 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.MODE AND NOT SYSOP THEN _ ' PE 11/04/88 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 = 79 THEN _ '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 = END KEY 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$) ' LP102201 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 QTPUT(FIRST.NAME$ + ", goodbye and don't call back",1) 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 QTPUT("Sysop exiting to DOS. Please wait...",1) : _ FUNCTION.KEY = 0 : _ CALL DELAYIT (3) 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 QTPUT ("Sysop back from DOS. Returning control to you.",1) 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 ' KG102601 33155 SUBROUTINE.PARAMETER = 1 CALL LINE25 GOTO 33970 33160 CALL UPDTCALR ("Sysop began chat",1) PAGE.STATUS$ = "" ' KG120301 CALL SKIPLINE (1) CALL QTPUT ("Hi " + _ FIRST.NAME$ + _ ", this is " + _ SYSOP.FIRST.NAME$ + _ " " + _ SYSOP.LAST.NAME$ + _ " Sorry to break in to CHAT but..",1) CALL SYSOPCHAT ' KG102206 COMMPORT.STACK$ = CHR$(13) ' KG103003 GOTO 33155 ' KG102206 ' ' * ' * 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 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 CALL PAGEUP D$ = MID$("NoviceExPERT",1 -6 * EXPERT.USER,6) GOSUB 33210 D$ = "GRAPHICS: " + _ MID$("None AsciiColor",GR * 5 + 1,5) GOSUB 33210 ' KG102002 D$ = "PROTOCOL : " + _ ' KG102002 USER.TRANSFER.DEFAULT$ ' KG102002 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 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 ' $SUBTITLE: 'PAGEUP - Display user profile to SYSOP' ' $PAGE ' ' SUBROUTINE NAME -- PAGEUP ' ' INPUT PARAMETERS -- 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 ' ' OUTPUT PARAMETERS -- MESSAGE.RECORD$ ' 33990 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) 'remove :- here 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 ' $SUBTITLE: 'CHKTREMAIN - Kicks off if no time remaining' ' $PAGE ' ' SUBROUTINE NAME -- CHKTREMAIN ' ' INPUT PARAMETERS -- PARAMETER MEANING ' TIME.LEFT! ' OUTPUT PARAMETERS -- 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 41008 CALL TIMEREMAIN (TIME.LEFT!) IF BYPASS.TIME.CHECK THEN _ EXIT SUB IF TIME.LEFT! < 0.1 THEN _ SUBROUTINE.PARAMETER = -1 END SUB ' $SUBTITLE: 'TIMEREMAIN - calculates time remaining in a session' ' $PAGE ' ' SUBROUTINE NAME -- TIMEREMAIN ' ' INPUT PARAMETERS -- PARAMETER MEANING ' USER.LOGON.TIME! ' SECONDS.PER.SESSION! ' BYPASS.TIME.CHECK ' OUTPUT PARAMETERS -- PARAMETER MEANING ' TIME.REMAINING! TIME IN MINUTES LEFT IN SESSION ' TCA! TIME USED IN SECONDS SUB TIMEREMAIN (TIME.REMAINING!) STATIC 41010 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 ' $SUBTITLE: 'DISPLAYTR - Display users time remaining' ' $PAGE ' ' SUBROUTINE NAME -- DISPLAYTR ' ' INPUT PARAMETERS -- PARAMETER MEANING ' TIME.REMAINING! ' ' OUTPUT PARAMETERS -- PARAMETER MEANING ' TIME.REMAINING! TIME IN MINUTES LEFT IN SESSION ' SUB DISPLAYTR (TIME.REMAINING!) STATIC CALL TIMEREMAIN (TIME.REMAINING!) CALL QTPUT (STR$(INT(TIME.REMAINING!)) + " min left",1) END SUB ' $SUBTITLE: 'AMORPM - subroutine to give time of day in AM/PM format' ' $PAGE ' ' SUBROUTINE NAME -- AMORPM ' ' INPUT PARAMETERS -- PARAMETER MEANING ' SUBROUTINE.PARAMETER = 1 GET CURRENT TIME AND DATE ' SUBROUTINE.PARAMETER = 2 CALCULATE TIME AS AM OR PM ' ' OUTPUT PARAMETERS -- 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) ' ' SUBROUTINE PURPOSE -- TO SET THE OUTPUT PARAMETERS AS INDICATED AND ' DESCRIBE THE TIME AS "AM" OR "PM." ' SUB AMORPM STATIC ON SUBROUTINE.PARAMETER GOTO 41500,41510 ' ' * ' * 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) 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 ' $SUBTITLE: 'CARRIER - subroutine to monitor carrier on comm. port' ' $PAGE ' ' SUBROUTINE NAME -- CARRIER ' ' INPUT PARAMETERS -- 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 ' ' OUTPUT PARAMETERS -- SUBROUTINE.PARAMETER = 0 CARRIER STILL PRESENT ' SUBROUTINE.PARAMETER = -1 CARRIER NOT PRESENT ' ' SUBROUTINE PURPOSE -- TO TEST IF CARRIER IS PRESENT (I.E. THE USER ' STILL ON LINE). ' SUB CARRIER STATIC IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB SPEEDY = SUBROUTINE.PARAMETER SUBROUTINE.PARAMETER = 0 ' ' * ' * TEST FOR CARRIER PRESENT (DROP CALLER IF CARRIER NOT PRESENT) * ' * ' 42000 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 ' Pe 03/22/89 Auto Log off fix IF DOWNLOAD.COMPLETED AND AUTO.END = 1 THEN _ CALL UPDTCALR (" Used Auto Logg Off ",1) _ ELSE _ CALL UPDTCALR ("Carrier dropped",1) END SUB ' $SUBTITLE: 'ASKGRAPH -- subroutine to ask users graphic preference' ' $PAGE ' ' SUBROUTINE NAME -- ASKGRAPH ' ' INPUT PARAMETERS -- PARAMETER MEANING ' UGD$ USER GRAPHIC DEFAULT ' ' OUTPUT PARAMETERS -- ' ' SUBROUTINE 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 QTPUT ("GRAPHICS for text files and menus",1) 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 QTPUT ("Unchanged",1) : _ EXIT SUB CALL ALLCAPS (B$(1)) GR = INSTR("NAC",B$(1)) IF GR = 2 AND NOT EIGHT.BIT THEN _ CALL QTPUT ("Ascii unavailable. Requires 8 bit",1) : _ GOTO 43007 IF GR = 0 THEN _ GOTO 43006 GR = GR - 1 CALL SETUGD (GR,UGD$) CALL GETCOLOR END SUB ' ' $SUBTITLE: 'GRAPHIC - subroutine to find graphic version of a file' ' $PAGE ' ' SUBROUTINE NAME -- GRAPHIC ' ' INPUT PARAMETERS -- PARAMETER MEANING ' DEFAULT$ USERS GRAPHIC DEFAULT ' GR WHETHER GRAPHICS ARE AVAILABLE ' FILE.NAME$ FILE TO CHECK ' ' OUTPUT PARAMETERS -- FILE.NAME$ SUBSTITUTES NAME OF GRAPHICS ' FILE (IF IT EXISTS). ' ' SUBROUTINE PURPOSE -- CHECKS WHETHER THERE IS A GRAPHICS VERSION OF ' A FILE, BASED ON USERS GRAPHICS PREFERENCE. ' SETS FILE NAME TO GRAPHICS FILE IF IT EXISTS, ' OTHERWISE LEAVES FILE NAME INTACT. RETURNS FILE ' NAME TO USE. ' SUB GRAPHIC (DEFAULT$) STATIC 43031 OK = FALSE IF GR THEN _ CALL BRKFNAME (FILE.NAME$,DR$,X$,EXTENTION$,TRUE) : _ IF LEN(X$) < 8 THEN _ DF$ = DR$ + _ X$ + _ DEFAULT$ + _ EXTENTION$ : _ CALL FINDIT (DF$) : _ IF OK THEN _ FILE.NAME$ = DF$ : _ IF DEFAULT$ = "C" THEN _ LINES.PRINTED = 0 IF NOT OK THEN _ CALL FINDIT (FILE.NAME$) END SUB ' $SUBTITLE: 'SAVEPROF - subroutine to read a user profile' ' $PAGE ' ' SUBROUTINE NAME -- SAVEPROF ' ' INPUT PARAMETERS -- PARAMETER MEANING ' BPS ' EIGHT.BIT ' EXIT.TO.DOORS ' GR ' KERMIT.FUNCTION ' MESSAGE.RECORD$ ' NODE.RECORD.INDEX ' SYSOP ' UPPER.CASE ' TIME.LOGGED.ON$ ' PRIVATE.DOOR ' RELIABLE.MODE ' ' OUTPUT PARAMETERS -- NONE ' ' SUBROUTINE 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 ' ' * ' * SAVE USER PROFILE WHEN EXITING * ' * ' 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 _ ' KG101404 MID$(MESSAGE.RECORD$,1,30) = "SYSOP" + SPACE$(25) ' KG101404 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$,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 ' $SUBTITLE: 'READPROF - subroutine to restore a user profile' ' $PAGE ' ' SUBROUTINE NAME -- READPROF ' ' INPUT PARAMETERS -- PARAMETER MEANING ' NODE.RECORD.INDEX NODE RECORD TO USE ' SYSOP.PASSWORD.1$ SYSOP'S PSEUDONYM 1 ' SYSOP.PASSWORD.2$ SYSOP'S PSEUDONYM 2 ' ' OUTPUT PARAMETERS -- USER'S OPTIONS AND COMMUNICATIONS PARAMETERS ' UPON EXITING RBBS-PC TO A "DOOR" ' ' SUBROUTINE 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 ' ' * ' * RESTORE USER PROFILE WHEN RETURNING FROM DOORS * ' * ' 44000 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)) CALL GETCOLOR TIME.LOGGED.ON$ = RIGHT$("0"+MID$(STR$(ASC(MID$(MESSAGE.RECORD$,65,1))),2),2) + _ ":" + _ RIGHT$("0"+MID$(STR$(ASC(MID$(MESSAGE.RECORD$,66,1))),2),2) + _ ":" + _ RIGHT$("0"+MID$(STR$(ASC(MID$(MESSAGE.RECORD$,67,1))),2),2) TRANSFER.FUNCTION = VAL(MID$(MESSAGE.RECORD$,74,1)) FT$ = MID$(MESSAGE.RECORD$,75,1) 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 CALL FINDTIME (USER.LOGON.TIME!) 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 _ ' KG101404 ACTIVE.USER.NAME$ = SYSOP.PASSWORD.1$ + " " + SYSOP.PASSWORD.2$ _ ' KG101404 ELSE FIRST.NAME.END = INSTR(MESSAGE.RECORD$," ") : _ ' KG101404 LAST.NAME.END = INSTR(FIRST.NAME.END + 1,MESSAGE.RECORD$ + " "," ") : _ ' KG101404 FIRST.NAME$ = LEFT$(MESSAGE.RECORD$,FIRST.NAME.END-1) : _ ' KG101404 LAST.NAME$ = MID$(MESSAGE.RECORD$,FIRST.NAME.END + 1,LAST.NAME.END - (FIRST.NAME.END + 1)) : _ ' KG101404 ACTIVE.USER.NAME$ = MID$(FIRST.NAME$ + " " + LAST.NAME$,1,31) ' KG101404 Z$ = FIRST.NAME$ END SUB ' $SUBTITLE: 'COMMINFO - subroutine for variable of users baud/parity' ' $PAGE ' ' SUBROUTINE NAME -- COMMINFO ' ' INPUT PARAMETERS -- PARAMETER MEANING ' BPS BAUD RATE INDICATOR ' EIGHT.BIT INDICATE FOR N/8/1 ' ' OUTPUT PARAMETERS -- BAUD.PARITY$ ' ' SUBROUTINE 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 ' $SUBTITLE: 'DELAYIT - subroutine to wait number of seconds specified' ' $PAGE ' ' SUBROUTINE NAME -- DELAYIT ' ' INPUT PARAMETERS -- PARAMETER MEANING ' DELAY.TIME NUMBER OF SECONDS TO DELAY ' (0 TO 3,600) ' ' OUTPUT PARAMETERS -- NONE ' ' SUBROUTINE 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 ' $SUBTITLE: 'MODEMPUT - subroutine 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 * ' * ' 52070 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) IF FOSSIL THEN _ STRNG$ = STRNG$ + CARRIAGE.RETURN$ : _ 'KG121804 BYTES% = LEN(STRNG$) : _ CALL FOSWRITE(COMPORT%,BYTES%,STRNG$) _ ELSE PRINT #3,STRNG$;CARRIAGE.RETURN$ 'KG120902 END SUB ' $SUBTITLE: 'DISPCALL - subroutine to display callers file' ' $PAGE ' ' SUBROUTINE NAME -- DISPCALL ' ' INPUT PARAMETERS -- PARAMETER MEANING ' ' OUTPUT PARAMETERS -- (NONE) ' ' SUBROUTINE PURPOSE -- DISPLAYS CALLERS FILE TO SYSOPS AND CALLERS ' 57001 SUB DISPCALL STATIC IF CALLERS.FILE.PREFIX$ = "" THEN _ 'KG102705 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 _ 'KG102505 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 QTPUT (A$,1) CALL ASKMORE ("",TRUE,TRUE,X,FALSE) IF NO OR SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB RETURN END SUB ' $SUBTITLE: 'FINDTIME - subroutine to calculate seconds since midnight' ' $PAGE ' ' SUBROUTINE NAME -- FINDTIME ' ' INPUT PARAMETERS -- PARAMETER MEANING ' SECONDS! VARIABLE TO RETURN RESULTS WITH ' ' OUTPUT PARAMETERS -- SECONDS! SECONDS SINCE MIDNIGHT ' ' SUBROUTINE PURPOSE -- TO CALCULATE THE NUMBER OF SECONDS THAT HAVE ' ELASPED SINCE MIDNIGHT ' SUB FINDTIME (SECONDS!) STATIC 58050 SECONDS! = TIMER END SUB ' $SUBTITLE: 'ALLCAPS - subroutine to convert string to upper case' ' $PAGE ' ' SUBROUTINE NAME -- ALLCAPS ' ' INPUT PARAMETERS -- PARAMETER MEANING ' CONVERT.FIELD$ STRING TO MAKE UPPER CASE ' ' OUTPUT PARAMETERS -- CONVERT.FIELD$ CONVERTED STRINGS ' ' SUBROUTINE PURPOSE -- SUBROUTINE TO CONVERT A STRING TO UPPER CASE ' SUB ALLCAPS (CONVERT.FIELD$) STATIC 58060 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 ' $SUBTITLE: 'CHECKTIM - subroutine to see if time has elasped' ' $PAGE ' ' SUBROUTINE NAME -- CHECKTIM ' ' INPUT PARAMETERS -- PARAMETER MEANING ' MAX.TIME! NUMBER OF SECONDS PAST MIDNIGHT ' NOT TO EXCEED ' ' OUTPUT PARAMETERS -- SUBROUTINE.PARAMETER = 1 CURRENT TIME IS LESS THAN ' MAX.TIME! ' SUBROUTINE.PARAMETER = 2 CURRENT TIME IS GREATER THAN ' OR EQUAL TO MAX.TIME! ' ' SUBROUTINE PURPOSE -- SUBROUTINE TO CHECK IF THE CURRENT TIME IS GREATER ' THAN OR EQUAL TO THE TIME ALLOWED ' SUB CHECKTIM (MAX.TIME!) STATIC 58070 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 ' $SUBTITLE: 'HASHRBBS - subroutine to determine where to look for user' ' $PAGE ' ' SUBROUTINE NAME -- HASHRBBS ' ' INPUT PARAMETERS -- PARAMETER MEANING ' STRNG.TO.HASH$ USER NAME TO LOCATE ' MAX.POSITION MAXIMUM # USERS ' ' OUTPUT PARAMETERS -- PRIME.HASH WHERE TO LOOK FIRST ' SECOND.HASH LOOK THIS FAR AHEAD ' ' SUBROUTINE 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 58080 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 ' $SUBTITLE: 'CALLOPT - subroutine to set prompts based on user security' ' $PAGE ' ' SUBROUTINE NAME -- CALLOPT ' ' INPUT PARAMETERS -- PARAMETER MEANING ' BEG.MAIN POSITION START OF MAIN CMDS ' BEG.FILE POSITION START OF FILE CMDS ' BEG.UTIL POSITION START OF UTIL CMDS ' BEG.LIBRARY POSITION START OF LIBRARY CMDS ' ' OUTPUT PARAMETERS -- PRESENT.OPTS$ DISPLAY WHAT USER CAN DO (1st) ' CALLERS.OPTS$ DISPLAY WHAT USER CAN DO (2nd) ' MAIN.OPTS$ MAIN OPTS USER CAN DO ' FILE.OPTS$ FILE OPTS USER CAN DO ' UTIL.OPTS$ UTIL OPTS USER CAN DO ' LIBRARY.OPTS$ LIBRARY OPTS USER CAN DO ' ' SUBROUTINE PURPOSE -- SETS COMMAND LINE DISPLAY OF WHAT USER CAN DO BY ' SECTION AND DISPLAY OF WHAT ALL USER CAN DO ' SUB CALLOPT STATIC 58090 FIRST = BEG.MAIN LAST = BEG.FILE - 1 CALL SETOPTS (MAIN.OPTS$,INVALID.MAIN.OPTS$,FIRST,LAST) FIRST = BEG.FILE LAST = BEG.UTIL - 1 CALL SETOPTS (FILE.OPTS$,INVALID.FILE.OPTS$,FIRST,LAST) FIRST = BEG.UTIL LAST = BEG.LIBRARY - 1 CALL SETOPTS (UTIL.OPTS$,INVALID.UTIL.OPTS$,FIRST,LAST) FIRST = BEG.LIBRARY LAST = BEG.LIBRARY + 6 CALL SETOPTS (LIBRARY.OPTS$,INVALID.LIBRARY.OPTS$,FIRST,LAST) FIRST = 50 LAST = 56 CALL SETOPTS (SYS.OPTS$,INVALID.SYS.OPTS$,FIRST,LAST) FIRST = 46 LAST = 49 CALL SETOPTS (GLOBAL.OPTS$,INVALID.GLOBAL.OPTS$,FIRST,LAST) IF LEN(SYS.OPTS$) > 0 THEN _ SYSTEM.OPTS$ = "Sysop: " + _ SYS.OPTS$ MAIN.OPTS$ = GLOBAL.OPTS$ + _ MAIN.OPTS$ FILE.OPTS$ = GLOBAL.OPTS$ + _ FILE.OPTS$ UTIL.OPTS$ = GLOBAL.OPTS$ + _ UTIL.OPTS$ LIBRARY.OPTS$ = GLOBAL.OPTS$ + _ LIBRARY.OPTS$ CALL SRTSTRNG (SYS.OPTS$) CALL SRTSTRNG (MAIN.OPTS$) MAIN.OPTS$ = MAIN.OPTS$ + _ SYS.OPTS$ CALL SRTSTRNG (FILE.OPTS$) CALL SRTSTRNG (UTIL.OPTS$) CALL SRTSTRNG (LIBRARY.OPTS$) CALL INSCOMMA (MAIN.OPTS$) CALL INSCOMMA (FILE.OPTS$) CALL INSCOMMA (UTIL.OPTS$) CALL INSCOMMA (LIBRARY.OPTS$) DIR.PROMPT$ = "What directory(s) (" + _ MID$("U)pload,A)ll,L)ist,E)xtended +/-, [Q]uit)",8 * (USER.SECURITY.LEVEL => MIN.SEC.TO.VIEW) + 9) QUIT.PROMPT.EXPERT$ = "QUIT C,S, or to F,[M],U,@" QUIT.PROMPT.NOVICE$ = "QUIT C)onference, S)ession or to section " + _ "F)ile, [M]ain, U)til, or @)Library" QUIT.LIST$ = "FMUS@C" IF USER.SECURITY.LEVEL < OPT.SEC(18) THEN _ QUIT.PROMPT.EXPERT$ = LEFT$(QUIT.PROMPT.EXPERT$,23) : _ QUIT.PROMPT.NOVICE$ = LEFT$(QUIT.PROMPT.NOVICE$,61) : _ MID$(QUIT.LIST$,5) = " " IF USER.SECURITY.LEVEL < OPT.SEC(15) THEN _ QUIT.PROMPT.EXPERT$ = LEFT$(QUIT.PROMPT.EXPERT$,22) + _ MID$(QUIT.PROMPT.EXPERT$,25) : _ QUIT.PROMPT.NOVICE$ = LEFT$(QUIT.PROMPT.NOVICE$,56) + _ MID$(QUIT.PROMPT.NOVICE$,63) : _ MID$(QUIT.LIST$,3,1) = " " IF USER.SECURITY.LEVEL < OPT.SEC(6) THEN _ QUIT.PROMPT.EXPERT$ = LEFT$(QUIT.PROMPT.EXPERT$,16) + _ MID$(QUIT.PROMPT.EXPERT$,19) : _ QUIT.PROMPT.NOVICE$ = LEFT$(QUIT.PROMPT.NOVICE$,41) + _ MID$(QUIT.PROMPT.NOVICE$,49) : _ MID$(QUIT.LIST$,1,1) = " " CALL SETSECT END SUB ' $SUBTITLE: 'SETOPTS - subroutine to set prompts based on user security' ' $PAGE ' ' SUBROUTINE NAME -- SETOPTS ' ' INPUT PARAMETERS -- PARAMETER MEANING ' FIRST POSITION WHERE START LOOKING ' LAST POSITION WHERE QUIT LOOKING ' USER.SECURITY.LEVEL SECURITY OF USER ' ' OUTPUT PARAMETERS -- OPTIONS$ LIST OF COMMANDS USER CAN DO ' ' SUBROUTINE PURPOSE -- STRING TOGETHER WHAT COMMANDS USER CAN DO ' IN A SECTION ' SUB SETOPTS (OPTIONS$,INVALID.OPTIONS$,FIRST,LAST) STATIC 58100 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 ' $SUBTITLE: 'CHKNEWBUL - subroutine to check whether got new bulletins' ' $PAGE ' ' SUBROUTINE NAME -- CHKNEWBUL ' ' INPUT PARAMETERS -- PARAMETER MEANING ' LAST.ON$ LAST DATE OF LOGON ' FORMAT MM/DD/YY ' ACTIVE.BULLETINS # OF BULLETING ' BULLETIN.PREFIX$ FILESPEC FOR BULLETINS ' ' OUTPUT PARAMETERS -- 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,...) ' ' SUBROUTINE 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 58110 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") 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 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 ' $SUBTITLE: 'SRTSTRNG - subroutine to sort characters in a string' ' $PAGE ' ' SUBROUTINE NAME -- SRTSTRNG ' ' INPUT PARAMETERS -- PARAMETER MEANING ' STRNG$ STRING TO SORT ' ' OUTPUT PARAMETERS -- STRNG$ SORTED STRING ' ' SUBROUTINE PURPOSE -- SORTS CHARACTERS IN PASSED STRING. ' SUB SRTSTRNG (STRNG$) STATIC 58120 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 ' $SUBTITLE: 'INSCOMMA - subroutine to format commands in command prompt' ' $PAGE ' ' SUBROUTINE NAME -- INSCOMMA ' ' INPUT PARAMETERS -- PARAMETER MEANING ' STRNG$ STRING TO REPLACE ' ' OUTPUT PARAMETERS -- STRNG$ REPLACED STRING ' ' SUBROUTINE PURPOSE -- INSERTS COMMANDS BETWEEN EACH LETTER IN STRNG$ ' AND ENCLOSES IN POINTED BRACKETS ' SUB INSCOMMA (STRNG$) STATIC 58130 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 ' $SUBTITLE: 'LOADNEW - subroutine to get latest uploads' ' $PAGE ' ' SUBROUTINE NAME -- LOADNEW ' ' INPUT PARAMETERS -- PARAMETER MEANING ' UPLOAD.DIRECTORY$ LIST OF FILES UPLOADED ' ' OUTPUT PARAMETERS -- A$ LATEST UPLOADS ' ' SUBROUTINE PURPOSE -- LOADS TABLE OF MOST RECENT NUMBER OF UPLOADS ' BY DATE ' SUB LOADNEW (ARA(2)) STATIC 58140 IF FMS.DIRECTORY$ = "" THEN _ EXIT SUB PREV.BASE$ = "" 'KG121803 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$) 'KG010901 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 ' $SUBTITLE: 'CTNEWFILES - subroutine to count how many files new' ' $PAGE ' ' SUBROUTINE NAME -- CTNEWFILES ' ' INPUT PARAMETERS -- PARAMETER MEANING ' LAST.ON$ Date of last logon ' UPLDS$ Latest uploads ' ' OUTPUT PARAMETERS -- NUM.NEW.FILES How many after last logon ' RPT.PREFIX$ Set to "At least " if ' above is a minimum ' ' SUBROUTINE 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 58150 BASE.DATE = 372 * (VAL(MID$(LAST.ON$,7,2)) - 80) + _ 'KG010901 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 ' $SUBTITLE: 'CTLINES - subroutine to determine file categories ' ' $PAGE ' ' SUBROUTINE NAME -- CTLINES ' ' INPUT PARAMETERS -- PARAMETER MEANING ' DIR.CATEGORY.FILE$ NAME OF THE FILE THAT HAS THE ' NUMBER OF CATEGORIES IN IT. ' ' OUTPUT PARAMETERS -- MAX.ENTRIES NUMBER OF FILE CATEGORIES ' ' SUBROUTINE PURPOSE -- SUBROUTINE TO COUNT THE NUMBER OF CATEGORIES THAT A ' FILE CAN BE CLASSIFIED INTO. ' SUB CTLINES (MAX.ENTRIES) STATIC 58160 CALL LINESNFIL (DIR.CATEGORY.FILE$,MAX.ENTRIES) ' KG101603 MAX.ENTRIES = MAX.ENTRIES + 3 IF MAX.ENTRIES < 10 THEN _ MAX.ENTRIES = 10 END SUB SUB LINESNFIL (FILNAME$,LKNT) STATIC ' KG101603 CALL FINDIT (FILNAME$) ' KG101603 LKNT = 0 ' KG101603 IF OK THEN _ ' KG101603 WHILE NOT EOF(2) : _ ' KG101603 LKNT = LKNT + 1 : _ ' KG101603 LINE INPUT #2,A$ : _ ' KG101603 WEND ' KG101603 CLOSE 2 ' KG101603 END SUB ' KG101603 ' $SUBTITLE: 'INITFMS - subroutine to initialize file management system' ' $PAGE ' ' SUBROUTINE NAME -- INITFMS ' ' INPUT PARAMETERS -- PARAMETER MEANING ' FMS.DIRECTORY$ ' ' OUTPUT PARAMETERS -- 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 ' ' SUBROUTINE PURPOSE -- SUBROUTINE TO INITIALIZE THE RBBS-PC UPLOAD 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) CATEGORY.INDEX = CATEGORY.INDEX + 1 INPUT #2, CATEGORY.NAME$(CATEGORY.INDEX), _ CATEGORY.CODE$(CATEGORY.INDEX), _ CATEGORY.DESC$(CATEGORY.INDEX) CATR$ = CATEGORY.CODE$(CATEGORY.INDEX) CALL REMOVE (CATR$,BLNK$) CATEGORY.CODE$(CATEGORY.INDEX) = CATR$ WEND CLOSE 2 END SUB ' $SUBTITLE: 'DISUPDIR - subroutine to display upload direcotry' ' $PAGE ' ' SUBROUTINE NAME -- DISUPDIR ' ' INPUT PARAMETERS -- 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 ' ' OUTPUT PARAMETERS -- DOWNLOAD.FLAG WHENEVER DOWNLOAD REQUESTED, SETS ' TO NEXT RECORD TO VIEW. OTHERWISE ' LEAVES AT ZERO'' SUBROUTINE PURPOS -- 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 58165 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$ = CX$(6)+",V)iew"+EMPASIZE.OFF$ IF CAN.DOWNLOAD THEN _ EXTRA.PRMPT$ = EXTRA.PRMPT$ +CX$(5)+ ",D)ownload"+EMPASIZE.OFF$ 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 58183 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 :_ ' found 2 of these ==>_ so removed one 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 QTPUT(A$,1) : _ GOTO 58178 CALL EOFCOMM (CHAR%) IF CHAR% = -1 THEN _ CALL QTPUT(A$,1) _ 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 CARRIER 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 QTPUT (EMPHASIZE.OFF$ + "Files checked thru " + MID$(PART.TO.PRINT$,24,8),1) 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$ = CX$(2)+"Download what file(s)"+EMPASIZE.OFF$ : _ 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) + _ " files 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) : _ IF NOT YES THEN _ NON.STOP = FALSE CHECK.POINT = 0 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