{$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

  BBSAlarm,

  BBSGlbls,

  FileIO,

  Globals,

  Keyboard,

  MiscSubs;



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);

Function  BullCountBulls(SA: W10k): W10k;

Function  BullCountChildren(SA: W10k): W10k;

Function  BullCountParents(SA: W10k): W10k;

Function  BullHeaderAuthor(BullFileStr: StrBSA): string;

Function  BullHeaderSubject(BullFileStr: StrBSA): string;

Function  BullListBulls: W10k;

Function  BullListChildren(BD, SA: W10k): W10k;

Function  BullListParents(BD, SA: W10k): W10k;

Function  BullNextBulletin: StrBSA;

Function  BullNextSubjectArea: W10k;

Function  BullReadFile: string;

Procedure BullReadMark(BullNum: W10k);

Function  BullSABFile(BD, SA: W10k): StrBSA;

Function  BullSABFileAssignResetMake(var BB: BSAFile; BD, SA: W10k): boolean;

Function  BullSACFile(BD, SA: W10k): StrBSA;

Function  BullSAPFile(BD, SA: W10k): StrBSA;

Function  BullSAConnect(ParentStr, ChildStr: StrBSA): boolean;

Function  BullSADisconnect(ParentStr, ChildStr: StrBSA): boolean;

Function  BullSAFileDatum(

            FileStr: StrBSA; Index: W10k; var Datum: StrBSA): boolean;

Function  BullSAFileDeleteDatum(FileStr: StrBSA; Index: W10k): boolean;

Function  BullSAFileExistMake(FileStr: string): boolean;

Function  BullSAFileSearch(FileStr,SearchStr: StrBSA;Var Index:W10k):boolean;

Procedure BullSwitchSubjectArea(NewSubjectArea: integer);

Procedure CheckTimeLeft;

Procedure FlushSessInput;

Procedure GetInputs;

Procedure IdentifyBBS;

Function  MailCheck: boolean;

Function  MailNext: string;

Procedure MainInit;

Procedure MainLoop;

Procedure Periodic;

Function  PrivCheck(MsgOn: boolean; PrivBits: longint): boolean;

Function  Reply: string;

Procedure RestartBBS;

Procedure SetTimeLogOut(NumSecs: longint);

Function  SetUpBBSFiles(BBSFile: string): boolean;

Procedure ShowTimeLeft;

Procedure SublimInit;

Procedure SublimPick;

Procedure ToggleSetUp;

Procedure Trash(DeadFile: string);

Procedure UpdateMonitor;

Procedure UpdateSession;

Function  UserDir(UserNum: W10k): string;

Function  UserFile: string;

Function  UserFindID(var NameStr: string): integer;

Function  UserFindName(UserNum: integer): string;

Function  UserKill: boolean;

Function  UserNext: integer;

Procedure UsersShow;

Procedure UserShowData(TempUserID: integer);

Function  ValidName: boolean;

Function  VarPeekByte: byte;

Function  VarPeekStr: string;

Function  VarPopByte: byte;

Function  VarPopStr: string;

Procedure VarPushByte(PushedByte: byte);

Procedure VarPushStr(PushedStr: string);

Procedure VarResetByte(InitByte: byte);

Procedure VarResetStr(InitStr: string);



implementation

{***************************************************************************}

{***************************************************************************}

Uses

  BBSDoSub,

  Crt,

  Dos,

  IOPorts,

  LctKrnl, {* for RestartBBS *}

  Windows;



Function AreaPeek: AreaType;

{***************************************************************************}

begin

  AreaPeek := Area[Now, AreaTOS[Now]];

end;



Procedure AreaPop;

{***************************************************************************}

begin

  if AreaTOS[Now] = 1 then

    begin

      ErrSayL('AreaTOS popped to less than 1!!!');

      Area[Now, AreaTOS[Now]] := Prompt;

    end

  else

    begin

      Area[Now, AreaTOS[Now]] := Zero;

      Dec(AreaTOS[Now]);

    end;

end;



Procedure AreaPush(PushedArea: AreaType);

{***************************************************************************}

var

  alpha: integer;

begin

  if AreaTOS[Now] = AreaMaxStack then

    begin

      ErrSayL('AreaTOS pushed past AreaMaxStack!!!');

      for alpha := 1 to (AreaMaxStack - 1) do

        Area[Now, alpha] := Area[Now, alpha + 1];

    end

  else

    Inc(AreaTOS[Now]);

  Area[Now, AreaTOS[Now]] := PushedArea;

end;



Procedure AreaReset(InitArea: AreaType);

{***************************************************************************}

