' $linesize:132 ' $title: 'RBBSSUB5.BAS CPC17.2B, Copyright 1986 - 89 by D. Thomas Mack' ' Copyright 1989 by D. Thomas Mack, all rights reserved. ' Name ...............: RBBSSUB5.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 ' BRKFNAME 63300 Break file name into component parts ' BUFASUNIT 63500 Buffer out a string with CR's ' CALLOPT 63470 Set prompts based on the user's security ' DOORRTN 63100 Process door requests ' FILESYS 20117 File System for RBBS-PC ' FINDIT Check whether file exists and if so open as #2 ' FORMREAD 63420 Read from file into a form ' LOCKAPPND 63400 Prepare for a file append ' MACROEXE 63460 Execute internal macro rather than user ' NOPATH 63480 Detects whether string has a path in it ' RESTORECOM 63310 Restore comm port after external program ' READMACRO 63330 Read and process macro ' SHELLEXIT 63320 Exit RBBS via shell ' UNLKAPPND 63410 Clean up after file append ' WILDCARD 63200 Match string to a pattern ' ' $INCLUDE: 'RBBS-VAR.BAS' ' 20117 ' $SUBTITLE: 'FILESYS -- subroutine for RBBS-PC's file system' ' $PAGE ' ' NAME -- FILESYS ' ' INPUTS -- PARAMETER MEANING ' FILESYS.PARAMETER = 1 LIST THE SYSOP'S COMMENTS FILE ' 2 L)IST DIRECTORY COMMAND ' 3 D)OWNLOAD COMMAND ' 4 RETURN FROM EXTERNAL PROTOCOLS ' 5 U)PLOAD COMMAND ' 6 S)CAN DIRECTORY COMMAND ' 7 P)ERSONAL FILES COMMAND ' 8 N)EW FILES COMMAND ' 9 RETURN FROM EXTENDED DESCRIPTION ' ' OUTPUTS -- FILESYS.PARAMETER = 1 COMMAND PROCESSED SUCCESSFULLY ' 2 RECYCLE TO TOP OF RBBS-PC (202) ' 3 PROCESS NEXT COMMAND (1200) ' 4 DENY USER ACCESS (1380) ' 5 HANDLE EXTENDED DESCRIP. (2008) ' 6 USER'S TIME EXCEEDED (10553) ' 7 CARRIER DROPPED (10595) ' ' PURPOSE -- To handle the RBBS-PC file system commands ' SUB FILESYS STATIC FF = FILESYS.PARAMETER FILESYS.PARAMETER = 1 ON FF GOSUB 20119, _ ' HANDLER TO LIST COMMENTS TO SYSOP 20150, _ ' L)IST DIRECTORY COMMAND HANDLER 20180, _ ' D)OWNLOAD COMMAND HANDLER 20262, _ ' RETURN FROM EXTERNAL PROTOCOL'S 20400, _ ' U)PLOAD COMMAND HANDLER 21800, _ ' S)CAN DIRECTORY COMMAND HANDLER 21850, _ ' P)ERSONAL FILES COMMAND HANDLER 21860, _ ' N)EW FILES COMMAND HANDLER 20705 ' RETURN FROM EXTENDED DESCRIPTIONS GOTO 21920 20119 EC = 0 GOTO 20122 ' ' ***** SCAN DIRECTORIES (PRINT TEXT) **** ' ' (formerly lines 7000 to 7260 in RBBS-PC.BAS CPC16-1A 20120 A$ = CX$(2)+"Scanning"+CX$(3)+" Directory "+CX$(5) + _ FILE.NAME.HOLD$ +CX$(3)+ _ " for " +CX$(7)+ _ RS$ GOSUB 21650 IF FILESYS.PARAMETER > 1 THEN _ RETURN PG = TRUE 20122 CALL OPENWORK (2,FILE.NAME$) IF EC = 53 THEN _ CALL UPDTCALR ("Missing File " + FILE.NAME$,2) : _ A$ = "Missing file " + _ FILE.NAME$ + _ ". Please tell SYSOP" : _ GOSUB 21650 : _ RETURN 20124 CALL CARRIER IF EOF(2) OR _ (SUBROUTINE.PARAMETER = -1 AND NOT LOCAL.USER) THEN _ GOTO 20142 20126 CALL READDIR (2,1) IF EC <> 0 THEN _ EL = 20126 : _ GOTO 21900 IF CK = 0 THEN _ GOTO 20140 IF LEN(A$) > 0 THEN IF ASC(A$) = 32 THEN _ IF LAST.OK AND NOT EXTENDED.OFF THEN _ GOTO 20140 _ ELSE GOTO 20124 LAST.OK = FALSE 20128 IF CK > 1 THEN _ IF WILD.SEARCH THEN _ A = INSTR(A$," ") : _ IF A = 0 THEN _ GOTO 20124 _ ELSE Z$ = LEFT$(A$,A - 1) : _ CALL WILDFILE (RS$,Z$,XXX) : _ GOTO 20136_ ELSE Z$ = A$ : _ CALL ALLCAPS (Z$) : _ XXX = (INSTR(Z$,RS$) = 0) : _ GOTO 20136 20130 A = INSTR(9,MID$(A$,1,32),"/") IF A = 0 THEN _ A = INSTR(9,MID$(A$,1,32),"-") 20132 IF A < 3 THEN _ GOTO 20124 IF INSTR("0123456789",MID$(A$,A - 1,1)) = 0 THEN _ GOTO 20124 A = A - 2 WK$ = RIGHT$(MID$(A$,A,8),2) + _ LEFT$(MID$(A$,A,8),2) + _ MID$(MID$(A$,A,8),4,2) IF MID$(WK$,3,1) = " " THEN _ MID$(WK$,3,1) = "0" IF MID$(WK$,5,1) = " " THEN _ MID$(WK$,5,1) = "0" 20134 XXX = (WK$ < RS$) 20136 IF XXX THEN _ GOTO 20124 IF PG THEN _ PG = FALSE : _ CALL OPENWORK (2,FILE.NAME$) : _ Q = 0 : _ GOTO 20124 20138 IF PG THEN _ GOTO 20124 20140 LAST.OK = TRUE GOSUB 21650 IF FILESYS.PARAMETER > 1 THEN _ RETURN CALL ASKMORE ("",TRUE,TRUE,ANS.INDEX,FALSE) ' KG081201 IF NO THEN _ EC = 0 : _ RETURN IF NOT RET THEN _ GOTO 20124 20142 Q = 0 CLOSE 2 CALL CARRIER IF SUBROUTINE.PARAMETER = -1 THEN _ FILESYS.PARAMETER = 7 RETURN ' ' * L - COMMAND FROM FILES MENU (LIST DIRECTORY) ' 20150 LIST.DIRECTORY = TRUE LIST.NEW = FALSE SEARCH.DATE$ = "" SEARCH.STRING$ = "" SHOW.DIR.OF.DIR = NOT EXPERT.USER CK = 0 IF Q > 1 THEN _ CALL ALLCAPS (B$(2)) : _ IF B$(2) = "L" THEN _ SHOW.DIR.OF.DIR = TRUE ' KG081201 SEARCHING.ALL = FALSE ' KG081201 20155 IF DOWNLOAD.COMPLETED AND AUTO.END = 1 THEN _ FILESYS.PARAMETER = 7: _ RETURN IF LIST.NEW OR ANS.INDEX > 255 THEN _ ' KG081201 RETURN ' KG081201 CALL GETDIRS (SHOW.DIR.OF.DIR) IF Q = 0 THEN _ RETURN SHOW.DIR.OF.DIR = FALSE CALL CONVDIRS (ANS.INDEX) ' KG081201 QX = LAST.INDEX ' KG081201 20157 CALL CARRIER ' KG081201 IF SUBROUTINE.PARAMETER = -1 THEN _ FILESYS.PARAMETER = 7 : _ RETURN ' KG081201 GOTO 20161 ' KG081201 20159 IF ANS.INDEX < LAST.INDEX THEN _ ' KG081201 GOTO 20155 ' KG081201 SEARCHING.ALL = FALSE ' KG081201 CALL CSPUSHPOP (1) ' KG082702 LAST.INDEX = 0 ' KG082702 IF NO OR (FILE.NAME.HOLD$ = DIRECTORY.PREFIX$) THEN _ GOTO 20155 ' KG081201 CALL QTPUT (EMPHASIZE.OFF$,0) A$ = "End list. R)elist, [Q]uit, or download what" GOSUB 21668 CALL ALLCAPS (B$(1)) IF B$(1) = "R" THEN _ B$(ANS.INDEX) = A1$ : _ ' KG081201 GOTO 20161 IF LEN(B$(1)) > 1 AND _ USER.SECURITY.LEVEL >= OPT.SEC(19 - 20 * (MENU.INDEX = 6)) THEN _ ANS.INDEX = 1 : _ ' KG081201 GOSUB 20202 ' KG082702 CALL CSPUSHPOP (2) ' KG082702 RETURN ' KG082702 20161 IF INSTR(B$(ANS.INDEX),".") THEN _ ' KG081201 GOTO 20172 VIOLATION$ = "List Dir. " Z$ = B$(ANS.INDEX) ' KG081201 A = INSTR("E+E-E",Z$) IF A > 0 THEN _ IF A = 5 THEN _ EXTENDED.OFF = NOT EXTENDED.OFF : _ GOTO 20155 _ ' KG081201 ELSE EXTENDED.OFF = (A > 2) : _ GOTO 20155 ' KG081201 CALL ALLCAPS(Z$) FILE.NAME.HOLD$ = Z$ A1$ = Z$ IF Z$ = DIRECTORY.PREFIX$ THEN _ GOTO 20164 IN.FMS = FALSE 20162 CALL CSPUSHPOP (1) ' save dir list list processing ' KG082702 CALL FMS (Z$,SEARCH.STRING$,SEARCH.DATE$,IN.FMS, _ CATEGORY.NAME$(),CATEGORY.CODE$(),CATEGORY.DESC$(),_ DOWNLOAD.FLAG,CAT.FOUND,ANS.INDEX) ' KG081201 WHILE DOWNLOAD.FLAG > 0 AND SUBROUTINE.PARAMETER > -1 ' KG081201 GOSUB 20202 IF FILESYS.PARAMETER > 1 THEN _ RETURN IF DOWNLOAD.COMPLETED and AUTO.END = 1 THEN _ RETURN ' AUTOLOGOFF MOD X$ = CATEGORY.CODE$(CAT.FOUND) CALL DISUPDIR (X$,SEARCH.STRING$,SEARCH.DATE$,DOWNLOAD.FLAG,ANS.INDEX) ' KG081201 CALL CHKTREMAIN (TIME.REMAINING!) IF SUBROUTINE.PARAMETER = -1 THEN _ FILESYS.PARAMETER = 6 : _ RETURN CALL CARRIER WEND IF SUBROUTINE.PARAMETER = -1 THEN _ FILESYS.PARAMETER = 7 : _ RETURN IF ANS.INDEX > 255 THEN _ ' KG081201 LAST.INDEX = 0 : _ ' KG081201 RETURN ' KG081201 CALL CSPUSHPOP (2) ' restore dir list list processing ' KG082702 ACTIVE.FMS.DIRECTORY$ = "" IF IN.FMS THEN _ GOTO 20159 ' KG081201 IF USER.SECURITY.LEVEL < MIN.SEC.TO.VIEW THEN _ IF FILE.NAME.HOLD$ = UPLOAD.DIR.CHECK$ THEN _ FILE.NAME.HOLD$ = "of uploads" : _ GOTO 20172 FILE.NAME.HOLD$ = B$(ANS.INDEX) ' KG081201 IF LIMIT.SEARCH.TO.FMS THEN _ GOTO 20166 IF NOT SEARCHING.ALL THEN _ ' KG081201 IF FILE.NAME.HOLD$ = "ALL" OR FILE.NAME.HOLD$ = "A" THEN _ ' KG081201 SEARCHING.ALL = TRUE : _ ' KG083002 GOTO 21890 ' KG081201 CALL BADFILE (FILE.NAME.HOLD$,BAD.FILE.NAME.INDEX) ON BAD.FILE.NAME.INDEX GOTO 20163,20172,20176 20163 FILE.NAME$ = FILE.NAME.HOLD$ CALL BADNAME (BAD.FILE.NAME.INDEX) ON BAD.FILE.NAME.INDEX GOTO 20164,20176 20164 IF FILE.NAME$ = UPLOAD.DIR.CHECK$ AND _ USER.SECURITY.LEVEL >= MIN.SEC.TO.VIEW THEN _ FILE.NAME$ = UPLOAD.PATH$ _ ELSE FILE.NAME$ = DIRECTORY.PATH$ FILE.NAME$ = FILE.NAME$ + _ FILE.NAME.HOLD$ + _ "." + _ DIRECTORY.EXTENTION$ CALL GRAPHIC (USER.GRAPHIC.DEFAULT$,FILE.NAME$) 20165 IF OK THEN _ CALL READDIR (2,1) : _ IF EC = 0 THEN _ IF LEFT$(A$,4) = "\FMS" THEN _ IN.FMS = TRUE : _ ACTIVE.FMS.DIRECTORY$ = FILE.NAME$ : _ GOTO 20162 _ ELSE GOTO 20167 20166 FILE.NAME$ = DIRECTORY.PATH$ + _ FILE.NAME.HOLD$ + ".MNU" CALL FINDIT (FILE.NAME$) IF OK THEN _ CALL BUFFILE (FILE.NAME$,ANS.INDEX) : _ ' KG081201 GOTO 20155 ' KG081201 IF ALTDIR.EXTENSION$ = "" THEN _ GOTO 20172 FILE.NAME$ = DIRECTORY.PATH$ + _ FILE.NAME.HOLD$ + _ "." + _ ALTDIR.EXTENSION$ CALL GRAPHIC (USER.GRAPHIC.DEFAULT$,FILE.NAME$) IF NOT OK THEN _ GOTO 20172 20167 B$(0) = B$(ANS.INDEX) ' KG081201 IF NOT LIST.NEW THEN _ GOTO 20168 GOSUB 20120 IF FILESYS.PARAMETER > 1 THEN _ RETURN GOTO 20170 20168 CALL BUFFILE(FILE.NAME$,ANS.INDEX) ' KG081201 CALL CARRIER IF SUBROUTINE.PARAMETER = -1 THEN _ FILESYS.PARAMETER = 7 : _ RETURN 20170 IF ANS.INDEX > 255 THEN _ ' KG081201 LAST.INDEX = 0 : _ ' KG081201 RETURN ' KG081201 B$(ANS.INDEX) = B$(0) ' KG081201 GOTO 20159 ' KG081201 20172 IF NOT SEARCHING.ALL THEN _ A$ = "Directory " + _ FILE.NAME.HOLD$ + _ " not found!" : _ GOSUB 21640 : _ NO = TRUE : _ IF FILESYS.PARAMETER > 1 THEN _ RETURN GOTO 20155 ' KG081201 20176 CALL SVIOLATION IF DENY.ACCESS THEN _ FILESYS.PARAMETER = 4 : _ RETURN GOTO 20172 ' ' * D - COMMAND FROM FILES MENU (SEARCH FOR FILE TO DOWNLOAD) ' 20180 A$ = CX$(5)+"Download"+CX$(6)+" what file(s)"+CX$(7) GOSUB 21668 ' KG081201 IF FILESYS.PARAMETER > 1 THEN _ RETURN IF Q = 0 THEN _ RETURN 20202 IF (TIME.LOCK AND 2) AND (NOT TIME.LOCK.EXEMPT) AND NOT HAS.PRIVDOOR THEN _ ' KG052501 CALL TIMELOCK : _ IF NOT OK THEN _ RETURN LAST.DOWNLOAD = LAST.INDEX ' KG081201 FIRST.DOWNLOAD = ANS.INDEX ' KG081201 COMMAND.TRANSFER$ = "" IF AUTODOWNLOAD.AVAILABLE THEN _ COMMAND.TRANSFER$ = "X" AUTODOWNLOAD.IN.PROGRESS = AUTODOWNLOAD.AVAILABLE IF LAST.DOWNLOAD > FIRST.DOWNLOAD THEN _ Z$ = B$(LAST.DOWNLOAD) : _ CALL ALLCAPS(Z$) : _ IF LEN (Z$) = 1 AND INSTR(DFLTXFER$,Z$) > 0 THEN _ LAST.DOWNLOAD = LAST.DOWNLOAD - 1 : _ COMMAND.TRANSFER$ = Z$ : _ AUTODOWNLOAD.IN.PROGRESS = FALSE : _ IF MID$(INTERNAL.EQUIV$,INSTR(DFLTXFER$,Z$),1) = "N" THEN _ COMMAND.TRANSFER$ = "" BATCH.BYTES# = 0 BATCH.BLOCKS# = 0 CALL KILLWORK (NODE.WORK.FILE$) EC = 0 FOR ANS.INDEX = FIRST.DOWNLOAD TO LAST.DOWNLOAD ' KG081201 GOSUB 20205 COMMAND.TRANSFER$ = FT$ ' KG082301 CALL LINE25 ' KG082703 IF FILESYS.PARAMETER > 1 THEN _ ANS.INDEX = LAST.DOWNLOAD + 1 ' KG081201 20203 NEXT LAST.INDEX = 0 ' KG082702 IF FILESYS.PARAMETER > 1 THEN _ RETURN BATCH.TRANSFER = FALSE COMMAND.TRANSFER$ = "" RETURN 20205 MARK.TIME = (ANS.INDEX = FIRST.DOWNLOAD OR NOT CONCAT.FILES) ' KG081201 FILE.NAME$ = B$(ANS.INDEX) ' KG081201 VIOLATION$ = "Download " IF PERSONAL.DOWNLOAD THEN _ CALL BRKFNAME (FILE.NAME$,DR$,Y$,X$,TRUE) : _ FILE.NAME.HOLD$ = Y$ + _ X$ : _ GOTO 20235 FILE.NAME.HOLD$ = FILE.NAME$ CALL BADFILE (FILE.NAME$,BAD.FILE.NAME.INDEX) ON BAD.FILE.NAME.INDEX GOTO 20220,20231,20233 20220 CALL ROTORSDIR (FILE.NAME$,SUBDIR$(),SUBDIR.COUNT + _ ((USER.SECURITY.LEVEL < MIN.SEC.TO.VIEW) OR _ NOT CAN.DOWNLOAD.FROM.UP),MARK.TIME) 20225 IF OK THEN _ GOTO 20235 20231 A$ = FILE.NAME.HOLD$ + _ " not found!" CALL UPDTCALR (A$,2) AUTO.LOGOFF = FALSE IF AUTODOWNLOAD.IN.PROGRESS THEN _ A$ = A$ + _ " during AUTODOWNLOAD" : _ GOSUB 21640 : _ RETURN A$ = A$ + _ " Correct name"+PRESS.ENTER.EXPERT$ GOSUB 21660 IF FILESYS.PARAMETER > 1 THEN _ RETURN IF Q=0 THEN _ RETURN B$(ANS.INDEX) = B$(1) ' KG081201 GOTO 20205 20233 CALL SVIOLATION IF DENY.ACCESS THEN _ FILESYS.PARAMETER = 4 : _ RETURN GOTO 20231 20235 CALL BADNAME (BAD.FILE.NAME.INDEX) ON BAD.FILE.NAME.INDEX GOTO 20236,20245 20236 LINE.25$ = "(D) " + _ Z$ IF AUTODOWNLOAD.IN.PROGRESS THEN _ MID$(LINE.25$,2,1) = "A" ' ' * TEST FOR DOWNLOAD SECURITY ' CALL OPENWORK (2,FILESEC.FILE$) IF EC = 53 THEN _ CALL UPDTCALR ("Missing file " + FILESEC.FILE$,2) : _ GOTO 20247 20242 IF EOF(2) THEN _ GOTO 20247 CALL READPARMS (WORK.ARA$(),3,1) IF EC <> 0 THEN _ EL = 20242 : _ GOTO 21900 20243 CALL WILDFILE (WORK.ARA$(1),Z$,OK) IF NOT OK THEN _ GOTO 20242 20244 IF USER.SECURITY.LEVEL < VAL(WORK.ARA$(2)) THEN _ GOTO 20245 FILE.PASSWORD$ = WORK.ARA$(3) IF FILE.PASSWORD$ = "" THEN _ GOTO 20247 CALL ALLCAPS (FILE.PASSWORD$) IF FILE.PASSWORD$ = PASSWORD$ THEN _ GOTO 20247 A$ = "Enter PASSWORD to download " + _ FILE.NAME$ GOSUB 21660 IF FILESYS.PARAMETER > 1 THEN _ RETURN IF Q = 0 THEN _ RETURN CALL ALLCAPS (B$(1)) IF B$(1) = FILE.PASSWORD$ THEN _ GOTO 20247 20245 VIOLATION$ = "DownLoad " + _ FILE.NAME$ 20246 CALL SVIOLATION IF DENY.ACCESS THEN _ FILESYS.PARAMETER = 4 RETURN 20247 DF = 0 CALL BRKFNAME (FILE.NAME$,DR$,X$,EXTENTION$,FALSE) IF AUTODOWNLOAD.IN.PROGRESS THEN _ A$ = "Transferring -- " + _ B$(ANS.INDEX) : _ ' KG081201 GOSUB 21640 : _ IF FILESYS.PARAMETER > 1 THEN _ RETURN IF INSTR("...WRK.FW .ARC.EXE.COM.OBJ.WKS.LBR.ZIP.PAK.ZOO.LZH.","."+EXTENTION$+".") > 2 OR _ ' KG081601 MID$(EXTENTION$,2,1) = "Q" OR _ (REQUIRE.NON.ASCII AND EXTENTION$ = "BAS") THEN _ DF = TRUE ' KG081201 20248 A$ = "" IF BATCH.TRANSFER THEN _ IF ANS.INDEX < LAST.DOWNLOAD THEN _ ' KG081201 GOTO 20260 CALL XFERTYPE (2,TRUE) IF FF THEN _ GOTO 20260 CALL XFERTYPE (1,TRUE) IF SUBROUTINE.PARAMETER = -1 THEN _ FILESYS.PARAMETER = 7 : _ ' KG081201 RETURN 20260 TRANSFER.FUNCTION = 1 GOSUB 21790 IF FILESYS.PARAMETER > 1 THEN _ RETURN BATCH.TRANSFER = BATCH.PROTO 'Pe Batch Mod ' BATCH.TRANSFER = (BATCH.PROTO AND (LAST.DOWNLOAD > FIRST.DOWNLOAD)) IF BATCH.TRANSFER AND COMMAND.TRANSFER$ = "" THEN _ COMMAND.TRANSFER$ = FT$ ON INSTR("AXCYN",INTERNAL.PROTO$) GOTO _ 20340, _ ' ASCII DOWNLOAD 20290, _ ' XMODEM 20290, _ ' XMODEM CRC 20270, _ ' YMODEM 21700 ' NONE - CANCEL ' ' * EXTERNAL PROTOCOL DOWNLOADS/UPLOADS ' 20261 IF REQ.8.BIT THEN _ IF NOT EIGHT.BIT THEN _ GOSUB 20318 : _ IF FILESYS.PARAMETER > 1 THEN _ RETURN _ ELSE GOSUB 20992 : _ IF FILESYS.PARAMETER > 1 THEN _ RETURN IF TRANSFER.FUNCTION = 1 THEN _ GOSUB 20750 : _ CLOSE 2 : _ IF FILESYS.PARAMETER > 1 OR NOT OK THEN _ RETURN IF BATCH.TRANSFER THEN _ IF ANS.INDEX < LAST.DOWNLOAD THEN _ ' KG081201 RETURN _ ELSE BLOCKS.IN.FILE# = BATCH.BLOCKS# : _ BYTES.IN.FILE# = BATCH.BYTES# : _ NUM.DNLD.BYTS! = BATCH.BYTES# : _ IF BYTES.IN.FILE# < 1 THEN _ ' KG082507 RETURN _ ' KG082507 ELSE GOSUB 20780 : _ ' KG082507 IF FILESYS.PARAMETER > 1 OR NOT OK THEN _ ' KG082507 RETURN ' KG082507 IF AUTODOWNLOAD.IN.PROGRESS THEN _ CALL SENDNAME : _ IF ABORT THEN _ DOWNLOAD.COMPLETED = FALSE : _ GOSUB 21760 : _ RETURN CALL TRANSFER 20262 IF PRIVATE.DOOR THEN _ COMMAND.TRANSFER$ = FT$ : _ CALL XFERTYPE (2,TRUE) : _ COMMAND.TRANSFER$ = "" CALL OPENWORK (2,"XFER-" + NODE.ID$ + ".DEF") IF EC <> 0 THEN _ GOTO 20267 CALL READPARMS (WORK.ARA$(), FAILURE.PARM, 1) IF EC <> 0 THEN _ GOTO 20267 CALL KILLWORK ("XFER-" + NODE.ID$ + ".DEF") 20264 IF PRIVATE.DOOR THEN _ FILE.NAME$ = WORK.ARA$(1) : _ CALL BRKFNAME (FILE.NAME$,X$,FILE.NAME.HOLD$,Y$,TRUE) : _ FILE.NAME.HOLD$ = FILE.NAME.HOLD$ + _ Y$ : _ SIZE.ONLY = TRUE : _ CALL OPENWORK (2,FILE.NAME$) : _ GOSUB 20760 : _ IF FILESYS.PARAMETER > 1 OR NOT OK THEN _ RETURN IF LEFT$(WORK.ARA$(FAILURE.PARM),1) = "L" THEN _ MID$(WORK.ARA$(FAILURE.PARM),1,1) = FAILURE.STRING$ 20265 IF TRANSFER.FUNCTION = 2 THEN _ IF INSTR(WORK.ARA$(FAILURE.PARM),FAILURE.STRING$) <> 1 THEN _ GOTO 20700 _ ELSE GOTO 20730 IF TRANSFER.FUNCTION = 1 THEN _ DOWNLOAD.COMPLETED = (INSTR(WORK.ARA$(FAILURE.PARM),FAILURE.STRING$) <> 1) GOSUB 21760 CALL CARRIER IF SUBROUTINE.PARAMETER = -1 THEN _ FILESYS.PARAMETER = 7 RETURN ' ' * XFER FILE NOT FOUND ' 20267 EL = 20262 GOTO 21900 ' ' * YMODEM DOWNLOAD DRIVER ' 20270 GOTO 20292 ' ' * XMODEM DOWNLOAD DRIVER ' 20290 ' 20292 GOSUB 20750 IF FILESYS.PARAMETER > 1 OR NOT OK THEN _ RETURN A1$ = "SEND" GOSUB 20320 IF FILESYS.PARAMETER > 1 THEN _ RETURN IF LOCAL.USER THEN _ CALL QTPUT1 ("Protocol not available in local mode") : _ RETURN IF AUTODOWNLOAD.IN.PROGRESS THEN _ GOSUB 20294 : _ IF ABORT THEN _ RETURN GOSUB 21300 IF FILESYS.PARAMETER > 1 THEN _ RETURN A$ = "" GOTO 20390 20294 CALL SENDNAME RETURN 20318 A$ = "Please SWITCH to N,8,1 for binary transfer" GOSUB 21630 IF FILESYS.PARAMETER > 1 THEN _ RETURN CALL DELAYIT (3) RETURN 20320 IF NOT EIGHT.BIT THEN _ GOSUB 20318 : _ IF FILESYS.PARAMETER > 1 THEN _ RETURN 20325 IF CHECKSUM THEN _ NEGATIVE.ACKNOWLEDGE$ = CHR$(21) : _ SOL = 132 _ ELSE NEGATIVE.ACKNOWLEDGE$ = "C" : _ SOL = 133 20330 IF AUTODOWNLOAD.IN.PROGRESS THEN _ RETURN A$ = PROTO.PROMPT$ + _ " " + A1$ + _ " of " + _ FILE.NAME.HOLD$ + _ " ready. aborts" GOSUB 21650 IF A1$ = "SEND" THEN _ CALL TALK (8,A$) _ ELSE CALL TALK (9,A$) RETURN ' ' * ASCII DOWNLOAD DRIVER ' 20340 IF DF THEN _ A$ = "Switch to a non-ascii protocol" : _ GOSUB 21650 : _ GOTO 21700 GOSUB 20750 IF FILESYS.PARAMETER > 1 OR NOT OK THEN _ RETURN CALL OPENWORK (2,FILE.NAME$) IF (ANS.INDEX = FIRST.DOWNLOAD OR NOT CONCAT.FILES) THEN _ ' KG081201 A$ = "^X aborts. ^S suspends ^Q resumes" : _ GOSUB 21640 : _ IF FILESYS.PARAMETER > 1 THEN _ RETURN _ ELSE A$ = PROTO.PROMPT$ + " SEND of " + _ FILE.NAME.HOLD$ + _ " ready. Press Any Key to start" : _ TURBO.KEY = 2 : _ FORCE.KEYBOARD = TRUE : _ ' KG090101 GOSUB 21660 : _ IF FILESYS.PARAMETER > 1 THEN _ RETURN 20380 STOP.INTERRUPTS = FALSE TU = 0 SWAP TU,PAGE.LENGTH CALL BUFFILE (FILE.NAME$,X) SWAP TU,PAGE.LENGTH NON.STOP = (PAGE.LENGTH < 1) IF STOP.FILE THEN _ DOWNLOAD.COMPLETED = FALSE : _ GOTO 20390 20381 IF (ANS.INDEX = LAST.DOWNLOAD OR NOT CONCAT.FILES) THEN _ ' KG081201 CALL QTPUT (CHR$(26),0) : _ IF NOT LOCAL.USER AND SUBROUTINE.PARAMETER = 0 THEN _ FOR X = 1 TO 5 : _ CALL PUTCOM (CHR$(7)) : _ CALL DELAYIT (3) : _ NEXT 20385 DOWNLOAD.COMPLETED = TRUE 20390 GOTO 21760 ' ' * U - COMMAND FROM FILES MENU (UPLOAD) ' 20395 GOSUB 21640 IF FILESYS.PARAMETER > 1 THEN _ RETURN A$ = "Correct name of file to upload" + _ PRESS.ENTER.EXPERT$ GOSUB 21660 IF FILESYS.PARAMETER > 1 THEN _ RETURN IF Q = 0 THEN _ RETURN B$(ANS.INDEX) = B$(1) GOTO 20435 20400 CALL TIMEBACK (1) ' KG082701 GOSUB 20420 ' KG081201 FIRST.UPLOAD = ANS.INDEX ' KG081201 GOTO 20430 20420 A$ = "Upload what file(s)" ' KG081201 GOSUB 21668 ' KG081201 RETURN ' ' * SEARCH FOR DUPLICATE FILENAME ' 20430 Z$ = B$(LAST.INDEX) ' KG081201 IF LEN(Z$) = 1 THEN _ CALL ALLCAPS (Z$) : _ IF INSTR(DFLTXFER$,Z$) > 0 THEN _ LAST.INDEX = LAST.INDEX - 1 : _ ' KG081201 COMMAND.TRANSFER$ = Z$ FOR ANS.INDEX = FIRST.UPLOAD TO LAST.INDEX ' KG081201 GOSUB 20435 IF FILESYS.PARAMETER > 1 THEN _ ANS.INDEX = LAST.INDEX + 1 ' KG081201 NEXT COMMAND.TRANSFER$ = "" RETURN 20435 FILE.NAME.HOLD$ = B$(ANS.INDEX) CALL ALLCAPS(FILE.NAME.HOLD$) FILE.NAME$ = FILE.NAME.HOLD$ VIOLATION$ = "Upload " ' IF INSTR(FILE.NAME$,":") OR _ ' INSTR(FILE.NAME$,"\") OR _ ' INSTR(FILE.NAME$," ") OR _ 'Pe 06/06/89 ' INSTR(FILE.NAME$,"*") OR _ ' INSTR(FILE.NAME$,"?") OR _ 'Pe 06/06/89 ' INSTR(FILE.NAME$,"/") THEN _ ' GOTO 20451 CALL NOPATH (FILE.NAME$,BAD.FILE.NAME.INDEX) ' KG060801 IF BAD.FILE.NAME.INDEX THEN _ ' KG060801 GOTO 20451 ' KG060801 CALL BADFILE (FILE.NAME$,BAD.FILE.NAME.INDEX) 'comment out the NEXT 2 lines if you want to enable files without EXTENSION 'to regular users ' IF EXT$ = "" AND USER.SECURITY.LEVEL < OVERWRITE.SECURITY.LEVEL THEN _ GOTO 20451 'Pe 12/22/88 ' ON BAD.FILE.NAME.INDEX GOTO 20440,20451,20515 20440 TMP.FILE.NAME$ ="NOTHANX.DEF" 'PE mode CALL FINDIT (TMP.FILE.NAME$) 'DGS-UNW IF OK THEN 'DGS-UNW CALL QTPUT ("Checking off line file list....",1) 'Pe 02/11/89 OPEN TMP.FILE.NAME$ FOR INPUT AS #9 'DGS-UNW HAV.FILE$ = "" 'DGS-UNW FILE.IN.LIST = FALSE 'DGS-UNW WHILE NOT EOF(9) AND NOT FILE.IN.LIST 'DGS-UNW INPUT #9, HAV.FILE$ 'DGS-UNW CALL ALLCAPS (HAV.FILE$) 'DGS-UNW FILE.IN.LIST = (INSTR(FILE.NAME.HOLD$,HAV.FILE$) > 0) 'DGS-UNW WEND 'DGS-UNW CLOSE 9 'DGS-UNW END IF 'DGS-UNW IF FILE.IN.LIST THEN _ 'DGS-UNW CALL BUFFILE ("NOTHANX.MSG",X) : _ 'Pe 02/19/89 GOTO 20453 'DGS-UNW CALL ROTORSDIR (FILE.NAME$,SUBDIR$(),SUBDIR.COUNT,TRUE) 20450 IF OK THEN _ GOTO 20452 CLOSE 2 ' MC0220 OPEN "EXTCHECK.DEF" FOR INPUT AS #2 ' MC0220 DO WHILE NOT EOF(2) ' MC0220 INPUT #2, CHECK$ ' MC0220 IF INSTR(FILE.NAME$,".") AND _ ' MC0220 RIGHT$(FILE.NAME.HOLD$,3) <> CHECK$ THEN _ ' MC0220 FILE.NAME$ = LEFT$(FILE.NAME.HOLD$,LEN(FILE.NAME.HOLD$)-3) + _ CHECK$ : _ ' MC0220 CALL ROTORSDIR (FILE.NAME$,SUBDIR$(),SUBDIR.COUNT,TRUE) ' MC0220 IF OK THEN _ ' MC0220 GOTO 20452 ' MC0220 LOOP ' MC0220 CLOSE 2 ' MC0220 GOTO 20475 CALL BRKFNAME (FILE.NAME$,DR$,X$,EXTENTION$,FALSE) IF EXTENTION$ = DEFAULT.EXTENSION$ THEN _ GOTO 20475 X$ = X$ + "." + DEFAULT.EXTENSION$ CALL ROTORSDIR (X$,SUBDIR$(),SUBDIR.COUNT,FALSE) IF OK THEN _ FILE.NAME.HOLD$ = DEFAULT.EXTENSION$ + " ver of " + FILE.NAME.HOLD$ : _ GOTO 20454 GOTO 20475 20451 A$ = "Invalid file name. File name cannot contain a Drive letter"+CRLF$ +_ "Subdirectory name, a Space, or any WildCard Characters " GOSUB 21655 CALL DELAYIT (2) FILESYS.PARAMETER = 3 RETURN 20452 IF USER.SECURITY.LEVEL < OVERWRITE.SECURITY.LEVEL THEN _ GOTO 20453 A$ = "Overwrite file (Y,[N])" GOSUB 21660 IF FILESYS.PARAMETER > 1 THEN _ RETURN IF NOT YES THEN _ GOTO 20453 Z$ = FILE.NAME$ CALL KILLWORK (FILE.NAME$) IF EC <> 0 THEN _ EL = 20452 : _ GOTO 21900 GOTO 20475 20453 CLOSE 2 IF USER.SECURITY.LEVEL >= ADD.DIR.SECURITY THEN _ GOTO 20455 20454 CALL QTPUT1 ("Thanks, but we already have " + FILE.NAME.HOLD$) CALL UPDTCALR ("Upload duplicate " + FILE.NAME.HOLD$,1) RETURN 20455 A$ = "Add new directory entry (Y,[N])" TURBO.KEY = - TURBO.KEY.USER GOSUB 21660 IF FILESYS.PARAMETER > 1 THEN _ RETURN IF NOT YES THEN _ RETURN ADDING.DESC.ONLY = TRUE FT$ = "l" CALL UPDTUPLOAD (CATEGORY.NAME$(),CATEGORY.CODE$(),LINES.IN.MESSAGE,1) 'UPL-MOD GOSUB 20702 RETURN 20475 FILE.NAME$ = LEFT$(FILE.NAME$,LEN(FILE.NAME$)-3) + _ 'MC0220 RIGHT$(FILE.NAME.HOLD$,3) 'MC0220 Z$ = UPLOAD.DRIVE.FILE$ CALL FINDFREE IF VAL(FREE.SPACE$) < 4096 THEN _ CALL QTPUT1 ("No room for uploads. Try tomorrow.") : _ ANS.INDEX = LAST.INDEX + 1 : _ ' KG081201 RETURN A$ = "Upload disk has" + _ FREE.SPACE$ GOSUB 21640 IF FILESYS.PARAMETER > 1 THEN _ RETURN '***************** CALL UPDTUPLOAD (CATEGORY.NAME$(),CATEGORY.CODE$(),LINES.IN.MESSAGE,1) '<++++++ '***************** IF ABORT THEN _ 'PE 12/14/88 ABORT = FALSE : _ 'PE 12/14/88 RETURN LINE.25$ = "(U) " + _ FILE.NAME.HOLD$ SUBROUTINE.PARAMETER = 2 CALL LINE25 A$ = "" OK = TRUE 20477 CALL XFERTYPE (2,TRUE) IF FF THEN _ GOTO 20500 CALL XFERTYPE (1,TRUE) IF SUBROUTINE.PARAMETER = -1 THEN _ FILESYS.PARAMETER = 7 : _ ' KG081201 RETURN 20500 CALL AUTOLOGOFF 'Autologoff mod TRANSFER.FUNCTION = 2 AUTODOWNLOAD.IN.PROGRESS = FALSE GOSUB 21790 IF FILESYS.PARAMETER > 1 THEN _ RETURN ON INSTR("AXCYN",INTERNAL.PROTO$) GOTO _ 20560, _ ' ASCII UPLOAD 20542, _ ' XMODEM 20542, _ ' XMODEM CRC 20542, _ ' YMODEM 20735 ' NONE - CANCEL GOTO 20261 20510 D$ = " by SYSOP aborts" GOSUB 21710 RETURN 20515 CALL SVIOLATION IF DENY.ACCESS THEN _ FILESYS.PARAMETER = 4 : _ RETURN GOTO 20420 ' ' * XMODEM/YMODEM UPLOAD DRIVER ' 20542 A1$ = "RECEIVE" GOSUB 20320 IF FILESYS.PARAMETER > 1 THEN _ RETURN OK = TRUE GOSUB 20860 IF FILESYS.PARAMETER > 1 THEN _ RETURN IF OK THEN _ GOTO 20700 GOTO 20730 ' ' * ASCII UPLOAD ' 20560 LINE.ACK = (DEFAULT.LINE.ACK$ <> "") IF LINE.ACK THEN _ A$ = "Acknowledge each line ([Y],N)" : _ TURBO.KEY = - TURBO.KEY.USER : _ LINE.ACK = NOT NO : _ GOSUB 21660 : _ IF FILESYS.PARAMETER > 1 THEN _ RETURN CALL QTPUT1 ("Transfer MUST end with a ") CALL QTPUT1 (PROTO.PROMPT$+" RECEIVE of " + FILE.NAME.HOLD$ + " ready") OK = FALSE XOFF = FALSE CALL OPENOUTW(FILE.NAME$) IF EC <> 0 AND EC <> 53 THEN _ EL = 20560 : _ GOTO 21900 GOSUB 20510 IF FILESYS.PARAMETER > 1 THEN _ RETURN 20600 CALL EOFCOMM (CHAR%) WHILE CHAR% <> -1 CALL CARRIER IF SUBROUTINE.PARAMETER = -1 THEN _ FILESYS.PARAMETER = 7 : _ RETURN IF NOT FOSSIL THEN _ IF LOF(3) < 512 THEN _ CALL PUTCOM(XOFF$) : _ XOFF = TRUE 20610 CALL FLUSHCOM (X$) IF SUBROUTINE.PARAMETER = -1 THEN _ FILESYS.PARAMETER = 7 : _ ' KG081201 RETURN IF INSTR(X$,CHR$(11)) THEN _ GOTO 20650 OK = TRUE 20620 CALL PRINTWRK (X$) IF LINE.ACK THEN _ IF INSTR(X$,CHR$(10)) > 0 THEN _ CALL PUTCOM (DEFAULT.LINE.ACK$) IF EC <> 0 THEN _ EL = 20620 : _ GOTO 21900 D$ = X$ NUM.RETURNS = 0 GOSUB 21720 IF FILESYS.PARAMETER > 1 THEN _ RETURN 20621 CALL FINDFUNC IF SUBROUTINE.PARAMETER < 0 THEN _ FILESYS.PARAMETER = 2 : _ RETURN IF KEY.PRESSED$ = ESCAPE$ THEN _ GOTO 20745 IF NOT OK THEN _ GOTO 20670 CALL EOFCOMM (CHAR%) 20630 WEND CALL CARRIER IF SUBROUTINE.PARAMETER = -1 THEN _ FILESYS.PARAMETER = 7 : _ RETURN IF XOFF THEN _ XOFF = FALSE : _ CALL PUTCOM (XON$) : _ IF EC <> 0 THEN _ EL = 20630 : _ GOTO 21900 GOTO 20600 20650 X = INSTR(X$,CHR$(11)) IF X = 1 THEN _ IF NOT OK THEN _ GOTO 20730 _ ELSE GOTO 20700 CALL PRNTWRKA (LEFT$(X$,X-1)) IF EC <> 0 THEN _ EL = 20650 : _ GOTO 21900 GOTO 20700 20670 A$ = XOFF$ + _ "System error! Upload aborted continues" 20675 GOSUB 21650 IF FILESYS.PARAMETER > 1 THEN _ RETURN CALL DELAYIT (3) CALL PUTCOM(XON$) 20680 CALL EOFCOMM (CHAR%) WHILE CHAR% <> -1 CALL FLUSHCOM(X$) IF INSTR(X$,CHR$(11)) THEN _ GOTO 20730 20685 CALL CARRIER IF SUBROUTINE.PARAMETER = -1 THEN _ FILESYS.PARAMETER = 7 : _ RETURN CALL EOFCOMM (CHAR%) WEND GOTO 20680 ' ' * UPDATE UPLOAD DIRECTORY ' 20700 GOSUB 21780 IF FILESYS.PARAMETER > 1 THEN _ RETURN 20702 CALL UPDTUPLOAD (CATEGORY.NAME$(),CATEGORY.CODE$(),LINES.IN.MESSAGE,2) '<++++++ '***** AUTO UP MOD ***** IF AUTO.END = 1 THEN _ 'AUTO-UP MOD to next comment CALL BRKFNAME (FILE.NAME$,DR$,X$,EXTENTION$,TRUE): _ Z$ = X$+EXTENTION$+DF$+" at "+TIM$ +" using " + FT$ + STR$(BYTES.IN.FILE#) :_ CALL UPDTCALR (Z$,2) : _ RETURN 'AUTO-UP MOD '***** end of Auto Up Mod**** PRIVATE.DOOR = FALSE IF NOT GET.EXT.DESC THEN _ GOTO 20710 MSG.HEADER$ = "Extended Description for " + FILE.NAME.HOLD$ ' KG072003 SYSOP.COMMENT = TRUE MAX.MESSAGE.LINES = MAX.EXTENDED.LINES LL = RIGHT.MARGIN RIGHT.MARGIN = 30 + MAX.DESC.LEN FILESYS.PARAMETER = 5 RETURN 20705 MAX.MESSAGE.LINES = MAX.MESSAGE.LINES.DEF RIGHT.MARGIN = LL CALL UPDTUPLOAD (CATEGORY.NAME$(),CATEGORY.CODE$(),LINES.IN.MESSAGE,3) '<++++++ 20710 ADDING.DESC.ONLY = FALSE IF BYTES.IN.FILE# > 0.0 THEN _ GOTO 21770 20730 GOSUB 21780 CALL QTPUT1 ("Upload aborted") PRIVATE.DOOR = FALSE 20735 CALL KILLWORK (FILE.NAME$) IF EC <>0 THEN _ EL = 20736 : _ GOTO 21900 RETURN ' ' * SYSOP ABORTED UPLOAD ' 20745 A$ = XOFF$ + _ "SYSOP aborted upload. Stop tranfer. continues" GOTO 20675 ' ' * CALCULATE DOWNLOAD TIME ESTIMATE ' 20750 START.OF.HEADER$ = CHR$(1 - (INTERNAL.PROTO$ = "Y")) CALL OPENRSEQ (FILE.NAME$,MAX.BLOCK,DF,FLEN) 20760 IF EC <> 0 THEN _ CALL QTPUT1 ("Unable to access "+FILE.NAME.HOLD$) : _ CALL UPDTCALR ("Unable to access "+FILE.NAME$,2) : _ OK = FALSE : _ EC = 0 : _ BYTES.IN.FILE# = 0 : _ RETURN BYTES.IN.FILE# = LOF(2) NUM.DNLD.BYTS! = LOF(2) OK = TRUE IF SIZE.ONLY THEN _ SIZE.ONLY = FALSE : _ RETURN BLOCKS.IN.FILE# = MAX.BLOCK IF BATCH.TRANSFER THEN _ TEMP# = BATCH.BLOCKS# + BLOCKS.IN.FILE# : _ ' KG081502 CALL CHKTREMAIN (TIME.REMAINING!) : _ ' KG081502 IF (INT(TEMP# / 60) + 1) > INT(TIME.REMAINING!) THEN _ ' KG081502 CALL QTPUT1 ("Omitting " + FILE.NAME.HOLD$ + ". Insufficient time") : _ ' KG081502 RETURN _ ' KG081502 ELSE BATCH.BLOCKS# = TEMP# : _ ' KG081502 BATCH.BYTES# = BATCH.BYTES# + BYTES.IN.FILE# : _ ' KG081502 CALL OPENWRKA (NODE.WORK.FILE$) : _ ' KG081502 CALL PRNTWRKA (FILE.NAME$) : _ ' KG081502 RETURN ' KG081502 20780 A$ = "File Size :" OK = TRUE IF BLOCK.SIZE > 0 THEN _ A$ = A$ + _ STR$(FIX(BLOCKS.IN.FILE#)) + _ " blocks " 20785 BLOCKS.IN.FILE# = BLOCKS.IN.FILE# / _ VAL(MID$("0000030004501200240048009601920", -4 * BPS, 4)) BLOCKS.IN.FILE# = BLOCKS.IN.FILE# * FLEN / SPEED.FACTOR! IF (ANS.INDEX > 1 AND CONCAT.FILES) THEN _ ' KG081201 RETURN A$ = A$ + _ STR$(BYTES.IN.FILE#) + _ " bytes" GOSUB 21650 IF FILESYS.PARAMETER > 1 THEN _ RETURN IF BYTES.IN.FILE# < 1 THEN _ RETURN 20790 SUBROUTINE.PARAMETER = 2 CALL LINE25 A$ = "Transfer Time:" + _ STR$(INT(BLOCKS.IN.FILE# / 60)) + _ " min," + _ STR$(INT(BLOCKS.IN.FILE# - (INT(BLOCKS.IN.FILE# / 60) * 60))) + _ " sec (approx)" GOSUB 21650 IF FILESYS.PARAMETER > 1 THEN _ RETURN 20791 IF PERSONAL.DOWNLOAD THEN _ RETURN CALL CHKTREMAIN (TIME.REMAINING!) IF SUBROUTINE.PARAMETER = -1 THEN _ FILESYS.PARAMETER = 6 : _ RETURN OK = TRUE IF (INT(BLOCKS.IN.FILE# / 60) + 1) > INT(TIME.REMAINING!) THEN _ A$ = "Not enough time left!" : _ CALL UPDTCALR (FILE.NAME$ + " " + A$,2) : _ CALL QTPUT1 (A$): _ A$ = "" : _ OK = FALSE : _ RETURN CALL AUTOLOGOFF 'Autologoff mod CALL CHECKRATIO (TRUE) ' ' ' *** Tell-m.mod as of 09/10/89****** Pete E ' ' If NOT OK THEN _ RETURN 'Pe 08/27/89 ' NOTIFY$ = WELCOME.FILE.DRV.PATH$ + _ "TELTHEM.DEF" ' <==== NOTE SPELLING CALL FINDIT (NOTIFY$) IF OK THEN _ STOP.INTERRUPTS = TRUE : _ CALL BUFFILE (NOTIFY$,X) '*************************************** RETURN 20810 CALL SETABORT (DELAY!,6) 20840 CALL EOFCOMM (CHAR%) IF CHAR% = -1 THEN _ GOTO 20850 CALL FLUSHCOM(Y$) RETURN 20850 CALL CHECKTIM (DELAY!) ON SUBROUTINE.PARAMETER GOTO 20840,20851 20851 Y$ = "" CALL CHKCARRIER ' KG061203 IF SUBROUTINE.PARAMETER = -1 THEN _ FILESYS.PARAMETER = 7 : _ RETURN RETURN ' ' * XMODEM/YMODEM UPLOAD ' 20860 GOSUB 20992 IF FILESYS.PARAMETER > 1 THEN _ RETURN IF NOT EIGHT.BIT THEN _ GOSUB 21280 : _ IF FILESYS.PARAMETER > 1 THEN _ RETURN 20900 X$ = "" SEC = 1 'CALL OPENOUTW (FILE.NAME$) IF FLEN > WRITE.BUF.DEF THEN _ WRITE.BUF = FLEN _ ELSE WRITE.BUF = WRITE.BUF.DEF CALL OPENRSEQ (FILE.NAME$,Y,DF,WRITE.BUF) IF EC <> 0 AND EC <> 53 THEN _ EL = 20900 : _ GOTO 21900 FIELD #2, WRITE.BUF AS UPLOAD.RECORD$ RECS.WRIT = 0 NUM.IN.BUFF = 0 CALL SETABORT (TRANSFER.ABORT!,WAIT.BEFORE.DISCONNECT) YY$ = " " + _ CHR$(1) + _ CHR$(2) + _ END.TRANSMISSION$ + _ CANCEL$ 20903 CALL PUTCOM (NEGATIVE.ACKNOWLEDGE$) 20920 X = 1 20922 CALL CHKCARRIER ' KG061203 IF SUBROUTINE.PARAMETER = -1 THEN _ FILESYS.PARAMETER = 7 : _ RETURN CALL FINDFUNC IF KEY.PRESSED$ = ESCAPE$ THEN _ GOSUB 20510 :_ IF FILESYS.PARAMETER > 1 THEN _ RETURN _ ELSE GOTO 21240 GOSUB 20810 IF FILESYS.PARAMETER > 1 THEN _ RETURN 20930 J = INSTR(YY$,LEFT$(Y$,1)) ON J GOTO 20960,20999,20999,21220,21230 20960 IF Y$ <> "" THEN _ GOSUB 21280 : _ IF FILESYS.PARAMETER > 1 THEN _ RETURN _ ELSE CALL CHECKTIM (TRANSFER.ABORT!) : _ ON SUBROUTINE.PARAMETER GOTO 20920,21230 20970 X = X + 1 CALL DELAYIT (1) CALL PUTCOM (NEGATIVE.ACKNOWLEDGE$) IF X < 6 THEN _ GOTO 20922 D$ = "Upload Timeout" GOSUB 21710 IF FILESYS.PARAMETER > 1 THEN _ RETURN CALL CHECKTIM (TRANSFER.ABORT!) ON SUBROUTINE.PARAMETER GOTO 20990,21230 20990 GOTO 20920 ' ' * CHANGE TO 8 BIT FOR XMODEM ' 20992 GOSUB 20510 IF FILESYS.PARAMETER > 1 THEN _ FILESYS.PARAMETER = 2 : _ RETURN IF NOT EIGHT.BIT THEN _ PREV.LINE.CONTROL = INP (LINE.CONTROL.REGISTER) : _ CALL DELAYIT (3) : _ SWITCHED.TO.EIGHT = TRUE : _ OUT LINE.CONTROL.REGISTER,3 20996 SO = 0 RETURN ' ' * EXPECTED BLOCK LENGTH. 132 FOR CHECKSUM, 133 FOR CRC, 1029 FOR YMODEM ' 20999 SOL = 896 * J - 1659 + CHECKSUM DATA.SOL = 128 - (SOL > 1024)*896 GOTO 21020 ' ' * XMODEM/YMODEM UPLOAD ' 21000 GOSUB 20810 IF FILESYS.PARAMETER > 1 THEN _ RETURN IF Y$ = "" THEN _ D$ = "Upload Timeout" : _ GOSUB 21710 : _ IF FILESYS.PARAMETER > 1 THEN _ RETURN _ ELSE GOTO 21040 21020 X$ = X$ + _ Y$ IF LEN(X$) < SOL THEN _ GOTO 21000 21040 IF LEN(X$) = SOL THEN _ GOTO 21090 21050 IF LEN(X$) > SOL THEN _ GOTO 21180 21060 IF X$ = END.TRANSMISSION$ THEN _ GOTO 21220 21070 IF X$ = CANCEL$ THEN _ GOTO 21230 21080 GOTO 21170 21090 JX = ASC(MID$(X$,2,1)) IF SEC = JX THEN _ GOTO 21100 IF SEC > JX THEN _ CALL PUTCOM (RIGHT$(ACKC$,1 - (JX = 0))) : _ GOTO 21150 GOTO 21200 21100 IF (SEC XOR 255) <> ASC(MID$(X$,3,1)) THEN _ GOTO 21210 21110 IF CHECKSUM THEN _ WK$ = MID$(X$,4,128) : _ GOSUB 21750 : _ IF FILESYS.PARAMETER > 1 THEN _ RETURN _ ELSE IF XMODEM.CHECKSUM <> ASC(MID$(X$,132,1)) THEN _ GOTO 21190 _ ELSE GOTO 21120 WK$ = MID$(X$,4) GOSUB 21750 IF FILESYS.PARAMETER > 1 THEN _ RETURN 21113 IF CRC.VALUE <> 0 THEN _ GOTO 21191 21120 SO = SO + 1 CALL PUTCOM (ACKNOWLEDGE$) 21131 IF NUM.IN.BUFF >= WRITE.BUF THEN _ NUM.IN.BUFF = 0 : _ CALL PUTWORK (UPLOAD.RECORD$,RECS.WRIT,WRITE.BUF) : _ IF EC <> 0 THEN _ EL = 21131 : _ GOTO 21900 MID$(UPLOAD.RECORD$,NUM.IN.BUFF+1,DATA.SOL) = WK$ NUM.IN.BUFF = NUM.IN.BUFF + DATA.SOL 21145 SEC = 255 AND (SEC + 1) CALL QLPRNT ("OK Rec Blk #",SO) 21150 X$ = "" XMODEM.CHECKSUM = 0 CALL SETABORT(TRANSFER.ABORT!,45) GOTO 20920 21170 A$ = "Short Blk #" GOTO 21212 21180 A$ = "Long Blk #" GOTO 21212 21190 A$ = "Chksum Error #" GOTO 21212 21191 A$ = "CRC Error" GOTO 21212 21200 A$ = "Blk # Error in #" JX = ASC(MID$(X$,2,1)) IF SEC < JX THEN _ GOTO 21212 CALL PUTCOM (ACKNOWLEDGE$) ' RIGHT$(ACKC$,1 - (JX = 0))) GOTO 21150 21210 A$ = "Complement Error in #" 21212 GOSUB 21280 IF FILESYS.PARAMETER > 1 THEN _ RETURN CALL PUTCOM (NEGATIVE.ACKNOWLEDGE$) CALL LPRNT(LINE.FEED$ + A$ + STR$(SO + 1),0) GOTO 21150 21220 IF NUM.IN.BUFF < 1 THEN _ GOTO 21225 WK$ = LEFT$(UPLOAD.RECORD$,NUM.IN.BUFF) CALL OPENRSEQ (FILE.NAME$,MAX.BLOCK,DF,128) FIELD #2, 128 AS UPLOAD.RECORD$ MAX.BLOCK = CDBL(RECS.WRIT) * WRITE.BUF / 128 FOR I = 1 TO NUM.IN.BUFF/128 CALL PUTWORK (MID$(WK$,128*I-127,128),MAX.BLOCK,128) IF EC > 0 THEN _ EL = 21220 : _ GOTO 21900 NEXT CLOSE 2 21225 CALL PUTCOM (ACKNOWLEDGE$) GOTO 21250 21230 D$ = LINE.FEED$ + _ "Transfer Aborted" GOSUB 21710 IF FILESYS.PARAMETER > 1 THEN _ RETURN 21240 CALL EOFCOMM (CHAR%) IF CHAR% <> -1 THEN _ GOSUB 21280 : _ IF FILESYS.PARAMETER > 1 THEN _ RETURN _ ELSE CALL DELAYIT (1) : _ GOTO 21240 CALL PUTCOM (CANCEL$ + CANCEL$) CALL DELAYIT (1) CALL EOFCOMM (CHAR%) IF CHAR% <> -1 THEN _ GOTO 21240 OK = FALSE 21250 EIGHT.BIT = TRUE RETURN ' ' * CLEAR GARBAGE OUT OF COMMUNICATIONS BUFFER ' 21280 CALL CHKCARRIER ' KG061203 IF SUBROUTINE.PARAMETER = -1 THEN _ FILESYS.PARAMETER = 7 : _ RETURN CALL EOFCOMM (CHAR%) IF CHAR% = -1 THEN _ RETURN 21281 CALL FLUSHCOM(DF$) IF SUBROUTINE.PARAMETER = -1 THEN _ FILESYS.PARAMETER = 7 : _ ' KG081201 RETURN GOTO 21280 ' ' * XMODEM/YMODEM DOWNLOAD ' 21300 GOSUB 20992 IF FILESYS.PARAMETER > 1 THEN _ RETURN SEC = 0 GOSUB 21280 IF FILESYS.PARAMETER > 1 THEN _ RETURN NEGATIVE.ACKNOWLEDGE$ = CHR$(21) CALL SETABORT (TRANSFER.ABORT!,WAIT.BEFORE.DISCONNECT) CALL OPENRSEQ (FILE.NAME$,MAX.BLOCK,DF,FLEN) 'Pe 08/15/89 21303 FIELD 2,FLEN AS DOWNLOAD.RECORD$ ' ' * ROUTINE TO START AN "XMODEM" OR "YMODEM" DOWNLOAD. CHECK'S INITIAL ' * "HANDSHAKE" TO SEE IF CHARACTER IS SENT IS A: ' * "X" = XMODEM WITH CHECKSUM AND 128 CHARACTER RECORDS ' * "C" = XMODEM WITH CRC CHECK AND 128 CHARACTER RECORDS ' * "Y" = YMODEM WITH CRC CHECK AND 1024 CHARACTER RECORDS ' 21350 CALL EOFCOMM (CHAR%) WHILE CHAR% <> -1 21360 CALL GETCOM(Y$) IF Y$ = CANCEL$ THEN _ GOTO 21560 21380 CHECKSUM = (Y$ = NEGATIVE.ACKNOWLEDGE$) IF CHECKSUM THEN _ FF = INSTR(INTERNAL.EQUIV$,"X") : _ IF FF > 0 THEN _ FT$ = MID$(DFLTXFER$,FF,1) : _ GOTO 21480 _ ELSE FT$ = "X" : _ GOTO 21480 _ ELSE IF Y$ = "C" THEN _ GOTO 21480 CALL EOFCOMM (CHAR%) 21390 WEND GOSUB 21460 IF FILESYS.PARAMETER > 1 THEN _ RETURN IF KEY.PRESSED$ = ESCAPE$ THEN _ RETURN CALL CHECKTIM (TRANSFER.ABORT!) ON SUBROUTINE.PARAMETER GOTO 21350,21455 21410 CALL SETABORT (TRANSFER.ABORT!, WAIT.BEFORE.DISCONNECT) ' ' * ROUTINE TO WAIT FOR AN ACKNOWLEDGEMENT ON AN "XMODEM" OR "YMODEM" ' * DOWNLOAD ' 21415 CALL EOFCOMM (CHAR%) IF CHAR% <> -1 THEN _ GOTO 21420 GOSUB 21460 IF FILESYS.PARAMETER > 1 THEN _ RETURN IF KEY.PRESSED$ = ESCAPE$ THEN _ RETURN CALL CHECKTIM (TRANSFER.ABORT!) ON SUBROUTINE.PARAMETER GOTO 21415,21455 21420 CALL GETCOM(Y$) IF Y$ = ACKNOWLEDGE$ THEN _ GOTO 21470 21440 IF Y$ <> NEGATIVE.ACKNOWLEDGE$ THEN _ GOTO 21450 21443 D$ = LINE.FEED$ + _ "Error -> retrans #" + _ STR$(SO) GOSUB 21710 IF FILESYS.PARAMETER > 1 THEN _ RETURN 21445 SO = SO - 1 GOTO 21490 21450 IF Y$ = CANCEL$ THEN _ IF HAVE.A.CANCEL THEN _ GOTO 21560 _ ELSE HAVE.A.CANCEL = TRUE CALL CHECKTIM (TRANSFER.ABORT!) ON SUBROUTINE.PARAMETER GOTO 21415,21455 21455 D$ = "Download timeout" GOSUB 21710 IF FILESYS.PARAMETER > 1 THEN _ RETURN GOTO 21560 21460 CALL CHKCARRIER ' KG061203 CALL FINDFUNC IF SUBROUTINE.PARAMETER < 0 THEN _ FILESYS.PARAMETER = 7 : _ RETURN IF KEY.PRESSED$ = ESCAPE$ THEN _ GOTO 21540 RETURN ' ' * DISPLAY BLOCK SENT OK AND THEN READ IN NEXT RECORD FROM DISK TO DOWNLOAD ' 21470 CALL QLPRNT ("OK Sent Blk #",SO) 21480 IF LOC(2) => MAX.BLOCK THEN _ GOTO 21530 CALL GETWORK (FLEN) IF EC <> 0 THEN _ EL = 21480 : _ GOTO 21900 SEC = 255 AND (SEC + 1) GOTO 21490 ' ' * ROUTINE TO WRITE OUT AN "XMODEM" OR "YMODEM" RECORD TO THE COMM. PORT ' 21490 SO = SO + 1 CALL PUTCOM (START.OF.HEADER$ + CHR$(SEC) + CHR$(SEC XOR 255)) CALL PUTCOM (DOWNLOAD.RECORD$) HAVE.A.CANCEL = FALSE 21503 WK$ = DOWNLOAD.RECORD$ 21504 GOSUB 21750 IF FILESYS.PARAMETER > 1 THEN _ RETURN 21510 IF CHECKSUM THEN _ CALL PUTCOM(CHR$(XMODEM.CHECKSUM)) _ ELSE CALL PUTCOM(CHR$(CRC.HIGH) + CHR$(CRC.LOW)) GOSUB 21280 IF FILESYS.PARAMETER > 1 THEN _ RETURN GOTO 21410 ' ' * END-OF-FILE FOR XMODEM DOWNLOADS -- SEND THE "EOT" CHARACTER AND WAIT UP ' * TO 2 SECONDS FOR A POSITIVE RESPONSE (I.E. AN "ACK"). IF NONE IS ' * RE-TRY UP TO 10 TIMES. IF NO POSITIVE RESPONSE IS RECEIVED AFTER TEN ' * ATTEMPTS, ASSUME THE DOWNLOAD WAS UNSUCCESSFULL. ' 21530 CALL PUTCOM (END.TRANSMISSION$) X = 1 21531 GOSUB 20810 IF FILESYS.PARAMETER > 1 THEN _ RETURN IF INSTR(Y$,ACKNOWLEDGE$) THEN _ GOTO 21550 CALL FINDFUNC IF SUBROUTINE.PARAMETER < 0 THEN _ FILESYS.PARAMETER = 2 : _ RETURN IF KEY.PRESSED$ = ESCAPE$ THEN _ GOSUB 21540 : _ GOTO 21545 IF X < 10 THEN _ X = X + 1 : _ GOTO 21531 DOWNLOAD.COMPLETED = FALSE GOTO 21230 21540 GOSUB 20510 IF FILESYS.PARAMETER > 1 THEN _ RETURN RETURN 21545 Y$ = CANCEL$ CALL PUTCOM (CANCEL$ + CANCEL$ + CANCEL$) DOWNLOAD.COMPLETED = FALSE GOTO 21250 21550 DOWNLOAD.COMPLETED = TRUE GOTO 21250 21560 DOWNLOAD.COMPLETED = FALSE D$ = LINE.FEED$ + _ "Caller aborted trans" GOSUB 21710 IF FILESYS.PARAMETER > 1 THEN _ RETURN GOTO 21545 ' ' STANDARD ENTRY FOR RBBS-PC'S COMMON TERMINAL OUTPUT ROUTINE ' ' Modeled on lines 12975 to 12983 in RBBS-PC.BAS 21630 SUBROUTINE.PARAMETER = 1 GOTO 21655 21640 SUBROUTINE.PARAMETER = 3 GOTO 21655 21650 SUBROUTINE.PARAMETER = 5 21655 CALL TPUT IF SUBROUTINE.PARAMETER < 0 THEN _ FILESYS.PARAMETER = 2 : _ RETURN IF SUBROUTINE.PARAMETER = 8 THEN _ GOSUB 21660 RETURN ' ' STANDARD ENTRY FOR RBBS-PC'S COMMON TERMINAL INPUT ROUTINE ' ' Modeled on lines 12995 to 12997 in RBBS-PC.BAS 21660 SUBROUTINE.PARAMETER = 1 CALL TGET 21665 IF SUBROUTINE.PARAMETER < 0 THEN _ ' KG081201 FILESYS.PARAMETER = 2 RETURN 21668 CALL POPCSTACK ' KG081201 GOTO 21665 ' KG081201 21700 EC = 0 RETURN ' ' **** COMMON LOCAL DISPLAY PRINT *** ' ' (formerly lines 1315 to 1320 in RBBS-PC.BAS CPC16-1A 21710 NUM.RETURNS = 1 21720 CALL LPRNT (D$,NUM.RETURNS) RETURN ' ' * XMODEM / CRC INTERFACE ' ' (formerly line 46000 in RBBS-PC.BAS CPC16-1A 21750 XMODEM.CHECKSUM = 0 CRC.VALUE = 0 CALL XMODEM(WK$,XMODEM.CHECKSUM,CRC.VALUE,CRC.HIGH,CRC.LOW) RETURN ' ' * UPDATE DOWNLOAD STATISTICS ' ' (formerly lines 50600 to 50614 in RBBS-PC.BAS CPC16-1A 21760 GOSUB 21780 IF FILESYS.PARAMETER > 1 THEN _ RETURN IF BATCH.TRANSFER THEN _ CALL LINESNFIL (NODE.WORK.FILE$,DOWN.FILES) _ ELSE DOWN.FILES = 1 IF NOT DOWNLOAD.COMPLETED THEN _ AUTO.LOGOFF = FALSE : _ DF$ = " Aborted" _ ELSE CALL LOGDOWN (PERSONAL.DOWNLOAD,1+ANS.INDEX-FIRST.DOWNLOAD) : _ ' KG082601 DOWNLOADS = DOWNLOADS + DOWN.FILES : _ GLOBAL.DL.TODAY! = GLOBAL.DL.TODAY! + DOWN.FILES : _ GLOBAL.DOWNLOADS = GLOBAL.DOWNLOADS + DOWN.FILES : _ DLBYTES! = DLBYTES! + NUM.DNLD.BYTS! : _ GLOBAL.DLBYTES! = GLOBAL.DLBYTES! + NUM.DNLD.BYTS! : _ DL.TODAY! = DL.TODAY! + DOWN.FILES : _ BYTES.TODAY! = BYTES.TODAY! + NUM.DNLD.BYTS! : _ GLOBAL.BYTES.TODAY! = GLOBAL.BYTES.TODAY! + NUM.DNLD.BYTS! : _ ' KG102004 NUM.DNLD.BYTS! = 0 : _ CALL MUZAK (6) : _ DF$ = " Downloaded" : _ IF (ANS.INDEX = LAST.DOWNLOAD OR NOT CONCAT.FILES) THEN _ ' KG081201 CALL SKIPLINE (1) : _ CALL QTPUT1 ("Download successful") IF AUTODOWNLOAD.IN.PROGRESS THEN _ DF$ = " AUTO" + _ MID$(N$,2) IF INSTR(N$,"Aborted") THEN _ AUTODOWNLOAD.IN.PROGRESS = 0 A$ = "" 21770 CALL AMORPM ' KG061203 IF NOT BATCH.TRANSFER THEN _ GOTO 21773 CALL OPENWORK (2,NODE.WORK.FILE$) IF EC > 0 THEN _ RETURN Q = 0 WHILE NOT EOF(2) CALL READANY Q = Q + 1 B$(Q) = A$ WEND 21772 IF Q < 1 THEN _ BATCH.TRANSFER = FALSE : _ CALL CHECKRATIO (FALSE):_ RETURN CALL OPENWORK (2,B$(Q)) IF EC > 0 THEN _ EC = 0 : _ Q = Q - 1 : _ GOTO 21772 BYTES.IN.FILE# = LOF(2) FILE.NAME$ = B$(Q) 21773 CALL BRKFNAME (FILE.NAME$,DR$,X$,EXTENTION$,TRUE) Z$ = X$ + _ EXTENTION$ + _ DF$ + _ " at " + _ TIM$ + _ " using " + _ FT$ + _ STR$(BYTES.IN.FILE#) CALL UPDTCALR (Z$,2) IF BATCH.TRANSFER THEN _ Q = Q - 1 : _ GOTO 21772 CALL CHECKRATIO (FALSE) 21774 IF MENU.INDEX = 6 THEN _ IF DOWNLOAD.COMPLETED THEN _ A$ = X$ : _ SUBROUTINE.PARAMETER = 5 : _ CALL LIBRARY RETURN ' ' ***** TURN ON INTERMEDIATE ECHO **** ' ' (formerly line 50620 in RBBS-PC.BAS CPC16-1A 21780 IF ECHOER$ = "I" THEN _ CALL SETECHO ("I") ' ' * RESTORE COMMUNICATIONS AFTER SWITCH TO 8 BIT ' ' (formerly between lines 50620 and 50630 in RBBS-PC.BAS CPC16-1A IF SWITCHED.TO.EIGHT THEN _ IF SWITCH.BACK THEN _ OUT LINE.CONTROL.REGISTER, PREV.LINE.CONTROL : _ CALL DELAYIT (3) : _ EIGHT.BIT = FALSE : _ SWITCHED.TO.EIGHT = FALSE RETURN ' ' ***** TURN OFF INTERMEDIATE ECHO **** ' ' (formerly line 50630 in RBBS-PC.BAS CPC16-1A 21790 IF ECHOER$ = "I" THEN _ CALL SETECHO ("R") RETURN ' ' ***** DIRECTORY SEARCH **** ' ' (formerly lines 52900 to 52920 in RBBS-PC.BAS CPC16-1A 21800 CK = 2 ' KG081201 21810 A$ = "Search for (in file name/desc, wildcards name only, [ENTER] quits)" MACRO.MIN = 99 GOSUB 21668 ' KG081201 IF Q = 0 THEN _ RETURN 21820 RS$ = B$(ANS.INDEX) ' KG081201 WILD.SEARCH = (INSTR(RS$,"*") > 0 OR INSTR(RS$,"?") > 0) CALL ALLCAPS (RS$) SEARCH.STRING$ = RS$ SEARCH.DATE$ = "" A1$ = RS$ GOTO 21867 ' ' ***** P - personal download **** ' ' (formerly lines 52950 to 52952 in RBBS-PC.BAS CPC16-1A 21850 IF PERSONAL.BEGIN < 1 OR PERSONAL.LEN < 1 THEN _ RETURN DOWNLOAD.FLAG = 0 PERSONAL.DOWNLOAD = TRUE 21852 CALL PERSFILE (MID$(USER.RECORD$,PERSONAL.BEGIN,PERSONAL.LEN),_ DOWNLOAD.FLAG) IF SUBROUTINE.PARAMETER = -1 THEN _ FILESYS.PARAMETER = 7: _ RETURN IF LAST.INDEX <= 0 THEN _ ' KG082601 GOTO 21854 CONCAT.FILES = PERSONAL.CONCAT STOP.INTERRUPTS = TRUE TIME.LOCK.EXEMPT = TRUE GOSUB 20202 IF FILESYS.PARAMETER > 1 THEN _ GOTO 21854 TIME.LOCK.EXEMPT = FALSE CONCAT.FILES = FALSE GOTO 21852 21854 PERSONAL.DOWNLOAD = FALSE RETURN ' ' * N - COMMAND FROM FILES MENU (DISPLAY NEW FILES SINCE LAST DIR DISPLAY) ' ' (formerly lines 53000 to 53070 in RBBS-PC.BAS CPC16-1A 21860 CK = 1 ' KG081201 21862 A1$ = RIGHT$(LM$,4) +_ LEFT$(LM$,2) A$ = "Files on/after (MMDDYY, [ENTER] = last on " + _ A1$ + _ ")" GOSUB 21668 ' KG081201 IF Q = 0 THEN _ RS$ = LM$ : _ GOTO 21866 ' KG081202 21865 IF LEN(B$(ANS.INDEX)) <> 6 THEN _ ' KG081201 GOTO 21862 A1$ = B$(ANS.INDEX) ' KG081201 RS$ = RIGHT$(A1$,2) + _ LEFT$(A1$,4) 21866 SEARCH.DATE$ = RS$ SEARCH.STRING$ = "" LIST.NEW = TRUE 'Pe 09/10/89 21867 ' 21871 B$(1) = "ALL" CALL CONVDIRS (ANS.INDEX) ' KG090205 LIST.DIRECTORY = TRUE ' KG083002 SEARCHING.ALL = TRUE ' Pe 09/10/89 21875 Z$ = B$(ANS.INDEX) ' KG081201 IF NOT SEARCHING.ALL THEN _ ' KG081201 IF Z$ = "ALL" THEN _ ' KG081201 IF NOT LIMIT.SEARCH.TO.FMS THEN _ ' KG081201 GOTO 21890 ' KG081201 21880 QX = ANS.INDEX ' KG081201 GOSUB 20157 ' KG081201 IF FILESYS.PARAMETER > 1 THEN _ RETURN ANS.INDEX = ANS.INDEX + 1 ' KG081201 IF ANS.INDEX <= LAST.INDEX THEN _ ' KG090205 GOTO 21875 LIST.NEW = FALSE SEARCH.STRING$ = "" SEARCH.DATE$ = "" RETURN 21890 G = ANS.INDEX ' KG083002 CALL GETALL (DIRECTORY.PATH$ + DIRECTORY.PREFIX$ + "." + DIRECTORY.EXTENTION$,B$(),DIRECTORY.EXTENTION$,G) SEARCHING.ALL = TRUE LAST.INDEX = G ' KG081201 ANS.INDEX = ANS.INDEX + 1 ' KG081201 GOTO 20157 ' KG081201 ' ' * MAIN FILE SYSTEM ERROR TRAP - ALL ERRORS PASS THROUGH THIS ROUTINE ' ' (formerly lines 13000 to 13500 in RBBS-PC.BAS CPC16-1A 21900 IF DEBUG THEN _ A$ = "RBBSSUB5 DEBUG Error Trap Entry ERL=" + _ STR$(EL) + _ " ERR=" + _ STR$(EC) : _ IF PRINTER THEN _ CALL PRINTIT(A$) _ ELSE CALL LPRNT(A$,1) IF EL = 20126 AND EC = 53 THEN _ GOTO 20142 IF EL = 20242 AND EC = 62 THEN _ CALL UPDTCALR (FILESEC.FILE$ + " bad format!",2) : _ GOTO 20247 IF EL = 20262 THEN _ A$ = "" : _ DOWNLOAD.COMPLETED = FALSE : _ GOTO 20390 IF EL = 20452 AND EC = 53 THEN _ GOTO 20451 IF EL = 20560 AND EC = 67 THEN _ GOTO 20451 IF EL = 20560 AND EC = 70 THEN _ IF VAL(FREE.SPACE$) > 1999 THEN _ GOTO 20610 _ ELSE CALL QTPUT1 ("No room for uploads. Try tomorrow.") : _ GOTO 21700 IF EL = 20620 THEN _ GOTO 20670 IF EL = 20650 THEN _ GOTO 20670 IF EL = 20736 AND EC = 53 THEN _ GOTO 21700 IF EL = 20900 AND EC = 75 THEN _ GOTO 21230 IF EL = 20900 AND EC = 70 THEN _ CALL QTPUT1 ("No room for uploads. Try tomorrow.") : _ GOTO 21230 IF EL = 21131 OR EL = 21220 THEN _ EC = 0 : _ GOTO 21230 IF EL = 21480 THEN _ CALL LOGERROR : _ IF EC = 57 THEN _ CALL QTPUT1 ("Error reading file. Aborting download") : _ DOWNLOAD.COMPLETED = FALSE : _ GOTO 21230 21910 CALL LOGERROR CALL QTPUT1 (CALLERS.RECORD$) FILESYS.PARAMETER = 3 RETURN 21920 ' EXIT RBBS-PC FILE SUBSYSTEM END SUB ' $SUBTITLE: 'GETCOLOR - subroutine to see if user wants color' ' $PAGE ' SUB GETCOLOR STATIC '****************************************************************************** '* Find out if user wants COLOR before getting name * '* * '* The color values are as follows * '* CX$(1)= red CX$(2) = GREEN CX$(3) = YELLOW CX$(4) = BLUE * '* CX$(5)= MAGENTA CX$(6) = CYAN CX$(7) = WHITE CX$(8)= BRT.WHITE * '* * '****************************************************************************** ' 21935 'CALL SKIPLINE(2) 'A$ = CHR$(7)+"Do you want IBM Color (Y/[N]) " 'TURBO.KEY = T.KEY 'CALL TGET 'IF Q = 0 THEN_ ' GOTO 21940 'IF NOT YES THEN GOTO 21940 IF GR < 2 then GOTO 21940 CX$(1) = CHR$(27) + "[01;31;40m": CX$(2) = CHR$(27) + "[01;32;40m" CX$(3) = CHR$(27) + "[01;33;40m": CX$(4) = CHR$(27) + "[01;34;40m" CX$(5) = CHR$(27) + "[01;35;40m": CX$(6) = CHR$(27) + "[01;36;40m" CX$(7) = CHR$(27) + "[01;37;40m": CX$(8) = CHR$(27) + "[01;37;40m" EXIT SUB ' '****************************************************************************** '* Turn Off Color if User does Not want it * '****************************************************************************** ' 21940 ' CX$(1) = "": CX$(2) = "": CX$(3) = "": CX$(4) = "": CX$(5) = "" CX$(6) = "": CX$(7) = "": CX$(8) = "" END SUB '******************** INSERTED AUTO.LOGOFF here ****************** ' ' $SUBTITLE: 'AUTOLOGOFF - Subroutine to to log off after transfer' ' $PAGE ' SUB AUTOLOGOFF STATIC AUTO.END = 0 IF GET.EXT.DESC = TRUE THEN _ EXIT SUB SUBROUTINE.PARAMETER = 1 A$ = CHR$(7)+CX$(2)+"Auto-"+_ CX$(5)+"LogOff"+CX$(2)+" after the transfer"+_ CX$(3)+" ?(Y/[N]) "+CX$(7)+CHR$(7) CALL QTPUT(A$,0) A$="" TURBO.KEY = -TURBO.KEY.USER CALL TGET IF NOT YES THEN _ CALL SKIPLINE (1) : _ EXIT SUB AUTO.END = 1 CALL SKIPLINE (1) END SUB 63100 ' $SUBTITLE: 'DOORRTN - Subroutine to process requests from a door' ' $PAGE ' ' NAME -- DOORRTN ' ' INPUTS -- PARAMETER MEANING ' DOUTx.DEF File of requests ' ' OUTPUTS -- USER.SECURITY.LEVEL Revised Security Level ' ' PURPOSE -- To give Doors a stable way to make requests ' to the host. ' SUB DOORRTN STATIC IF PRIVATE.DOOR OR NOT EXIT.TO.DOORS THEN _ EXIT SUB FILE.NAME$ = "DOUT" + NODE.ID$ + ".DEF" CALL FINDIT (FILE.NAME$) IF NOT OK THEN _ EXIT SUB 63105 IF EOF(2) THEN _ GOTO 63195 CALL READPARMS (A$(),2,1) IF EC > 0 THEN _ GOTO 63115 IF LEN(A$(1)) < 2 THEN _ EXIT SUB B$ = LEFT$(A$(1),2) + "," X = INSTR("SL,UR,",B$) IF X = 0 THEN _ GOTO 63105 X = X\3 + 1 ON X GOTO 63110,63115 GOTO 63105 63110 X$ = LEFT$(A$(2),1) ' SL = Security Level CALL CHECKINT (A$(2)) IF EC > 0 THEN _ GOTO 63105 IF X$ = "+" OR X$ = "-" THEN _ A = USER.SECURITY.LEVEL + TESTED.INTEGER.VALUE _ ELSE A = TESTED.INTEGER.VALUE IF A < SYSOP.SECURITY.LEVEL THEN _ ADJUSTED.SECURITY = (A <> USER.SECURITY.LEVEL) : _ IF ADJUSTED.SECURITY THEN _ USER.SECURITY.LEVEL = A : _ MID$(USER.RECORD$,47,2) = MKI$(A) : _ CALL QTPUT1 ("Security changed to" + STR$(A)) : _ CALL UPDTCALR ("Door reset security to "+STR$(A),2) GOTO 63105 63115 IF LEN(A$(1)) < 7 THEN _ GOTO 63105 IF MID$(A$(1),3,1) <> "(" THEN _ GOTO 63105 X = INSTR(4,A$(1),":") IF X < 1 THEN _ GOTO 63105 CALL CHECKINT (MID$(A$(1),4,X-4)) IF EC > 0 THEN _ GOTO 63105 IF TESTED.INTEGER.VALUE > 128 OR TESTED.INTEGER.VALUE < 1 THEN _ GOTO 63105 A = TESTED.INTEGER.VALUE CALL CHECKINT (MID$(A$(1),X+1)) IF EC > 0 OR TESTED.INTEGER.VALUE < 1 OR TESTED.INTEGER.VALUE > 128 THEN _ GOTO 63105 MID$(USER.RECORD$,A,TESTED.INTEGER.VALUE) = LEFT$(A$(2) + _ SPACE$(TESTED.INTEGER.VALUE),TESTED.INTEGER.VALUE) CALL UPDTCALR ("Door set UR"+STR$(A)+":"+STR$(TESTED.INTEGER.VALUE)+" to <"+A$(2)+">",2) GOTO 63105 63195 CALL KILLWORK (FILE.NAME$) EC = 0 END SUB 63200 ' $SUBTITLE: 'WILDCARD -- Matches string to a pattern' ' $PAGE ' NAME -- WILDCARD ' ' INPUTS -- PARAMETER MEANING ' PATTERN$ PATTERN TO CHECK ' STRNG$ STRING TO FIE ' ' OUTPUTS -- OK TRUE IF MATCH FOUND ' FALSE IF NO MATCH WAS FOUND ' ' PURPOSE Determine whether a string is an instance in a pattern ' supported patterns are only "?" which requires a ' character but can be any, and "*" which matches any- ' thing, including a null string. Anything else in a ' sting must be an exact match. Supports reverse ' wildcards. ' ' SUB WILDCARD (PATTERN$,STRNG$) STATIC 63285 OK = TRUE PATPOS = 0 STRPOS = 0 INC = 1 KT = 0 P = LEN(PATTERN$) L = LEN(STRNG$) 63286 PATPOS = PATPOS + INC STRPOS = STRPOS + INC KT = KT + 1 IF KT > L THEN _ GOTO 63288 B$ = MID$(PATTERN$,PATPOS,1) IF B$ = "*" THEN _ GOTO 63289 63287 IF B$ <> "?" AND MID$(STRNG$,STRPOS,1) <> B$ THEN _ OK = FALSE : _ EXIT SUB GOTO 63286 63288 IF PATPOS >= LEN(PATTERN$) OR PATPOS < 1 THEN _ EXIT SUB IF MID$(PATTERN$,PATPOS,1) <> "*" THEN _ OK = FALSE : _ EXIT SUB 63289 IF PATPOS <> P THEN _ ' Reverse search INC = -1 : _ P = PATPOS : _ PATPOS = LEN(PATTERN$) + 1 : _ STRPOS = LEN(STRNG$) + 1 : _ KT = 0 : _ GOTO 63286 END SUB 63300 ' $SUBTITLE: 'BRKFNAME - sub to split file name into components' ' $PAGE ' ' NAME -- BRKFNAME ' ' INPUTS -- PARAMETER MEANING ' FILENAME$ FULL NAME OF FILE ' FOR.JOINING TRUE IF WANT PARTS FORMATTED FOR ' FORMING FILE NAMES ' OUTPUTS -- DRVPATH$ DRIVE AND PATH ' PREFIX$ PREFIX OF FILE NAME ' EXTENSION$ EXTENSION OF FILE NAME ' ' (E.G. "C:\RBBS\ARCE.COM" HAS "C:\RBBS" AS DRIVE AND PATH, ' "ARCE" AS PREFIX OF THE FILE NAME, AND ' "COM" AS THE EXTENSION OF THE FILE NAME. ' ' JOINED FORMAT IS C:\RBBS\,ARCE,.COM ' ' PURPOSE -- To break a file name into its component parts ' of drive/path, prefix, and extension ' ' SUB BRKFNAME (FILENAME$,DRVPATH$,PREFIX$,EXTENSION$,FOR.JOINING) STATIC CALL ALLCAPS (FILENAME$) DRVPATH$ = "" PREFIX$ = "" EXTENSION$ = "" CALL TRIMTRAIL (FILENAME$,"\") L = LEN(FILENAME$) IF L < 1 THEN _ EXIT SUB CALL FINDLAST (FILENAME$,"\",X,Y) IF X < 1 THEN _ IF MID$(FILENAME$,2,1) = ":" THEN _ DRVPATH$ = LEFT$(FILENAME$,1) : _ S = 3 _ ELSE S = 1 _ ELSE DRVPATH$ = LEFT$(FILENAME$,X-1) : _ S = X + 1 : _ IF Y = 1 THEN _ ' KG061201 DRVPATH$ = DRVPATH$ + "\" ' KG061201 X = INSTR(FILENAME$ + ".",".") IF X < L THEN _ EXTENSION$ = MID$(FILENAME$,X + 1,3) IF S <= L THEN _ IF X >= S THEN _ PREFIX$ = MID$(FILENAME$,S,X - S) IF NOT FOR.JOINING THEN _ EXIT SUB IF LEN(DRVPATH$) = 1 THEN _ IF DRVPATH$ <> "\" THEN _ ' KG061201 DRVPATH$ = DRVPATH$ + _ ' KG061201 ":" ' KG061201 IF INSTR(DRVPATH$,"\") > 0 AND RIGHT$(DRVPATH$,1) <> "\" THEN _ ' KG061201 DRVPATH$ = DRVPATH$ + _ "\" IF LEN(EXTENSION$) > 0 THEN _ EXTENSION$ = "." + _ EXTENSION$ END SUB 63310 ' $SUBTITLE: 'RESTORECOM - sub to restore comm port' ' $PAGE ' ' NAME -- RESTORECOM ' ' INPUTS -- none ' ' OUTPUTS -- none ' ' PURPOSE -- To restore communications port after an external ' program may have left it in altered state ' SUB RESTORECOM STATIC PARITY$ = MID$(",N,8,1,E,7,1",7 + 6 * EIGHT.BIT,6) IF LOCAL.USER THEN _ EXIT SUB CALL SETBAUD ' KG052102 IF NOT FOSSIL THEN _ ' KG052102 CALL OPENCOM(TALK.TO.MODEM.AT$,PARITY$) END SUB 63320 ' $SUBTITLE: 'SHELLEXIT - sub to shell out from RBBS' ' $PAGE ' ' NAME -- SHELLEXIT ' ' INPUTS -- SHELL.TEM$ String to invoke shell with ' ' OUTPUTS -- none ' ' PURPOSE -- Delay so that strings can finish printing. Restore comm ' port on return ' SUB SHELLEXIT (SHELL.TEM$) STATIC CALL DELAYIT (8 + BPS) IF FOSSIL THEN _ CALL FOSEXIT(COMPORT%) _ ELSE CLOSE 3 : _ OUT MODEM.CONTROL.REGISTER,INP(MODEM.CONTROL.REGISTER) OR 1 CLOSE 2 CALL METAGSR (SHELL.TEM$,FALSE) SHELL SHELL.TEM$ IF FOSSIL THEN _ CALL FOSINIT(COMPORT%,RESULT%) : _ IF RESULT% = -1 THEN _ CALL PSCRN("ERROR INITIALIZING FOSSIL AFTER EXTERNAL PROTOCOL") : _ SYSTEM CALL DELAYIT (2) CALL RESTORECOM END SUB 63330 ' $SUBTITLE: 'READMACRO - sub to read macro' ' $PAGE ' ' NAME -- READMACRO ' ' INPUTS -- PARAMETER MEANING ' ' OUTPUTS -- A$ LINE TO PROCESS IN MACRO ' MACRO.ACTIVE FLAG WHETHER IN A MACRO ' ' PURPOSE -- Reads in a line from macro file (#6) and processes ' macro commands, which are: ' *0 - display what follows, no carriage return ' *1 - display what follows with carriage return ' *B - display block that follows ' *F - display File ' WT - wait specified # of seconds ' >> - append following block to specified file ' ST - stack following (with carriage return) ' ON - define case ' == - case value that applies to following block ' M! - execute following macro ' M@ - abort macro processing ' EY - Echo on (yes) ' EN - Echo off (no) ' /* - comment line skipped in processing ' TK - Turbo key on (if user preference) ' << - Read from file into a form ' SUB READMACRO STATIC IF MACRO.TEMPLATE$ <> "" THEN _ GOTO 63392 IF DISTANT.TGET = 2 THEN _ GOTO 63349 63336 GOSUB 63395 IF NOT MACRO.ACTIVE THEN _ MACRO.ECHO = TRUE : _ EXIT SUB IF LEN(A$) < 3 THEN _ GOTO 63398 X$ = RIGHT$(A$,LEN(A$)-3) IF COMPARE.VAR > 0 THEN _ IF NOT CASE.EXECUTE THEN _ IF LEFT$(A$,3) = SMART.TEXT$+"==" THEN _ GOTO 63370 _ ELSE IF LEFT$(A$,7) = "{END ON" THEN _ COMPARE.VAR = 0 : _ GOTO 63336 _ ELSE GOTO 63336 IF LEFT$(A$,1) <> SMART.TEXT$ THEN _ GOTO 63398 CALL CHECKINT (MID$(A$,2)) IF EC > 0 THEN _ GOTO 63398 IF TESTED.INTEGER.VALUE > 0 AND TESTED.INTEGER.VALUE <= MAX.WORK.VAR THEN _ A$ = X$ : _ ' Macro command ask SUBROUTINE.PARAMETER = 4 : _ CALL TPUT : _ A$ = "" : _ B$ = "" :_ FORCE.KEYBOARD = TRUE : _ MACRO.SAVE = TESTED.INTEGER.VALUE : _ LINES.PRINTED = 1 : _ NON.STOP = (PAGE.LENGTH < 1) : _ ' KG072603 EXIT SUB ON (1+INSTR("*0*1*B*FWT>>STON==M!M@EYEN/*TK<<",MID$(A$,2,2)))\2 GOTO _ 63345, _ ' Display with no Carriage Return 63347, _ ' Display with Carriage Return 63340, _ ' Display Block 63348, _ ' Display File 63343, _ ' Wait # of seconds 63350, _ ' Append to file 63355, _ ' Stack 63360, _ ' Case 63370, _ ' Case Comparison 63375, _ ' Macro execute 63380, _ ' Macro Abort 63383, _ ' Macro Echo on 63385, _ ' Macro Echo off 63336, _ ' Macro Comment 63387, _ ' Turbo Key allowed 63390 ' Form read GOTO 63398 63338 A$ = X$ 63339 SUBROUTINE.PARAMETER = 4 ' KG062803 CALL TPUT RETURN 63340 X$ = SMART.TEXT$ + "END" ' Print Block GOSUB 63395 WHILE MACRO.ACTIVE AND LEFT$(A$,4) <> X$ GOSUB 63339 CALL SKIPLINE (1) GOSUB 63395 WEND GOTO 63336 63343 CALL CHECKINT (X$) ' Delay IF EC = 0 THEN _ CALL DELAYIT (TESTED.INTEGER.VALUE) GOTO 63336 63345 GOSUB 63338 ' Print Line GOTO 63336 63347 GOSUB 63338 CALL SKIPLINE (1) GOTO 63336 63348 CALL TRIM (X$) ' Print File CALL FINDITX (X$,7) ' KG061001 IF NOT OK THEN _ GOTO 63336 LINES.PRINTED = 1 NO = FALSE ' KG071902 NON.STOP = (NON.STOP OR PAGE.LENGTH < 1) ' KG060401 63349 WHILE (NOT EOF(7) AND (NOT NO) AND (NON.STOP OR (LINES.PRINTED < PAGE.LENGTH)) AND (SUBROUTINE.PARAMETER > -1)) ' KG071904 CALL READDIR (7,1) ' KG061001 GOSUB 63396 ' KG060401 SUBROUTINE.PARAMETER = 5 CALL TPUT WEND DISTANT.TGET = 0 IF SUBROUTINE.PARAMETER < 0 THEN _ EXIT SUB IF EOF(7) OR NO THEN _ ' KG061001 CLOSE 7 : _ ' KG061001 NO = FALSE : _ ' KG061001 GOTO 63336 DISTANT.TGET = 2 CALL PAUSEEXIT EXIT SUB 63350 EN$ = X$ ' Append to file X = INSTR(EN$," /FL") OVERSTRIKE = (X > 0) IF OVERSTRIKE THEN _ EN$ = LEFT$(EN$,X-1) + RIGHT$(EN$,LEN(EN$)-X-3) CALL TRIM (EN$) CALL LOCKAPPND IF EC > 0 THEN _ GOTO 63352 GOSUB 63395 X$ = SMART.TEXT$ + "END" WHILE MACRO.ACTIVE AND LEFT$(A$,4) <> X$ ' KG062803 CALL PRNTWRKA (A$) GOSUB 63395 WEND 63352 CALL UNLKAPPND OVERSTRIKE = FALSE GOTO 63336 63355 COMMPORT.STACK$ = COMMPORT.STACK$ + X$ + CARRIAGE.RETURN$ ' STack GOTO 63336 63360 COMPARE.VAR = VAL(X$) CALL ALLCAPS (X$) ' KG062901 IF COMPARE.VAR < 1 OR COMPARE.VAR > MAX.WORK.VAR THEN _ COMPARE.VAR = 0 GOTO 63336 63370 IF COMPARE.VAR = 0 THEN _ ' Compare Case GOTO 63336 DF$ = GSR.ARA$(COMPARE.VAR) CALL ALLCAPS (DF$) CASE.EXECUTE = (X$ = DF$) GOTO 63336 63375 CALL TRIM (X$) ' Execute Macro CALL CHKMACRO (X$,X) GOTO 63336 63380 MACRO.ACTIVE = FALSE ' Abort Macro GOTO 63398 63383 MACRO.ECHO = TRUE GOTO 63336 63385 MACRO.ECHO = FALSE GOTO 63336 63387 TURBO.KEY = -TURBO.KEY.USER 'TK Turbo Key GOTO 63336 63390 B$ = A$ B$(5) = "" B$(6) = "" Q = 1 STORE.PARSE.AT = 1 ' KG083101 CALL PARSEIT IF Q < 4 THEN _ GOTO 63336 X$ = SMART.TEXT$ + "END" GOSUB 63397 ' KG081006 MACRO.TEMPLATE$ = "" WHILE MACRO.ACTIVE AND LEFT$(A$,4) <> X$ MACRO.TEMPLATE$ = MACRO.TEMPLATE$ + A$ + CRLF$ GOSUB 63397 ' KG080302 WEND X = VAL(B$(4)) VAR.LEN = (B$(3) <> "/F") CALL FINDIT (B$(2)) IF (X < 1) OR (NOT OK) OR (VAR.LEN AND X > MAX.WORK.VAR) THEN _ MACRO.TEMPLATE$ = "" : _ GOTO 63336 63392 CALL FORMREAD (MACRO.TEMPLATE$,B$(2),NOT VAR.LEN,X,(B$(5) = "/FL"),(B$(6) = "/1")) IF MACRO.TEMPLATE$ <> "" THEN _ EXIT SUB _ ELSE GOTO 63336 63395 GOSUB 63397 ' KG080302 GOSUB 63396 ' KG080302 RETURN ' KG080302 63396 CALL SMARTTXT (A$,FALSE, OVERSTRIKE) CALL METAGSR (A$,OVERSTRIKE) RETURN 63397 IF EOF(6) THEN _ ' Read next line in macro ' KG080302 MACRO.ACTIVE = FALSE _ ELSE CALL READDIR (6,1) : _ ' KG080302 MACRO.ACTIVE = (EC = 0) RETURN 63398 END SUB ' Not Macro command - pass to normal processing 63400 ' $SUBTITLE: 'LOCKAPPND - prepares for file append' ' $PAGE ' ' NAME -- LOCKAPPND ' ' INPUTS -- EN$ Name of file to append to ' ' OUTPUTS -- none ' ' PURPOSE -- Locks and opens file to append to ' SUB LOCKAPPND STATIC BX = &H4 SUBROUTINE.PARAMETER = 9 CALL FILELOCK EC = 0 CALL OPENWRKA (EN$) END SUB 63410 ' $SUBTITLE: 'UNLKAPPND - cleans up after file append' ' $PAGE ' ' NAME -- UNLKAPPND ' ' INPUTS -- none ' ' OUTPUTS -- none ' ' PURPOSE -- Unlocks and close file appending to ' SUB UNLKAPPND STATIC BX = &H4 SUBROUTINE.PARAMETER = 10 CALL FILELOCK CLOSE 2 END SUB 63420 ' $SUBTITLE: 'FORMREAD - Reads from a file into a form' ' $PAGE ' ' NAME -- FORMREAD ' ' INPUTS -- TEMPLATE$ Display formvoke shell with ' FILNAME$ Data file to get values from ' FIXED.LENGTH Whether file is fixed length ' DATA.VAR # bytes data if fixed length; # fields ' if variable length ' OVERSTRIKE Whether typeover into form or insert ' REC.PAUSE Whether pause after every record displayed ' otherwise when screen fills ' OUTPUTS -- (displays data base records) ' ' PURPOSE -- Allows field oriented data base data to be displayed ' in a human readable format by substituting field ' data into template or form ' SUB FORMREAD (TEMPLATE$,FILNAME$,FIXED.LENGTH,DATA.VAR,OVERSTRIKE,REC.PAUSE) STATIC 63422 IF EOF(2) OR NO OR (EC > 0) OR (SUBROUTINE.PARAMETER < 0) THEN _ TEMPLATE$ = "" : _ EXIT SUB IF FIXED.LENGTH THEN _ CALL READDIR (2,1) : _ GSR.ARA$(1) = A$ _ ELSE CALL READPARMS (GSR.ARA$(),DATA.VAR,1) X$ = TEMPLATE$ CALL SMARTTXT (X$,TRUE,OVERSTRIKE) CALL METAGSR (X$,OVERSTRIKE) CALL BUFASUNIT (X$) IF REC.PAUSE OR (PAGE.LENGTH > 0 AND (LINES.PRINTED >= PAGE.LENGTH-1)) THEN _ CALL PAUSEEXIT : _ EXIT SUB GOTO 63422 END SUB 63440 ' $SUBTITLE: 'BUFASUNIT - prints string with no pauses' ' $PAGE ' ' NAME -- BUFASUNIT ' ' INPUTS -- STRNG$ String to print ' ' OUTPUTS -- none ' ' PURPOSE -- Prints string with embedded carriage returns. ' Will never pause. Used to print when can't call TGET ' SUB BUFASUNIT (STRNG$) STATIC L = LEN(STRNG$) IF L < 1 THEN _ EXIT SUB START.BYTE = 1 63450 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 A$ = MID$(STRNG$,START.BYTE,NUM.BYTES) SUBROUTINE.PARAMETER = 4 CALL TPUT CALL SKIPLINE (-(CR.FOUND)) IF RET THEN _ EXIT SUB START.BYTE = EOD + EOL.LEN IF START.BYTE <= L THEN _ GOTO 63450 END SUB 63460 SUB MACROEXE (STRNG$) STATIC CALL TRIM (STRNG$) CALL FINDIT (STRNG$) IF NOT OK THEN _ EXIT SUB COMMPORT.STACK$ = COMMPORT.STACK$ + STRNG$ + CARRIAGE.RETURN$ CALL FDMACEXE END SUB 63462 SUB FDMACEXE STATIC A$ = "" MACRO.ECHO = FALSE SUBROUTINE.PARAMETER = 4 CALL TGET END SUB 63465 SUB PAUSEEXIT STATIC ' CALL SKIPLINE (1) SUBROUTINE.PARAMETER = 4 TURBO.KEY = -TURBO.KEY.USER A$ = MORE.PROMPT$ + ">" + MID$("? ! ",2*TURBO.KEY+1,2) FORCE.KEYBOARD = TRUE NO.ADVANCE = TRUE CALL TPUT LINES.PRINTED = 0 B$ = "" ' KG060401 END SUB 63470 ' $SUBTITLE: 'CALLOPT - sub to set prompts based on user security' ' $PAGE ' ' NAME -- CALLOPT ' ' INPUTS -- 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 ' ' OUTPUTS -- 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 ' ' PURPOSE -- Sets command line display of what user can do by ' section and display of what all user can do ' SUB CALLOPT STATIC 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 63480 ' $SUBTITLE: 'NOPATH - detects whether string has path' ' $PAGE ' ' NAME -- NOPATH ' ' INPUTS -- STRNG$ String to check ' ' OUTPUTS -- HAS.NONE True if has no path ' ' PURPOSE -- Detects whether have path. Used when shouldn't ' be any ' SUB NOPATH (STRNG$,HAS.PATH) STATIC ' KG060801 CALL BRKFNAME (STRNG$,DRVPATH$,PREFX$,EXT$,FALSE) ' KG060801 HAS.PATH = (DRVPATH$ <> "") ' KG060801 END SUB ' KG060801 63490 ' $SUBTITLE: 'FINDIT - Determine whether file exists' ' $PAGE ' ' NAME -- FINDIT ' ' INPUTS -- FILNAME$ File name to check ' ' OUTPUTS -- OK True if file exists. Opened as #2 if does ' ' PURPOSE -- Determine whether file exists and open as standard work ' file if it does (#2) ' SUB FINDIT (FILNAME$) STATIC ' KG061001 CALL FINDITX (FILNAME$,2) ' KG061001 END SUB ' KG061001 63495 ' $SUBTITLE: 'TIMEBACK - Give time back to the user' ' KG082701 ' $PAGE ' ' NAME -- TIMEBACK ' ' INPUTS -- INDEX = 1 Set start of time (begin give back) ' = 2 Give back time from defined start ' ' OUTPUTS -- TIME.CREDIT! Number of seconds to credit with ' SECONDS.PER.SESSION! Number of seconds in current session ' ' PURPOSE -- Give time back to the user (e.g. sysop initiated chat) ' SUB TIMEBACK (INDEX) STATIC ' KG082701 IF INDEX = 1 THEN _ ' KG082701 CALL TIMEREMAIN (TIME.REMAINING!) : _ ' KG082701 Q! = TCA! : _ ' KG082701 EXIT SUB ' KG082701 CALL TIMEREMAIN (TIME.REMAINING!) ' KG082701 X! = (TCA! - Q!) ' KG082701 TIME.CREDITS! = TIME.CREDITS! + X! ' KG082701 SECONDS.PER.SESSION! = SECONDS.PER.SESSION! + X! ' KG082701 END SUB ' KG082701 63500 ' $SUBTITLE: 'CSPUSHPOP - Save/restore command stack' ' KG082702 ' $PAGE ' ' NAME -- CSPUSHPOP ' ' INPUTS -- INDEX = 1 Save command stack ' = 2 Restore command stack ' ANS.INDEX ' LAST.INDEX ' B$() ' ' OUTPUTS -- B$() Stacked commands ' ANS.INDEX ' LAST.INDEX ' ' PURPOSE -- Save restore a command stack list when need to input ' another list in middle of previous list processing ' SUB CSPUSHPOP (INDEX) STATIC ' KG082702 IF INDEX = 1 THEN _ ' KG082702 ORIG.LAST.INDEX = LAST.INDEX : _ ' save ' KG082702 ORIG.INDEX = ANS.INDEX : _ ' KG082702 FOR I = 1 TO ORIG.LAST.INDEX : _ ' KG082702 A$(I) = B$(I) : _ ' KG082702 NEXT : _ ' KG082702 EXIT SUB ' KG082702 LAST.INDEX = ORIG.LAST.INDEX ' restore ' KG082702 ANS.INDEX = ORIG.INDEX ' KG082702 FOR I = 1 TO ORIG.LAST.INDEX ' KG082702 B$(I) = A$(I) ' KG082702 NEXT ' KG082702 END SUB ' KG082702