Program MultiBoard_V1_Beta;
{**************************}

uses crt,dos;

Const
 basex : byte = 1;
 basey : byte = 1;
 esc = #27;
 Serie = $2E8;

Type
  commentaire = string[55];   {Type ncessaires au record 'Mboard!' }
  scom = string [30];
  Mboard = Record
     bbsname   : scom;
     comBBS1,comBBS2,comBBS3   : commentaire; { Commentaires au dbut }
     Loc       : scom;
     sysopname : scom;
     nbr_sys   : byte; { Nombre de boards }
     board_name: array[1..20] of scom;
     errorl    : array[1..20] of byte;
     comb1     : array[1..20] of commentaire;
     comb2     : array[1..20] of commentaire;
     comb3     : array[1..20] of commentaire;
     pass      : array[1..20] of scom; {Mot de passe }
     passagree : array[1..20] of boolean; {Oui ou non (pour le mot de passe)}
     nbr_es    : array[1..20] of byte; {Nombre d'essaies pour le mot }
  end;

Var
 Config : Mboard;
 fichier : file of mboard;
 fich : text;

                { Procdures de communication... }
                { Elles sont pas encore en Lib car version 1.0/Bta }
                { Enfin, il faudra... je pense qd mme les mettre en }
                { Lors de la premire compilation officielle de la bta }

{***************************************************************************}
Procedure GetChar(inchar : char);
(*******************************)
Begin
  Inchar := chr(Port[serie]);
end;



Procedure SENDCHAR(outchar : char);

  begin {* SendChar *}
    port[Serie] := ord(outchar)            { send character }
  end;  {* SendChar *}


Procedure SENDSTRING2(outstr : string;docr : boolean);
  var
    sloop : byte;

  begin {* SendString *}
        for sloop := 1 to length(outstr) do SendChar(outstr[sloop]);
        if docr then
          begin
            SendChar(char($0D));       { send CR }
            SendChar(char($0A));       { send LF }
          end;
  end;  {* SendString *}

Procedure SENDSTRING(outstr : string;docr : boolean);
  var
    sloop : byte;

  begin {* SendString *}
        write(outstr);
        for sloop := 1 to length(outstr) do SendChar(outstr[sloop]);
        if docr then
          begin
            SendChar(char($0D));       { send CR }
            SendChar(char($0A));       { send LF }
            writeln;
          end;
  end;  {* SendString *}

Procedure Sauteligne;
 begin
     SendChar(char($0D));        { send CR }
     SendChar(char($0A));        { send LF }
     writeln;
 end;

Function INTSTR(val : longint;isize : byte) : string;
(****************************************************)
  var
    ist : string;

  begin {* fIntStr *}
    Str(val:isize,ist);
    IntStr := ist
  end;  {* fIntStr *}

Procedure GOTOPORTXY(x,y : byte);
(********************************)
  begin {* GotoPortXY *}
    x := x + basex - 1;
    y := y + basey - 1;
    SendString2(esc+'['+IntStr(y,0)+';'+IntStr(x,0)+'H',false);
    gotoxy(x,y);
  end;  {* GotoPortXY *}

Procedure clearscr;
(****************)
  Begin
    SendString2(esc+'[2J',false); { Efface l'cran de la remote }
    clrscr;
  end;

Procedure SETCOLOR(color : byte);
(*******************************)
 var col : byte;
  begin {* SetColor *}
        SendString2(esc+'['+IntStr(color,0)+'m',false);
      case color of
         30 : col := 0;
         31 : col := 4;
         32 : col := 2;
         33 : col := 14;
         34 : col := 1;
         35 : col := 5;
         36 : col := 3;
         37 : col := 15;
        end;
         textcolor(col);
   end;  {* SetColor *}

Procedure BACKCOLOR(color: byte);
(********************************)
 var col : byte;
  begin {* BackColor *}
    if color in [30..37] then SendString2(esc+'['+IntStr(color+10,0)+'m',false);
     case color of
         30 : col := 0;
         31 : col := 4;
         32 : col := 2;
         33 : col := 14;
         34 : col := 1;
         35 : col := 5;
         36 : col := 3;
         37 : col := 15;
        end;
         textbackground(col);
  end;  {* BackColor *}

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

{                   Fin des procdures de communication                     }

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


Function str_time : string;
(**************************)
var item : string[20];
    hour,minute,second,sec100,year,month,day,dayofweed : word;
    h,m,s,y,mo,d : string[2];
begin
  gettime(hour,minute,second,sec100);
  getdate(year,month,day,dayofweed);
  str(day:0,d);
  if length(d) < 2 then d := '0' + d;
  str(minute:0,m);
  if length(m) < 2 then m := '0' + m;
  str(month:0,mo);
  if length(mo) < 2 then mo := '0' + mo;
  str(second:0,s);
  if length(s) < 2 then s := '0' + s;
  str(hour:0,h);
  if length(h) < 2 then h := '0' + h;
  item := '> ' + d + '/' + mo + ' ' + h + ':' + m + ':' + s;
  str_time := item;
end;

Procedure Erreur(error_message:string);
(*************************************)
begin
  writeln(error_message);
  Repeat until keypressed;
  readkey;
end;

Procedure demande_creation;
(*************************)
begin
end;




Procedure VerifierIO;  { Vrifie les erreurs d'E/S }
(*******************)
var
  CodesES : integer;
  ErreurES : boolean;
begin
   CodesES := IOresult;
   ErreurES := (CodesES <> 0);
   if ErreurES then begin
    case CodesES of
      $02 : begin Erreur('File not found MBOARD.CFG');
                  demande_creation;end;
      $03 : begin Erreur('File not found MBOARD.CFG');
                  demande_creation;end;
      $04 : begin Erreur('File not open !');halt(1); end;
      $10 : begin Erreur('Numeric format error');halt(1);end;
      $20 : begin Erreur('Error');halt(1); end;
      $21 : begin Erreur('Error');halt(1); end;
      $22 : begin Erreur('Error');halt(1); end;
      $90 : begin Erreur('Error');halt(1); end;
      $91 : begin Erreur('Error');halt(1); end;
      $99 : begin Erreur('Error');halt(1); end;
      $F0 : begin Erreur('Error');halt(1); end;
      $F1 : begin Erreur('Error');halt(1); end;
      $F2 : begin Erreur('Error');halt(1); end;
      $F3 : begin Erreur('Error');halt(1); end;
      $FF : begin Erreur('Error');halt(1); end;
     end;
   end;
end;

procedure new_log; forward;

Procedure VerifierIO_log;  { Vrifie les erreurs d'E/S }
(***********************)
var
  CodesES : integer;
  ErreurES : boolean;
begin
   CodesES := IOresult;
   ErreurES := (CodesES <> 0);
   if ErreurES then begin
    case CodesES of
      $02 : new_log;
      $03 : new_log;
      $04 : begin Erreur('File not open !');halt(1); end;
      $10 : begin Erreur('Numeric format error');halt(1);end;
      $20 : begin Erreur('Error');halt(1); end;
      $21 : begin Erreur('Error');halt(1); end;
      $22 : begin Erreur('Error');halt(1); end;
      $90 : begin Erreur('Error');halt(1); end;
      $91 : begin Erreur('Error');halt(1); end;
      $99 : begin Erreur('Error');halt(1); end;
      $F0 : begin Erreur('Error');halt(1); end;
      $F1 : begin Erreur('Error');halt(1); end;
      $F2 : begin Erreur('Error');halt(1); end;
      $F3 : begin Erreur('Error');halt(1); end;
      $FF : begin Erreur('Error');halt(1); end;
     end;
   end;
end;

Procedure new_log; { Cration du fichier.log }
(****************)
Begin
  {$I-}
  Assign(fich,'mboard.log');
  Rewrite(fich);
  verifierio;
  writeln(fich,str_time + ' Multiboard 1.0/Bta [REG] log file created');
  verifierio;
  writeln(fich);
  {$I+}
end;


Procedure charge_config;    { Chargement du fichier MBOARD.CFG }
(**********************)
begin
  {$I-}
  Assign(fichier,'mboard.cfg');
  reset(fichier);
  verifierio;
  read(fichier,config);
  verifierio;
  close(fichier);
  verifierio;
  {$I+}
end;

Procedure ecris_log(texte : string);    { Chargement du fichier MBOARD.CFG }
(**********************************)
begin
  {$I-}
  Assign(fich,'mboard.log');
  append(fich);
  verifierio_log;
  writeln(fich,texte);
  close(fich);
  verifierio;
  {$I+}
end;


Procedure ecris_config; { Enregistrement de la configuration dans MBOARD.CFG }
(*********************)
Begin
  {$I-}
  Assign(fichier,'mboard.cfg');
  Rewrite(fichier);
  verifierio;
  write(fichier,config);
  verifierio;
  close(fichier);
  verifierio;
  {$I+}
end;

Procedure Time_out;
(*****************)
begin
 ecris_log(str_time + '  Incativity Timout  Errorlevel: 1');
 halt(1);
end;

Procedure Code(code:scom;nbr:byte;current:byte;nom:scom;var yerORno:boolean);
(***************************************************************************)
Begin            { Affichage du cadre }
  SetColor(33);
  backcolor(34);
  GotoPortXY(9,4);
  sendstring('ڎ',false);
  GotoPortXY(9,5);
  sendstring('  ' + nom + '  Password Required                        ',false);
  Setcolor(37);
  GotoPortXY(56,5);
  sendstring(' #'+intstr(current,0)+'/'+intstr(nbr,0),false);
  setcolor(33);
  GotoPortXY(67,5);
  sendstring('',false);
  GotoPortXY(9,6);
  sendstring('',false);
  Setcolor(37);
  Sendstring('  Enter The password: ',false);
  setcolor(33);
  Sendstring('     ',false);
  GotoPortXY(9,7);
  SendString('',false);
  GotoPortXY(32,6);
 end;


Function CharWaiting : boolean;
(*****************************)
begin
 delay(50);
 CharWaiting := ((port[Serie + 5] and $01) = $01);
end;


Procedure affiche_menu;
(*********************)
Var comp : byte;
    ligne : array[1..20] of byte;
    lig : byte;
    deplace : byte;
    touche : char;
    exit,yorn : boolean;
    minute,minute2,second : word;

begin
    exit := false;
    deplace := 1;
    ecris_log(str_time + ' User on line');
    gettime(second,minute,second,second);
    setcolor(30);backcolor(30);
    clearscr;
    setcolor(30);backcolor(36);
    SendString('MultiBoard V1.0/Beta',false);
    setcolor(31);
    Sendstring('  REGISTERED To David Robert ',false);
    setcolor(30);
    Sendstring('       (C) 1995 David Robert',true);
    sauteligne;
    setcolor(33);backcolor(30);
    SendString('Dplacez vous avec les touches ''a'' et ''q'' puis appuyez sur [ENTER]:',true);
    sauteligne;
    setcolor(30);Backcolor(37);
    lig := 4;
    For comp := 1 to config.nbr_sys do
     begin
       sendstring(config.board_name[comp],true);
       inc(lig);
       ligne[comp] := lig;
       if config.comb1[comp] <> '' then
        begin
         setcolor(35);backcolor(30);
         Sendstring('      ['+config.comb1[comp]+']',true);
         inc(lig);
        end;
       if config.comb2[comp] <> '' then
        begin
         setcolor(35);backcolor(30);
         Sendstring('      ['+config.comb2[comp]+']',true);
         inc(lig);
        end;
       if config.comb3[comp] <> '' then
        begin
         setcolor(35);backcolor(30);
         Sendstring('      ['+config.comb3[comp]+']',true);
         inc(lig);
        end;
       setcolor(37);backcolor(30);
      end;
      sauteligne;
      setcolor(30);backcolor(36);
 sendstring('  logiciel en test, merci de me reporter toute anomalie que vous remarquerez  ',false);

               {  Fin de l'affichage }

 Repeat
   if CharWaiting then begin
         GetChar(Touche);
          if touche = esc then
            if Charwaiting then begin
             GetChar(Touche); if touche = '[' then if CharWaiting then begin
             GetChar(Touche);
             if touche = 'A' then begin
                     setcolor(37);backcolor(30);
                     gotoportxy(1,ligne[deplace]);
                     sendstring(config.board_name[deplace],false);
                     dec(deplace); if deplace = 0 then deplace := config.nbr_sys;
                     setcolor(30);Backcolor(37);
                     gotoportxy(1,ligne[deplace]);
                     sendstring(config.board_name[deplace],false);
                    end;

             if touche = 'B' then begin
                     setcolor(37);backcolor(30);
                     gotoportxy(1,ligne[deplace]);
                     sendstring(config.board_name[deplace],false);
                     inc(deplace); if deplace = config.nbr_sys+1 then deplace := 1;
                     setcolor(30);Backcolor(37);
                     gotoportxy(1,ligne[deplace]);
                     sendstring(config.board_name[deplace],false);
                   end;

              if touche = chr(13) then begin

  ecris_log(str_time+' Escape at errorlevel: '+intstr(config.errorl[deplace],0)
             + ' => ' + config.board_name[deplace]);

{if config.passagree[deplace] then begin
code(config.pass[deplace],config.nbr_es[deplace],1,config.board_name[deplace],YorN);
readln;
end;}

                     setcolor(37);backcolor(30);
                     clearscr;
                     gotoportxy(1,1);
                     sendstring2('Loading board: [' + config.board_name[deplace] + '] please wait...',false);
                     writeln('Escape at errorlevel: ',config.errorl[deplace]);
                     exit := true;
                     halt(config.errorl[deplace]);
                   end;
                 end;
                end;
              end
  else begin
            if Keypressed then begin
                    touche := ReadKey;
                    if touche = chr(72) then begin
                     setcolor(37);backcolor(30);
                     gotoportxy(1,ligne[deplace]);
                     sendstring(config.board_name[deplace],false);
                     dec(deplace); if deplace = 0 then deplace := config.nbr_sys;
                     setcolor(30);Backcolor(37);
                     gotoportxy(1,ligne[deplace]);
                     sendstring(config.board_name[deplace],false);
                    end;

                   if touche = chr(80) then begin
                     setcolor(37);backcolor(30);
                     gotoportxy(1,ligne[deplace]);
                     sendstring(config.board_name[deplace],false);
                     inc(deplace); if deplace = config.nbr_sys+1 then deplace := 1;
                     setcolor(30);Backcolor(37);
                     gotoportxy(1,ligne[deplace]);
                     sendstring(config.board_name[deplace],false);
                   end;

                   if touche = chr(13) then begin

ecris_log(str_time + ' Escape at errorlevel: ' + intstr(config.errorl[deplace],0)
           + ' => ' + config.board_name[deplace]);

{if config.passagree[deplace] then begin
code(config.pass[deplace],config.nbr_es[deplace],1,config.board_name[deplace],YorN);
readln;
end;}

                     setcolor(37);backcolor(30);
                     clearscr;
                     gotoportxy(1,1);
                     sendstring2('Loading board: [' + config.board_name[deplace] + '] please wait...',false);
                     writeln('Escape at errorlevel: ',config.errorl[deplace]);
                     exit := true;
                     halt(config.errorl[deplace]);
                   end;
                 end;
               end;
 Until exit;
end;

Procedure affiche_presentation;
(*****************************)
Begin
 ClrScr;
 textcolor(14);
 Writeln('MultiBoard 1.0/Beta  Registered to David Robert');
 Textcolor(lightCyan);
 Writeln('Copyright (C) 1995 David Robert.  All Rights Reserved.');
 writeln;
 textcolor(7);
 writeln('Usage:   Multib <port>');
 writeln;
 writeln('<port>  Witch serial port your modem is set on.');
end;


begin
     Charge_config;  { Charge le fichier de configuration mboard.cfg }

     { Pour le moment, pour le programme d'essaie, on va dire qu'il y a   }
     { aucuns problme: fichier existe, io ok, enfin tout ce passe bien :-}
     { m'enfin ca commence a prendre forme :-)))))))))))))))))))          }
     { Mais heu ! Il est jamais content ce David, ce programme sera       }
     { bientot sur tous les bons BBS ! MAIS HEU !!                        }

      affiche_menu;   { Envoie la procdure de l'affichage menu }
end.




{   car := true;
   gettime(second,minute2,second,second);
   if minute2 - minute > 2 then time_out;
 until car or keypressed;


 if car then touche := chr(port[Serie]);
 if keypressed then touche := readkey;

if car then begin}


syntax highlighted by Code2HTML, v. 0.9.1