{$N+,E+} {* required for ASK and the time outs *} Unit BBSFuncs; {***************************************************************************} {* This unit contains the subprograms called by Unit BBSDoSub. {* They must be all non-interactive. {***************************************************************************} interface {***************************************************************************} {***************************************************************************} uses BBSGlbls, Glob; Function AreaPeek: AreaType; Procedure AreaPop; Procedure AreaPush(PushedArea: AreaType); Procedure AreaReset(InitArea: AreaType); Procedure AreaSub(SubstituteArea: AreaType); Procedure Ask(QueryStr: string; TheNextArea: AreaType; StringLength: byte); Procedure CheckTimeLeft; Procedure DelayBBS(Secs: real; TheNextArea: AreaType); Procedure EditMenu; Procedure FileAddList(FileCodeName, UpFile, CopyrStr, Descrip: string); Function FileRemList(NumStr: string): boolean; Function FileNext: string; Function FilesLoaded: integer; Procedure FilterPortChar(alpha: integer; PortChar: char); Procedure FlushSessInput; Procedure GetInputs; Procedure IdentifyBBS; Procedure InitBBSGlbls; Procedure InitSessionVariables(Session: integer); Function MailCheck(QuietMode: boolean): boolean; Procedure MailMenu; Procedure MailNewUser; Function MailNext: string; Procedure MainInit; Procedure MainLoop; Procedure MainMenu; Function OutputClear(InPort: integer): boolean; Procedure Periodic; Function PrivCheck(MsgOn: boolean; PrivBits: longint): boolean; Function Reply: string; Procedure RestartBBS; Function SetUpBBSFiles(BBSFile: string): boolean; Procedure ShowTimeLeft; Procedure StatMenu; Procedure StatUserMenu; Procedure SublimInit; Procedure SublimPick; Procedure Trash(DeadFile: string); Function UserDir(UserNum: W10k): string; Function UserFindID(var NameStr: string): integer; Function UserFindName(UserNum: integer): string; Function UserKill: boolean; Function UserNext: integer; Function ValidName: boolean; Function VarPeekInteger: Integer; Function VarPeekStr: string; Function VarPeekTextNum: integer; Function VarPopInteger: Integer; Function VarPopStr: string; Function VarPopTextNum: integer; Procedure VarPushInteger(PushedInteger: Integer); Procedure VarPushStr(PushedStr: string); Function VarPushText: integer; Procedure VarResetInteger(InitInteger: Integer); Procedure VarResetStr(InitStr: string); Procedure VarTextCloseAll(Session: integer); Procedure XFileMenu; implementation {***************************************************************************} {***************************************************************************} Uses BBSAlarm, Data, Disk, Keyb, Misc, Monitor, Scrn, Time, Crt, Dos, DoSubs1, DoSubs2, IOPorts, LctKrnl, {* for RestartBBS *} LctSupp; {* for OutputClear *} Function AreaPeek: AreaType; {***************************************************************************} begin AreaPeek := Area[Port, AreaTOS[Port]]; end; Procedure AreaPop; {***************************************************************************} begin if AreaTOS[Port] = 1 then begin ErrSayL('AreaTOS popped to less than 1!!!'); Area[Port, AreaTOS[Port]] := Prompt; end else begin Area[Port, AreaTOS[Port]] := Zero; Dec(AreaTOS[Port]); end; end; Procedure AreaPush(PushedArea: AreaType); {***************************************************************************} var alpha: integer; begin if AreaTOS[Port] = AreaMaxStack then begin ErrSayL('AreaTOS pushed past AreaMaxStack!!!'); for alpha := 1 to (AreaMaxStack - 1) do Area[Port, alpha] := Area[Port, alpha + 1]; end else Inc(AreaTOS[Port]); Area[Port, AreaTOS[Port]] := PushedArea; end; Procedure AreaReset(InitArea: AreaType); {***************************************************************************} begin AreaTOS[Port] := 1; Area[Port, AreaTOS[Port]] := InitArea; end; Procedure AreaSub(SubstituteArea: AreaType); {***************************************************************************} begin Area[Port, AreaTOS[Port]] := SubstituteArea end; Procedure Ask(QueryStr: string; TheNextArea: AreaType; StringLength: byte); {***************************************************************************} {* if StringLength = 0 then StringLength = LineLen - Len(QueryStr) {***************************************************************************} var EnterPos: integer; begin Say(QueryStr); AreaSub(TheNextArea); if StringLength = 0 then StringLength := LineLen - Length(QueryStr); InStrMaxLen[Port] := StringLength; BeepTime[Port] := InputTime/10; InputDeadLine[Port] := JulianDateTimeNow + BeepTime[Port]; EnterPos := 1; PosString(Enter, SessInStr[Port], EnterPos); SessInStr[Port] := copy(SessInStr[Port], EnterPos, length(SessInStr[Port]) - EnterPos + 1); if SessInStr[Port, 1] <> Enter then SessInStr[Port] := '' else begin SessInStr[Port] := copy(SessInStr[Port], 2, length(SessInStr[Port]) - 1); Say(SessInStr[Port]); end; AreaPush(UserInput); end; Procedure CheckTimeLeft; {***************************************************************************} begin if DateTimeLogOut[Port] = Infinity then exit; if JulianDateTimeNow < DateTimeLogOut[Port] then exit; DateTimeLogOut[Port] := Infinity; SayL(Beep); SayL('It is time to give someone else a chance to log in.'); SayL('Please call again tomorrow!'); AreaPush(Disconnect); end; Procedure DelayBBS(Secs: real; TheNextArea: AreaType); {***************************************************************************} begin AreaSub(TheNextArea); DelayDone[Port] := JulianDateTimeNow + Secs; AreaPush(PassTime); end; Procedure EditMenu; {***************************************************************************} begin SayL(''); SayL('EDITOR HELP MENU'); SayL('|'); SayL('A ----- Append Line(s)'); SayL('D ----- Delete Line'); SayL('I ----- Insert Line'); SayL('L ----- List File with Line Numbers'); SayL('M ----- Modify Line'); SayL('S ----- Show File'); SayL('|'); SayL('C ----- Chat/Comment to the SYSOP'); SayL('G ----- Goodbye (log off)'); SayL('H ----- Help (this menu)'); SayL('Q ----- Quit back to the menu that calls this one'); end; Procedure FileAddList(FileCodeName, UpFile, CopyrStr, Descrip: string); {***************************************************************************} var FL: text; begin if FileOpen('A', FileListFile, FL) = 0 then begin {$I-} writeln(FL, FileCodeName); writeln(FL, UpFile); writeln(FL, CopyrStr); writeln(FL, Descrip); writeln(FL, 'N/A'); writeln(FL, '0'); writeln(FL, '0'); {* Global FileListLines = 7 *} Close(FL); {$I+} end; if IOResult <> 0 then SayL('Failure. Unable to add file to public File List.'); end; Function FileRemList(NumStr: string): boolean; {***************************************************************************} var Temp: boolean; FirstLine, LastLine: integer; begin if not(PrivCheck(true, FileDelPriv)) then begin FileRemList := false; exit; end; FirstLine := IntStr(NumStr); LastLine := FirstLine + FileListLines - 1; Temp := FileLineDel(FileListFile, FirstLine, LastLine); FileRemList := Temp; end; Function FileNext: string; {***************************************************************************} var Temp: string; NumFiles: W10k; NumFilesStr: string; begin Temp := UserDir(UserID[Port]) + '\' + 'File'; NumFiles := 0; if FileLine('R', StatFile, 5, NumFilesStr) then begin NumFiles := IntStr(NumFilesStr); Temp := Temp + StrIntZer(NumFiles, 4) end else Temp := Temp + '0000'; inc(NumFiles); NumFilesStr := StrInt(NumFiles); DumBool := FileLine('O', StatFile, 5, NumFilesStr); FileNext := Temp + '.BBS'; end; Function FilesLoaded: integer; {***************************************************************************} var Temp: integer; TempStr: string; begin Temp := 0; if FileLine('R', StatFile, 5, TempStr) then Temp := IntStr(TempStr); FilesLoaded := Temp; end; Procedure FilterPortChar(alpha: integer; PortChar: char); {***************************************************************************} var LenStr: integer; Letter: integer; SpaceFound: boolean; BackCount: integer; BackLoop: integer; CutStr: string; TooLong: boolean; begin TooLong := false; if (InStrMaxLen[alpha] <= length(SessInStr[alpha])) and (AreaPeek = UserInput) then if (PortChar = Enter) or (PortChar = BackSpace) then SessInStr[alpha] := SessInStr[alpha] + PortChar else begin if WordWrap[Port] then begin LenStr := length(SessInStr[alpha]); Letter := LenStr; repeat SpaceFound := SessInStr[alpha, Letter] = ' '; Dec(Letter); until (Letter = 0) or SpaceFound; if SpaceFound then begin SessInStr[alpha] := SessInStr[alpha] + PortChar; BackCount := 0; for BackLoop := LenStr downto Letter do begin inc(BackCount); SessInStr[alpha] := SessInStr[alpha] + BackSpace; end; CutStr := copy(SessInStr[alpha], Letter + 2, BackCount - 1); SessInStr[alpha] := SessInStr[alpha] + Enter + CutStr; end else {* no spaces *} SessInStr[alpha] := copy(SessInStr[alpha], 1, InStrMaxLen[alpha]) + Enter + copy(SessInStr[alpha], InStrMaxLen[alpha]+1, length(SessInStr[alpha])); end else begin Say(Beep); TooLong := true; end; end else if (PortChar = BackSpace) and (SessInStr[alpha] = '') then Say(Beep) else SessInStr[alpha] := SessInStr[alpha] + PortChar; if ((PortChar <> BackSpace) and Echo[alpha]) and not(TooLong) then begin if PortChar = '+' then PortChar := #197; PortOutStr[alpha] := PortOutStr[alpha] + PortChar; end; TooLong := false; end; Procedure FlushSessInput; {***************************************************************************} var alpha: integer; begin FlushInputBuff(Port); end; procedure GetInputs; {***************************************************************************} var PortChar: char; alpha: integer; begin for alpha := 0 to NumPorts do if GetChar(alpha, PortChar) then begin if alpha = 0 then begin if PortChar = Null then Monitor.Change else if Monitor.KeyboardOn then begin if Area[Displayed, AreaTOS[Displayed]] = WaitConnect then PortOutStr[Displayed] := PortOutStr[Displayed] +PortChar; FilterPortChar(Displayed, PortChar); end; end else FilterPortChar(alpha, PortChar); end; end; Procedure IdentifyBBS; {***************************************************************************} begin SayL(#7+#7+#7); SayL('You have connected to the '+BBS_G+' BBS!'); SayL(''); SayL('Licensed to '+Owner_G+', Registration Number '+RegNum_G); SayL('Wyrm BBS Version '+Version_G+' Copyright 1991 David Croft'); SayL(''); end; Procedure InitBBSGlbls; {***************************************************************************} begin for Port := 0 to NumPorts do begin InitSessionVariables(Port); ResetDateTime[Port] := JulianDateTimeNow; end; for Port := NumPorts downto 0 do PortOutStr[Port] := ''; end; procedure InitSessionVariables(Session: integer); {***************************************************************************} var alpha: integer; begin Baud[Session] := 300; IsCallBack[Session] := false; InStrMaxLen[Session] := LineLen; Echo[Session] := false; LoginOK[Session] := false; UserID[Session] := 0; UserName[Session] := ''; DateTimeLogOut[Session] := Infinity; for alpha := 1 to AreaMaxStack do Area[Session, alpha] := Zero; AreaTOS[Session] := 1; for alpha := 1 to VarIntegerMaxStack do VarInteger[Session, alpha] := 0; VarIntegerTOS[Session] := 1; for alpha := 1 to VarStrMaxStack do VarStr[Session, alpha] := ''; VarStrTOS[Session] := 1; VarTextTOS[Session] := 1; ResetDateTime[Session] := JulianDateTimeNow + (15*60); Area[Session, AreaTOS[Session]] := WaitConnect; LinesPerPage[Session] := 23; SessInStr[Session] := ''; WordWrap[Session] := false; end; Function MailCheck(QuietMode: boolean): boolean; {***************************************************************************} var InStr: string; UserBox: string; TempMailCheck: boolean; begin TempMailCheck := false; UserBox := UserDir(UserID[Port]) + '\' + MailBox; if FileSizeAny(UserBox) > 0 then TempMailCheck := true; if not(QuietMode) then if TempMailCheck then SayL('You have E-MAIL.') else SayL('You have no e-mail right now.'); MailCheck := TempMailCheck; end; Procedure MailMenu; {***************************************************************************} begin SayL(''); SayL('E-MAIL HELP MENU'); SayL('|'); SayL('R ----- Read e-mail'); SayL('S ----- Send e-mail'); SayL('|'); SayL('C ----- Chat/Comment to the SYSOP'); SayL('G ----- Goodbye (log off)'); SayL('H ----- Help (this menu)'); SayL('Q ----- Quit back to the menu that calls this one'); end; Procedure MailNewUser; {***************************************************************************} var EM: text; begin if not(FileExists(NewUserMailFile)) then exit; if DirExists(UserDir(UserID[Port])) then if FileOpen('A', UserDir(UserID[Port]) + '\' + MailBox, EM) = 0 then begin writeln(EM, 'Wyrm BBS MANAGER'); writeln(EM, 'New User Mail'); writeln(EM, NewUserMailFile); close(EM); end; end; Function MailNext: string; {***************************************************************************} var TempMailNext: string; MailCount: integer; begin TempMailNext := ''; if DirExists(UserDir(UserID[Port])) then if FileLine('R', StatFile, 4, TempMailNext) then begin MailCount := IntStr(TempMailNext); Inc(MailCount); TempMailNext := StrInt(MailCount); DumBool := FileLine('O', StatFile, 4, TempMailNext); TempMailNext := UserDir(UserID[Port])+'\' + 'M' + StrIntZer(MailCount, 7) + '.BBS'; end; MailNext := TempMailNext; end; Procedure MainInit; {***************************************************************************} var alpha: integer; InStr: string; CF: text; begin AlarmInit; Monitor.Init; InitBBSGlbls; ExitSave := ExitProc; ExitProc := @RestartBBS; DosError := 0; SublimInit; DumBool := DirExistsMake(UserDir(0)); for alpha := 0 to NumPorts do InitPort(alpha); end; Procedure MainLoop; {***************************************************************************} begin repeat Periodic; case AreaPeek of WaitConnect : DoWaitConnect; WaitConnect_1: DoWaitConnect_1; UserInput : DoUserInput; Welcome : DoWelcome; Prompt : DoPrompt; Prompt_1 : DoPrompt_1; LogOff : DoLogOff; LogOff_1 : DoLogOff_1; Bulletins : DoBulletins; BullDel : DoBullDel; BullDel_1 : DoBullDel_1; BullEdit : DoBullEdit; BullNext : DoBullNext; BullNext_1 : DoBullNext_1; BullPickedBull : DoBullPickedBull; BullPickedBull_1 : DoBullPickedBull_1; BullPickedBull_2 : DoBullPickedBull_2; BullPickedChild : DoBullPickedChild; BullPickedChild_1 : DoBullPickedChild_1; BullPickedParent : DoBullPickedParent; BullPickedParent_1 : DoBullPickedParent_1; BullPost : DoBullPost; BullPost_1 : DoBullPost_1; BullPrompt : DoBullPrompt; BullPrompt_1 : DoBullPrompt_1; BullRead : DoBullRead; BullRead_1 : DoBullRead_1; BullSubCon : DoBullSubCon; BullSubCon_1 : DoBullSubCon_1; BullSubCon_2 : DoBullSubCon_2; BullSubDown : DoBullSubDown; BullSubDown_1: DoBullSubDown_1; BullSubKill : DoBullSubKill; BullSubKill_1 : DoBullSubKill_1; BullSubMake : DoBullSubMake; BullSubMake_1 : DoBullSubMake_1; BullSubOpen : DoBullSubOpen; BullSubUp : DoBullSubUp; BullSubUp_1 : DoBullSubUp_1; CallBack : DoCallBack; CallBack_1 : DoCallBack_1; CallBack_2 : DoCallBack_2; CallBack_3 : DoCallBack_3; CallBack_4 : DoCallBack_4; Comment : DoComment; Comment_1 : DoComment_1; Disconnect : DoDisconnect; Disconnect_1 : DoDisconnect_1; Disconnect_2 : DoDisconnect_2; EditAppend : DoEditAppend; EditAppend_1 : DoEditAppend_1; EditDelete : DoEditDelete; EditDelete_1 : DoEditDelete_1; EditDelete_2 : DoEditDelete_2; EditInsert : DoEditInsert; EditInsert_1 : DoEditInsert_1; EditInsert_2 : DoEditInsert_2; EditModify : DoEditModify; EditModify_1 : DoEditModify_1; EditModify_2 : DoEditModify_2; EditPrompt : DoEditPrompt; EditPrompt_1 : DoEditPrompt_1; FileShow : DoFileShow; FileShow_1 : DoFileShow_1; GetName : DoGetName; GetName_1 : DoGetName_1; GetName_2 : DoGetName_2; GetName_3 : DoGetName_3; HangUp : DoHangUp; HangUp_1 : DoHangUp_1; HangUp_2 : DoHangUp_2; HangUp_3 : DoHangUp_3; Mail : DoMail; Mail_1 : DoMail_1; MailSend : DoMailSend; MailSend_1 : DoMailSend_1; MailSend_2 : DoMailSend_2; MailRead : DoMailRead; MakePassword : DoMakePassword; MakePassword_1 : DoMakePassword_1; MakePassword_2 : DoMakePassword_2; ModemSetup : DoModemSetup; ModemSetup_1 : DoModemSetup_1; PassTime : DoPassTime; PasswordGood : DoPasswordGood; PasswordGood_1 : DoPasswordGood_1; Pause : DoPause; Pause_1 : DoPause_1; Register : DoRegister; Register_1 : DoRegister_1; Register_2 : DoRegister_2; Register_3 : DoRegister_3; Register_4 : DoRegister_4; Statistics : DoStatistics; Statistics_1 : DoStatistics_1; StatUser : DoStatUser; StatUser_1 : DoStatUser_1; StatUsersDel : DoStatUsersDel; StatUsersDel_1 : DoStatUsersDel_1; StatUsersShow : DoStatUsersShow; StatUsersShow_1: DoStatUsersShow_1; XFilePrompt : DoXFilePrompt; XFilePrompt_1 : DoXFilePrompt_1; XFileDown : DoXFileDown; XFileDown_1 : DoXFileDown_1; XFileDown_2 : DoXFileDown_2; XFileDown_3 : DoXFileDown_3; XFileRem : DoXFileRem; XFileRem_1 : DoXFileRem_1; XFileUp : DoXFileUp; XFileUp_1 : DoXFileUp_1; XFileUp_2 : DoXFileUp_2; XFileUp_3 : DoXFileUp_3; XFileUp_4 : DoXFileUp_4; XFileUp_5 : DoXFileUp_5; XFileView : DoXFileView; XFileView_1 : DoXFileView_1; else ErrSayL(Beep+'Bad Area!!!: '+ StrInt(Ord(AreaPeek))); end; {case} until Forever; end; Procedure MainMenu; {***************************************************************************} begin SayL(''); SayL('MAIN HELP MENU'); SayL('|'); SayL('A ----- Added BBS sections'); SayL('B ----- Bulletins'); SayL('C ----- Chat/Comment to the System Operator (SYSOP)'); SayL('D ----- Data for the BBS and Users'); SayL('E ----- Electronic Mail (E-Mail)'); SayL('F ----- Files'); SayL('G ----- Goodbye (log off)'); SayL('H ----- Help (this menu)'); SayL('I ----- Information about Wyrm BBS'); end; Function OutputClear(InPort: integer): boolean; {***************************************************************************} var Temp: boolean; begin if InPort = 0 then begin OutputClear := PortOutStr[0] = ''; exit; end; Temp := not((BytesInOutput(InPort) <> 0) or (PortOutStr[InPort] <> '')); OutputClear := Temp; end; Procedure Periodic; {***************************************************************************} var AreaP: AreaType; begin inc(Port); {* !!!!!!!!!!!! PATCH !!!!!!!!!!!!! *} Port := 2; if Port > NumPorts then Port := 0; Monitor.Update; GetInputs; PutOutputs; CheckTimeLeft; AreaP := AreaPeek; {* Temp disabled !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! if not(AreaP in [ WaitConnect..WaitConnect_1, CallBack_2..CallBack_3, Disconnect..Disconnect_2, GetName, HangUp..HangUp_3, PassTime, ModemSetup..ModemSetup_1 ]) then if Disconnected(Port) then AreaReset(Disconnect); *} if AlarmOn then DumBool := AlarmCheck; end; Function PrivCheck(MsgOn: boolean; PrivBits: longint): boolean; {***************************************************************************} begin if UserPrivs[Port] and PrivBits = PrivBits then PrivCheck := true else if MsgOn then begin PrivCheck := false; SayL(Beep); case PrivBits of BullReadPriv: SayL('You lack the privilege to read bulletins.'); BullPostPriv: SayL('You lack the privilege to post bulletins.'); BullKillPriv: SayL('You lack the privilege to trash another''s bulletins.'); BullAreaMakePriv: SayL('You lack the privilege to make a BULLETIN subject area.'); BullAreaKillPriv: SayL('You lack the privilege to delete a BULLETIN subject area.'); BullEditPriv: SayL('You can only edit bulletins that you author.'); else SayL('You lack the privileges to do this.'); end; {case} SayL('Please contact the BBS Manager to expand your privileges.'); end; end; Function Reply: string; {***************************************************************************} var Ending: integer; Temp: string; begin Ending := 1; PosString(Enter, SessInStr[Port], Ending); Temp := copy(SessInStr[Port], 1, Ending - 1); Reply := Temp; end; {$F+} Procedure RestartBBS; {***************************************************************************} {* Catches fatal errors and restarts the BBS. {* TP Reference Guide pp. 216-7 {* future mods: p. 217 check and report ErrorAddr {* & output to printer (although if looping may use up all the paper) {***************************************************************************} var alpha: longint; begin for alpha := 1 to NumPorts do CommClose(alpha, true); ExitProc := ExitSave; ErrSayL('Fatal Error! BBS hung!'); ErrSayL('Exit code: '+StrInt(ExitCode)); ErrSayL('IO Error : '+StrInt(IOError)); ErrSayL('Dos error: '+StrInt(DosError)); SayL('Hit any key to halt the program.'); SayL('Wyrm BBS will automatically restart itself in a few seconds...'); alpha := 0; repeat Inc(alpha); until (alpha = 100000) or keypressed; if keypressed then halt; MainLoop; end; {$F-} Function SetUpBBSFiles(BBSFile: string): boolean; {***************************************************************************} var Success: boolean; BBS: text; begin Success := false; if BBSFile = 'NUL' then begin end else SayL(Beep+'SetUpBBSFile function does not recognize '+BBSFile+'!'); SetUpBBSFiles := Success; end; Procedure ShowTimeLeft; {***************************************************************************} var Sec, Min, Hour: longint; TimeLeft: longint; begin if DateTimeLogOut[Port] = Infinity then begin Say('(No Time Limit) '); exit; end; TimeLeft := DateTimeLogOut[Port] - JulianDateTimeNow; SecsSplit(TimeLeft, DumLongInt, Hour, Min, Sec); Say('('+StrIntZer(Hour,2) +':'+ StrIntZer(Min, 2) + ':' + StrIntZer(Sec, 2)+') '); end; Procedure StatMenu; {***************************************************************************} begin SayL(''); SayL('DATA HELP MENU'); SayL('|'); SayL('B ----- BBS data'); SayL('D ----- Disk data'); SayL('U ----- User Data Menu'); SayL('|'); SayL('C ----- Chat/Comment to the SYSOP'); SayL('G ----- Goodbye (log off)'); SayL('H ----- Help (this menu)'); SayL('Q ----- Quit back to the menu that calls this one'); end; Procedure StatUserMenu; {***************************************************************************} begin SayL(''); SayL('USER DATA HELP MENU'); SayL('|'); SayL('S ----- Show users and their last logout time'); SayL('U ----- show User data and settings'); SayL('M ----- Toggle automatic menu display'); SayL('P ----- change Password'); SayL('|'); SayL('N ----- change user privileges code Number'); SayL('D ----- Delete a user'); SayL('T ----- change user on-line Time'); SayL('|'); SayL('C ----- Chat/Comment to the SYSOP'); SayL('G ----- Goodbye (log off)'); SayL('H ----- Help (this menu)'); SayL('Q ----- Quit back to the menu that calls this one'); end; Procedure SublimInit; {***************************************************************************} var SF: text; begin if not(FileExists(SubliminalFile)) then begin DumBool := FileCreate(SubliminalFile); Assign(SF, SubliminalFile); Append(SF); writeln(SF, 'Wyrm Bulletin Board System (WBBS) Version Test 1.'); writeln(SF, 'Wyrm BBS by David Croft, copyright 1991.'); writeln(SF, 'WBBS is a multi-user board.'); writeln(SF, 'WBBS does bulletins, electronic-mail, and up/downloads.'); writeln(SF, 'WBBS uses a system of privileges to protect data.'); writeln(SF, 'WBBS users can change these one-line, random messages.'); Close(SF); end; SublimRange := 0; if FileOpen('R', SubliminalFile, SF) = 0 then begin while not(EOF(SF)) and (SublimRange <= SublimRangeMax) do begin Inc(SublimRange); readln(SF, Sublim[SublimRange]); end; close(SF); end else begin Sublim[1] := 'Error: ' + SubliminalFile + ' will not open for read!'; SublimRange := 1; end; end; Procedure SublimPick; {***************************************************************************} var LuckyLine: integer; begin randomize; LuckyLine := random(SublimRange) + 1; SayL(Sublim[LuckyLine]); end; Procedure Trash(DeadFile: string); {***************************************************************************} var DF, TF: text; InStr: string; Dir: DirStr; Name: NameStr; Ext: ExtStr; begin if FileOpen('R', DeadFile, DF) <> 0 then exit; FSplit(DeadFile, Dir, Name, Ext); if FileOpen('W', TrashDir + '\' + Name, TF) <> 0 then exit; repeat readln(DF, InStr); writeln(TF, InStr); until EOF(DF); Close(TF); Close(DF); FileDel(DeadFile, DumInt); end; Function UserDir(UserNum: W10k): string; {***************************************************************************} begin UserDir := UsersDir + '\' + 'USER'+StrIntZer(UserNum, 4) + '.BBS'; end; Function UserFindID(var NameStr: string): integer; {***************************************************************************} var TempUserFindID: integer; UserLine: integer; IDStr: string; begin TempUserFindID := -1; UserLine := FileSearch('u', UsersLog, NameStr); if UserLine <> 0 then if FileLine('R', UsersLog, UserLine + 1, IDStr) then if FileLine('R', UsersLog, UserLine, NameStr) then TempUserFindID := IntStr(IDStr); if UpCaseStr(NameStr) = 'MANAGER' then begin NameStr := 'MANAGER'; TempUserFindID := 0; end; if UpCaseStr(NameStr) = 'SYSOP' then begin NameStr := 'SYSOP'; TempUserFindID := 0; end; UserFindID := TempUserFindID; end; Function UserFindName(UserNum: integer): string; {***************************************************************************} var TempUserFindName: string; UserLine: integer; UserNumStr: string; NameUser: string; begin TempUserFindName := 'unkPortn'; UserNumStr := StrInt(UserNum); UserLine := FileSearch('L', UsersLog, UserNumStr); if UserLine > 1 then if FileLine('R', UsersLog, UserLine - 1, NameUser) then TempUserFindName := NameUser; UserFindName := TempUserFindName; end; Function UserKill: boolean; {***************************************************************************} var TempUserKill: boolean; DeadLine: integer; begin TempUserKill := false; DeadLine := FileSearch('U', UsersLog, UserName[Port]); if DeadLine <> 0 then if FileLine('D', UsersLog, DeadLine, DumStr) then if FileLine('D', UsersLog, DeadLine, DumStr) then TempUserKill := true; UserKill := TempUserKill; end; Function UserNext: integer; {***************************************************************************} var NumUsersStr: string; NumUsers: integer; begin if not(FileExists(StatFile)) then DumBool := FileCreate(StatFile); if not(FileLine('R', StatFile, 3, NumUsersStr)) then NumUsersStr := '0'; NumUsers := IntStr(NumUsersStr) + 1; NumUsersStr := StrInt(NumUsers); DumBool := FileLine('O', StatFile, 3, NumUsersStr); UserNext := NumUsers; end; Function ValidName: boolean; {***************************************************************************} var InStr: string; F: text; Found: boolean; begin if (UpCaseStr(UserName[Port]) = 'MANAGER') or (UpCaseStr(UserName[Port]) = 'SYSOP') or (UpCaseStr(UserName[Port]) = 'SYSTEM') then begin UserName[Port] := 'Manager'; ValidName := true; UserID[Port] := 0; exit; end; if not(FileExists(UsersLog)) then DumBool := FileCreate(UsersLog); if FileOpen('R', UsersLog, F) <> 0 then if not(FileCreate(UsersLog)) or (FileOpen('R', UsersLog, F) <> 0) then begin ErrSayL('UsersLog not found!'); ValidName := false; exit; end; Found := false; repeat ReadLn(F, InStr); if UpCaseStr(InStr) = UpCaseStr(UserName[Port]) then begin UserName[Port] := InStr; Found := true; ReadLn(F, UserID[Port]); end; until EOF(F) or Found; Close(F); if Found then ValidName := true else ValidName := false; end; Function VarPeekInteger: Integer; {***************************************************************************} begin VarPeekInteger := VarInteger[Port, VarIntegerTOS[Port] - 1]; end; Function VarPeekStr: string; {***************************************************************************} begin if VarStrTOS[Port] = 1 then ErrSayL('Error: VarPeekStr attempted when VarStrTOS = 1!') else VarPeekStr := VarStr[Port, VarStrTOS[Port] - 1]; end; Function VarPeekTextNum: integer; {***************************************************************************} begin VarPeekTextNum := VarTextTOS[Port] - 1; end; Function VarPopInteger: Integer; {***************************************************************************} begin if VarIntegerTOS[Port] = 1 then begin ErrSayL('VarIntegerTOS popped to less than 1!!!'); VarPopInteger := 0; end else begin VarPopInteger := VarInteger[Port, VarIntegerTOS[Port] - 1]; VarInteger[Port, VarIntegerTOS[Port]] := 0; Dec(VarIntegerTOS[Port]); end; end; Function VarPopStr: string; {***************************************************************************} begin if VarStrTOS[Port] = 1 then begin ErrSayL('VarStrTOS popped to less than 1!!!'); VarPopStr := ''; end else begin VarPopStr := VarStr[Port, VarStrTOS[Port] - 1]; VarStr[Port, VarStrTOS[Port]] := ''; Dec(VarStrTOS[Port]); end; end; Function VarPopTextNum: integer; {***************************************************************************} begin if VarTextTOS[Port] = 1 then ErrSayL('VarTextTOS popped to less than 1!!!') else begin VarPopTextNum := VarTextTOS[Port] - 1; Dec(VarTextTOS[Port]); end; end; Procedure VarPushInteger(PushedInteger: Integer); {***************************************************************************} var alpha: integer; begin if VarIntegerTOS[Port] = VarIntegerMaxStack then begin ErrSayL('VarIntegerTOS pushed past VarIntegerMaxStack!!!'); for alpha := 1 to (VarIntegerMaxStack - 1) do VarInteger[Port, alpha] := VarInteger[Port, alpha + 1]; VarInteger[Port, VarIntegerTOS[Port]] := PushedInteger; end else begin VarInteger[Port, VarIntegerTOS[Port]] := PushedInteger; Inc(VarIntegerTOS[Port]); end; end; Procedure VarPushStr(PushedStr: string); {***************************************************************************} var alpha: integer; begin if VarStrTOS[Port] = VarStrMaxStack then begin ErrSayL('VarStrTOS pushed past VarStrMaxStack!!!'); for alpha := 1 to (VarStrMaxStack - 1) do VarStr[Port, alpha] := VarStr[Port, alpha + 1]; VarStr[Port, VarStrTOS[Port]] := PushedStr; end else begin VarStr[Port, VarStrTOS[Port]] := PushedStr; Inc(VarStrTOS[Port]); end; end; Function VarPushText: integer; {***************************************************************************} var Temp: integer; begin if VarTextTOS[Port] = VarTextMaxStack then ErrSayL('VarTextTOS pushed past VarTextMaxStack!!!') else Inc(VarTextTOS[Port]); Temp := VarTextTOS[Port] - 1; VarPushText := Temp; end; Procedure VarResetInteger(InitInteger: Integer); {***************************************************************************} begin VarIntegerTOS[Port] := 1; VarInteger[Port, VarIntegerTOS[Port]] := InitInteger; end; Procedure VarResetStr(InitStr: String); {***************************************************************************} begin VarStrTOS[Port] := 1; VarStr[Port, VarStrTOS[Port]] := InitStr; end; Procedure VarTextCloseAll(Session: integer); {***************************************************************************} var Index: integer; begin {$I-} for Index := 1 to VarTextMaxStack do Close(VarText[Session, Index]); {$I+} DumInt := IOResult; end; Procedure XFileMenu; {***************************************************************************} begin SayL(''); SayL('FILE HELP MENU'); SayL('|'); SayL('V ----- View files available'); SayL('D ----- Download a file from this BBS'); SayL('U ----- Upload a file to this BBS'); SayL('R ----- Remove a file from the list'); SayL('|'); SayL('C ----- Chat/Comment to the SYSOP'); SayL('G ----- Goodbye (log off)'); SayL('H ----- Help (this menu)'); SayL('Q ----- Quit back to the menu that calls this one'); end; {***************************************************************************} {***************************************************************************} {***************************************************************************} begin end.