begin

  AreaTOS[Now] := 1;

  Area[Now, AreaTOS[Now]] := InitArea;

end;



Procedure AreaSub(SubstituteArea: AreaType);

{***************************************************************************}

begin

  Area[Now, AreaTOS[Now]] := SubstituteArea

end;



Procedure Ask(QueryStr: string; TheNextArea: AreaType; StringLength: byte);

{***************************************************************************}

{* if StringLength = 0 then StringLength = LineLen - Len(QueryStr)

{***************************************************************************}

begin

  Say(QueryStr);

  AreaSub(TheNextArea);

  if StringLength = 0 then

    StringLength := LineLen - Length(QueryStr);

  InStrMaxLen[Now] := StringLength;

  BeepTime[Now] := InputTime/10;

  InputDeadLine[Now] := JulianDate*24*3600 + TimeInSecs + BeepTime[Now];

  SessInStr[Now] := '';

  AreaPush(UserInput);

end;



Function BullCountBulls(SA: W10k): W10k;

{***************************************************************************}

var

  Temp: integer;

  BF: BSAFile;

begin

  Assign(BF, BullSABFile(BullAreaDir[Now], SA));

{$I-}

  Reset(BF);

  Temp := FileSize(BF) - 1;

  if Temp = -1 then

    Temp := 0;

  Close(BF);

{$I+}

  if IOResult = 0 then

    BullCountBulls := Temp

  else

    BullCountBulls := 0;

end;



Function BullCountChildren(SA: W10k): W10k;

{***************************************************************************}

var

  Temp: integer;

  BC: BSAFile;

begin

  Assign(BC, BullSACFile(BullAreaDir[Now], SA));

{$I-}

  Reset(BC);

  Temp := FileSize(BC) - 1;

  if Temp = -1 then

    Temp := 0;

  Close(BC);

{$I+}

  if IOResult = 0 then

    BullCountChildren := Temp

  else

    BullCountChildren := 0;

end;



Function BullCountParents(SA: W10k): W10k;

{***************************************************************************}

var

  Temp: integer;

  BP: BSAFile;

begin

  Assign(BP, BullSAPFile(BullAreaDir[Now], SA));

{$I-}

  Reset(BP);

  Temp := FileSize(BP) - 1;

  if Temp = -1 then

    Temp := 0;

  Close(BP);

{$I+}

  if IOResult = 0 then

    BullCountParents := Temp

  else

    BullCountParents := 0;

end;



Function BullHeaderAuthor(BullFileStr: StrBSA): string;

{***************************************************************************}

var

  BF: text;

  Temp: string;

begin

  Assign(BF, BullFileStr);

{$I-}

  Reset(BF);

  if IOResult = 0 then

    begin

      readln(BF, DumStr);

      readln(BF, Temp);

      Temp := copy(Temp, 11, length(Temp) - 10);

    end

  else

    Temp := 'Bulletin would not open! Contact BBS Manager.';

  Close(BF);

{$I+}

  BullHeaderAuthor := Temp;

end;



Function BullHeaderSubject(BullFileStr: StrBSA): string;

{***************************************************************************}

var

  BF: text;

  Temp: string;

begin

  Assign(BF, BullFileStr);

{$I-}

  Reset(BF);

  if IOResult = 0 then

    begin

      readln(BF, Temp);

      Temp := copy(Temp, 11, length(Temp) - 10);

    end

  else

    Temp := 'Bulletin would not open! Contact BBS Manager.';

  Close(BF);

{$I+}

  BullHeaderSubject := Temp;

end;



Function  BullListBulls: W10k;

{***************************************************************************}

var

  alpha: W10k;

  BB:  BSAFile;

  BullStr: StrBSA;

  BullReadChar: char;

  BullID: W10k;

  BullReadBool: boolean;

begin

  if FileExists(BullSABFile(BullAreaDir[Now], BullAreaID[Now])) then

    begin

      alpha := 0;

      Assign(BB, BullSABFile(BullAreaDir[Now], BullAreaID[Now]));

{$I-}

      Reset(BB);

      read(BB, BullStr);

      while not(EOF(BB)) do

        begin

          Inc(alpha);

          read(BB, BullStr);

          BullReadChar := ' ';

          BullID := IntStr(copy(BullStr, length(BullStr) - 7, 4));

          if FileDataBool('R',BullReadFile,BullID-1,BullReadBool) then

            if BullReadBool then

              BullReadChar := '*';

          SayL(StrInt(alpha)+')'+BullReadChar+' '+

            BullHeaderSubject(BullStr));

        end;

      Close(BB);

{$I+}

    end;

  if alpha = 0 then

    SayL('There are no bulletin subject areas under this one.');

  BullListBulls := alpha;

end;



Function  BullListChildren(BD, SA: W10k): W10k;

{***************************************************************************}

var

  alpha: W10k;

  BB,

  BC: BSAFile;

  BullStr: StrBSA;

begin

  if FileExists(BullSACFile(BD, SA)) then

    begin

      alpha := 0;

      Assign(BC, BullSACFile(BD, SA));

{$I-}

      Reset(BC);

      read(BC, BullStr);

      while not(EOF(BC)) do

        begin

          inc(alpha);

          read(BC, BullStr);

          Assign(BB, BullStr);

          Reset(BB);

          read(BB, BullStr);

          Close(BB);

          SayL(StrInt(alpha)+') '+BullStr);

        end;

      Close(BC);

{$I+}

    end;

  if alpha = 0 then

    SayL('There are no bulletin subject areas below this one.');

  BullListChildren := alpha;

end;





Function  BullListParents(BD, SA: W10k): W10k;

{***************************************************************************}

var

  alpha: W10k;

  BB,

  BP: BSAFile;

  BullStr: StrBSA;

begin

  if FileExists(BullSAPFile(BD, SA)) then

    begin

      alpha := 0;

      Assign(BP, BullSAPFile(BD, SA));

{$I-}

      Reset(BP);

      read(BP, BullStr);

      while not(EOF(BP)) do

        begin

          inc(alpha);

          read(BP, BullStr);

          Assign(BB, BullStr);

          Reset(BB);

          if IOResult = 2 then

            BullStr := BullTopSubjectStr

          else

            begin

              Read(BB, BullStr);

              Close(BB);

            end;

          SayL(StrInt(alpha)+') '+BullStr);

        end;

      Close(BP);

{$I+}

    end;

  if alpha = 0 then

    SayL('There are no bulletin subject areas above this one.');

  BullListParents := alpha;

end;



Function BullNextBulletin: StrBSA;

{***************************************************************************}

var

  MaxBltn: integer;

  MaxBltnStr: string;

begin

  if FileExists(StatFile) then

    if FileLine('R', StatFile, 1, MaxBltnStr) then

      begin

        if MaxBltnStr = '' then

          MaxBltnStr := '0';

        MaxBltn := IntStr(MaxBltnStr) + 1;

        MaxBltnStr := StrInt(MaxBltn);

        DumBool := FileLine('O', StatFile, 1, MaxBltnStr);

      end;

  BullNextBulletin := UserDir(UserID[Now])

    + '\' + 'BULL' + StrIntZer(MaxBltn, 4) + '.BBS';

end;



Function BullNextSubjectArea: W10k;

{***************************************************************************}

var

  MaxSubjArea: integer;

  MaxSubjAreaStr: string;

begin

  if not(FileExists(StatFile)) then

    begin

      DumBool := FileCreate(StatFile);

      MaxSubjAreaStr := '1';

      DumBool := FileLine('O', StatFile, 2, MaxSubjAreaStr);

      BullNextSubjectArea := 1;

      exit;

    end;

  if FileLine('R', StatFile, 2, MaxSubjAreaStr) then

    begin

      if MaxSubjAreaStr = '' then

        MaxSubjAreaStr := '0';

      MaxSubjArea := IntStr(MaxSubjAreaStr) + 1;

      MaxSubjAreaStr := StrInt(MaxSubjArea);

      DumBool := FileLine('O', StatFile, 2, MaxSubjAreaStr);

    end;

  BullNextSubjectArea := MaxSubjArea;

end;



Function BullReadFile: string;

{***************************************************************************}

begin

  BullReadFile := UserDir(UserID[Now]) + '\BULLREAD.BBS';

end;



Procedure BullReadMark(BullNum: W10k);

{***************************************************************************}

var

  Mark: boolean;

begin

  Mark := true;

  DumBool := FileDataBool('W', BullReadFile, BullNum - 1, Mark);

end;



Function BullSABFile(BD, SA: W10k): StrBSA;

{***************************************************************************}

begin

  BullSABFile := UserDir(BD) + '\BSAB' + StrIntZer(SA, 4) + '.BBS';

end;



Function BullSABFileAssignResetMake(var BB: BSAFile; BD, SA: W10k): boolean;

{***************************************************************************}

var

  ErrMsg: StrBSA;

begin

  Assign(BB, BullSABFile(BD, SA));

{$I-}

  Reset(BB);

  if IOResult = 2 then

    begin

      Rewrite(BB);

      ErrMsg := 'UNKNOWN SUBJECT AREA: contact manager!';

      write(BB, ErrMsg);

      close(BB);

      Reset(BB);

    end;

  BullSABFileAssignResetMake := IOResult = 0;

end;



Function BullSACFile(BD, SA: W10k): StrBSA;

{***************************************************************************}

var

  Temp: StrBSA;

begin

  Temp := UserDir(BD) + '\BSAC' + StrIntZer(SA, 4) + '.BBS';

  DumBool := BullSAFileExistMake(Temp);

  BullSACFile := Temp;

end;



Function BullSAPFile(BD, SA: W10k): StrBSA;

{***************************************************************************}

begin

  BullSAPFile := UserDir(BD) + '\BSAP' + StrIntZer(SA, 4) + '.BBS';

end;



Function  BullSAConnect(ParentStr, ChildStr: StrBSA): boolean;

{***************************************************************************}

var

  Temp: boolean;

  B: BSAFile;

  BullStr: StrBSA;

begin

{$I-}

  Temp := BullSAFileExistMake(ParentStr);

  if Temp then

    begin

      Assign(B, ParentStr);

      Reset(B);

      if FileSize(B) = 0 then

        begin

          BullStr := 'Parent Subject Areas                 ';

          write(B, BullStr);

        end;

      Seek(B, FileSize(B));

      BullStr := BullSABFile(BullAreaDir[Now], BullAreaID[Now]);

      write(B, BullStr);

      close(B);

      if IOResult <> 0 then

        Temp := false;

    end;

  if Temp then

    begin

      Temp := BullSAFileExistMake(ChildStr);

      Assign(B, ChildStr);

      Reset(B);

      if FileSize(B) = 0 then

        begin

          BullStr := 'Child Subject Areas                  ';

          write(B, BullStr);

        end;

      Seek(B, FileSize(B));

      BullStr := BullSABFile(

        UserID[Now],IntStr(copy(ParentStr,length(ParentStr)-7,4)));

      write(B, BullStr);

      close(B);

      if IOResult <> 0 then

        Temp := false;

    end;

  BullSAConnect := Temp;

{$I+}

end;



Function  BullSADisconnect(ParentStr, ChildStr: StrBSA): boolean;

{***************************************************************************}

var

  Temp: boolean;

  Index: W10k;

begin

  Temp := BullSAFileSearch(ParentStr, ChildStr, Index);

  if Temp then

    Temp := BullSAFileDeleteDatum(ParentStr, Index);

  if Temp then

    Temp := BullSAFileSearch(ChildStr, ParentStr, Index);

  if Temp then

    Temp := BullSAFileDeleteDatum(ChildStr, Index);

  BullSADisconnect := Temp;

end;



Function  BullSAFileDatum(

            FileStr: StrBSA; Index: W10k; var Datum: StrBSA): boolean;

{***************************************************************************}

var

  BF: BSAFile;

begin

  Assign(BF, FileStr);

{$I-}

  Reset(BF);

  Seek(BF, Index);

  read(BF, Datum);

  Close(BF);

{$I+}

  BullSAFileDatum := IOResult = 0;

end;



Function BullSAFileDeleteDatum(FileStr: StrBSA; Index: W10k): boolean;

{***************************************************************************}

var

  F,

  TF: BSAFile;

  alpha: W10k;

  TempStr: StrBSA;

begin

  Assign(F, FileStr);

  Assign(TF, 'TempFile.BBS');

  {$I-}

  Reset(F);

  Rewrite(TF);

  for alpha := 0 to Index - 1 do

    begin

      read(F, TempStr);

      write(TF, TempStr);

    end;

  read(F, TempStr);

  while not(EOF(F)) do

    begin

      read(F, TempStr);

      write(TF, TempStr);

    end;

  close(F);

  close(TF);

  erase(F);

  rename(TF, FileStr);

  {$I+}

  if IOResult = 0 then

    BullSAFileDeleteDatum := true

  else

    BullSAFileDeleteDatum := false;

end;



Function  BullSAFileExistMake(FileStr: string): boolean;

{***************************************************************************}

var

  BF: BSAFile;

  IOTest: integer;

begin

  Assign(BF, FileStr);

{$I-}

  Reset(BF);

  IOTest := IOResult;

  case IOTest of

    2: Rewrite(BF);

    3: DumBool := DirMake(copy(FileStr, 1, length(FileStr) - 13));

  end; {case}

  Close(BF);

{$I+}

  BullSAFileExistMake := IOResult = 0;

end;



Function BullSAFileSearch(FileStr, SearchStr: StrBSA;Var Index:W10k):boolean;

{***************************************************************************}

var

  TempIndex: integer;

  F: BSAFile;

  CompareStr: StrBSA;

begin

  Assign(F, FileStr);

  {$I-}

  Reset(F);

  CompareStr := '';

  TempIndex := -1;

  while not(EOF(F)) and (CompareStr <> SearchStr) do

    begin

      read(F, CompareStr);

      Inc(TempIndex);

    end;

  Close(F);

  {$I+}

  if CompareStr = SearchStr then

    begin

      Index := TempIndex;

      BullSAFileSearch := true;

    end

  else

    BullSAFileSearch := false;

end;



Procedure BullSwitchSubjectArea(NewSubjectArea: integer);

{***************************************************************************}

var

  BullStr: StrBSA;

  Found: boolean;

  NewSubj: StrBSA;

begin

  if NewSubjectArea = 0 then {* Abort *}

    exit;

  Found := false;

  if NewSubjectArea < 0 then

    Found := BullSAFileDatum(BullSAPFile(BullAreaDir[Now], BullAreaID[Now]),

      NewSubjectArea*(-1), BullStr)

  else

    Found := BullSAFileDatum(BullSACFile(BullAreaDir[Now], BullAreaID[Now]),

      NewSubjectArea, BullStr);

  if Found then

    begin

      BullAreaID[Now]  := IntStr(copy(BullStr, length(BullStr) - 7, 4));

      BullAreaDir[Now] := IntStr(copy(BullStr, length(BullStr) - 20, 4));

      if BullSAFileDatum(BullStr, 0, NewSubj) then

        BullAreaSubj[Now] := NewSubj

      else

        BullAreaSubj[Now] := BullTopSubjectStr;

    end;

end;



Procedure CheckTimeLeft;

{***************************************************************************}

begin

  if TimeLogOut[Now] = Infinity then

    exit;

  TimeLeft[Now] := TimeDiff(DateLogOut[Now], TimeLogOut[Now]);

  if TimeLeft[Now] > 0 then

    exit;

  TimeLogOut[Now] := 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 FlushSessInput;

{***************************************************************************}

var

  alpha: integer;

begin

  for alpha := 1 to NumPorts do

    if InputFrom[Now, alpha] then

      FlushInputBuff(alpha);

end;



procedure GetInputs;

{***************************************************************************}

var

  PortChar: char;

  alpha, bravo, charlie: integer;

begin

  for alpha := 0 to NumPorts do

    if GetChar(alpha, PortChar) then

      if (alpha = 0) and (PortChar = Null) then

        ToggleSetUp

      else

      if (AreaPeek = WaitRing) and (alpha = 0) then

        SessInStr[Now] := 'KEYBOARD'

      else

        begin

          for bravo := 1 to MaxSessions do

            if InputFrom[bravo, alpha] then

              begin

                if (InStrMaxLen[bravo] <= length(SessInStr[bravo]))

                  and ((PortChar <> Enter) and (PortChar <> BackSpace)) then

                    PortChar := Beep

                else

                  SessInStr[bravo] := SessInStr[bravo] + PortChar;

                if (PortChar <> BackSpace) and Echo[bravo] then

                  begin

                    DoWindow(bravo);

                    if (PortChar = Beep) and not(BeepOn) then

                      write(QuietBeep)

                    else

                      write(PortChar);

                    SaveX[bravo] := WhereX;

                    SaveY[bravo] := WhereY;

                    for charlie := 1 to NumPorts do

                      if InputFrom[bravo, charlie] then

                        if OutputTo[bravo, charlie] then

                          PortOutStr[charlie] := PortOutStr[charlie] + PortChar;

                  end;

              end;

        end;

end;



Procedure IdentifyBBS;

{***************************************************************************}

begin

  SayL(#7+#7+#7+#7);

  SayL('You are communicating with a WYRM BBS.');

  SayL('Copyright 1990 David Croft.');

  SayL('Owner:  Deadliner Cognomen');

  SayL('Version:  Test 1');

  SayL('Registration Number:  T1');

  SayL('');

end;



Function MailCheck: boolean;

{***************************************************************************}

var

  InStr: string;

  UserBox: string;

  TempMailCheck: boolean;

begin

  TempMailCheck := false;

  UserBox := UserDir(UserID[Now]) + '\' + EMailBox;

  if FileExists(UserBox) then

    if FileLine('R', UserBox, 1, InStr) then

      if InStr <> '' then

        TempMailCheck := true;

  if not(TempMailCheck) then

    SayL('You have no e-mail right now.');

  MailCheck := TempMailCheck;

end;



Function MailNext: string;

{***************************************************************************}

var

  TempMailNext: string;

  MailCount: integer;

begin

  TempMailNext := '';

  if DirExists(UserDir(UserID[Now])) 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[Now])+'\'

          + 'M' + StrIntZer(MailCount, 7) + '.BBS';

      end;

  MailNext := TempMailNext;

end;



Procedure MainInit;

{***************************************************************************}

var

  alpha: integer;

begin

  AlarmInit;

  BeepOn := true;

  InitBBSGlbls;

  ExitSave := ExitProc;

  ExitProc := @RestartBBS;

  DosError := 0;

  InitWindows;

  ActiveSession := 1;

  UpdateSession;

  ShowWriters;

  SublimInit;

{* This loop can be removed when doing keyboard-only testing. *}

{*  for alpha := 1 to NumPorts do

    if PortOn[alpha] then

      InitPort(alpha);

*}

  repeat

    Periodic;

    MainLoop;

  until false;

end;



Procedure MainLoop;

{***************************************************************************}

begin

  case AreaPeek of

    WaitRing     :  DoWaitRing;

    WaitConnect  :  DoWaitConnect;

    GetName      :  DoGetName;

    GetName_1    :  DoGetName_1;

    GetName_2    :  DoGetName_2;

    UserInput    :  DoUserInput;

    Register     :  DoRegister;

    Register_1   :  DoRegister_1;

    Welcome      :  DoWelcome;

    Menu         :  DoMenu;

    Prompt       :  DoPrompt;

    Prompt_1     :  DoPrompt_1;

    LogOff       :  DoLogOff;

    LogOff_1     :  DoLogOff_1;

    Disconnect   :  DoDisconnect;

    Chat         :  DoChat;

    BullRead     :  DoBullRead;

    BullRead_1   :  DoBullRead_1;

    BullPost     :  DoBullPost;

    BullPost_1   :  DoBullPost_1;

    BullDel      :  DoBullDel;

    BullDel_1    :  DoBullDel_1;

    Bulletins    :  DoBulletins;

    BullMenu     :  DoBullMenu;

    BullPrompt   :  DoBullPrompt;

    BullPrompt_1 :  DoBullPrompt_1;

    BullSubCon       :  DoBullSubCon;

    BullSubCon_1     :  DoBullSubCon_1;

    BullSubCon_2     :  DoBullSubCon_2;

    BullSubMake      :  DoBullSubMake;

    BullSubMake_1    :  DoBullSubMake_1;

    BullSubKill      :  DoBullSubKill;

    BullSubKill_1    :  DoBullSubKill_1;

    BullSubDown  :  DoBullSubDown;

    BullSubDown_1:  DoBullSubDown_1;

    BullSubUp    :  DoBullSubUp;

    BullSubUp_1  :  DoBullSubUp_1;

    BullPickedChild      : DoBullPickedChild;

    BullPickedChild_1    : DoBullPickedChild_1;

    BullPickedParent     : DoBullPickedParent;

    BullPickedParent_1   : DoBullPickedParent_1;

    BullPickedBull       : DoBullPickedBull;

    BullPickedBull_1     : DoBullPickedBull_1;

    Statistics   :  DoStatistics;

    Statistics_1 :  DoStatistics_1;

    DataMenu     :  DoDataMenu;

    MailMenu     :  DoMailMenu;

    EMail        :  DoEMail;

    EMail_1      :  DoEMail_1;

    EMailSend    :  DoEMailSend;

    EMailSend_1  :  DoEMailSend_1;

    EMailSend_2  :  DoEMailSend_2;

    EMailSend_3  :  DoEMailSend_3;

    EMailSend_4  :  DoEMailSend_4;

    EMailRead    :  DoEMailRead;

    MakePassword :  DoMakePassword;

    Feedback     :  DoFeedback;

    Feedback_1   :  DoFeedback_1;

    Feedback_2   :  DoFeedback_2;

    PasswordGood         : DoPasswordGood;

    PasswordGood_1       : DoPasswordGood_1;

    MakePassword         : DoMakePassword;

    MakePassword_1       : DoMakePassword_1;

    MakePassword_2       : DoMakePassword_2;

    FileLineEdit         : DoFileLineEdit;

    FileLineEdit_1       : DoFileLineEdit_1;

    FileShow             : DoFileShow;

    UpDown               : DoUpDown;

    AddOn                : DoAddOn;

    AddOnMenu            : DoAddOnMenu;

    AddOnPrompt          : DoAddOnPrompt;

    AddOnPrompt_1        : DoAddOnPrompt_1;

    else

      ErrSayL(Beep+'Bad Area!!!:  '+ StrInt(Ord(AreaPeek)));

  end; {case}

end;



Procedure Periodic;

{***************************************************************************}

begin

  inc(Now);

  if Now > MaxSessions then

    Now := 1;

  UpdateMonitor;

  GetInputs;

  PutOutputs;

  CheckTimeLeft;

  if Disconnected then

    AreaReset(WaitRing);

  if AlarmOn then

    DumBool := AlarmCheck;

end;



Function PrivCheck(MsgOn: boolean; PrivBits: longint): boolean;

{***************************************************************************}

begin

  if UserPrivs[Now] 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.');

          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;

{***************************************************************************}

begin

  Reply := SessInStr[Now];

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;

  MainInit;

end;

{$F-}



Procedure SetTimeLogOut(NumSecs: longint);

{***************************************************************************}

begin

  DateLogOut[Now] := JulianDate;

  TimeLogOut[Now] := trunc(TimeInSecs) + NumSecs;

  DateLogOut[Now] := DateLogOut[Now] + TimeLogOut[Now] div (24*3600);

  TimeLogOut[Now] := TimeLogOut[Now] mod (24*3600);

end;



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;

begin

  if TimeLogOut[Now] = Infinity then

    begin

      Say('(No Time Limit) ');

      exit;

    end;

  TimeLeft[Now] := TimeDiff(DateLogOut[Now], TimeLogOut[Now]);

  Hour := TimeLeft[Now] div 3600;

  Min := (TimeLeft[Now] div 60) - (Hour*60);

  Sec := TimeLeft[Now] mod 60;

  Say('('+StrIntZer(Hour,2) +':'+ StrIntZer(Min, 2) + ':'

    + StrIntZer(Sec, 2)+') ');

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 1990.');

      writeln(SF, 'WBBS is capable of up to 3 users online at a time.');

      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 ToggleSetUp;

{***************************************************************************}

var

  InChar: char;

  ComPort: integer;

begin

  if AltKey(InChar) then

    case InChar of

      AltA:

        begin

          AlarmToggle;

          UpdateSession;

        end;

      AltB:

        begin

          BeepOn := not(BeepOn);

          UpdateSession;

        end;

      #68:

        InputFrom[ActiveSession, 0] := not(InputFrom[ActiveSession, 0]);

      #93:

        begin

          Inc(ActiveSession);

          if ActiveSession > MaxSessions then

            ActiveSession := 1;

          UpdateSession;

        end;

      #59..#67:

        begin

          ComPort := ord(InChar) - 58;

          if ComPort <= NumPorts then

            InputFrom[ActiveSession, ComPort] :=

              not(InputFrom[ActiveSession, ComPort])

          else

            write(#7);

        end;

      #84..#92:

        begin

          ComPort := ord(InChar) - 83;

          if ComPort <= NumPorts then

            OutputTo[ActiveSession, ComPort] :=

              not(OutputTo[ActiveSession, ComPort])

          else

            write(#7);

        end;

      else

        write(#7);

    end; {case}

  ShowWriters;

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;



Procedure UpdateMonitor;

{***************************************************************************}

var

  alpha: integer;

  Hour,

  Minute,

  Sec,

  Sec100: word;

begin

  GetTime(Hour, Minute, Sec, Sec100);

  Window(1,1,80,1);

  write(StrWrdZer(Hour,2),':',

    StrWrdZer(Minute,2),':',StrWrdZer(Sec,2),'.',StrWrdZer(Sec100,2),' ');

end;



Procedure UpdateSession;

{***************************************************************************}

begin

  UpdateMonitor;

  write('Alarm ');

  if AlarmOn then

    write('On  ')

  else

    write('Off ');

  write('Beep ');

  if BeepOn then

    write('On  ')

  else

    write('Off ');

  write('Fn in., Shft-Fn out., F10 keyb, Shft-F10 sess(');

  write(ActiveSession,')');

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 := 'unknown';

  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 UserFile: string;

{***************************************************************************}

begin

  UserFile := UserDir(UserID[Now]) + '\UserData.BBS';

end;



Function UserKill: boolean;

{***************************************************************************}

var

  TempUserKill: boolean;

  DeadLine: integer;

begin

  TempUserKill := false;

  DeadLine := FileSearch('U', UsersLog, UserName[Now]);

  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;



Procedure UserShowData(TempUserID: integer);

{***************************************************************************}

const

  DescripU: array[1..11] of string = (

    'Password:  ',

    'Number of seconds per call:  ',

    'Privileges Code Number:  ',

    'Date last logged out:  ',

    'Time last logged out:  ',

    'Minimum time between calls in seconds:  ',

    'Total time allowable per day in seconds:  ',

    'Total time used today in seconds:  ',

    'Credit:  $',

    'Acquired kudos:  ',

    'Second password:  ');

var

  SF: text;

  alpha: integer;

  LineStr: string;

  SaveUserID: integer;

begin

  SaveUserID := UserID[Now];

  UserID[Now] := TempUserID;

  alpha := 0;

  if FileOpen('R', UserFile, SF) = 0 then

    begin

      while not(EOF(SF)) do

        begin

          Inc(alpha);

          Say(DescripU[alpha]);

          readln(SF, LineStr);

          if alpha <> 1 then

            SayL(LineStr)

          else

            SayL('not shown');

        end;

      close(SF);

    end;

  UserID[Now] := SaveUserID;

end;



Procedure UsersShow;

{***************************************************************************}

var

  UL: text;

  UserStr: string;

  UserNum: string;

begin

  if FileOpen('R', UsersLog, UL) = 0 then

    begin

      while not(EOF(UL)) do

        begin

          readln(UL, UserStr);

          readln(UL, UserNum);

          SayL(UserNum+') '+UserStr);

        end;

      close(UL);

    end;

end;



Function ValidName: boolean;

{***************************************************************************}

var

  InStr: string;

  F: text;

  Found: boolean;

begin

  if (UpCaseStr(UserName[Now]) = 'MANAGER') or

    (UpCaseStr(UserName[Now]) = 'SYSOP') or

    (UpCaseStr(UserName[Now]) = 'SYSTEM') then

      begin

        UserName[Now] := 'Manager';

        ValidName := true;

        UserID[Now] := 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[Now]) then

      begin

        UserName[Now] := InStr;

        Found := true;

        ReadLn(F, UserID[Now]);

      end;

  until EOF(F) or Found;

  Close(F);

  if Found then

    ValidName := true

  else

    ValidName := false;

end;



Function VarPeekByte: byte;

{***************************************************************************}

begin

  VarPeekByte := VarByte[Now, VarByteTOS[Now]];

end;



Function VarPeekStr: string;

{***************************************************************************}

begin

  VarPeekStr := VarStr[Now, VarStrTOS[Now]];

end;



Function VarPopByte: byte;

{***************************************************************************}

begin

  if VarByteTOS[Now] = 1 then

    begin

      ErrSayL('VarByteTOS popped to less than 1!!!');

      VarPopByte := 0;

    end

  else

    begin

      VarPopByte := VarByte[Now, VarByteTOS[Now]];

      VarByte[Now, VarByteTOS[Now]] := 0;

      Dec(VarByteTOS[Now]);

    end;

end;



Function VarPopStr: string;

{***************************************************************************}

begin

  if VarStrTOS[Now] = 1 then

    begin

      ErrSayL('VarStrTOS popped to less than 1!!!');

      VarPopStr := '';

    end

  else

    begin

      VarPopStr := VarStr[Now, VarStrTOS[Now]];

      VarStr[Now, VarStrTOS[Now]] := '';

      Dec(VarStrTOS[Now]);

    end;

end;



Procedure VarPushByte(PushedByte: byte);

{***************************************************************************}

var

  alpha: integer;

begin

  if VarByteTOS[Now] = VarByteMaxStack then

    begin

      ErrSayL('VarByteTOS pushed past VarByteMaxStack!!!');

      for alpha := 1 to (VarByteMaxStack - 1) do

        VarByte[Now, alpha] := VarByte[Now, alpha + 1];

    end

  else

    Inc(VarByteTOS[Now]);

  VarByte[Now, VarByteTOS[Now]] := PushedByte;

end;



Procedure VarPushStr(PushedStr: string);

{***************************************************************************}

var

  alpha: integer;

begin

  if VarStrTOS[Now] = VarStrMaxStack then

    begin

      ErrSayL('VarStrTOS pushed past VarStrMaxStack!!!');

      for alpha := 1 to (VarStrMaxStack - 1) do

        VarStr[Now, alpha] := VarStr[Now, alpha + 1];

    end

  else

    Inc(VarStrTOS[Now]);

  VarStr[Now, VarStrTOS[Now]] := PushedStr;

end;



Procedure VarResetByte(InitByte: byte);

{***************************************************************************}

begin

  VarByteTOS[Now] := 1;

  VarByte[Now, VarByteTOS[Now]] := InitByte;

end;



Procedure VarResetStr(InitStr: String);

{***************************************************************************}

begin

  VarStrTOS[Now] := 1;

  VarStr[Now, VarStrTOS[Now]] := InitStr;

end;



{***************************************************************************}

{***************************************************************************}

{***************************************************************************}

begin

end.