' $linesize:132 ' $title: 'RBBSSUB4.BAS CPC17.2B, Copyright 1986 - 89 by D. Thomas Mack' ' Copyright 1989 by D. Thomas Mack, all rights reserved. ' Name ...............: RBBSSUB4.BAS ' Written by .........: D. Thomas Mack ' First Released .....: May 28, 1989 ' Subsequent Releases.: 07-30-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 ' ANYBUT 59760 Determine where a "word" begins ' ASKUSERS 64003 Ask users questions based on a script and save answers ' ASKMORE 59858 Check whether screen full ' AUTOPAGE 60300 Check whether to notify sysop caller is on ' BADFILECHAR 59800 Check file name for bad character ' BRACKET 59960 Puts strings around a substring ' BUFFILE 58400 Write a file to the user quickly ' BUFSTRNG 58300 Write a string with imbedded CR/LF to the user quickly ' CHKCOLOR 59930 Highlighting based on search string ' CHKNARY 58190 Check for the occurance of a string in an array ' COLORDIR 59920 Adds colorization to FMS directory entry ' COLORPMT 59940 Colorizes prompts ' COMPDATE 59880+ Produces a computational data from YY, MM, DD ' CONFMAIL 59854 Check conference mail waiting ' CONVDIRS 58950 Checks for U & A (shorthand) and converts appropriately ' CSTRDATE 59201 Compress date in string format to 2 characters ' EOFCOMM 60000 Determine whether any chars in comm port buffer ' EXPDATE 59890 Calculate registration expiration date ' FAKEXRPT 62650 Write out file transfer report for protocols that don't ' FINDEND 58770 Find where a "word" ends ' FINDFILE 58790 Determine whether a file exists without opening it ' FINDLAST 58600 Find last occurence of a string ' FMS 58200 Search the upload management system for entries ' GETALL 59780 Get list of all directories to display ' GETDIRS 58895 Prompts for directories for file list/new/search cmds ' GETMATTR 62530 Restore attributes of original message ' GETYMD 59204 Pulls YY, MM, or DD from a 2 byte stored date ' GSANDR 60100 Global search and replace ' LOGDOWN 59400 Records download in private directory ' MARKTIME 60200 Give visual feedback during lengthy process ' METAGSR 60130 Meta statement global search and replace ' MIMPORT 59698 Allow local user to import a text file to a message ' MUZAK 59100 Play musical themes for different RBBS functions ' NEWPASWRD 60668 Get a new password ' PERSFILE 59300 View and select personal files for downloading ' PROTOCOL 62600 Determine if external protocols are available ' PUTMATTR 62520 Save attributes of original message ' REMOVE 58210 Remove characters from within strings ' ROTORSDIR 58700 Searches for a file using list of subdirs ' RPTTIME 62540 Report date/time and time on ' SETABORT 58750 Set time for a process to abort ' SETECHO 59600 Set RBBS properly for who is to echo ' SETHILITE 59934 Set user preference on highlighting ' SETUGD 59980 Sets graphic preference for text file display ' SMARTTXT 58250 Process SMART TEXT control strings ' SUBMENU 59500 Processes options that have sub-menus ' TIMEDOUT 63000 Write timed exit semaphore file ' TIMELOCK 60150 Check for TIME LOCK on certain features ' TRANSFER 62624 RBBS-PC support for external protocols for file transfer ' TOGGLE 57000 Toggles or views user options ' TWOBYTEDATE 59200 Reduces a data to 2 byte string for space compression ' UNCDATE 59902 Uncompresses a 2 byte date ' USERCOLOR 59965 Lets user set color for text and whether bold ' USERFACE 59450 Processes programmable user interface ' VIEWARC 64600 Display .ARC file contents to user ' XFRETURN 62629 Private door exit routine ' WIPELINE 58800 Wipes away a line so next prints in its place ' WORDWRAP 59710 Adjust a message --wrap linesand perserve paragraphs ' ' $INCLUDE: 'RBBS-VAR.BAS' ' 57000 ' $SUBTITLE: 'TOGGLE - Toggle User Preferences' ' $PAGE ' ' NAME -- TOGGLE ' ' INPUTS -- TOGGLE.OPTION Option to toggle or view ' according to the following: ' TOGGLE.OPTION PREFERENCE ' TOGGLE VIEW ' 1 -1 Autodownload ' 2 -2 Bulletin review on logon ' 3 -3 Case change ' 4 -4 File review on logon ' 5 -5 Highlight ' 6 -6 Line feeds ' 7 -7 Nulls ' 8 -8 TurboKey ' 9 -9 Expert ' 10 -10 Bell ' ' OUTPUTS -- SUBROUTINE.PARAMETER passed from TPUT ' ' PURPOSE -- Sets or views any single user preference value ' SUB TOGGLE (TOGGLE.OPTION) STATIC SUBROUTINE.PARAMETER = 0 IF TOGGLE.OPTION < 0 THEN _ GOTO 57005 ON TOGGLE.OPTION GOSUB _ 57010, _ 'Autodownload 57120, _ 'Bulletin review on logon 57260, _ 'Case change 57150, _ 'File review on logon 57040, _ 'Highlight 57100, _ 'Line feeds 57210, _ 'Nulls 57230, _ 'TurboKey 57190, _ 'Expert 57170 'Bell EXIT SUB 57005 CALL ASKMORE ("",TRUE,TRUE,X,TRUE) ON -TOGGLE.OPTION GOSUB _ 57030, _ 'Autodownload 57130, _ 'Bulletin review on logon 57270, _ 'Case change 57160, _ 'File review on logon 57050, _ 'Highlight 57110, _ 'Line feeds 57220, _ 'Nulls 57240, _ 'TurboKey 57200, _ 'Expert 57180 'Bell EXIT SUB 57010 IF AUTODOWNLOAD.DESIRED THEN _ GOTO 57020 IF NOT AUTODOWNLOAD.VERIFIED THEN _ CALL TESTUSER IF NOT AUTODOWNLOAD.AVAILABLE THEN _ CALL QTPUT1 ("Your comm pgm does not support AUTODOWNLOAD") : _ AUTODOWNLOAD.DESIRED = TRUE 57020 AUTODOWNLOAD.DESIRED = NOT AUTODOWNLOAD.DESIRED 57030 A$ = "Autodownload " + FNOFFON$(AUTODOWNLOAD.DESIRED) CALL QTPUT1 (A$) RETURN 57040 IF EMPHASIZE.ON.DEF$ = "" THEN _ CALL QTPUT1 ("Highlighting unavailable") : _ RETURN CALL SETHILITE (NOT HIGHLIGHT.OFF) IF HIGHLIGHT.OFF THEN _ CALL QTPUT (COLOR.RESET$,0) GOSUB 57050 CALL USERCOLOR RETURN 57050 IF EMPHASIZE.ON$ <> "" THEN _ EMPHASIZE.OFF$ = ESCAPE$ + "[" + BOLD.TEXT$ + _ ";40;" + MID$(STR$(USER.TEXT.COLOR),2) + "m" CALL QTPUT1 (EMPHASIZE.ON$ + "Highlighting" + EMPHASIZE.OFF$ + _ " " + FNOFFON$(NOT HIGHLIGHT.OFF)) RETURN 57100 LINE.FEEDS = NOT LINE.FEEDS IF LOCAL.USER THEN _ LINE.FEEDS = TRUE 57110 CALL QTPUT1 ("Line Feeds " + FNOFFON$(LINE.FEEDS)) CALL SETCRLF RETURN 57120 CHECK.BULLETIN.LOGON = NOT CHECK.BULLETIN.LOGON 57130 A$ = MID$("SKIP CHECK",1 -5 * CHECK.BULLETIN.LOGON,5) + _ " old BULLETINS in logon" CALL QTPUT1 (A$) RETURN 57150 SKIP.FILES.LOGON = NOT SKIP.FILES.LOGON 57160 A$ = MID$("CHECKSKIP",1 -5 * SKIP.FILES.LOGON,5) + _ " new files in logon" CALL QTPUT1 (A$) RETURN 57170 PROMPT.BELL = NOT PROMPT.BELL 57180 A$ = "Prompt Bell " + FNOFFON$(PROMPT.BELL) CALL QTPUT1 (A$) RETURN 57190 EXPERT.USER = NOT EXPERT.USER CALL SETEXPERT 57200 A$ = MID$("NoviceExpert",1 -6 * EXPERT.USER,6) CALL QTPUT1 (A$) RETURN 57210 NULLS = NOT NULLS NUL$ = MID$(STRING$(5,0),1, - 5 * NULLS) CALL SETCRLF 57220 A$ = "Nulls " + FNOFFON$(NULLS) CALL QTPUT1 (A$) RETURN 57230 TURBO.KEY.USER = NOT TURBO.KEY.USER 57240 CALL QTPUT1 ("TurboKey " + FNOFFON$(TURBO.KEY.USER)) RETURN 57260 UPPER.CASE = NOT UPPER.CASE 57270 A$ = "UPPER CASE " + _ MID$("and lowerONLY",1 - 9 * UPPER.CASE,9) CALL QTPUT1 (A$) 57280 USE.TPUT = (UPPER.CASE OR XON.XOFF) RETURN END SUB ' 58190 ' $SUBTITLE: 'CHKNARY - subroutine to check for a string in an array' ' $PAGE ' ' NAME -- CHKNARY ' ' INPUTS -- PARAMETER MEANING ' ELEMENT$ THE STRING TO CHECK FOR ' ARRAY$() THE ARRAY TO BE SEARCHED ' NUM.ENTRIES.TO.SEARCH NUMBER OF ENTRIES WITHIN IN ' THE ARRAY TO BE SEARCHED ' ' OUTPUTS -- IS.IN.ARA 0 = STRING NOT FOUND IN THE ' ARRAY SPECIFIED ' OTHERWISE IT IS THE NUMBER OF ' ELEMENT WITHIN THE ARRAY THAT ' WAS FOUND TO MATCH ' ' PURPOSE -- Search an array for a specified string and, if found, ' return the number of the element that matched. ' SUB CHKNARY (ELEMENT$,ARRAY$(1),NUM.ENTRIES.TO.SEARCH,IS.IN.ARA) STATIC IS.IN.ARA = 1 CALL ALLCAPS (ELEMENT$) MAX.TRIES = NUM.ENTRIES.TO.SEARCH + 1 ARRAY$(MAX.TRIES) = ELEMENT$ WHILE ARRAY$(IS.IN.ARA) <> ELEMENT$ IS.IN.ARA = IS.IN.ARA + 1 WEND IF IS.IN.ARA = MAX.TRIES THEN _ IS.IN.ARA = 0 END SUB 58200 ' $SUBTITLE: 'FMS - subroutine to search the upload management system' ' $PAGE ' ' NAME -- FMS ' ' INPUTS -- PARAMETER MEANING ' DIR.TO.SEARCH$ RBBS-PC "DIR" CATEGORY TO LOOK ' FOR ' SEARCH.STRING$ STRING TO SEARCH FOR ' SEARCH.DATE$ DATE TO SEARCH FOR ' CATEGORY.NAME$() ' CATEGORY.CODE$() ' CATEGORY.DESC$() ' CAT.FOUND ' NUM.CATEGORIES ' ' OUTPUTS -- PROCESSED.IN.FMS ' DOWNLOAD.FLAG ' ' PURPOSE -- To search the file management system and display the ' files being searched for as well as the catetory descriptions ' SUB FMS (DIR.TO.SEARCH$,SEARCH.STRING$,SEARCH.DATE$, _ PROCESSED.IN.FMS,CATEGORY.NAME$(1),CATEGORY.CODE$(1), _ CATEGORY.DESC$(1),DOWNLOAD.FLAG,CAT.FOUND,ABORT.INDEX) STATIC DOWNLOAD.FLAG = 0 CALL CHKNARY (DIR.TO.SEARCH$,CATEGORY.NAME$(),NUM.CATEGORIES,CAT.FOUND) PROCESSED.IN.FMS = PROCESSED.IN.FMS OR (CAT.FOUND > 0) IF PROCESSED.IN.FMS THEN _ SUBROUTINE.PARAMETER = 5 : _ GOSUB 58202 : _ A$ = "Scanning directory " + _ DIR.TO.SEARCH$ + _ HDR$ + _ " - " + _ CATEGORY.DESC$(CAT.FOUND) : _ CALL TPUT : _ CAT$ = CATEGORY.CODE$(CAT.FOUND) : _ CALL DISUPDIR (CAT$,SEARCH.STRING$,SEARCH.DATE$,DOWNLOAD.FLAG,ABORT.INDEX) EXIT SUB 58202 A$ = SEARCH.DATE$ IF LEN(A$) > 0 THEN _ A$ = MID$(A$,3) + LEFT$(A$,2) HDR$ = " for " + _ SEARCH.STRING$ + _ A$ IF LEN(HDR$) < 6 THEN _ HDR$ = "" RETURN END SUB 58210 ' $SUBTITLE: 'REMOVE - subroutine to delete a string from within a string' ' $PAGE ' ' NAME -- REMOVE ' ' INPUTS -- PARAMETER MEANING ' BADSTRING$ STRING CONTAINING CHARACTERS ' TO BE DELETED FROM "L$" ' L$ STRING TO BE ALTERED ' ' OUTPUTS -- L$ WITH THE CHARACTERS IN ' "BADSTRING#" DELETED FROM IT ' ' PURPOSE -- To remove all instances of the characters in ' "BADSTRING$" from "L$" ' SUB REMOVE (L$,BADSTRNG$) STATIC J = 0 FOR I=1 TO LEN(L$) IF INSTR(BADSTRNG$,MID$(L$,I,1)) = 0 THEN _ J = J + 1 : _ MID$(L$,J,1) = MID$(L$,I,1) NEXT I L$ = LEFT$(L$,J) END SUB ' 58250 ' $SUBTITLE: 'SMARTTXT - smart text substitution' ' $PAGE ' ' NAME -- SMARTTXT (WRITTEN BY DOUG AZZARITO) ' ' INPUTS -- STRNG.WORK$ string to scan for Smart Text ' CR.FOUND Does this line contain a CR? ' SMART.TEXT Smart Text control code ' ' OUTPUTS -- STRNG.WORK$ Input string with Smart replaced ' ' PURPOSE -- Smart Text allows control strings in text files ' to be replaced at runtime with user info or other ' data. The Smart Text control code is a 1-byte ' code (configurable) with a 2-byte action code. ' SUB SMARTTXT (STRNG.WORK$, CR.FOUND, OVERSTRIKE) STATIC IF SMART.CARRY$<>"" THEN _ STRNG.WORK$ = SMART.CARRY$+STRNG.WORK$ INDEX = INSTR(STRNG.WORK$, SMART.TEXT$) WHILE INDEX > 0 AND INDEX < LEN(STRNG.WORK$)-1 IF INSTR(MID$(STRNG.WORK$, INDEX+1,2)," ") THEN _ SMART.ACT = 0 _ ELSE _ SMART.ACT = INSTR(SMART.TABLE$, MID$(STRNG.WORK$, INDEX+1, 2)) IF SMART.ACT > 0 THEN _ SMART.ACT = (SMART.ACT+2)/3 : _ ON SMART.ACT GOSUB 58260, 58261, 58262, 58263, 58264, 58265, _ 58266, 58267, 58268, 58269, 58270, _ 58271, 58272, 58273, 58274, 58275, _ 58276, 58277, 58278, 58279, 58280, _ 58281, 58282, 58283, 58284, 58285 : _ IF OVERSTRIKE THEN _ MID$(STRNG.WORK$,INDEX) = SMART.HOLD$ _ ELSE STRNG.WORK$ = LEFT$(STRNG.WORK$, INDEX-1) + SMART.HOLD$ + _ MID$(STRNG.WORK$,INDEX+3) INDEX = INSTR(INDEX+1, STRNG.WORK$, CHR$(SMART.TEXT)) WEND IF INDEX AND (INDEX > LEN(STRNG.WORK$)-2) AND NOT CR.FOUND THEN _ SMART.CARRY$ = MID$(STRNG.WORK$,INDEX) : _ STRNG.WORK$ = LEFT$(STRNG.WORK$,INDEX-1) : _ ELSE _ SMART.CARRY$ = "" EXIT SUB 58258 LAST.SMART.COLOR$ = SMART.HOLD$ ' MZ060302 RETURN ' MZ060302 58260 LINES.PRINTED = 0 ' CS (Clear screen line count reset) SMART.HOLD$ = "" RETURN 58261 LINES.PRINTED = PAGE.LENGTH ' PB Page Break IF NON.STOP THEN _ ' force a 1-time pause ONE.STOP = TRUE : _ ' if NON STOP is on NON.STOP = FALSE SMART.HOLD$ = "" FORCE.KEYBOARD = TRUE RETURN 58262 NON.STOP = TRUE ' NS Non-stop SMART.HOLD$ = "" RETURN 58263 IF GLOBAL.SYSOP THEN _ 'FN First Name SMART.HOLD$ = ORIG.SYSOP.FN$ _ ELSE SMART.HOLD$ = FIRST.NAME$ RETURN 58264 IF GLOBAL.SYSOP THEN _ SMART.HOLD$ = ORIG.SYSOP.LN$ _ ELSE SMART.HOLD$ = LAST.NAME$ RETURN 58265 SMART.HOLD$ = MID$(STR$(USER.SECURITY.LEVEL),2) ' SL Security level RETURN 58266 SMART.HOLD$ = DATE$ RETURN 58267 CALL AMORPM ' KG061203 SMART.HOLD$ = TIM$ RETURN 58268 CALL TIMEREMAIN(TIME.REMAINING!) ' TR Time remaining (in mins) SMART.HOLD$ = MID$(STR$(INT(TIME.REMAINING!)),2) RETURN 58269 CALL TIMEREMAIN(TIME.REMAINING!) ' TE Time elapsed (mm:ss) SMART.HOLD$ = MID$(STR$(INT(TCA!/60)),2)+":"+ MID$(STR$((TCA! MOD 60)+100),3) RETURN 58270 SMART.HOLD$ = MID$(STR$(INT((TIME.LOCK.SET+0.5)/60)),2) ' TL - Time Lock period SMART.HOLD$ = SMART.HOLD$ + ":"+ MID$(STR$((TIME.LOCK.SET MOD 60)+100),3) RETURN 58271 SMART.HOLD$ = MID$(STR$(DAYS.IN.REGISTRATION.PERIOD),2) RETURN ' RP Registration Length 58272 SMART.HOLD$ = MID$(STR$(REG.DAYS.REMAINING),2) RETURN ' RR Registration Remaining 58273 SMART.HOLD$ = CITY.STATE$ ' CT Users CITY & STATE RETURN 58274 SMART.HOLD$ = FG.1$ ' C1 Color 1 GOTO 58258 ' MZ060302 58275 SMART.HOLD$ = FG.2$ ' C2 Color 2 GOTO 58258 ' MZ060302 58276 SMART.HOLD$ = FG.3$ ' C3 Color 3 GOTO 58258 ' MZ060302 58277 SMART.HOLD$ = FG.4$ ' C4 Color 4 GOTO 58258 ' MZ060302 58278 SMART.HOLD$ = EMPHASIZE.OFF$ ' C0 Reset color LAST.SMART.COLOR$ = "" ' MZ060302 RETURN 58279 SMART.HOLD$ = MID$(STR$(INT(DL.TODAY!)),2) RETURN ' DD files Dnlded TODAY 58280 SMART.HOLD$ = MID$(STR$(INT(BYTES.TODAY!)),2) RETURN ' BD Bytes Dnlded TODAY 58281 SMART.HOLD$ = MID$(STR$(INT(DLBYTES!)),2) RETURN ' DB Download Bytes 58282 SMART.HOLD$ = MID$(STR$(INT(ULBYTES!)),2) RETURN ' UB Upload Bytes 58283 SMART.HOLD$ = MID$(STR$(DOWNLOADS),2) ' DL Number of Dnlds RETURN 58284 SMART.HOLD$ = MID$(STR$(UPLOADS),2) ' UL Number of Uplds RETURN 58285 SMART.HOLD$ = FILE.NAME$ ' FILE NAME END SUB ' 58300 ' $SUBTITLE: 'BUFSTRNG - write a string with imbedded CR/LF' ' $PAGE ' ' NAME -- BUFSTRNG ' ' INPUTS -- PARAMETER MEANING ' STRNG$ STRING TO BE WRITTEN OUT ' DATA.SIZE LENGTH OF STRING - # LEFT ' CHARS TO OUTPUT ' ' OUTPUTS -- STRNG$ IS WRITTEN TO THE USER ' ' PURPOSE -- To search the string, STRNG$, for embedded carriage ' returns and line feeds and write out each line with ' the appropriate substitution (cr/lf if to the local ' screen or cr/nulls/lf if to the communications port). ' SUB BUFSTRNG (STRNG$,PASSED.DATA.SIZE,ABORT.INDEX) STATIC L = LEN(STRNG$) IF PASSED.DATA.SIZE < L THEN _ L = PASSED.DATA.SIZE IF L < 1 THEN _ EXIT SUB FF = PAGE.LENGTH - 1 START.BYTE = 1 IF CARRY.OVER THEN _ IF ASC(STRNG$) = 10 THEN _ START.BYTE = 2 : _ CALL SKIPLINE (1) CARRY.OVER = (MID$(STRNG$,L,1) = CARRIAGE.RETURN$) L = L + CARRY.OVER 58301 CRAT = INSTR(START.BYTE,STRNG$,CARRIAGE.RETURN$) IF CRAT > 0 AND CRAT < L THEN _ CR.FOUND = (MID$(STRNG$,CRAT + 1,1) = LINE.FEED$) _ ELSE CR.FOUND = FALSE EOL.LEN = -2 * CR.FOUND IF CR.FOUND THEN _ EOD = CRAT _ ELSE EOD = L + 1 NUM.BYTES = EOD - START.BYTE STRNG.WORK$ = MID$(STRNG$,START.BYTE,NUM.BYTES) IF NOT DELETE.INVALID THEN _ GOTO 58304 INDEX = INSTR(STRNG.WORK$,"[") J = LEN(STRNG.WORK$) - 1 WHILE INDEX > 0 AND INDEX < J IF MID$(STRNG.WORK$,INDEX + 2,1) = "]" THEN _ IF INSTR (INVALID.OPTS$,MID$(STRNG.WORK$,INDEX + 1,1)) THEN _ MID$(STRNG.WORK$,INDEX + 1,1) = "*" INDEX = INSTR(INDEX + 1,STRNG.WORK$,"[") WEND 58304 IF SMART.TEXT THEN _ CALL SMARTTXT (STRNG.WORK$, CR.FOUND, FALSE) CALL QTPUT (STRNG.WORK$, - (CR.FOUND)) IF RET THEN _ EXIT SUB IF LINES.PRINTED < FF THEN _ GOTO 58305 CALL CHKTREMAIN (TIME.REMAINING!) CALL CHKCARRIER ' KG061203 IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB IF NON.STOP THEN _ GOTO 58305 IF NOT CR.FOUND THEN _ ' KG052002 GOTO 58305 ' KG052002 CALL ASKMORE ("",TRUE,FALSE,ABORT.INDEX,STOP.INTERRUPTS) IF NO THEN _ RET = TRUE : _ EXIT SUB 58305 START.BYTE = EOD + EOL.LEN IF START.BYTE <= L THEN _ GOTO 58301 END SUB 58400 ' $SUBTITLE: 'BUFFILE - subroutine to write a sequential file to the user' ' $PAGE ' ' NAME -- BUFFILE ' ' INPUTS -- PARAMETER MEANING ' FILENAME$ NAME OF THE FILE TO WRITE TO ' OUT TO THE USER ' ' OUTPUTS -- NONE FILE IS WRITTEN TO THE USER ' ' PURPOSE -- To display a sequential file to the user ' SUB BUFFILE (FILNAME$,ABORT.INDEX) STATIC CALL FINDIT (FILNAME$) IF NOT OK THEN _ EXIT SUB NO = FALSE CALL OPENRSEQ (FILNAME$,NUM.RECS,LEN.LAST.REC,BUFFER.SIZE) DATA.SIZE = BUFFER.SIZE FIELD 2, DATA.SIZE AS SEQ.REC$ NON.STOP = NON.STOP OR (PAGE.LENGTH < 1) IF NOT STOP.INTERRUPTS THEN _ IF NOT CONCAT.FILES THEN _ IF NOT NON.STOP THEN _ A$ = "* Ctrl-K(^K) / ^X aborts. ^S suspends ^Q resumes *" : _ SUBROUTINE.PARAMETER = 2 : _ CALL TPUT TU = 0 58405 TU = TU + 1 IF TU < NUM.RECS THEN _ GET 2,TU _ ELSE IF TU = NUM.RECS THEN _ GET 2,TU : _ X = INSTR(SEQ.REC$,CHR$(26)) : _ IF X = 0 OR X > LEN.LAST.REC THEN _ DATA.SIZE = LEN.LAST.REC _ ELSE DATA.SIZE = X - 1 _ ELSE GOTO 58419 IF LOCAL.USER THEN _ GOTO 58406 CALL EOFCOMM (CHAR%) IF CHAR% <> -1 THEN _ GOTO 58407 ' comm port input 58406 KEYBOARD.STACK$ = INKEY$ IF KEYBOARD.STACK$ = "" THEN _ ' no keyboard input CALL BUFSTRNG (SEQ.REC$,DATA.SIZE,ABORT.INDEX) : _ GOTO 58408 58407 A$ = LEFT$(SEQ.REC$,DATA.SIZE) ' process comm/keyboard SUBROUTINE.PARAMETER = 4 CALL TPUT 58408 IF SUBROUTINE.PARAMETER <> -1 AND NOT RET THEN _ GOTO 58405 58419 CLOSE 2 BYPASS.TIME.CHECK = FALSE STOP.INTERRUPTS = FALSE CALL QTPUT (EMPHASIZE.OFF$,0) END SUB 58600 ' $SUBTITLE: 'FINDLAST - find last occurence of a string' ' $PAGE ' ' NAME -- FINDLAST ' ' INPUTS -- PARAMETER MEANING ' LOOK.IN$ STRING TO LOOK INTO ' LOOK.FOR$ STRING TO SEARCH FOR ' ' OUTPUTS -- WHERE.FOUND POSITION IN LOOK.IN$ THAT ' LOOK.FOR$ FOUND ' NUM.FINDS HOW MANY OCCURENCES IN LOOK.IN$ ' ' PURPOSE -- Finds last occurence of LOOK.FOR$ in LOOK.IN$ and ' returns count of # of occurences. If none found, ' both returned parameters are set to 0. ' SUB FINDLAST (LOOK.IN$,LOOK.FOR$,WHERE.FOUND,NUM.FINDS) STATIC WHERE.FOUND = INSTR(LOOK.IN$,LOOK.FOR$) NUM.FINDS = -(WHERE.FOUND > 0) NEXT.FOUND = INSTR(WHERE.FOUND + 1,LOOK.IN$,LOOK.FOR$) WHILE NEXT.FOUND > 0 NUM.FINDS = NUM.FINDS + 1 WHERE.FOUND = NEXT.FOUND NEXT.FOUND = INSTR(WHERE.FOUND + 1,LOOK.IN$,LOOK.FOR$) WEND END SUB 58700 ' $SUBTITLE: 'ROTORSDIR - search thru a list of subdirs for a file' ' $PAGE ' ' NAME -- ROTORSDIR ' ' INPUTS -- PARAMETER MEANING ' FILNAME$ FILE NAME TO LOOK FOR ' SDIR.ARA ARRAY OF SUBDIRECTORIES ' MAX.SEARCH MAX # OF SUBDIRECTORIES ' MARK.TIME WHETHER TO MARK TIME ' ' OUTPUTS -- FNAME$ ADD SUBDIRECTORY TO THE ' FILE NAME IF FOUND. OTHER- ' WISE DON'T. ' OK TRUE IF FILE WAS FOUND ' ' PURPOSE -- Hunt through a list of subdirectories to determine ' if a file is in any of them. If file is found, open ' the file as file #2, add the drive/path to the file ' name, and sets OK to true. If file isn't found, set ' file name to the last subdirectory searched -- which ' should be the upload subdirectory. ' ' If the library menu is selected (MENU.INDEX = 6), then ' only 2 subdirectories are searched. The first being ' the work disk and the second being the selected ' library disk. ' SUB ROTORSDIR (FILNAME$,SDIR.ARA$(1),MAX.SEARCH,MARK.TIME) STATIC OK = FALSE IF MARK.TIME THEN _ CALL QTPUT ("Searching for "+FILNAME$,0) IF MENU.INDEX = 6 THEN _ GOTO 58705 NUM.SEARCH = 1 X = 0 WHILE (NOT OK) AND NUM.SEARCH <= MAX.SEARCH AND _ SDIR.ARA$(NUM.SEARCH) <> "" IF MARK.TIME THEN _ CALL MARKTIME (X) X$ = SDIR.ARA$(NUM.SEARCH) + _ FILNAME$ CALL FINDIT (X$) NUM.SEARCH = NUM.SEARCH + 1 WEND GOTO 58710 58705 X$ = LIBRARY.WORK.DISK.PATH$ + _ FILNAME$ CALL FINDIT (X$) IF OK THEN _ GOTO 58710 X$ = LIBRARY.DRIVE$ + _ FILNAME$ CALL FINDIT (X$) 58710 FILNAME$ = X$ CALL SKIPLINE (-MARK.TIME) END SUB 58800 ' $SUBTITLE: 'WIPELINE - Wipe away a line so next overprints' ' $PAGE ' ' NAME -- WIPELINE ' ' INPUTS -- PARAMETER MEANING ' CARRIAGE.RETURN$ ' CHARS.TO.WIPE # OF CHARACTERS TO BLANK ' NULLS ' ' OUTPUTS -- NONE ' ' PURPOSE -- Wipe away a line and leave cursor at beginning of the ' same line so that the next line will print in its place ' SUB WIPELINE (CHARS.TO.WIPE) STATIC IF NULLS OR CHARS.TO.WIPE > 79 THEN _ CALL SKIPLINE (1) : _ EXIT SUB IF NOT LOCAL.USER THEN _ STRNG$ = CARRIAGE.RETURN$ + SPACE$(CHARS.TO.WIPE) + CARRIAGE.RETURN$ : _ IF FOSSIL THEN _ BYTES% = LEN(STRNG$) : _ CALL FOSWRITE(COMPORT%,BYTES%,STRNG$) _ ELSE PRINT #3,STRNG$ IF SNOOP THEN _ LOCATE ,1 : _ CALL LPRNT(SPACE$(CHARS.TO.WIPE),0) : _ LOCATE ,1 IF F7.MESSAGE$ = "" OR _ F7.MESSAGE$ = "NONE" OR _ NOT SYSOP.NEXT THEN _ EXIT SUB BYPASS.TIME.CHECK = TRUE CALL BUFFILE (F7.MESSAGE$,X) END SUB 58895 ' $SUBTITLE: 'GETDIRS -- Prompt for directories to search' ' $PAGE ' ' NAME -- GETDIRS ' ' INPUTS -- PARAMETER MEANING ' DIR.PROMPT$ BASE OF DIRECTORY PROMPT ' SHOW.HELP Whether to display help ' on entry ' OUTPUTS -- B$ ' Q ' ' PURPOSE -- Prompt for directories to search ' SUB GETDIRS (SHOW.HELP) STATIC IF SHOW.HELP THEN _ GOTO 58902 58900 A$ = DIR.PROMPT$ MACRO.MIN = 2 SUBROUTINE.PARAMETER = 1 CALL TGET IF Q = 0 OR SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB CALL ALLCAPS (B$(1)) IF B$(1) = "Q" THEN _ Q = 0 : _ EXIT SUB A = INSTR("E+.E-.E.L.H.?.",B$(1)+".") IF A = 0 THEN _ EXIT SUB IF A > 8 THEN _ GOTO 58901 IF A = 7 THEN _ EXTENDED.OFF = NOT EXTENDED.OFF _ ELSE EXTENDED.OFF = (A > 3) CALL QTPUT1 ("Extended directory display "+MID$("ON OFF",1-3*EXTENDED.OFF,3)) GOTO 58900 58901 IF A = 9 AND Q > 1 THEN _ Q = Q - 1 : _ FOR B = 1 TO Q : _ B$(B) = B$(B + 1) : _ NEXT : _ EXIT SUB 58902 FILE.NAME$ = DIRECTORY.PATH$ + DIRECTORY.PREFIX$ + _ "." + DIRECTORY.EXTENTION$ GDEFAULT$ = MID$(" GC",GR + 1, 1) CALL GRAPHIC (GDEFAULT$,FILE.NAME$) CALL BUFFILE (FILE.NAME$,X) GOTO 58900 END SUB ' 58950 ' $SUBTITLE: 'CONVDIRS -- Converts coded response to right directory' ' $PAGE ' ' NAME -- CONVDIRS ' ' INPUTS -- PARAMETER MEANING ' STRT ELEMENT TO BEGIN WITH ' B$ ARRAY TO CONVERT ' Q LAST ELEMENT TO CONVERT ' ' OUTPUTS -- B$ CONVERTED DIRECTORY LIST ' ' PURPOSE -- Let the user put in a short standard string for a directory ' ' SUB CONVDIRS (STRT) STATIC FOR I=STRT TO Q CALL ALLCAPS (B$(I)) IF B$(I)="U" THEN _ B$(I) = UPLOAD.DIR.CHECK$ IF B$(I) = "A" THEN _ B$(I) = "ALL" NEXT END SUB 59100 ' $SUBTITLE: 'MUZAK - subroutine to PLAY MUSIC' ' $PAGE ' ' NAME -- MUZAK ' ' INPUTS -- PARAMETER MEANING ' 1 PLAY CONSIDER YOURSELF(OPENING SCREEN) ' 2 PLAY WALK RIGHT IN(NEW USERS) ' 3 PLAY DRAGNET (SECURITY VIOLATION) ' 4 PLAY GOODBYE CHARLIE (GOODBYE) ' 5 PLAY TAPS (ACCESS DENIED) ' 6 PLAY OOM PAH PAH (DOWNLOAD) ' 7 PLAY THNKS FOR MEMORIES(UPLOAD) ' ' OUTPUTS -- NONE ' ' PURPOSE -- Provide sysops and the visually impaired with ' auditory feedback on what RBBS-PC is doing ' SUB MUZAK (PASSED.ARG) STATIC FF = PASSED.ARG SUBROUTINE.PARAMETER = 0 IF (NOT SNOOP) OR (NOT MUSIC) OR LOCAL.USER.MODE THEN _ EXIT SUB ON FF GOTO 59102,59104,59106,59108,59110,59112,59114 EXIT SUB 59102 '---[Introduction CONSIDER YOURSELF]--- LEC$ = "MBT180A4B-8B-8B-8B-2.G4A8F2" PLAY "O2 X" + VARPTR$(LEC$) EXIT SUB 59104 '---[New User WALK RIGHT IN]--- LEC1$ = "MBT180G4G4D2G8F+8F8E2A8B8" LEC2$ = "C8C+8D8C8" LEC3$ = "B4G2" PLAY "O2 X" + VARPTR$(LEC1$) + "O3 X" + VARPTR$(LEC2$) + "O2 X" + VARPTR$(LEC3$) EXIT SUB 59106 '---[Security Violation DRAGNET THEME]--- LEC$ = "MBT120C2D8E-4C2.C2D8E-4C4G-2." PLAY "O2 X" + VARPTR$(LEC$) EXIT SUB 59108 '---[Goodbye GOODBYE CHARLIE]--- LEC$ = "MBT180B-2.G2.F4D2." PLAY "O2 X" + VARPTR$(LEC$) EXIT SUB 59110 '---[Access Denied TAPS]--- LEC1$ = "MBT90F8A16" LEC2$ = "C4." LEC3$ = "A4F4C2.C8C16F2" PLAY "O2 X" + VARPTR$(LEC1$) + "O3 X" + VARPTR$(LEC2$) + "O2 X" + VARPTR$(LEC3$) EXIT SUB 59112 '---[Download OOM PAH PAH]--- LEC$ = "MBT180F4A4A4C4A4A4G4A4G4D2" PLAY "O2 X" + VARPTR$(LEC$) EXIT SUB 59114 '---[Upload THANKS FOR THE MEMORIES]--- LEC1$ = "MBT180C2." LEC2$ = "A8G8F4D2" PLAY "O3 X" + VARPTR$(LEC1$) + "O2 X" + VARPTR$(LEC2$) END SUB 59200 ' $SUBTITLE: 'TWOBYTEDATE -- subroutine to put date in 2 bytes' ' $PAGE ' ' NAME -- TWOBYTEDATE ' ' INPUTS -- PARAMETER MEANING ' YY FOUR DIGIT YEAR (I.E. 1987) ' MM MONTH ' DD DAY ' RESULT$ LOCATION TO PLACE THE RESULT ' ' OUTPUTS -- RESULT$ TWO BYTE COMPRESSED DATE FOR USE IN ' A RANDOM RECORD ' ' PURPOSE -- Compress a Y,M,D date into two characters ' SUB TWOBYTEDATE (YY,MM,DD,RESULT$) STATIC RESULT$ = CHR$(((YY - 1980) * 2) OR - ((MM AND 8) <> 0)) + _ CHR$((MM AND NOT 8) * 32 + DD) END SUB 59201 ' $SUBTITLE: 'CSTRDATE -- subroutine to Compress STRing DATE' ' $PAGE ' ' NAME -- CSTRDATE ' ' INPUTS -- PARAMETER MEANING ' STRNG$ String Date (mm-dd-yyyy) ' ' OUTPUTS -- RESULT$ TWO BYTE COMPRESSED DATE FOR USE IN ' A RANDOM RECORD ' ' PURPOSE -- Compress an 8-character date into two characters ' SUB CSTRDATE (STRNG$,RESULT$) STATIC IF LEN(STRNG$) < 8 THEN _ EXIT SUB YY = VAL(MID$(STRNG$,7)) MM = VAL(STRNG$) DD = VAL(MID$(STRNG$,4)) CALL TWOBYTEDATE (YY,MM,DD,RESULT$) END SUB 59202 ' $SUBTITLE: 'UNCDATE -- subroutine to UNCompress DATE' ' $PAGE ' ' NAME -- UNCDATE ' ' INPUTS -- PARAMETER MEANING ' COMPRESSED.DATE$ Date in 2 byte compressed form ' ' OUTPUTS -- YY Year of compressed date ' MM Month of compressed date ' DD Day of compressed date ' DISPLAY.DATE$ 8 char display date (mm-dd-yyyy) ' ' PURPOSE -- Uncompress a 2 char date to get Y,M,D & display ' SUB UNCDATE (COMPRESSED.DATE$,YY,MM,DD,DISPLAY.DATE$) STATIC CALL GETYMD (COMPRESSED.DATE$,1,YY) CALL GETYMD (COMPRESSED.DATE$,2,MM) CALL GETYMD (COMPRESSED.DATE$,3,DD) DISPLAY.DATE$ = RIGHT$("00" + MID$(STR$(MM),2),2) + _ "-" + _ RIGHT$("00" + MID$(STR$(DD),2),2) + _ "-" + _ RIGHT$(STR$(YY),2) END SUB 59204 ' $SUBTITLE: 'GETYMD -- subroutine to unpack a two-byte date' ' $PAGE ' ' NAME -- GETYMD ' ' INPUTS -- PARAMETER MEANING ' TWOBYTE$ PACKED TWO-BYTE DATE FIELD ' YMD 1 = YEAR ' 2 = MONTH ' 3 = DAY ' RESULT LOCATION TO PLACE THE RESULT ' ' OUTPUTS -- RESULT FOUR DIGIT RESULT OF UNPAKING THE DATE ' ' PURPOSE -- Unpack a compressed two-byte date field ' SUB GETYMD (TWOBYTE$,YMD,RESULT) STATIC ON YMD GOTO 59206,59210,59215 EXIT SUB 59206 RESULT = (ASC(TWOBYTE$)AND NOT 1) / 2 + 1980 EXIT SUB 59210 RESULT = FIX((ASC(MID$(TWOBYTE$,2)) / 32)) OR ((ASC(TWOBYTE$) AND 1) * 8) EXIT SUB 59215 RESULT = ASC(MID$(TWOBYTE$,2)) AND NOT 224 END SUB 59300 ' $SUBTITLE: 'PERSFILE - processes requests for personal files' ' $PAGE ' ' NAME -- PERSFILE ' ' INPUTS -- PARAMETER MEANING ' PERSONAL.CAT$ CATEGORY IN DIR FOR CALLER ' PERSONAL.LEN # CHARS IN PERSONAL CATEGORY ' OUTPUTS -- NONE UP DOWNLOADS ' ' PURPOSE -- Show caller what personal files have for downloading, ' verify and process requests for downloads ' SUB PERSFILE (PERSONAL.CAT$,DOWNLOAD.FLAG) STATIC CALL FINDIT (PERSONAL.DIR$) 59302 IF NOT OK THEN _ CALL QTPUT1 ("No personal files available") : _ Q = 0 : _ EXIT SUB L = 36 + MAX.DESC.LEN + PERSONAL.LEN IF LOF(2) < L THEN _ OK = FALSE : _ GOTO 59302 B$(0) = "" CLOSE 2 IF SHARE.IT THEN _ OPEN PERSONAL.DIR$ FOR RANDOM SHARED AS #2 LEN=L _ ELSE OPEN "R",2,PERSONAL.DIR$,L FIELD #2,33 + MAX.DESC.LEN AS PART.TO.PRINT$, _ PERSONAL.LEN AS PRIVATE.CAT$, _ 1 AS PERSONAL.STATUS$, _ 2 AS FILLER$ MAX.PRINT = PAGE.LENGTH - 1 NON.STOP = NON.STOP OR (PAGE.LENGTH < 1) LAST.REC = LOF(2) / L IF DOWNLOADING THEN _ DOWNLOADING = FALSE : _ PERS.INDEX = DOWNLOAD.FLAG : _ DOWNLOAD.FLAG = 0 : _ GOTO 59306 IF Q > 1 THEN _ FOR I = 2 TO Q : _ B$(I - 1) = B$(I) : _ NEXT : _ Q = Q - 1 : _ GOTO 59304 59303 A$ = "Download what: L)ist, * = new, or file(s)" + _ PRESS.ENTER.EXPERT$ SUBROUTINE.PARAMETER = 1 MACRO.MIN = 99 CALL TGET IF SUBROUTINE.PARAMETER = -1 OR Q = 0 THEN _ EXIT SUB 59304 SELECTED.PROTOCOL$ = "" IF Q > 1 THEN _ IF LEN(B$(Q)) = 1 THEN _ SELECTED.PROTOCOL$ = B$(Q) : _ Q = Q - 1 IF LEN(B$(1)) > 2 THEN _ GOTO 59330 CALL ALLCAPS (B$(1)) ON INSTR("L*",B$(1)) GOTO 59305,59327 GOTO 59303 59305 PERS.INDEX = LAST.REC L = FALSE 59306 IF PERS.INDEX < 1 THEN _ IF L THEN _ GOTO 59303 _ ELSE _ A$ = "No files for you" : _ CALL QTPUT1 (A$) : _ GOTO 59303 GET #2,PERS.INDEX PERS.INDEX = PERS.INDEX - 1 IF SYSOP THEN _ GOTO 59320 IF ASC(PRIVATE.CAT$) = 32 THEN _ IF USER.SECURITY.LEVEL < VAL(PRIVATE.CAT$) THEN _ GOTO 59306 _ ELSE GOTO 59308 IF PERSONAL.CAT$ <> PRIVATE.CAT$ THEN _ GOTO 59306 59308 L = TRUE FILNAME$ = PERSONAL.DRVPATH$ + _ LEFT$(PART.TO.PRINT$,12) 59320 A$ = PART.TO.PRINT$ ' KG052003 CALL COLORDIR (A$,"Y") ' KG052003 IF PERSONAL.STATUS$ = "*" AND LEFT$(A$,1) <> " " THEN _ ' KG052003 A$ = "*" + A$ _ ' KG052003 ELSE A$ = " " + A$ ' KG052003 IF LOCAL.USER THEN _ GOTO 59322 CALL EOFCOMM (CHAR%) IF CHAR% <> -1 THEN _ GOTO 59323 ' comm port input 59322 KEYBOARD.STACK$ = INKEY$ IF KEYBOARD.STACK$ = "" THEN _ ' no keyboard input CALL QTPUT1 (A$) : _ GOTO 59324 59323 SUBROUTINE.PARAMETER = 1 CALL TPUT IF RET THEN _ GOTO 59303 IF SUBROUTINE.PARAMETER = -1 THEN _ GOTO 59335 59324 IF LINES.PRINTED <= MAX.PRINT THEN _ GOTO 59306 CALL TIMEREMAIN (TIME.REMAINING!) IF TIME.REMAINING! < 0.1 THEN _ SUBROUTINE.PARAMETER = -1 : _ GOTO 59335 CALL CARRIER IF SUBROUTINE.PARAMETER = -1 THEN _ GOTO 59335 IF NON.STOP THEN _ GOTO 59306 59325 IF PERS.INDEX > 0 THEN _ A$ = "MORE: [Y],N,C or download what (* = new)" _ ELSE GOTO 59303 SUBROUTINE.PARAMETER = 1 NO.ADVANCE = TRUE MACRO.MIN = 99 CALL TGET IF SUBROUTINE.PARAMETER = -1 THEN _ GOTO 59335 NON.STOP = (NON.STOP OR INSTR(" Cc",B$) > 1) IF PERS.INDEX < 1 AND Q = 0 THEN _ GOTO 59335 CALL WIPELINE (78) IF NO THEN _ GOTO 59303 IF LEN(B$(1)) > 2 THEN _ GOTO 59304 GOTO 59306 59327 PERS.INDEX = LAST.REC ' handle new files Q = 0 WHILE PERS.INDEX > 0 AND Q < UBOUND(B$) GET 2,PERS.INDEX IF PERSONAL.CAT$ <> PRIVATE.CAT$ THEN _ GOTO 59329 IF PERSONAL.STATUS$ <> "*" THEN _ GOTO 59329 Q = Q + 1 I = Q GOSUB 59336 IF OK THEN _ X$ = MID$(STR$(PERS.INDEX),2) : _ B$(0) = B$(0) + _ X$ + _ SPACE$(5 - LEN(X$)) _ ELSE Q = Q - 1 59329 PERS.INDEX = PERS.INDEX - 1 WEND IF Q = 0 THEN _ A$ = "No new files for you" : _ CALL QTPUT1 (A$) : _ GOTO 59303 GOTO 59332 59330 I = 1 ' handle list of files WHILE I <= Q OK = FALSE J = LAST.REC + 1 CALL ALLCAPS (B$(I)) WHILE J > 1 AND NOT OK J = J - 1 GET #2,J IF (PERSONAL.CAT$ = PRIVATE.CAT$ OR _ (ASC(PRIVATE.CAT$) = 32 AND _ USER.SECURITY.LEVEL => VAL(PRIVATE.CAT$))) THEN _ OK = (B$(I) = LEFT$(PART.TO.PRINT$,INSTR(PART.TO.PRINT$," ") - 1)) WEND IF OK THEN _ GOSUB 59336 : _ IF OK THEN _ X$ = MID$(STR$(J),2) : _ B$(0) = B$(0) + _ X$ + _ SPACE$(5 - LEN(X$)) IF NOT OK THEN _ CALL QTPUT1 (B$(I) + " not found - omitted") : _ FOR K = I + 1 TO Q : _ B$(K - 1) = B$(K) : _ NEXT : _ Q = Q - 1 : _ I = I - 1 I = I + 1 WEND IF Q = 0 THEN _ GOTO 59303 59332 DOWNLOAD.FLAG = PERS.INDEX ' set protocol DOWNLOADING = TRUE B = 1 IF SELECTED.PROTOCOL$ = "" THEN _ IF PERSONAL.PROTOCOL$ <> " " THEN _ SELECTED.PROTOCOL$ = PERSONAL.PROTOCOL$ IF SELECTED.PROTOCOL$ <> "" THEN _ Q = Q + 1 : _ B$(Q) = SELECTED.PROTOCOL$ EXIT SUB 59335 CLOSE 2 EXIT SUB 59336 B$(I) = LEFT$(PART.TO.PRINT$,INSTR(PART.TO.PRINT$," ") - 1) CALL RBBSFIND (PERSONAL.DRVPATH$ + B$(I),Z,K,L,M) OK = (Z = 0) IF OK THEN _ B$(I) = PERSONAL.DRVPATH$ + B$(I) _ ELSE K = 0 : _ WHILE K < SUBDIR.COUNT AND NOT OK : _ K = K + 1 : _ CALL RBBSFIND (SUBDIR$(K) + B$(I),Z,X,L,M) : _ OK = (Z=0) : _ WEND : _ IF OK THEN _ B$(I) = SUBDIR$(K) + B$(I) RETURN END SUB 59400 ' $SUBTITLE: 'LOGDOWN -- subroutine to record private downloads' ' $PAGE ' ' NAME -- LOGDOWN ' ' INPUTS -- PARAMETER MEANING ' ' OUTPUTS -- ' ' PURPOSE -- Puts a "!" in place of an "*" in private directory ' after downloaded ' SUB LOGDOWN (PRIVATE.DOWNLOAD,DWN.INDEX) STATIC IF NOT PRIVATE.DOWNLOAD THEN _ EXIT SUB EN$ = PERSONAL.DIR$ BX = &H4 SUBROUTINE.PARAMETER = 9 CALL FILELOCK L = 36 + MAX.DESC.LEN + PERSONAL.LEN CLOSE 2 IF SHARE.IT THEN _ OPEN EN$ FOR RANDOM SHARED AS #2 LEN=L _ ELSE OPEN "R",2,PERSONAL.DIR$,L FIELD #2,L AS PERSONAL.REC$ A = VAL(MID$(B$(0),5 * (DWN.INDEX - 1) + 1,5)) GET #2,A MID$(PERSONAL.REC$,L-2,1) = "!" PUT #2,A CALL UNLKAPPND END SUB 59450 ' $SUBTITLE: 'USERFACE - handles programmable user interface' ' $PAGE ' ' NAME -- USERFACE ' ' INPUTS -- PARAMETER MEANING ' GDEFAULT$ GRAPHICS DEFAULT TO USE ' CURRENT.PUI$ PUI TO USE ' EXPERT.USER WHETHER CALL IN EXPERT MODE ' ' OUTPUTS -- Q ' B$() ' Z$ ' ' PURPOSE -- When sysop overrides RBBS-PC's default user ' interface (provides a MAIN.PUT), this routine ' reads in the table of specifications, presents ' the sysop menu, presents the prompt, verifies ' that a valid option has been picked, determines ' whether the option is another PUI, and passes ' back choices to be processed. ' SUB USERFACE (GDEFAULT$) STATIC 59455 IF PREV.PUI$ = CURRENT.PUI$ THEN _ GOTO 59458 59456 FILE.NAME$ = CURRENT.PUI$ CALL GRAPHIC (GDEFAULT$,FILE.NAME$) IF NOT OK THEN _ CALL UPDTCALR ("Missing menu " + CURRENT.PUI$,2) : _ CURRENT.PUI$ = PREV.PUI$ : _ GOTO 59456 PREV.PUI$ = CURRENT.PUI$ LINE INPUT #2,FILE.NAME$ LINE INPUT #2,PRMPT$ INPUT #2,VALID.CHOICE$,ACTUAL.COMMANDS$ LINE INPUT #2,MENU.CHOICE$ LINE INPUT #2,MENU.NAME$ LINE INPUT #2,QUIT.COMMAND$ LINE INPUT #2,QUIT.PROMPT$ LINE INPUT #2,QUIT.SUBCOMMANDS$ LINE INPUT #2,QUIT.MENUOPT$ LINE INPUT #2,QUIT.MENUS$ CALL GRAPHIC (GDEFAULT$,FILE.NAME$) CALL BRKFNAME (FILE.NAME$,MENU.DRVPATH$,X$,Y$,TRUE) MENU.TO.DISPLAY$ = FILE.NAME$ J = INSTR(ORIG.COMMANDS$,"?") IF J < 1 THEN _ X$ = "" _ ELSE X$ = MID$(ALL.OPTS$,J,1) 59458 IF EXPERT.USER THEN _ GOTO 59461 59460 NON.STOP = (PAGE.LENGTH < 1) ' KG060304 CALL BUFFILE (MENU.TO.DISPLAY$,X) 59461 A$ = PRMPT$ TURBO.KEY = -TURBO.KEY.USER SUBROUTINE.PARAMETER = 1 CALL TGET IF SUBROUTINE.PARAMETER = -1 OR FUNCTION.KEY <> 0 THEN _ EXIT SUB IF Q = 0 THEN _ GOTO 59458 59462 Z$ = B$(1) CALL ALLCAPS (Z$) J = INSTR(VALID.CHOICE$,Z$) IF J < 1 THEN _ GOTO 59492 Z$ = MID$(ACTUAL.COMMANDS$,J,1) B$(1) = Z$ J = INSTR(MENU.CHOICE$,Z$) IF J > 0 THEN _ CURRENT.PUI$ = MID$(MENU.NAME$,1 + (J - 1) * 7,7) : _ GOTO 59490 IF Z$ = X$ THEN _ GOTO 59460 IF Z$ <> QUIT.COMMAND$ THEN _ EXIT SUB IF Q > 1 THEN _ Y = 2 : _ GOTO 59480 59470 A$ = QUIT.PROMPT$ TURBO.KEY = -TURBO.KEY.USER CALL TGET IF SUBROUTINE.PARAMETER = -1 OR FUNCTION.KEY <> 0 THEN _ EXIT SUB IF Q = 0 THEN _ GOTO 59458 Y = 1 59480 Z$ = B$(Y) CALL ALLCAPS (Z$) J = INSTR(QUIT.SUBCOMMANDS$,Z$) IF J < 1 THEN _ GOTO 59470 J = INSTR(QUIT.MENUOPT$,Z$) IF J > 0 THEN _ 'quit to submenu CURRENT.PUI$ = MID$(QUIT.MENUS$,1 + (J - 1) * 7,7) : _ GOTO 59490 IF Q = 1 THEN _ 'valid but not menu - send to RBBS Q = 2 : _ B$(2) = B$(1) : _ B$(1) = QUIT.COMMAND$ EXIT SUB 59490 CALL REMOVE (CURRENT.PUI$," ") CURRENT.PUI$ = MENU.DRVPATH$ + _ CURRENT.PUI$ + _ ".PUI" GOTO 59455 59492 CALL QTPUT1 (Z$ + " not valid choice") GOTO 59460 END SUB 59500 ' $SUBTITLE: 'SUBMENU -- subroutine to process menus' ' $PAGE ' ' NAME -- SUBMENU ' ' INPUTS -- PARAMETER MEANING ' PASSED.PROMPT$ PROMPT TO DISPLAY ' CURRENT.MENU$ NOVICE MENU TO DISPLAY ' FRONT.OPT$ DRIVE/PATH/PREFIX OF FILE ' NEEDED FOR TYPED OPTION ' BACK.OPT$ SUFFIX/EXTENSION OF FILE ' NEEDED WITH TYPED OPTION ' RETURN.ON$ LETTERS CALLING PROGRAM WANTS ' CONTROL ON ' GR.DEFAULT$ GRAPHICS DEFAULT TO USE ' VERIFY.IN.MENU WHETHER VERIFY OPTION IS IN MENU ' ALL.MENU.OK WHETHER CONTROL SHOULD RETURN ' WHEN IN MENU ' ANS.INDEX # OF COMMANDS IN TYPE AHEAD ' REQUIRE.IN.MENU WHETHER OPTION MUST BE IN MENU ' ' OUTPUTS -- Z$ OPTION PICKED ' FILE.NAME$ NAME OF FILE SUPPORTING OPTION ' ' ' PURPOSE -- Handles menus - including conference, bulletins, ' doors, questionnaires. Supports sub-menus (i.e. ' an option on the menu that invokes another menu) ' SUB SUBMENU (PASSED.PROMPT$,CURRENT.MENU$,FRONT.OPT$, _ BACK.OPT$,RETURN.ON$,GR.DEFAULT$,VERIFY.IN.MENU, _ ALL.MENU.OK,REQUIRE.IN.MENU,BACK.OPT2$) STATIC 59510 FILE.NAME$ = CURRENT.MENU$ CALL BRKFNAME (CURRENT.MENU$,MNU.DRV$,X$,DF$,TRUE) MENU.FRONT$ = MNU.DRV$ + X$ CALL GRAPHIC (GR.DEFAULT$,FILE.NAME$) CURRENT.MENU.VER$ = FILE.NAME$ STOP.INTERRUPTS = FALSE IF ANS.INDEX > 1 THEN _ Q = 1 : _ GOTO 59530 IF EXPERT.USER THEN _ GOTO 59520 59515 CALL BUFFILE (CURRENT.MENU.VER$,ANS.INDEX) 'show menu 59520 A$ = PASSED.PROMPT$ 'get response SUBROUTINE.PARAMETER = 1 CALL TGET IF Q = 0 OR SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB ANS.INDEX = 1 LAST.INDEX = Q 59530 Z$ = B$(ANS.INDEX) CALL ALLCAPS (Z$) IF INSTR(RETURN.ON$,Z$) THEN _ 'check whether calling pgm wants EXIT SUB IF INSTR("LH?",Z$) THEN _ 'check whether caller wants help GOTO 59515 IF INSTR(Z$,".") > 0 THEN _ GOTO 59532 FPRE$ = FRONT.OPT$ GOSUB 59538 IF (BF < 2) AND (NOT OK) THEN _ FPRE$ = MNU.DRV$ : _ ' KG061102 GOSUB 59538 : _ ' KG061102 IF NOT OK THEN _ ' support shared options ' KG061102 FPRE$ = MENU.FRONT$ : _ ' KG061102 GOSUB 59538 ' KG061102 IF NEW.MENU THEN _ NEW.MENU = FALSE : _ GOTO 59515 IF OK THEN _ EXIT SUB 59532 IF INSTR(RETURN.ON$,LEFT$(Z$,1)) > 0 THEN _ EXIT SUB GOSUB 59547 GOTO 59515 59538 FILNAME$ = FPRE$ + Z$ CALL BADFILE (FILNAME$,BF) IF BF > 1 THEN _ OK = FALSE : _ RETURN FILE.NAME$ = FILNAME$ + _ BACK.OPT$ CALL GRAPHIC (GR.DEFAULT$,FILE.NAME$) IF NOT OK THEN _ IF BACK.OPT2$ <> "" THEN _ FILE.NAME$ = FILNAME$ + _ BACK.OPT2$ : _ CALL GRAPHIC (GR.DEFAULT$,FILE.NAME$) IF OK THEN _ IF SYSOP OR (NOT REQUIRE.IN.MENU) THEN _ RETURN _ ELSE CALL WORDINFILE (CURRENT.MENU$,Z$,FOUND) : _ IF FOUND THEN _ RETURN _ ELSE GOTO 59540 IF (NOT VERIFY.IN.MENU) THEN _ GOTO 59540 CALL WORDINFILE (CURRENT.MENU$,Z$,FOUND) 'verify against menu itself IF FOUND THEN _ IF ALL.MENU.OK THEN _ RETURN 59540 X$ = FPRE$ + _ Z$ + _ ".MNU" 'check whether option is a menu FILE.NAME$ = X$ CALL GRAPHIC (GR.DEFAULT$,FILE.NAME$) IF OK THEN _ NEW.MENU = TRUE : _ CURRENT.MENU.VER$ = FILE.NAME$ : _ CURRENT.MENU$ = X$ : _ CALL BRKFNAME (CURRENT.MENU$,MNU.DRV$,X$,DF$,TRUE) : _ MENU.FRONT$ = MNU.DRV$ + X$ : _ RETURN IF VERIFY.IN.MENU AND FOUND AND NOT REQUIRE.IN.MENU THEN _ CALL UPDTCALR("Option " + Z$ + " on menu " + _ CURRENT.MENU$ + " but not found",1) RETURN 59547 CALL QTPUT1 ("No such option " + Z$) RETURN 59548 END SUB 59600 ' $SUBTITLE: 'SETECHO -- subroutine to reset who echoes' ' $PAGE ' ' NAME -- SETECHO ' ' INPUTS -- PARAMETER MEANING ' NEW.ECHO$ The new echo option ' LOCAL.USER ' ' OUTPUTS -- REMOTE.ECHO Whether RBBS is to echo what a ' remote caller types ' ' PURPOSE -- Resets who echos. "R" is for RBBS to echo. ' "I" is for intermediate host to echo. ' "C" is for caller's communication pgm to echo. ' SUB SETECHO (NEW.ECHO$) STATIC IF NEW.ECHO$ = PREV.ECHO$ THEN _ EXIT SUB IF NEW.ECHO$ = "R" THEN _ REMOTE.ECHO = (NOT LOCAL.USER) _ ELSE REMOTE.ECHO = FALSE IF LOCAL.USER THEN _ GOTO 59602 IF NEW.ECHO$ = "I" THEN _ IF FOSSIL THEN _ BYTES% = LEN(HOST.ECHO.ON$) : _ CALL FOSWRITE(COMPORT%,BYTES%,HOST.ECHO.ON$) : _ GOTO 59602 _ ELSE PRINT #3,HOST.ECHO.ON$; : _ GOTO 59602 IF PREV.ECHO$ = "I" THEN _ IF FOSSIL THEN _ BYTES% = LEN(HOST.ECHO.OFF$) : _ CALL FOSWRITE(COMPORT%,BYTES%,HOST.ECHO.OFF$) _ ELSE PRINT #3,HOST.ECHO.OFF$; 59602 PREV.ECHO$ = NEW.ECHO$ END SUB 59698 ' $SUBTITLE: 'MIMPORT -- subroutine to import a message' ' $PAGE ' ' NAME -- MIMPORT ' ' INPUTS -- PARAMETER MEANING ' MAX.LINES MAXIMUM # OF LINES ' MAX.LEN MAXIMUM LENGTH OF A LINE ' NUM.LINES NUMBER OF LINES ALREADY IN MESSAGE ' LINE.ARA$ ARRAY OF LINES IN MESSAGE ' ' OUTPUTS -- NUM.LINES ' LINE.ARA$ ' ' PURPOSE -- Allows local user to append a text file to ' a message. Will word wrap if needed. ' SUB MIMPORT (MAX.LINES,MAX.LEN,NUM.LINES,LINE.ARA$(1)) STATIC IF NOT (LOCAL.USER OR SYSOP) THEN _ CALL QTPUT1 ("Only for SYSOPS/local users") : _ EXIT SUB 59700 SUBROUTINE.PARAMETER = 1 A$ = "Import what file" + PRESS.ENTER$ CALL TGET IF SUBROUTINE.PARAMETER = -1 OR Q = 0 THEN _ EXIT SUB CALL FINDIT (B$) IF NOT OK THEN _ CALL QTPUT1 (B$ + " not found") : _ GOTO 59700 WHILE NOT EOF(2) AND NUM.LINES < MAX.LINES NUM.LINES = NUM.LINES + 1 LINE INPUT #2,LINE.ARA$(NUM.LINES) WEND CLOSE 2 CALL WORDWRAP (MAX.LEN,NUM.LINES,LINE.ARA$()) END SUB 59703 ' $SUBTITLE: 'WORDWRAP -- subroutine to wrap lines in a message' ' $PAGE ' ' NAME -- WORDWRAP ' ' INPUTS -- PARAMETER MEANING ' MAX.LEN MAXIMUM LENGTH OF A SINGLE LINE ' NUM.LINES NUMBER OF LINES IN A MESSAGE ' LINE.ARA$ ALL THE LINES IN THE MESSAGE ' ' OUTPUTS -- NUM.LINES ' LINE.ARA$ ' ' PURPOSE -- Batch adjusts a message, wrapping lines if ' needed. Preserves paragraph structure. ' SUB WORDWRAP (MAX.LEN,NUM.LINES,LINE.ARA$(1)) STATIC J = 1 WHILE J <= NUM.LINES 59704 CALL TRIMTRAIL (LINE.ARA$(J)," ") K = LEN(LINE.ARA$(J)) IF K <= MAX.LEN THEN _ GOTO 59705 CALL FINDLAST (LINE.ARA$(J)," ",LAST.POS,HOW.MANY) CALL ANYBUT (LINE.ARA$(J),1,">",X) ' KG061202 CALL ANYBUT (LINE.ARA$(J+1),1,">",TEMP) ' KG061202 IF LEFT$(LINE.ARA$(J + 1),2) = " " OR ((TEMP > 0) AND X <> TEMP) THEN _ ' KG061202 FOR K = NUM.LINES TO J + 1 STEP -1 : _ LINE.ARA$(K + 1) = LINE.ARA$(K) : _ NEXT : _ NUM.LINES = NUM.LINES + 1 : _ LINE.ARA$(J + 1) = "" IF X > 1 THEN _ ' KG061202 IF MID$(LINE.ARA$(J),X,1) = " " THEN _ ' KG061202 X = X + 1 ' KG061202 X$ = LEFT$(LINE.ARA$(J),X-1) ' KG061202 IF LAST.POS < 1 THEN _ LINE.ARA$(J + 1) = X$ + MID$(LINE.ARA$(J),MAX.LEN) + MID$(LINE.ARA$(J + 1),X) : _ ' KG061202 LINE.ARA$(J) = LEFT$(LINE.ARA$(J),MAX.LEN - 1) + "-" _ ELSE B$ = LEFT$(" ", - (LEN(LINE.ARA$(J + 1)) > 0)) : _ LINE.ARA$(J + 1) = X$ + MID$(LINE.ARA$(J),LAST.POS + 1) + B$ + MID$(LINE.ARA$(J + 1),X) : _ ' KG061202 LINE.ARA$(J) = LEFT$(LINE.ARA$(J),LAST.POS - 1) GOTO 59704 59705 J = J + 1 WEND NUM.LINES = NUM.LINES - (LEN(LINE.ARA$(NUM.LINES + 1)) > 0) END SUB 59750 ' $SUBTITLE: 'SETABORT -- subroutine to set a time-limit' ' $PAGE ' ' NAME -- SETABORT ' ' INPUTS -- PARAMETER MEANING ' SECONDS.TO.ADD # SECONDS AFTER CURRENT TIME ' WHEN TIME LIMIT IS TO EXPIRE ' ' OUTPUTS -- ABORT.TIME! THE TIME (IN SECONDS AFTER MIDNIGHT) ' WHEN TIME LIMIT EXPIRES ' ' PURPOSE -- Sets a time limit in units of seconds after ' midnight after which a time limit will expire. ' Calling program passes number of seconds that can ' elapse before time-limit is reached. ' SUB SETABORT (ABORT.TIME!,SECONDS.TO.ADD) STATIC CALL FINDTIME (ABORT.TIME!) ABORT.TIME! = ABORT.TIME! + SECONDS.TO.ADD END SUB 59760 ' $SUBTITLE: 'ANYBUT -- subroutine to find where a word begins' ' $PAGE ' ' NAME -- ANYBUT ' ' INPUTS -- PARAMETER MEANING ' STRNG$ STRING TO SEARCH FOR WORDS ' BEG% BYTE POSITION IN STRNG$ TO ' BEGIN SEARCHING ' SKIP.CHARS$ CHARACTERS TO SKIP OVER WHEN ' SEARCHING ' ' OUTPUTS -- WHEREIS% BYTES POSITION IN STRNG$ WHERE ' WORD BEGINS ' ' PURPOSE -- Parser. Finds where a "word" begins, where ' any character will be accepted as the beginning of a ' word except those listed in SKIP.CHAR$ ' SUB ANYBUT (STRNG$, BEG%, SKIP.CHARS$, WHEREIS%) STATIC X$ = STRNG$ + _ CHR$(0) WHEREIS% = BEG% IF WHEREIS% < 1 THEN _ WHEREIS% = 1 WHILE INSTR(SKIP.CHARS$, MID$(X$, WHEREIS%, 1)) > 0 WHEREIS% = WHEREIS% + 1 WEND IF WHEREIS% > LEN(STRNG$) THEN _ WHEREIS% = 0 END SUB 59770 ' $SUBTITLE: 'FINDEND -- subroutine to find where a word ends' ' $PAGE ' ' NAME -- FINDEND ' ' INPUTS -- PARAMETER MEANING ' STRNG$ STRING TO SEARCH FOR WORDS ' BEG% POSITION IN STRNG$ TO BEGIN SEARCH ' STOP.WITH$ CHARACTERS THAT TERMINATE A WORD ' ' OUTPUTS WHEREIS% POSITION IN STRNG$ WHERE WORD ENDS ' (I.E. THE LAST CHARACTER OF THE WORD) ' ' PURPOSE -- Parser. Finds where a "word" ends, where ' any character will be counted as in a word ' except for those in STOP.WITH$ or when the end of ' the string is found. ' SUB FINDEND (STRNG$, BEG%, STOP.WITH$, WHEREIS%) STATIC B = BEG% IF B < 1 THEN _ B = 1 IF B > LEN(STRNG$) THEN _ X$ = STOP.WITH$ _ ELSE X$ = MID$(STRNG$, B) + _ STOP.WITH$ I = 1 X = INSTR(STOP.WITH$, MID$(X$, I, 1)) WHILE X = 0 I = I + 1 X = INSTR(STOP.WITH$, MID$(X$, I, 1)) WEND WHEREIS% = I - 1 + B - 1 END SUB 59780 ' $SUBTITLE: 'GETALL -- subroutine to create directory list' ' $PAGE ' ' NAME -- GETALL ' ' INPUTS -- PARAMETER MEANING ' LOOK.IN$ NAME OF FILE TO SEARCH ' DIR.EXT$ MAIN DIRECTORY EXTENSION TO USE ' START.POS LAST POSITION USED IN ARRAY ' ' OUTPUTS START.POS LAST ELEMENT USED IN ARRAY ' LOAD.INTO$ ARRAY TO LOAD ELEMENTS FOUND ' ' PURPOSE -- Creates a list (LOAD.INTO$) of all directories ' found in directory of directories (LOOK.IN$). ' Used for determining what gets listed when doing ' an "ALL" to determinate what separate directories ' to display. Directory name must be all caps ' and followed by a space or dash. ' SUB GETALL (LOOK.IN$, LOAD.INTO$(1), DIR.EXT$, START.POS) STATIC IF MASTER.DIRECTORY.NAME$ <> "" THEN _ START.POS = START.POS + 1 : _ LOAD.INTO$(START.POS) = MASTER.DIRECTORY.NAME$ : _ EXIT SUB CALL FINDIT(LOOK.IN$) IF NOT OK THEN _ EXIT SUB MAX.LOAD = UBOUND(LOAD.INTO$, 1) START.SORT = START.POS + 1 WHILE NOT EOF(2) AND START.POS < MAX.LOAD LINE INPUT #2, A$ LAST.POS = LEN(A$) CALL ANYBUT(A$, 1, " ", X) WHILE X > 0 AND X < LAST.POS AND START.POS < MAX.LOAD CALL FINDEND(A$, X + 1, " -.", Y) L = Y - X + 1 IF L > 8 THEN _ GOTO 59782 B$ = MID$(A$, X, L) IF B$ = "ALL" THEN _ GOTO 59782 CALL BADFILECHAR (B$,I) IF NOT I THEN _ GOTO 59782 Z$ = LEFT$(B$,1) IF (Z$ >= "0" AND Z$ <= "9") OR _ (Z$ >= "A" AND Z$ <= "Z") THEN _ Z$ = B$ : _ CALL ALLCAPS (Z$) : _ IF Z$ = B$ THEN _ LOAD.INTO$(START.POS + 1) = Z$ : _ IF USE.DIR.ORDER THEN _ I = START.SORT : _ WHILE LOAD.INTO$(I) <> Z$ : _ I = I + 1 : _ WEND : _ START.POS = START.POS - (I > START.POS) _ ELSE _ I = START.SORT : _ Z = VAL(Z$) : _ WHILE VAL(LOAD.INTO$(I)) < Z : _ I = I + 1 : _ WEND : _ WHILE VAL(LOAD.INTO$(I)) = Z AND LOAD.INTO$(I) < Z$ AND I <= START.POS : _ I = I + 1 : _ WEND : _ IF I > START.POS THEN _ START.POS = I _ ELSE IF Z$ <> LOAD.INTO$(I) THEN _ FOR J = START.POS TO I STEP -1 : _ LOAD.INTO$(J + 1) = LOAD.INTO$(J) : _ NEXT : _ LOAD.INTO$(I) = Z$ : _ START.POS = START.POS + 1 59782 CALL ANYBUT(A$, Y + 1, " ", X) WEND WEND CLOSE 2 END SUB 59790 ' $SUBTITLE: 'FINDFILE -- subroutine to find a file' ' $PAGE ' ' NAME -- FINDFILE ' ' INPUTS -- PARAMETER MENANING ' FILNAME$ NAME OF FILE TO LOOK FOR ' FEXISTS WHETHER FILE EXISTS ' ' OUTPUTS -- RETURNED.VALUE VALUE RETURNED ' TRUE = FILE EXISTS ' FALSE = FILE DOES NOT EXIST ' ' PURPOSE -- Determine whether passed file FILNAME$ exists ' Unlike, FINDIT, this routine does not open any ' file and, hence, does not create one in determining ' whether a file exists. ' SUB FINDFILE (FILNAME$,FEXISTS) STATIC CALL BADFILECHAR (FILNAME$,FEXISTS) IF FEXISTS THEN _ CALL RBBSFIND (FILNAME$,Z,Y,M,D) : _ FEXISTS = (Z = 0) END SUB 59800 ' $SUBTITLE: 'BADFILECHAR -- checks file for illegal char' ' $PAGE ' ' NAME -- BADFILECHAR ' ' INPUTS -- PARAMETER MEANING ' FILNAME$ NAME OF FILE TO CHECK ' ' OUTPUTS -- IS.OK WHETHER NAME OK ' ' PURPOSE -- Part of test for file's existence. If bad ' character in name, can't exist. ' SUB BADFILECHAR (FILNAME$,IS.OK) STATIC L = LEN(FILNAME$) IF L > 2 THEN _ IF INSTR(3,FILNAME$,":") > 0 THEN _ IS.OK = FALSE : _ EXIT SUB X$ = FILNAME$ + "=" I = 1 WHILE INSTR("/[]|<>+=;, ?*",MID$(X$,I,1)) = 0 AND ASC(MID$(X$,I)) < 128 I = I + 1 WEND IS.OK = I > L END SUB ' 59850 ' $SUBTITLE: 'CONFMAIL -- quickly checks mail waiting' ' $PAGE ' ' NAME -- CONFMAIL ' ' INPUTS -- PARAMETER MEANING ' SKIP.CONFIRM Whether to skip confirm of option ' CONFMAIL.LIST$ File of user/message pairs to check ' ACTIVE.USER.FILE$ Active user file (restored on exit) ' ACTIVE.MESSAGE.FILE$ Active msg file (restored) ' OUTPUTS -- None ' ' PURPOSE -- Quicking scans message header record to get ' last msg # and user record to get whether any ' new mail and last msg read, reports both, using ' highlighting if new mail to caller. ' SUB CONFMAIL (MAILCHECK.CONFIRM) STATIC SKIP.JOIN.UNJOIN = NON.STOP ' KG071906 IF START.HASH = 1 AND USER.FILE.INDEX > 0 THEN _ CALL FINDIT (CONFMAIL.LIST$) _ ELSE OK = FALSE IF NOT OK THEN _ EXIT SUB IF MAILCHECK.CONFIRM THEN _ A$ = "Check conferences for mail ([Y],N)" : _ SUBROUTINE.PARAMETER = 1 : _ TURBO.KEY = -TURBO.KEY.USER : _ CALL TGET : _ IF NO OR SUBROUTINE.PARAMETER < 0 THEN _ EXIT SUB CALL SKIPLINE (1) CALL QTPUT1 ("Checking Message Bases since last on...") ANY.MAIL = FALSE STOP.INTERRUPTS = FALSE A1$ = ACTIVE.USER.FILE$ M$ = ACTIVE.MESSAGE.FILE$ TEMP.INDIV.VALUE$ = "" SUIX = USER.FILE.INDEX USER.RECORD.HOLD$ = USER.RECORD$ OK = TRUE 59852 IF EOF(2) OR NOT OK THEN _ GOTO 59854 CALL READANY ACTIVE.USER.FILE$ = A$ CALL READANY IF EC > 0 THEN _ GOTO 59854 ACTIVE.MESSAGE.FILE$ = A$ CALL FINDFILE (ACTIVE.USER.FILE$,OK) IF NOT OK THEN _ GOTO 59854 CALL OPENUSER (HIGHEST.USER.RECORD) FIELD 5, 128 AS USER.RECORD$ CALL FINDFILE (ACTIVE.MESSAGE.FILE$,OK) IF NOT OK THEN _ GOTO 59854 CALL FINDUSER (ORIG.USER.NAME$,"",START.HASH,LEN.HASH,_ 0,0,HIGHEST.USER.RECORD,_ FOUND,UFI,SL) IF NOT FOUND THEN _ GOTO 59852 CALL OPENMSG FIELD 1, 128 AS MESSAGE.RECORD$ GET 1,1 ANY.MAIL = TRUE X = CVI(MID$(USER.RECORD$,57,2)) X = (X AND 512) > 0 CALL BRKFNAME (ACTIVE.USER.FILE$,X$,Y$,Z$,FALSE) A = CVI(MID$(USER.RECORD$,51,2)) B = VAL(LEFT$(MESSAGE.RECORD$,8)) Z = (B - A) IF Z < 0 THEN _ ' KG051701 A = 0 : _ ' KG051701 Z = B _ ' KG051701 ELSE IF Z = 0 THEN _ ' KG051701 X = FALSE ' KG051701 A$ = MID$(STR$((B > A) * Z),2) SL = LEN(A$) A$ = SPACE$(-(SL<3) * (3-SL)) + A$ SL = LEN(Y$) CONF$ = LEFT$(Y$,SL-1) Y$ = CONF$ + SPACE$(-(SL<8) * (8-SL)) IF X THEN _ X$ = EMPHASIZE.ON$ : _ Z$ = EMPHASIZE.OFF$ _ ELSE X$ = "" : _ Z$ = "" A$ = Y$ + ": " + A$ + " new message(s): " + _ X$ + MID$(" None *Some*",-6 * X + 1,6) + " to you" + Z$ SUBROUTINE.PARAMETER = 5 CALL TPUT IF SKIP.JOIN.UNJOIN THEN _ ' KG071907 CALL ASKMORE ("",TRUE,TRUE,X,TRUE) : _ GOTO 59853 TURBO.KEY = -TURBO.KEY.USER CALL ASKMORE (",J)oin,U)njoin",TRUE,FALSE,X,FALSE) IF NO THEN _ GOTO 59854 X$ = LEFT$(B$(1),1) CALL ALLCAPS (X$) IF X$ = "U" THEN _ LSET USER.RECORD$ = CHR$(0) + "deleted user" : _ USER.FILE.INDEX = UFI : _ SUBROUTINE.PARAMETER = 6 : _ CALL FILELOCK : _ PUT 5, UFI : _ SUBROUTINE.PARAMETER = 8 : _ CALL FILELOCK : _ CALL QTPUT1 ("Omitted you from " + CONF$) _ ELSE IF X$ = "J" THEN _ HOME.CONFERENCE$ = CONF$ : _ GOTO 59854 59853 IF NOT RET THEN _ GOTO 59852 59854 ACTIVE.USER.FILE$ = A1$ CALL OPENUSER (HIGHEST.USER.RECORD) FIELD 5, 128 AS USER.RECORD$ IF (NOT RET) AND NOT ANY.MAIL THEN _ CALL QTPUT1 ("No new personal mail") USER.FILE.INDEX = SUIX LSET USER.RECORD$ = USER.RECORD.HOLD$ ACTIVE.MESSAGE.FILE$ = M$ CALL OPENMSG FIELD 1, 128 AS MESSAGE.RECORD$ GET 1,1 NON.STOP = (PAGE.LENGTH > 0) END SUB 59858 ' $SUBTITLE: 'ASKMORE -- pauses when possible screen full' ' $PAGE ' ' NAME -- ASKMORE ' ' INPUTS -- PARAMETER MEANING ' EXTRA.PRMPT$ STRING TO ADD TO MORE PROMPT AT END ' OVERWRITE WHETHER TO WIPE AWAY PROMPT ' ' OUTPUTS -- B$() ' NO ' ' PURPOSE -- Determines whether need to pause if screen full. ' And, if so, asks the appropriate question. If non- ' stop, at least check for carrier present. ' SUB ASKMORE (EXTRA.PRMPT$, OVERWRITE, CHECK.LINES,ABORT.INDEX,CANT.INTERRUPT) STATIC NO = FALSE IF CHECK.LINES THEN _ X = -DISPLAY.AS.UNIT*UNIT.COUNT -(NOT DISPLAY.AS.UNIT)*LINES.PRINTED : _ IF X < PAGE.LENGTH OR (PAGE.LENGTH = 0) THEN _ Q = 0 : _ EXIT SUB IF ONE.STOP THEN _ ONE.STOP = FALSE : _ NON.STOP = TRUE : _ GOTO 59860 IF NON.STOP THEN _ LINES.PRINTED = 0 : _ CALL CHKCARRIER : _ ' KG061203 IF KEYBOARD.STACK$ = "" AND COMMPORT.STACK$ = "" THEN _ EXIT SUB _ ELSE NON.STOP = FALSE 59860 CALL QTPUT (EMPHASIZE.OFF$,0) IF CANT.INTERRUPT THEN _ TURBO.KEY = 2 : _ A$ = "Press Any Key to continue" _ ELSE A$ = MORE.PROMPT$ + EXTRA.PRMPT$ + LEFT$(">",-EXPERT.USER) X = LEN(A$) + 2 NO.ADVANCE = OVERWRITE SUBROUTINE.PARAMETER = 1 IF EXTRA.PRMPT$ = "" AND TURBO.KEY = 0 THEN _ TURBO.KEY = -TURBO.KEY.USER MACRO.MIN = 2 CALL TGET IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB TURBO.KEY = FALSE DF$ = B$ ' KG072701 CALL ALLCAPS (DF$) ' KG072701 I = INSTR(";C;A;",";"+DF$+";") ' KG072701 IF I = 1 THEN _ ' KG072701 NON.STOP = TRUE : _ ' KG072701 Q = 0 ' KG072701 CALL WIPELINE (X + LEN(B$)) IF NOT HIGHLIGHT.OFF THEN _ ' MZ061401 CALL QTPUT (LAST.SMART.COLOR$,0) ' MZ061401 IF CANT.INTERRUPT THEN _ NO = FALSE : _ EXIT SUB IF I = 3 THEN _ ' KG072701 ABORT.INDEX = 32000 IF NO THEN _ KEYBOARD.STACK$ = "" : _ COMMPORT.STACK$ = "" : _ ' MZ060302 LAST.SMART.COLOR$ = "" ' MZ060302 END SUB 59880 ' $SUBTITLE: 'COMPDATE -- subroutine to compute elased days' ' $PAGE ' ' NAME -- COMPDATE ' ' INPUTS -- PARAMETER MEANING ' YY YEAR ' MM MONTH ' DD DAY ' RESULT! LOCATION TO PLACE THE RESULT ' ' OUTPUTS -- RESULT! COMPUTE COMPUTATIONAL DATE ' ' PURPOSE -- Computes a computational date from YEAR, MONTH, DAY. ' Results may be used to compute the number of elapsed ' days between two dates. You may pass a 2 or 4 digit ' year, but for meaningful results, be consistent ' SUB COMPDATE (YY,MM,DD,RESULT!) STATIC IF MM < 1 OR MM > 12 THEN _ MM = 1 RESULT! = YY * 365.0 + _ INT((YY - 1) / 4) + _ (MM - 1) * 28 + _ VAL(MID$("000303060811131619212426",(MM - 1) * 2 + 1,2)) - _ ((MM > 2) AND ((YY MOD 4) = 0)) + _ DD END SUB 59890 ' $SUBTITLE: 'EXPDATE -- subroutine to display expiration date' ' $PAGE ' ' NAME -- EXPDATE ' ' INPUTS -- PARAMETER MEANING ' REGISTRATION.DATE! COMPUTATIONAL REGISTRATION DATE ' REGISTRATION.PERIOD DAYS IN REGISTRATION PERIOD ' ' OUTPUTS -- EXP.DATE$ DISPLAYABLE EXPIRATION DATE ' ' PURPOSE -- Computes/creates a displayable registration ' expiration date using registration date and days in ' registration period. ' SUB EXPDATE (REGISTRATION.DATE!,REGISTRATION.PERIOD,EXP.DATE$) STATIC EXPIRE.DATE! = REGISTRATION.DATE! + REGISTRATION.PERIOD EXPIRE.YEAR! = INT((EXPIRE.DATE! - EXPIRE.DATE! / 1461) / 365) EXPIRE.DAY% = EXPIRE.DATE! - (EXPIRE.YEAR! * 365 + INT((EXPIRE.YEAR! -1)/4)) EXPIRE.MONTH% = -((EXPIRE.YEAR! MOD 4)<>0) * _ (1 - (EXPIRE.DAY% > 31) - (EXPIRE.DAY% > 59) - _ (EXPIRE.DAY% > 90) - (EXPIRE.DAY% >120) - _ (EXPIRE.DAY% > 151) - (EXPIRE.DAY% > 181) - _ (EXPIRE.DAY% > 212) - (EXPIRE.DAY% > 243) - _ (EXPIRE.DAY% > 273) - (EXPIRE.DAY% > 304) - _ (EXPIRE.DAY% > 334)) - ((EXPIRE.YEAR! MOD 4) = 0) * _ (1 - (EXPIRE.DAY% > 31) - (EXPIRE.DAY% > 60) - _ (EXPIRE.DAY% > 91) - (EXPIRE.DAY% >121) - _ (EXPIRE.DAY% > 152) - (EXPIRE.DAY% > 182) - _ (EXPIRE.DAY% > 213) - (EXPIRE.DAY% > 243) - _ (EXPIRE.DAY% > 274) - (EXPIRE.DAY% > 305) - _ (EXPIRE.DAY% > 335)) EXPIRE.DAY% = (EXPIRE.DAY% - ((EXPIRE.MONTH% - 1) * 28 + _ VAL(MID$("000303060811131619212426",(EXPIRE.MONTH% -1) * 2 + 1,2)))) + _ ((EXPIRE.MONTH% > 2) AND ((EXPIRE.YEAR! MOD 4) = 0)) EXP.DATE$ = RIGHT$("0" + MID$(STR$(EXPIRE.MONTH%),2),2) + _ "/" + _ RIGHT$("0" + MID$(STR$(EXPIRE.DAY%),2),2) + _ "/" + _ RIGHT$(STR$(EXPIRE.YEAR!),2) END SUB 59920 ' $SUBTITLE: 'COLORDIR - builds a color FMS directory string' ' $PAGE ' ' NAME -- COLORDIR ' ' INPUTS -- PARAMETER MEANING ' STRNG$ String to alter ' FMS.DIR$ "Y" FOR FMS DIR ' "N" FOR PERSONAL DOWNLOADS ' SUB COLORDIR (STRNG$,FMS.DIR$) STATIC IF GR < 2 THEN _ EXIT SUB IF FMS.DIR$ = "N" THEN _ GOTO 59921 ' ' INSERT COLOR FOR FILENAME ' ON INSTR("\ *",LEFT$(STRNG$,1)) GOTO 59924,59922,59923 59921 STRNG$ = DR.1$ + LEFT$(STRNG$,13) + DR.2$ + MID$(STRNG$,14,10) + _ DR.3$ + MID$(STRNG$,24,10) + DR.4$ + MID$(STRNG$,34,MAX.DESC.LEN) EXIT SUB 59922 STRNG$ = DR.4$ + STRNG$ EXIT SUB 59923 STRNG$ = EMPHASIZE.OFF$ + STRNG$ 59924 END SUB 59930 ' $SUBTITLE: 'CHKCOLOR - highlights based on search string' ' $PAGE ' ' NAME -- CHKCOLOR ' ' INPUTS -- PARAMETER MEANING ' LOOK.FOR$ String that triggers highlight ' LOOK.IN$ String being searched ' END.COLOR$ Terminating color ' ' OUTPUTS -- STRNG$ Revised string ' ' PURPOSE -- Adds highlighting to a string within a string. ' Respects previous colorization. SUB CHKCOLOR (LOOK.IN$,LOOK.FOR$,PASSED.END.COLOR$) STATIC IF LOOK.FOR$ = "" THEN _ EXIT SUB X$ = LOOK.IN$ CALL ALLCAPS (X$) START.COLOR = INSTR(X$,LOOK.FOR$) IF START.COLOR < 1 THEN _ EXIT SUB END.COLOR$ = PASSED.END.COLOR$ IF END.COLOR$ = "" THEN _ END.COLOR$ = EMPHASIZE.OFF$ : _ CALL FINDLAST (LEFT$(LOOK.IN$,START.COLOR-1),ESCAPE$,WHERE.FOUND,J) : _ IF WHERE.FOUND > 0 THEN _ J = INSTR(WHERE.FOUND,LOOK.IN$,"m") : _ IF J > 0 THEN _ END.COLOR$ = MID$(LOOK.IN$,WHERE.FOUND,J-WHERE.FOUND+1) CALL BRACKET (LOOK.IN$,START.COLOR,START.COLOR + LEN(LOOK.FOR$)-1,EMPHASIZE.ON$,END.COLOR$) END SUB 59934 ' $SUBTITLE: 'SETHILITE - subroutine to reset highlight preference' ' $PAGE ' ' NAME -- SETHILITE ' ' INPUTS -- PARAMETER MEANING ' SET.TO New value (True or False) ' EMPHASIZE.ON.DEF$ String turns emphasize on ' EMPHASIZE.OFF.DEF$ String turns emphasize off ' ' OUTPUTS -- HIGHLIGHT.OFF Callers preference on Hilite ' EMPHASIZE.ON$ String to use for emphasis ' EMPHASIZE.OFF$ String to use after emphasis ' SUB SETHILITE (SET.TO) STATIC HIGHLIGHT.OFF = (EMPHASIZE.ON.DEF$ <> "" AND SET.TO) IF HIGHLIGHT.OFF THEN _ EMPHASIZE.ON$ = "" : _ EMPHASIZE.OFF$ = "" : _ FG.1$ = "" : _ FG.2$ = "" : _ FG.3$ = "" : _ FG.4$ = "" _ ELSE EMPHASIZE.ON$ = EMPHASIZE.ON.DEF$ : _ FG.1$ = FG.1.DEF$ : _ FG.2$ = FG.2.DEF$ : _ FG.3$ = FG.3.DEF$ : _ FG.4$ = FG.4.DEF$ END SUB 59940 ' $SUBTITLE: 'COLORPMT - subroutine to colorize prompts' ' $PAGE ' ' NAME -- COLORPMT ' ' INPUTS -- PARAMETER MEANING ' STRNG$ String to colorize ' HIGHLIGHT.OFF Whether highlighting is off ' EMPHASIZE.ON$ String to use for emphasis ' EMPHASIZE.OFF$ String to use after emphasis ' ' OUTPUTS -- STRNG$ Colorized string ' ' PURPOSE -- colorizes a string based on sysop settings ' and the string. ' [...] is the default - put in emphasis ' <...> options to type - put in FG.4$ ' and first two precedign words use FG.1$ and FG.2$ ' options identified on right by ) and on ' left by space or comma - put in FG.4$ ' SUB COLORPMT (STRNG$) STATIC IF HIGHLIGHT.OFF THEN _ EXIT SUB ALREADY.COLORIZED = (INSTR(STRNG$,ESCAPE$) > 0) X = INSTR(STRNG$,"<") IF X > 0 THEN _ GOTO 59943 X = INSTR(STRNG$,"[") ' highlight default IF X > 0 THEN _ Y = INSTR(X,STRNG$,"]") : _ IF Y > 0 THEN _ CALL BRACKET (STRNG$,X,Y,EMPHASIZE.ON$,EMPHASIZE.OFF$) IF ALREADY.COLORIZED THEN _ EXIT SUB X = INSTR(STRNG$,"<") IF X < 1 THEN _ GOTO 59945 59943 Y = INSTR(X,STRNG$,">") IF Y < 1 THEN _ GOTO 59945 CALL BRACKET (STRNG$,X,Y,FG.4$,EMPHASIZE.OFF$) Y = INSTR(STRNG$," ") IF Y > 1 AND Y < X THEN _ STRNG$ = FG.1$ + STRNG$ : _ Z = INSTR(Y+1,STRNG$," ") : _ IF Z > 1 AND Z < X+LEN(FG.1$) THEN _ STRNG$ = LEFT$(STRNG$,Z) + FG.2.DEF$ + MID$(STRNG$,Z+1) EXIT SUB 59945 X = 1 DID.INSERT = FALSE L = LEN(FG.4$) 59950 Y = INSTR (X,STRNG$,")") ' x: where command begins, y: terminating pos Z = INSTR (X,STRNG$,",") IF Y = 0 OR (Z > 0 AND Z < Y) THEN _ Y = Z K = LEN(STRNG$) IF X > K THEN _ EXIT SUB IF Y < 1 THEN _ IF NOT DID.INSERT THEN _ EXIT SUB _ ELSE Y = K+1 Z = Y - 1 WHILE Z > 0 ' got terminating pos: find beginning IF INSTR(OPTION.END$,MID$(STRNG$,Z,1)) > 0 THEN _ X = Z + 1 : _ Z = 0 Z = Z - 1 WEND IF Y-X < 3 THEN _ ' exclude commands too long CMND.STRNG$ = MID$(STRNG$,X,Y-X) : _ X$ = CMND.STRNG$ : _ CALL ALLCAPS (CMND.STRNG$) : _ IF X$ = CMND.STRNG$ THEN _ ' exclude lower case DID.INSERT = TRUE : _ CALL BRACKET (STRNG$,X,Y-1,FG.4$,EMPHASIZE.OFF$) : _ ' colorize Y = Y + L X = Y + 1 GOTO 59950 END SUB 59960 ' $SUBTITLE: 'BRACKET - Inserts strings around a string' ' $PAGE ' ' NAME -- BRACKET ' ' INPUTS -- PARAMETER MEANING ' STRNG$ Insert in this string ' B4.HERE Insert 1st before this pos ' AFTER.HERE Insert 2nd after this pos ' B4.STRNG$ String to insert before ' AFTER.STRNG$ String to insert after ' ' OUTPUTS -- STRNG$ ' ' PURPOSE -- Primarily for colorization ' SUB BRACKET (STRNG$,B4.HERE,AFTER.HERE,B4.STRNG$,AFTER.STRNG$) STATIC STRNG$ = LEFT$(STRNG$,B4.HERE-1) + _ B4.STRNG$ + _ MID$(STRNG$,B4.HERE,AFTER.HERE-B4.HERE+1) + _ AFTER.STRNG$ + _ RIGHT$(STRNG$,LEN(STRNG$) - AFTER.HERE) END SUB 59965 ' $SUBTITLE: 'USERCOLOR - lets user set color for normal text' ' $PAGE ' ' NAME -- USERCOLOR ' ' INPUTS -- PARAMETER MEANING ' EMPHASIZE.OFF$ Normal text color ' ' OUTPUTS -- EMPHASIZE.OFF$ New text color ' BOLD.TEXT$ Whether bold (0 not, 1 bold) ' USER.TEXT.COLOR ANSI Color selected ' ' PURPOSE -- Lets caller select desired color and whether bold. ' SUB USERCOLOR STATIC IF HIGHLIGHT.OFF THEN _ EXIT SUB 59970 CALL QTPUT (EMPHASIZE.OFF$,0) A$ = "Make text R)ed,G)reen,Y)ellow,B)lue,P)urple,C)yan,W)hite" + PRESS.ENTER.EXPERT$ GOSUB 59973 IF Q = 0 THEN _ EMPHASIZE.OFF$ = ESCAPE$ + "[" + BOLD.TEXT$ + _ ";40;" + MID$(STR$(USER.TEXT.COLOR),2) + "m" : _ EXIT SUB CALL ALLCAPS (B$) X = INSTR("RGYBPCW",B$) IF X = 0 THEN _ GOTO 59970 USER.TEXT.COLOR = 30 + X A$ = "Make text BOLD (Y,[N])" GOSUB 59973 BOLD.TEXT$ = CHR$(48 - YES) EMPHASIZE.OFF$ = ESCAPE$ + "[" + BOLD.TEXT$ + ";40;" + MID$(STR$(USER.TEXT.COLOR),2) + "m" GOTO 59970 59973 SUBROUTINE.PARAMETER = 1 TURBO.KEY = -TURBO.KEY.USER CALL TGET IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB RETURN END SUB 59980 ' $SUBTITLE: 'SETUGD - Sets user graphic preference' ' $PAGE ' ' NAME -- SETUGD ' ' INPUTS -- PARAMETER MEANING ' GRAPHICS.NUMBER 0=None, 1=Ascii, 2=color ' ' OUTPUTS -- GR Shared var - set to ' graphics.number ' GRAPHICS.LETTER$ What add to file name to ' see if got graphics file ver ' ' PURPOSE -- Sets file graphics preference ' SUB SETUGD (GRAPHICS.NUMBER,GRAPHICS.LETTER$) STATIC GR = GRAPHICS.NUMBER IF GR = 2 THEN _ DR.1$ = FG.1.DEF$ : _ DR.2$ = FG.2.DEF$ : _ DR.3$ = FG.3.DEF$ : _ DR.4$ = FG.4.DEF$ _ ELSE DR.1$ = "" : _ DR.2$ = "" : _ DR.3$ = "" : _ DR.4$ = "" GRAPHICS.LETTER$ = MID$(" GC",GR+1, - (GR > 0)) END SUB 60000 ' $SUBTITLE: 'EOFCOMM - Determines whether input in comm port buffer' ' $PAGE ' ' NAME -- EOFCOMM ' ' INPUTS -- PARAMETER MEANING ' FOSSIL Whether fossil driver used ' COMPORT% Comm port # in use ' ' OUTPUTS -- NOCHARS% -1 (TRUE) if no chars in buffer. ' Anything else means has char. ' ' PURPOSE -- Query comm port to see if input waiting ' SUB EOFCOMM (NOCHARS%) STATIC IF FOSSIL THEN _ CALL FOSREADAHEAD(COMPORT%,NOCHARS%) _ ELSE NOCHARS% = EOF(3) END SUB 60100 ' $SUBTITLE: 'GSANDR - Global search and replace' ' $PAGE ' ' NAME -- GSANDR ' ' INPUTS -- PARAMETER MEANING ' STRNG$ String to edit ' LOOK.FOR$ String to look for ' REPLACE.BY$ String to replace by ' ' OUTPUTS -- STRNG$ Edited string ' ' PURPOSE -- Replaces every occurence of LOOK.FOR$ that ' is in STRNG$ by REPLACE.BY$ ' SUB GSANDR (STRNG$,LOOK.FOR$,REPLACE.BY$,OVERSTRIKE) STATIC IF LOOK.FOR$ = "" THEN _ EXIT SUB X = 1 L = LEN(REPLACE.BY$) M = LEN(LOOK.FOR$) 60102 Y = INSTR(X,STRNG$,LOOK.FOR$) IF Y < 1 THEN _ EXIT SUB IF OVERSTRIKE THEN _ MID$(STRNG$,Y) = REPLACE.BY$ + SPACE$((L-M)*(L < M)) _ ELSE STRNG$ = LEFT$(STRNG$,Y-1) + _ REPLACE.BY$ + _ RIGHT$(STRNG$,LEN(STRNG$)-Y+1-M) X = Y + L IF X > LEN(STRNG$) THEN _ EXIT SUB GOTO 60102 END SUB 60130 ' $SUBTITLE: 'METAGSR -- Meta Global search and replace' ' $PAGE ' ' NAME -- METAGSR ' ' INPUTS -- PARAMETER MEANING ' STRNG$ String to edit ' ' OUTPUTS -- STRNG$ Edited string ' ' PURPOSE -- Global search and replace for meta variables ' SUB METAGSR (STRNG$,OVERSTRIKE) STATIC Y = 1 60131 IF Y > LEN(STRNG$) THEN _ EXIT SUB X = INSTR(Y,STRNG$,"[") IF X = 0 THEN _ EXIT SUB Y = INSTR(X,STRNG$,"]") IF Y = 0 THEN _ EXIT SUB M = Y-X+1 TEMP = Y-X-1 CALL CHECKINT(MID$(STRNG$,X+1,TEMP)) IF (EC > 0) OR (TESTED.INTEGER.VALUE < 1) OR (TESTED.INTEGER.VALUE > MAX.WORK.VAR) THEN _ GOTO 60135 IF ((TESTED.INTEGER.VALUE < 10) AND (TEMP = 1)) OR ((TESTED.INTEGER.VALUE > 9) AND (TEMP = 2)) THEN _ GOTO 60132 Y = X + 1 GOTO 60131 60132 WORK.HOLD$ = GSR.ARA$(TESTED.INTEGER.VALUE) IF Y = LEN(STRNG$) THEN _ GOTO 60151 IF MID$(STRNG$,Y+1,1) <> "(" THEN _ GOTO 60151 I = INSTR(Y+1,STRNG$,")") IF I = 0 THEN _ GOTO 60151 J = INSTR(Y+1,STRNG$,":") IF J > I THEN _ GOTO 60151 CALL CHECKINT (MID$(STRNG$,Y+2)) IF (EC > 0) OR (TESTED.INTEGER.VALUE < 1) OR _ (TESTED.INTEGER.VALUE > LEN(WORK.HOLD$)) THEN _ GOTO 60151 Y = I M = I-X+1 STRT.SUB = TESTED.INTEGER.VALUE CALL CHECKINT (MID$(STRNG$,J+1)) IF EC > 0 OR TESTED.INTEGER.VALUE < 1 OR _ (TESTED.INTEGER.VALUE > LEN(WORK.HOLD$)) THEN _ GOTO 60151 LEN.SUB = TESTED.INTEGER.VALUE WORK.HOLD$ = MID$(WORK.HOLD$,STRT.SUB,LEN.SUB) GOTO 60151 60135 META.VAL$ = MID$(STRNG$,X+1,Y-X-1) I = INSTR(" BAUD PORT PORT# PARITYPROTO NODE FILE ",META.VAL$) IF I = 0 OR LEN(META.VAL$) < 4 THEN _ ' KG071901 Y = X + 1 : _ GOTO 60131 J = (I-1)\6 + 1 K = (I+4)\6 + 1 IF K > J THEN _ EXIT SUB ON J GOTO 60155, _ 60137, _ 60139, _ 60141, _ 60143, _ 60145, _ 60147, _ 60149, _ 60151 60137 WORK.HOLD$ = TALK.TO.MODEM.AT$ GOTO 60151 60139 WORK.HOLD$ = COM.PORT$ GOTO 60151 60141 WORK.HOLD$ = MID$(COM.PORT$,4) GOTO 60151 60143 WORK.HOLD$ = MID$(BAUD.PARITY$,INSTR(BAUD.PARITY$,",")+1,1) GOTO 60151 60145 WORK.HOLD$ = FT$ GOTO 60151 60147 WORK.HOLD$ = NODE.ID$ GOTO 60151 60149 IF BATCH.TRANSFER THEN _ WORK.HOLD$ = "@" + NODE.WORK.FILE$ _ ELSE WORK.HOLD$ = FILE.NAME$ GOTO 60151 60151 L = LEN(WORK.HOLD$) IF OVERSTRIKE THEN _ MID$(STRNG$,X) = WORK.HOLD$ + SPACE$((L-M)*(L < M)) _ ELSE STRNG$ = LEFT$(STRNG$,X-1) + WORK.HOLD$ + RIGHT$(STRNG$,LEN(STRNG$)-Y) Y = 1 ' Y = X + L GOTO 60131 60155 Y = Y + 1 GOTO 60131 END SUB 60180 ' $SUBTITLE: 'TIMELOCK - Test TIME LOCK for premium features' ' $PAGE ' ' NAME -- TIMELOCK (written by Doug Azzarito) ' ' INPUTS -- PARAMETER MEANING ' TIME.LOCK.SET SECONDS/SESSION TO LOCK ' ' OUTPUTS -- SUBROUTINE.PARAMETER -1 if feature is LOCKED ' ' PURPOSE -- Check elapsed time for lock duration ' SUB TIMELOCK STATIC CALL TIMEREMAIN(TIME.REMAINING!) IF TCA! > TIME.LOCK.SET THEN _ OK = TRUE : _ EXIT SUB CALL BUFFILE(HELP.PATH$+"TIMELOCK"+HELP.EXTENSION$,X) IF NOT OK THEN _ CALL QTPUT1 ("Sorry, " + FIRST.NAME$ + _ ", function unavailable for first" + _ STR$(TIME.LOCK.SET) + "seconds") OK = FALSE END SUB 60200 ' $SUBTITLE: 'MARKTIME - Give feedback for lengthy processes' ' $PAGE ' ' NAME -- MARKTIME ' ' INPUTS -- PARAMETER MEANING ' DOT.NUMBER How many dots printed ' ' OUTPUTS -- DOT.NUMBER ' ' PURPOSE -- Marks time by putting colorized dots out ' to 4, then erasing ' SUB MARKTIME (DOT.NUMBER) STATIC CALL FINDTIME (TI!) IF TI! - PREV.TI! < 1.0 THEN _ EXIT SUB PREV.TI! = TI! IF REMOVE.DOT AND DOT.NUMBER > 0 THEN _ CALL QTPUT (BACKSPACE$,0) : _ DOT.NUMBER = DOT.NUMBER - 1 : _ EXIT SUB DOT.NUMBER = DOT.NUMBER + 1 ON DOT.NUMBER GOTO 60201,60202,60203,60204 60201 X$ = FG.1$ REMOVE.DOT = FALSE GOTO 60205 60202 X$ = FG.2$ GOTO 60205 60203 X$ = FG.3$ GOTO 60205 60204 X$ = FG.4$ REMOVE.DOT = TRUE 60205 CALL QTPUT (X$ + "." + EMPHASIZE.OFF$,0) END SUB 60300 ' $SUBTITLE: 'AUTOPAGE - NOTIFIES SYSOP WHEN SPECIFIC USER CALLS' ' $PAGE ' ' NAME -- AUTOPAGE 'Contributed by Gregg and Bob Snyder ' 'and RoseMarie Siddiqui ' ' INPUTS -- AUTOPAGE.DEF$ List of conditions that trigger ' notification and how ' ' OUTPUTS -- NONE ' ' PURPOSE -- Search AUTOPAGE.DEF$ for match on whether ' on name, security level, whether new user. ' Also controls whether caller notified and ' number of times sysop has bell rung. ' And what tune to play (if any). ' SUB AUTOPAGE STATIC CALL FINDIT (AUTOPAGE.DEF$) IF NOT OK THEN _ EXIT SUB EC = 0 OK = FALSE WHILE NOT EOF(2) AND OK = FALSE AND EC = 0 CALL READPARMS (WORK.ARA$(),4,1) IF EC = 0 THEN _ OK = (WORK.ARA$(1) = ACTIVE.USER.NAME$) : _ IF NOT OK THEN _ IF NEW.USER AND WORK.ARA$(1) = "NEWUSER" THEN _ OK = TRUE _ ELSE IF LEFT$(WORK.ARA$(1),1) = "/" AND LEN(WORK.ARA$(1)) > 2 THEN _ B = INSTR (2,WORK.ARA$(1),"/") : _ IF B > 0 AND LEN(WORK.ARA$(1)) > B THEN _ IF USER.SECURITY.LEVEL <= VAL(MID$(WORK.ARA$(1),B+1)) AND _ USER.SECURITY.LEVEL >= VAL(MID$(WORK.ARA$(1),2)) THEN _ OK = TRUE WEND CLOSE 2 IF EC > 0 OR NOT OK THEN _ EC = 0 : _ EXIT SUB PAGE.STATUS$ = "AutoPaged!" IF LEFT$(WORK.ARA$(2),1) = "N" THEN _ A$ = "Notifying sysop of your presence" : _ CALL RINGCALLER B = (WORK.ARA$(4) = "") WORK.ARA$(5) = "" FOR I = 1 TO VAL(WORK.ARA$(3)) IF B THEN _ CALL LPRNT (BELL.RINGER$,0) : _ ELSE WORK.ARA$(5) = WORK.ARA$(5) + "O4 X" + VARPTR$(WORK.ARA$(4)) NEXT IF NOT B THEN _ CALL RBBSPLAY (WORK.ARA$(5)) END SUB 62520 ' $SUBTITLE: 'PUTMATTR - subroutine to save msg. attributes' ' $PAGE ' ' NAME -- PUTMATTR ' ' INPUTS -- PARAMETER MEANING ' Q ' B$ ' LINES.IN.MESSAGE ' S ' NON.STOP ' MESSAGE.DIM.INDEX ' ' OUTPUTS -- SQ ' LG$(10) ' LINES.IN.MESSAGE.SAVE ' SL ' NON.STOP.SAVE ' MESSAGE.DIM.INDEX.SAVE ' ' PURPOSE -- WHEN REPLYING TO A MESSAGE THIS ROUTINE SAVES ' THE ATTRIBUTES OF THE ORGINAL MESSAGE ' SUB PUTMATTR STATIC SQ = Q LG$(10) = B$ LINES.IN.MESSAGE.SAVE = LINES.IN.MESSAGE SL = S NON.STOP.SAVE = NON.STOP MESSAGE.DIM.INDEX.SAVE = MESSAGE.DIM.INDEX END SUB 62530 ' $SUBTITLE: 'GETMATTR - subroutine to get msg. attributes' ' $PAGE ' ' NAME -- GETMATTR ' ' INPUTS -- PARAMETER MEANING ' SQ ' LG$(10) ' LINES.IN.MESSAGE.SAVE ' SL ' NON.STOP.SAVE ' MESSAGE.DIM.INDEX.SAVE ' ' OUTPUTS -- Q ' B$ ' LINES.IN.MESSAGESAVE ' S ' NON.STOP ' MESSAGE.DIM.INDEX ' KILL.MESSAGE ' ' PURPOSE -- After replying to a message this routine restores ' the attributes of the orginal message ' SUB GETMATTR STATIC Q = SQ B$ = LG$(10) LINES.IN.MESSAGE = LINES.IN.MESSAGE.SAVE S = SL NON.STOP = NON.STOP.SAVE MESSAGE.DIM.INDEX = MESSAGE.DIM.INDEX.SAVE KILL.MESSAGE = FALSE END SUB 62540 ' $SUBTITLE: 'RPTTIME -- Reports time on system' ' $PAGE ' ' NAME -- RPTTIME ' ' INPUTS -- PARAMETER MEANING ' ' OUTPUTS -- ' ' PURPOSE -- Tells user time used on system ' SUB RPTTIME STATIC CALL SKIPLINE (1) CALL GETIME ' KG061203 CALL AMORPM QX = ((HHH * 60) + MMM + (SSS / 60.0)) * 10.0 Q! = QX / 10.0 MINS = (HHH * 60) + MMM CALL CARRIER IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB CALL QTPUT1 ("Now: " + DATE$ + " at " + TIME$) CALL QTPUT1 ("On for" + STR$(MINS) + " mins," + STR$(SSS) + " secs") CALL TALK (7,A$) END SUB 62600 ' $SUBTITLE: 'PROTOCOL - Determine protocols available' ' $PAGE ' ' NAME -- PROTOCOL ' ' INPUTS -- PARAMETER MEANING ' PROTO.DEF$ File of installed protocols ' ' OUTPUTS -- TRANSFER.OPTIONS$ Prompt for protocol choice ' DFLTXFER$ Letters of protocols ' INTERNAL.EQUIV$ Internal protocol to use ' ' PURPOSE -- TO determine what protocols are available to user ' SUB PROTOCOL STATIC CALL FINDIT (PROTO.DEF$) IF NOT OK THEN _ TRANSFER.OPTIONS$ = "A)scii,X)modem,C)rcXmodem,Y)modem" : _ INTERNAL.EQUIV$ = "AXCY" : _ DFLTXFER$ = "AXCY" : _ GOTO 62604 DFLTXFER$ = "" INTERNAL.EQUIV$ = "" TRANSFER.OPTIONS$ = "" L = 0 62602 IF EOF(2) THEN _ GOTO 62604 CALL READPARMS (WORK.ARA$(),13,1) IF EC > 0 THEN _ EXIT SUB DFLTXFER$ = DFLTXFER$ + " " INTERNAL.EQUIV$ = INTERNAL.EQUIV$ + " " IF USER.SECURITY.LEVEL < VAL(WORK.ARA$(2)) THEN _ GOTO 62602 IF LEFT$(WORK.ARA$(5),1) = "R" THEN _ IF NOT RELIABLE.MODE THEN _ GOTO 62602 IF LEFT$(WORK.ARA$(3),1) = "I" THEN _ GOTO 62603 X = INSTR(WORK.ARA$(12)+" "," ") X$ = LEFT$(WORK.ARA$(12),X-1) CALL FINDFILE (X$,FOUND) IF FOUND THEN _ X = INSTR(WORK.ARA$(13)+" "," ") : _ X$ = LEFT$(WORK.ARA$(13),X-1) : _ CALL FINDFILE (X$,FOUND) IF NOT FOUND THEN _ GOTO 62602 62603 MID$(DFLTXFER$,LEN(DFLTXFER$),1) = LEFT$(WORK.ARA$(1),1) CALL FINDLAST (WORK.ARA$(1),CRLF$,X,I) IF X > 0 AND X >= LEN(WORK.ARA$(1)) - 2 THEN _ WORK.ARA$(1) = LEFT$(WORK.ARA$(1),X-1) IF (L + LEN(WORK.ARA$(1)) < 62) AND X = 0 THEN _ TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + "," + WORK.ARA$(1) : _ L = L + LEN(WORK.ARA$(1)) + 1 _ ELSE L = LEN(WORK.ARA$(1)) : _ TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + _ CRLF$ + _ WORK.ARA$(1) IF LEFT$(WORK.ARA$(3),1) = "I" AND RIGHT$(WORK.ARA$(3),1) <> "I" THEN _ MID$(INTERNAL.EQUIV$,LEN(INTERNAL.EQUIV$),1) = RIGHT$(WORK.ARA$(3),1) GOTO 62602 62604 IF INSTR(INTERNAL.EQUIV$,"N") > 0 THEN _ GOTO 62605 IF X = 0 THEN _ TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + ",N)one" _ ELSE TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + CRLF$ + "N)one" DFLTXFER$ = DFLTXFER$ + "N" INTERNAL.EQUIV$ = INTERNAL.EQUIV$ + "N" 62605 IF LEFT$(TRANSFER.OPTIONS$,1) = "," THEN _ TRANSFER.OPTIONS$ = MID$(TRANSFER.OPTIONS$,2) IF INSTR(DFLTXFER$,USER.TRANSFER.DEFAULT$) = 0 THEN _ CALL QTPUT1 ("Protocol "+USER.TRANSFER.DEFAULT$+" unavailable. Default reset to None") : _ USER.TRANSFER.DEFAULT$ = MID$(DFLTXFER$,INSTR(INTERNAL.EQUIV$,"N"),1) END SUB 62620 ' $SUBTITLE: 'TRANSFER - Subroutine for external protocols' ' $PAGE ' ' NAME -- TRANSFER ' ' INPUTS -- PARAMETER MEANING ' TRANSFER.FUNCTION = 1 DOWNLOAD FILE TO USER ' = 2 UPLOAD FILE TO RBBS-PC ' FILE.NAME$ NAME OF FILE FOR TRANSFER ' COM.PORT$ NAME OF COMMUNICATIONS PORT ' TO BE USED BY KERMIT (COM1 ' OR COM2) ' BPS = -1 FOR 300 BAUD ' = -2 FOR 450 BAUD ' = -3 FOR 1200 BAUD ' = -4 FOR 2400 BAUD ' = -5 FOR 4800 BAUD ' = -6 FOR 9600 BAUD ' = -7 FOR 19200 BAUD ' ' OUTPUTS -- NONE ' ' PURPOSE -- To transfer files using external protocols ' SUB TRANSFER STATIC IF PRIVATE.DOOR THEN _ CALL XFRETURN : _ EXIT SUB IF TRANSFER.FUNCTION = 1 THEN _ B$ = DOWN.TEMPLATE$ : _ Z$ = "send " _ ELSE IF TRANSFER.FUNCTION = 2 THEN _ B$ = UP.TEMPLATE$ : _ Z$ = "receive " CALL METAGSR (B$,FALSE) CALL QTPUT1 ("Protocol : "+PROTO.PROMPT$) CALL QTPUT ("Ready to " + Z$ + " ",0) IF BATCH.TRANSFER THEN _ CALL QTPUT1 ("(BATCH)") : _ CALL OPENWORK (2,NODE.WORK.FILE$) : _ WHILE NOT EOF(2) : _ CALL READANY : _ CALL BRKFNAME (A$,Z$,Y$,X$,TRUE) : _ CALL QTPUT1 (" "+Y$+X$) : _ WEND _ ELSE CALL QTPUT1 (FILE.NAME.HOLD$) CALL XFRETURN END SUB 62624 ' $SUBTITLE: 'XFRETURN - subroutine to exit as a private door.' ' $PAGE ' ' NAME -- XFRETURN ' ' INPUTS -- PARAMETER MEANING ' TRANSFER.FUNCTION = 1 DOWNLOAD FILE TO USER ' = 2 UPLOAD FILE TO RBBS-PC ' = 3 USER REGISTRATION PGM ' B$ NAME OF FILE TO EXIT TO ' COM.PORT$ NAME OF COMMUNICATIONS PORT ' TO BE USED BY KERMIT (COM1 ' OR COM2) ' BPS = -1 FOR 300 BAUD ' = -2 FOR 450 BAUD ' = -3 FOR 1200 BAUD ' = -4 FOR 2400 BAUD ' = -5 FOR 4800 BAUD ' = -6 FOR 9600 BAUD ' = -7 FOR 19200 BAUD ' ' OUTPUTS -- NONE ' ' PURPOSE -- To transfer control to another program ' SUB XFRETURN STATIC IF PRIVATE.DOOR THEN _ GOTO 62630 IF FAKE.XRPT THEN _ CALL FAKEXRPT (FT$) IF ADVANCE.PROTO.WRITE THEN _ CALL OPENOUTW ("XFER-"+NODE.ID$+".DEF") : _ IF EC < 1 THEN _ CALL PRNTWRKA (FILE.NAME$+",,"+FT$) : _ CLOSE 2 IF PROTO.METHOD$ = "S" THEN _ GOTO 62629 62628 X$ = LEFT$(B$,INSTR(B$+" "," ")-1) IF X$ = "" THEN _ EXIT SUB CALL FINDIT (X$) IF NOT OK THEN _ A$ = "Missing door program" : _ CALL UPDTCALR (A$ + " " + X$,1) : _ SNOOP = TRUE : _ CALL LPRNT (A$,1) : _ EXIT SUB A$(1) = DISK.FOR.DOS$ + _ "COMMAND /C " + _ B$ A$(2) = RBBS.BAT$ PRIVATE.DOOR = TRUE CALL QTPUT1 ("Exiting to External Program for File Transfer") LOCATE 25,1 CALL LPRNT(LINE.FEED$,0) CALL RBBSEXIT (A$(),2) 62629 CALL SHELLEXIT (B$) 62630 IF PRIVATE.DOOR THEN _ CALL RESTORECOM : _ CALL DELAYIT (7 + BPS) : _ CALL QTPUT1 ("Reloading RBBS-PC. Please be patient.") 62631 CALL SKIPLINE (2) LOCATE 24,1 62632 END SUB 62650 ' $SUBTITLE: 'FAKEXRPT - subroutine to create fake xfer report' ' $PAGE ' ' NAME -- FAKEXRPT ' ' INPUTS -- PARAMETER MEANING ' FILE.NAME.HOLD$ FILE TO BE TRANSFERRED ' PROTO.USED$ PROTOCOL USED ' ' OUTPUTS -- WRITES OUT TRANSFER FILE REPORT ' ' PURPOSE -- External protocol drivers that do not write ' out a standard transfer report must have one ' provided in order for "dooring" to external ' protocols to work properly, since this file ' is read upon returning from an external protocol. ' SUB FAKEXRPT (PROTO.USED$) STATIC CLOSE 2 OPEN "O",2,"XFER-" + _ NODE.FILE.ID$ + _ ".DEF" PRINT #2,FILE.NAME$ PRINT #2, PRINT #2,PROTO.USED$ PRINT #2,"S" CLOSE 2 END SUB 62660 ' $SUBTITLE: 'SETEXPERT - subroutine to adjust for expert change' ' $PAGE ' ' NAME -- SETEXPERT ' ' INPUTS -- PARAMETER MEANING ' EXPERT.USER WHETHER IS AN EXPERT ' ' OUTPUTS -- MORE.PROMPT$ Pause prompt ' PRESS.ENTER$ Prompt to press enter ' ' PURPOSE -- External protocol drivers that do not write ' out a standard transfer report must have one ' provided in order for "DOORING" to external ' protocols to work properly, since this file ' is read upon returning from an external protocol. ' SUB SETEXPERT STATIC IF EXPERT.USER THEN _ MORE.PROMPT$ = "More <[Y],N,C,A" : _ PRESS.ENTER$ = PRESS.ENTER.EXPERT$ : _ EXIT SUB MORE.PROMPT$ = "More [Y]es,N)o,C)ontinuous,A)bort" PRESS.ENTER$ = PRESS.ENTER.NOVICE$ END SUB 62668 ' $SUBTITLE: 'NEWPASWRD - subroutine to get new password' ' $PAGE ' ' NAME -- NEWPASWRD ' ' INPUTS -- PARAMETER MEANING ' PRMPT$ Prompt to display ' DISALLOW.SPACES Whether answer can have all spaces ' ' OUTPUTS -- Z$ Password ' ' PURPOSE -- To get a new password. ' SUB NEWPASWRD (PRMPT$,DISALLOW.SPACES) STATIC 62670 A$ = PRMPT$ HIDDEN = TRUE SUBROUTINE.PARAMETER = 1 CALL TGET HIDDEN = FALSE IF SUBROUTINE.PARAMETER < 0 OR Q = 0 THEN _ EXIT SUB IF LEN(B$) > 15 THEN _ CALL QTPUT1 ("15 chars max") : _ GOTO 62670 IF INSTR(B$,";") > 0 THEN _ CALL QTPUT1 ("Cannot use ';'") : _ GOTO 62670 IF DISALLOW.SPACES THEN _ IF B$ = SPACE$(LEN(B$)) THEN _ CALL QTPUT1 ("Not all blanks") : _ GOTO 62670 CALL ALLCAPS (B$) Z$ = B$ END SUB 63000 ' $SUBTITLE: 'TIMEDOUT - exits based on time of day' ' $PAGE ' ' NAME -- TIMEDOUT ' ' INPUTS -- PARAMETER MEANING ' RCTTY.BAT$ ' NODE.RECORD.INDEX ' MESSAGE.RECORD$ ' MODEM.INIT.BAUD$ ' MODEM.GO.OFFHOOK.COMMADN$ ' ' OUTPUTS -- NONE ' ' PURPOSE -- When RBBS-PC is to exit to DOS at a specific time of ' day, this routine writes out to the file specified ' in "RCTTY.BAT$" the one-line entry: ' RBBSxTM.BAT ' WHERE "x" is the node id. ' SUB TIMEDOUT STATIC FIELD #1,128 AS MESSAGE.RECORD$ SUBROUTINE.PARAMETER = 3 CALL FILELOCK GET 1,NODE.RECORD.INDEX X$ = DATE$ CALL CSTRDATE (X$,Y$) MID$(MESSAGE.RECORD$,77,2) = Y$ 'MID$(MESSAGE.RECORD$,86,5) = LEFT$(TIME$,5) PUT 1,NODE.RECORD.INDEX SUBROUTINE.PARAMETER = 2 CALL FILELOCK CLOSE 2 CALL BRKFNAME(CALLERS.FILE$,X$,Y$,Z$,TRUE) FILE.NAME$ = X$ + "RBBS" + NODE.FILE.ID$ + "TM.DEF" OPEN "O",2,FILE.NAME$ PRINT #2,MID$(FILE.NAME$,3,7) CLOSE 2 IF LOCAL.USER.MODE THEN _ EXIT SUB IF SUBROUTINE.PARAMETER <> 7 THEN _ SUBROUTINE.PARAMETER = 4 : _ CALL FILELOCK : _ CALL OPENCOM(MODEM.INIT.BAUD$,",N,8,1") CALL MODEMPUT (MODEM.GO.OFFHOOK.COMMAND$) IF MULTI.LINK.PRESENT <> 0 THEN _ CALL DELAYIT (3) END SUB 64003 ' $SUBTITLE: 'ASKUSERS - subroutine to get registration information' ' $PAGE ' ' NAME -- ASKUSERS (WRITTEN BY JON MARTIN) ' ' INPUTS -- PARAMETER MEANING ' FILE.NAME$ NAME OF THE FILE CONTAINING THE ' SCRIPT TO BE USED WHEN ASKING ' THE USER QUESTIONS. ' ACTIVE.USER.NAME$ NAME OF THE CURRENT USER ' USER.SECURITY.LEVEL USER'S SECURITY ' UPPER.CASE SET IF USER NEEDS UPPERCASE ' ' OUTPUTS -- WRITE THE USER'S RESPONSES TO THE QUESTIONS TO THE ' FILE NAME SPECIFIED AS THE FIRST PARAMETER IN THE ' FIRST RECORD OF THE FILE CONTAINING THE SCRIPT TO ' BE USED. ' USER.SECURITY.LEVEL CAN BE RAISED OR LOWERED ' ' PURPOSE -- Provides a sophisticated, script driven mechanism by ' which a sysop can solicit information from new users ' (via a script that requests registration information ' and which can raise or lower his default security ' level based on the responses) or ask a questions of ' when the user logs off. The former occurs if the ' file "RBBS-REG.DEF" containing the registration ' script exists on the same drive as the "WELCOME". ' The later exists if the file "EPILOG.DEF" exists on ' the same drive as the "WELCOME". ' SUB ASKUSERS STATIC QUESTIONNAIRE.ABORTED = FALSE QUESTIONNAIRE.CHAIN.STARTED = FALSE ' KG060301 REDIM A$(256) REDIM WORK.ARA$(MAX.WORK.VAR),GSR.ARA$(MAX.WORK.VAR) PREV.APPEND$ = "" ' MZ060301 ' ' ' * LOAD SCRIPT CONTAINING THE QUESTIONS INTO THE A$ DIMENSION * ' ' 64005 CHAT.AVAILABLE = FALSE QUESTIONNAIRE.CHAIN = FALSE LAST.QUES = 0 CALL GRAPHIC (USER.GRAPHIC.DEFAULT$,FILE.NAME$) ' KG060301 IF NOT OK THEN _ ' KG060301 EXIT SUB ' KG060301 CALL READPARMS (A$(),2,1) IF EC > 0 THEN _ EXIT SUB PREV.APPEND$ = APPEND.FILE.NAME$ ' MZ060301 APPEND.FILE.NAME$ = A$(1) MAXIMUM.SECURITY.LEVEL = VAL(A$(2)) X = INSTR(A$(2)," ") IF X > 0 THEN _ IF USER.SECURITY.LEVEL < VAL(MID$(A$(2),X)) THEN _ CALL QTPUT1 ("Higher security needed for this questionnaire") : _ EXIT SUB ' ' ' * THE FIRST RECORD OF THE SCRIPT FILE CONTAINS THREE PARAMETERS: ' * 1. THE NAME OF THE FILE TO APPEND THE ANSWERS TO. ' * 2. THE MAXIMUM SECURITY LEVEL THE + COMMAND CAN RAISE A USER SECURITY ' * 3. THE MINIMUM SECURITY TO USE THIS QUESTIONNAIRE ' * e.g. 'C:XXX.DAT,6 5' writes answers to C:XXX.DAT, can raise to 6, ' * and requires security 5 or more to access SCRIPT.INDEX = 1 A$(SCRIPT.INDEX) = ACTIVE.USER.NAME$ + _ " " + _ DATE$ + _ " " + _ TIME$ 64010 IF EOF(2) OR SCRIPT.INDEX > 255 THEN _ GOTO 64100 SCRIPT.INDEX = SCRIPT.INDEX + 1 LINE INPUT #2,A$(SCRIPT.INDEX) IF LEFT$(A$(SCRIPT.INDEX),1) = ":" THEN _ CALL ALLCAPS (A$(SCRIPT.INDEX)) : _ CALL TRIM (A$(SCRIPT.INDEX)) IF UPPER.CASE THEN _ CALL ALLCAPS (A$(SCRIPT.INDEX)) IF LEFT$(A$(SCRIPT.INDEX),1) = "?" THEN _ SCRIPT.INDEX = SCRIPT.INDEX + 1 : _ A$(SCRIPT.INDEX) = "!" GOTO 64010 ' ' ' * PROCESS QUESTIONS IN THE SCRIPT AS FOLLOWS: ' * ' * FIRST COLUMN MEANING ' * : THIS LINE IS A LABEL THAT MAY BE BRANCHED TO ' * ! THIS MEANS THIS IS AN ANSWER ' * > THIS IS A "GOTO" COMMAND TO ONE OF THE LABELS ' * * THIS MEANS THE LINE IS A MESSAGE TO BE WRITTEN TO THE USER ' * ? THIS MEANS THIS IS A QUESTION FOR THE USER ' * = THIS MEANS THAT THIS LINE CONTAINS DECISION CRITERIA ' * - THIS MEANS TO LOWER THE USER'S SECURITY LEVEL ' * + THIS MEANS TO RAISE THE USER'S SECURITY LEVEL ' * @ THIS MEANS TO ABORT THE QUESTIONNAIRE DO NOT WRITE OUT ' * & THIS MEANS TO CHAIN TO ANOTHER QUESTIONNAIRE ' * M Execute specified macro ' * T Turbo Key ' * < Assign value to work variable ' 64100 SCRIPT.MAX = SCRIPT.INDEX SCRIPT.INDEX = 1 64110 CALL CARRIER IF SUBROUTINE.PARAMETER = -1 THEN _ GOTO 64115 SCRIPT.INDEX = SCRIPT.INDEX + 1 IF SCRIPT.INDEX > SCRIPT.MAX THEN _ GOTO 64400 A$ = MID$(A$(SCRIPT.INDEX),2) X = FALSE IF LEFT$(A$,3) = "/FL" THEN _ A$ = RIGHT$(A$,LEN(A$)-3) : _ X = TRUE CALL METAGSR (A$,X) CALL SMARTTXT (A$,FALSE,X) X$ = A$ IF LEFT$(A$(SCRIPT.INDEX),1) = ":" THEN _ ' LABEL GOTO 64110 IF LEFT$(A$(SCRIPT.INDEX),1) = "!" THEN _ ' ANSWER GOTO 64110 IF LEFT$(A$(SCRIPT.INDEX),1) = "@" THEN _ ' ABORT QUESTIONNAIRE.ABORTED = TRUE : _ GOTO 64510 IF LEFT$(A$(SCRIPT.INDEX),1) = "M" THEN _ ' MACRO GOTO 64120 IF LEFT$(A$(SCRIPT.INDEX),1) = "T" THEN _ TURBO.KEY = -TURBO.KEY.USER : _ GOTO 64110 IF LEFT$(A$(SCRIPT.INDEX),1) = ">" THEN _ ' GOTO BRANCH.LABEL$ = A$ : _ GOSUB 64200 : _ IF SUBROUTINE.PARAMETER = -1 THEN _ GOTO 64510 _ ELSE GOTO 64110 IF LEFT$(A$(SCRIPT.INDEX),1) = "<" THEN _ GOTO 64190 IF LEFT$(A$(SCRIPT.INDEX),1) = "*" THEN _ ' MESSAGE SUBROUTINE.PARAMETER = 5 : _ CALL TPUT : _ IF SUBROUTINE.PARAMETER = -1 THEN _ GOTO 64510 _ ELSE GOTO 64110 64113 IF LEFT$(A$(SCRIPT.INDEX),1) <> "?" THEN _ ' QUESTION GOTO 64114 LAST.QUES = SCRIPT.INDEX GOSUB 64180 SUBROUTINE.PARAMETER = 1 CALL TGET IF SUBROUTINE.PARAMETER = -1 THEN _ GOTO 64510 _ ELSE IF Q = 0 THEN _ A$ = X$ : _ GOTO 64113 _ ELSE A$(SCRIPT.INDEX + 1) = "!" + _ B$ : _ GSR.ARA$(TESTED.INTEGER.VALUE) = B$ GOTO 64110 64114 IF LEFT$(A$(SCRIPT.INDEX),2) = "=#" THEN _ ' NUMERIC GOSUB 64350 : _ GOTO 64110 IF LEFT$(A$(SCRIPT.INDEX),1) = "=" THEN _ ' DECISION GOSUB 64300 : _ IF SUBROUTINE.PARAMETER = -1 THEN _ GOTO 64510 _ ELSE GOTO 64110 IF LEFT$(A$(SCRIPT.INDEX),1) = "-" THEN _ ' LOWER ADJUSTED.SECURITY = -1 : _ USER.SECURITY.LEVEL = USER.SECURITY.LEVEL - _ VAL(MID$(A$(SCRIPT.INDEX),2,5)) : _ USER.SECURITY.SAVE = USER.SECURITY.LEVEL : _ GOTO 64110 IF LEFT$(A$(SCRIPT.INDEX),1) = "+" THEN _ ' RAISE IF USER.SECURITY.LEVEL + VAL(MID$(A$(SCRIPT.INDEX),2,5)) _ <= MAXIMUM.SECURITY.LEVEL THEN _ ADJUSTED.SECURITY = -1 : _ USER.SECURITY.SAVE = USER.SECURITY.LEVEL : _ USER.SECURITY.LEVEL = USER.SECURITY.LEVEL + _ VAL(MID$(A$(SCRIPT.INDEX),2,5)) IF LEFT$(A$(SCRIPT.INDEX),1) = "+" THEN _ GOTO 64110 IF LEFT$(A$(SCRIPT.INDEX),1) = "&" THEN _ QUESTIONNAIRE.CHAIN = TRUE : _ FILE.NAME.HOLD$ = A$ : _ GOTO 64110 A$ = "Invalid line. Column 1 is <" + LEFT$(A$(SCRIPT.INDEX),1)+">. Must be: * ? = + - > @ & M T <" SUBROUTINE.PARAMETER = 5 CALL TPUT 64115 GOTO 64510 64120 Z$ = MID$(A$(SCRIPT.INDEX),2) ' Execute macro CALL TRIM (Z$) ' KG062801 CALL ACHKMAC (Z$,FOUND) ' KG062801 IF FOUND THEN _ ' KG062801 CALL FDMACEXE ' KG062801 GOTO 64110 64180 CALL CHECKINT (A$) IF (EC > 0) OR (TESTED.INTEGER.VALUE < 1) OR _ (TESTED.INTEGER.VALUE > MAX.WORK.VAR) OR _ (INSTR("123456789",LEFT$(A$,1)) = 0) THEN _ TESTED.INTEGER.VALUE = 0 _ ELSE A$ = RIGHT$(A$,LEN(A$)-1+(TESTED.INTEGER.VALUE > 9)) RETURN 64190 GOSUB 64180 IF TESTED.INTEGER.VALUE > 0 THEN _ GSR.ARA$(TESTED.INTEGER.VALUE) = MID$(A$,2) GOTO 64110 ' ' ' * SEARCH FOR GOTO LABEL ' ' 64200 SCRIPT.INDEX = 1 CALL METAGSR (BRANCH.LABEL$,FALSE) CALL SMARTTXT (BRANCH.LABEL$,FALSE,FALSE) CALL ALLCAPS (BRANCH.LABEL$) CALL TRIM (BRANCH.LABEL$) 64210 SCRIPT.INDEX = SCRIPT.INDEX + 1 IF SCRIPT.INDEX > SCRIPT.MAX THEN _ A$ = BRANCH.LABEL$ + _ " not found!" : _ SUBROUTINE.PARAMETER = 5 : _ CALL TPUT : _ IF SUBROUTINE.PARAMETER = -1 THEN _ RETURN _ ELSE IF LAST.QUES > 0 THEN _ SCRIPT.INDEX = LAST.QUES - 1 : _ RETURN _ ELSE GOTO 64115 IF LEFT$(A$(SCRIPT.INDEX),1) <> ":" THEN _ GOTO 64210 IF MID$(A$(SCRIPT.INDEX),2) <> BRANCH.LABEL$ THEN _ GOTO 64210 RETURN ' ' ' * DETERMINE BRANCH LOGIC ' ' 64300 CURRENT.EQUALS = 1 Z$ = RIGHT$(A$(LAST.QUES + 1),1) CALL ALLCAPS (Z$) 64310 NEXT.EQUALS = INSTR(CURRENT.EQUALS + 1, A$(SCRIPT.INDEX),"=") IF NEXT.EQUALS = 0 THEN _ BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2) : _ GOTO 64320 IF Z$ <> _ MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 1,1) THEN _ CURRENT.EQUALS = NEXT.EQUALS : _ GOTO 64310 BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2,NEXT.EQUALS-(CURRENT.EQUALS + 2)) 64320 GOSUB 64200 RETURN ' ' ' * DETERMINE NUMERIC BRANCH LOGIC ' ' 64350 CURRENT.EQUALS = 1 64360 NEXT.EQUALS = INSTR(CURRENT.EQUALS + 1, A$(SCRIPT.INDEX),"=") IF NEXT.EQUALS = 0 THEN _ BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2) : _ GOTO 64380 NUMERIC = TRUE LOOP.INDEX = 2 WHILE LOOP.INDEX < LEN(A$(SCRIPT.INDEX - 1)) +1 IF INSTR("()1234567890- ",MID$(A$(SCRIPT.INDEX - 1),LOOP.INDEX,1)) THEN _ GOTO 64370 NUMERIC = FALSE 64370 LOOP.INDEX = LOOP.INDEX + 1 WEND IF NOT NUMERIC THEN _ CURRENT.EQUALS = NEXT.EQUALS : _ GOTO 64360 BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2,NEXT.EQUALS-(CURRENT.EQUALS + 2)) 64380 GOSUB 64200 RETURN ' ' ' * WRITE RESPONSES TO DESIGNATED FILE ' ' 64400 SCRIPT.INDEX = 0 EN$ = APPEND.FILE.NAME$ CALL LOCKAPPND IF EC <> 0 THEN _ A$ = "Fatal Error in script!" : _ SUBROUTINE.PARAMETER = 5 : _ CALL TPUT : _ GOTO 64500 64410 SCRIPT.INDEX = SCRIPT.INDEX + 1 IF SCRIPT.INDEX > SCRIPT.MAX THEN _ GOTO 64500 IF LEFT$(A$(SCRIPT.INDEX),1) = ":" THEN _ QUESTION.SAVE$ = MID$(A$(SCRIPT.INDEX),2) : _ GOTO 64410 IF LEFT$(A$(SCRIPT.INDEX),1) = "!" AND _ LEN(A$(SCRIPT.INDEX)) < 2 THEN _ GOTO 64410 IF LEFT$(A$(SCRIPT.INDEX),1) = "!" THEN _ CALL PRNTWRKA (QUESTION.SAVE$) : _ CALL PRNTWRKA (MID$(A$(SCRIPT.INDEX),2)) IF SCRIPT.INDEX = 1 AND _ APPEND.FILE.NAME$ <> PREV.APPEND$ THEN _ ' MZ060301 CALL PRNTWRKA (A$(SCRIPT.INDEX)) IF EC <> 0 THEN _ A$ = "Unrecoverable failure in script!" : _ SUBROUTINE.PARAMETER = 5 : _ CALL TPUT : _ GOTO 64500 GOTO 64410 64500 CALL UNLKAPPND CALL CARRIER IF QUESTIONNAIRE.CHAIN THEN _ QUESTIONNAIRE.CHAIN.STARTED = TRUE : _ FILE.NAME$ = FILE.NAME.HOLD$ : _ GOTO 64005 64510 CHAT.AVAILABLE = (INSTR("MUF",ACTIVE.MENU$) > 0) OK = TRUE END SUB 64600 ' $SUBTITLE: 'VIEWARC - subroutine to display .ARC contents' ' $PAGE ' ' NAME -- VIEWARC (Written by Jon Martin) ' ' INPUTS -- PARAMETER MEANING ' FILE.NAME$ NAME OF THE ARC FILE TO BE ' VIEWED. ' ' OUTPUTS -- NONE ' ' PURPOSE -- Provides a mechanism to provide users with the ' contents of a libraried file prior to downloading. ' SUB VIEWARC STATIC CLOSE 2 IF TURBO.RBBS THEN _ RETCODE% = 0 : _ CALL ARCV (ARC.WORK$,FILE.NAME$,RETCODE%) : _ CALL BUFFILE (ARC.WORK$,X) : _ EXIT SUB IF SHARE.IT THEN _ OPEN FILE.NAME$ FOR RANDOM SHARED AS #2 LEN=1 _ ELSE OPEN "R",2,FILE.NAME$,1 FIELD 2,1 AS CHAR$ BYTE.POINTER! = 1 ARC.END! = LOF(2) 64605 IF BYTE.POINTER! > ARC.END! THEN _ GOTO 64620 GET 2,BYTE.POINTER! IF CHAR$ <> CHR$(26) THEN _ GOTO 64620 BYTE.POINTER! = BYTE.POINTER! + 1 GET 2,BYTE.POINTER! IF CHAR$ = CHR$(0) THEN _ GOTO 64620 ARCED.NAME$ = "" FOR X = 1 TO 12 GET 2,BYTE.POINTER! + X IF CHAR$ < CHR$(40) THEN _ GOTO 64610 ARCED.NAME$ = ARCED.NAME$ + _ CHAR$ NEXT 64610 A$ = ARCED.NAME$ BYTE.POINTER! = BYTE.POINTER! + 14 GOSUB 64630 TOTAL.BYTES# = WORK.BYTES# BYTE.POINTER! = BYTE.POINTER! + 10 GOSUB 64630 FINAL.BYTES# = WORK.BYTES# A$ = A$ + _ SPACE$(20 - LEN(ARCED.NAME$) - LEN(STR$(FINAL.BYTES#))) + _ STR$(FINAL.BYTES#) + _ " bytes." CALL QTPUT1 (A$) BYTE.POINTER! = BYTE.POINTER! + TOTAL.BYTES# + 4 GOTO 64605 64620 CLOSE 2 SUBROUTINE.PARAMETER = 0 CALL CARRIER A$ = "" EXIT SUB 64630 FACTOR# = 1# WORK.BYTES# = 0 FOR X = 0 TO 3 GET 2,BYTE.POINTER! + X WORK.BYTES# = WORK.BYTES# + FACTOR# * ASC(CHAR$) FACTOR# = FACTOR# * 256# NEXT RETURN END SUB