Program Cstlfix; {Version 1.2} { /* Remplace le trop LENT Allfix */}

{ Version 1.0 }
{  *Version de base utilisant CSTLPOST pour poster la réponse dans la base }

{ VERSION 1.1 }
{  * Système 100% Autonome (postage incorporé base Hudson)
   * interface améliorée }

{ VERSION 1.2 }
{  * Correction des bugs sur les problèmes de la longueur des réponses
     (nombre de fichiers au max paramétrable).
   * Gestion avancée de la ligne de commande (AND, OR, &, &&, | ).
   * Multiboard en une passe (si pas fait, dans version suivante }

Uses Crt,Dos;

     {$I IMAGE.PAS}
     {$I HUDSON.INC}

Type DirBufTyp = Record {Structure de donnée des fncts $4E et $4F}
             Reserve : array[1..21] of char;
             Attr    : byte;
             Time    : integer;
             Date    : integer;
             Size    : longint;
             Name    : array[1..13] of char;
          end;


Var desc     : string;
    out      : text;
    DirBuf   : DirBufTyp;


    { A modifier pour version 1.2 }

    Tableau  : array[1..5,1..4] of string[20];
    type_tab : array[1..5,1..4] of boolean;
    nbr_item : array[1..5] of byte;

    {}

    message  : boolean;
    fich     : text;


function strchar(num : integer) : string;
(***************************************)
var texte : string;
begin
 str(num,texte);
 strchar := texte;
end;

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 ecris_log(texte : string);    { Chargement du fichier MBOARD.CFG }
(**********************************)
begin
Assign(fich,'cstlfix.log');
 {$I-} Append(fich); {$I+}
 If IOResult<>0 Then
 Begin
  {$I-} Rewrite(fich); {$I+}
  If IOResult<>0 Then
  Begin
   WriteLn('Impossible de créer cstlfix.log');
   Halt;
  End;
  WriteLn(fich,str_time + ' -=-=- CSTLFIX+ 1.10 log file created -=-=-');
  writeln(fich);
 End;
  writeln(fich,str_time+' ' + texte);
  close(fich);
end;

Procedure Saute_ligne;
(********************)
begin
Assign(fich,'cstlfix.log');
 {$I-} Append(fich); {$I+}
 If IOResult<>0 Then
 Begin
  {$I-} Rewrite(fich); {$I+}
  If IOResult<>0 Then
  Begin
   WriteLn('Impossible de créer cstlfix.log');
   Halt;
  End;
  WriteLn(fich,str_time + ' -=-=- CSTLFIX+ 1.10 log file created -=-=-');
  writeln(fich);
 End;
  writeln(fich);
  close(fich);
end;



procedure print(x,y:byte;stt:string); {affiche les caractères direct video }
(************************************)
var q:byte;
begin
  for q:= 1 to length(stt) do mem[$b800:(x+y*80+q-1)*2]:=ord(stt[q]);
end;

Function Change(chaine : string) : string;
(****************************************)
var I : word;
begin
   for I := 1 to length(chaine) do
     begin
       if chaine[I] = '_' then chaine[I] := ' ';
     end;
    change := chaine;
end;

Function BlankAfter(S : String; Len : Byte): String;
(**************************************************)
var
  o : string;
  SLen : Byte absolute S;
Begin
  If Length(S) >= Len then BlankAfter := S
  Else begin
    o[0] := Chr(Len);
    Move(S[1], o[1], SLen);
    if SLen < 255 then FillChar(o[Succ(SLen)], Len-SLen, ' ');
    BlankAfter := o;
  End;
End;

Function GrabWord(S: String; B: Byte) : String;
(*********************************************)
Var st,e:Byte;
    return : String[80];
Begin
  Return:='';
  st:=1;e:=1;
  While B>0 Do
  Begin
    While (S[st]=' ') or (S[st]=#9) Do Inc(st);  { #9 er TAB }
    e:=st;
    While (S[e]<>' ') And (e<=Length(s)) Do Inc(e);
    Return:=Copy(S,st,e-st);
    st:=e;
    Dec(B);
  End;
  GrabWord:=Return;
End;



Function StUpcase(s:string):string;
(*********************************)
Var i :byte;
Begin
  for i := 1 to Length(s) do s[i] := UpCase(s[i]);
  StUpcase:=s;
End;


Function  exist_file(NomFichier:string) : boolean;
(************************************************)
Var Regs : registers;
begin
 nomFichier := nomfichier + #0;
 regs.ah := $4E;
 regs.cx := $3F;
 regs.ds := seg(nomfichier);
 regs.dx := succ(ofs(nomfichier));
 MsDos(Regs);

  exist_file := ( (Regs.flags and 1) = 0)
end;

procedure efface;   {Procedure qui efface le fichier answer.lst }
(***************)
Var Regs : registers;
    fichier : string[11];
begin
 fichier := 'answer.lst';
 fichier := fichier + #0;
 regs.ah := $41;
 regs.ds := seg(fichier);
 regs.dx := succ(ofs(fichier));
 MsDos(Regs);
end;


Procedure SetDTA(Segment, Offset : integer);
(******************************************)
var regs : registers;
begin
 regs.ah := $1A;
 regs.ds := Segment;
 regs.dx := Offset;
 MsDos(Regs);
end;

Procedure wrt_com(comment : string); {Procedure qui écrit la description }
(**********************************) {Après le nom du fichier. A Améliorer ?}
Var I : byte;
Begin
     Writeln(out,copy(comment,1,47));
     For I := 1 to length(comment) div 47 do
     Writeln(out,'                     ',copy(comment,I*47,47));
end;

(*****************)
(*****************)


procedure Get_sh(chaine:string;var ch:string;var status:byte);
(***********************************************************)
Var compteur : byte;
Begin
     if Chaine[1] = '/' then
       begin
        delete(chaine,1,1);
        ch := chaine;
        status := 0;
        exit;
       end;
     if Chaine[1] = '"' then
      begin
       compteur := 2;
         Repeat
          inc(compteur);
         until chaine[compteur] = '"';
        delete(chaine,compteur,1);
       delete(chaine,1,1);
        ch := chaine;
        status := 0;
        exit;
       end;
     if not (Chaine[1] in ['/','"',#1]) then { C'est un nom de fichier }
     begin
      ch := chaine;
      status := 1;
      if (StUpcase(chaine) = 'and') then status := 3;
      if (StUpcase(chaine) = 'or') or (StUpcase(chaine) = '|')
      then status := 4;
     end;
end;

function init_fich(chaine:string) : string; {Fonction de traitement des nom}
(*******************************)
Var I : byte;
    position : byte;
begin
 position := pos('.',chaine);
 if position > 0 then { effacement des extention du style .* ou .zip }
 begin
  delete(chaine,position,length(chaine)-position+1);
 end;
 for I := 1 to length(chaine) do
 begin
  if chaine[I] in ['*','?'] then
  begin
   delete(chaine,I,1);
  end;
 end;
 init_fich := chaine;
end;



Procedure init_mot(chaine:string);
(********************************)
Var I,V,K : byte;
    ch,mot : string;
    status : byte;

begin
 I := 0;
 K := 1;
 V := 0;
chaine := '/toto and /toto '+#1;
 Repeat
     inc(I);
     if V < 4 then inc(V);
     ch :=grabword(chaine,I);

     if ch[1] = '"' then
     begin
      while(ch[length(ch)] <> '"') do { Réuni le mot en "toto n'est pas mort"}
      begin
       inc(I);
       ch := ch + ' ' + grabword(chaine,I);
      end;
     end;

     get_sh(ch,mot,status); { décode chaque mot }
     mot := 'toto';

      if status = 1 then begin
        tableau[K][V] := init_fich(mot);
        type_tab[K][V] := true;
        end;

      if status = 0 then begin
        tableau[K][V] := mot;
        type_tab[K][V] := false;
                writeln(K,' ',V);

        end;

       nbr_item[K] := V;

       if status <> 3 then begin
        nbr_item[K] := V;
        if K < 5 then inc(K);
        V := 0;
       end;

   until ch = #1; { Caractère signalant la fin de la chaine de recherche }
   readln;
end;

(*****************)
(*****************)


Procedure Search;
(***************)
var
  List : text;
  I : text;
  S : String;

  Path : string;
  comment : string;
  yon : boolean;
  trouve,find : boolean;
  compteur : byte;
  compteur2 : byte;

Begin

 Print(49,8,'Scan de la base fichiers    ');

 window(2,14,77,22);  {Fenetre de défillement du scan des aires de fichier}
 textcolor(yellow);
 textbackground(blue);
 clrscr;

 SetDTA(Seg(DirBuf), Ofs(DirBuf));

 Assign(List,'cstlfix.cfg');                {                                }
 {$I-} Reset(List); {$I+}                   {                                }
 If IOResult<>0 Then                        { Ouverture du fichier de config }
  Begin                                     {                                }
    WriteLn('Unable to open config file');  {           CSTLFIX.CFG          }
    Halt;                                   { Il contient la liste des *.bbs }
  End;

 Assign(Out,'answer.lst');               { Creation et ouverture du fichier }
 {$I-} Append(Out); {$I+}                { De sortie ... }
 If IOResult<>0 Then
 Begin
  {$I-} Rewrite(Out); {$I+}
  If IOResult<>0 Then
  Begin
   WriteLn('Impossible de créer answer.lst');
   Halt;
  End;
  WriteLn(#13#10'Creation de answer.lst...');
 End
 Else WriteLn(#13#10'Ajout a answer.lst');

 Writeln(out,'Trouvé chez  : Castle BBS');
 Writeln(out,'Sysop        : David Robert');
 Writeln(out,'Téléphone    : +033 61 73 46 52');
 Writeln(out,'Location     : Toulouse, France');
 Writeln(out,'Vitesse      : 14400 Bps');
 Writeln(out,'Flags        : CM,XA,V32B,V42B');
 Writeln(out,'Adresse      : 2:324/109');
 Writeln(out,'Comment      : Freq Ok 24h/24h');


{ Boucle du fichier de config }

 While Not Eof(list) Do
 Begin
  ReadLn(list,S);  { On lit la première ligne de la liste }
  If (S<>'') And Not (S[1] in [';','%']) Then
  begin
   Path := GrabWord(S,1); {On récupère le path des fichiers de l'aire..}
   Write(Path);
   desc := GrabWord(S,3); {...La description...}
   desc := Change(desc); {...décodée}
   Writeln(' => ',desc);

 { Ouverture de files.bbs de l'aire courrante }

   Assign(I,GrabWord(S,2)); {I : c'est le fichier Files.bbs de l'aire}
   {$I-} Reset(I); {$I+}
   If IOResult<>0 Then
   Begin
    WriteLn('Le fichier: ',grabword(s,2),' n''est pas accessible');
    Halt;
   End;

   yon := true;  { l'entète de l'aire n'a pas été marqué }
   trouve := false; { les mot clés ne correspondent pas...}

                      {__Boucle du files.bbs maintenant__}

   While Not Eof(I) Do
   Begin
    Readln(I,S);

(*****************)
(*****************)


 compteur := 0;
 Repeat
  inc(compteur);

  find := true;
  for compteur2 := 1 to nbr_item[compteur] do

   begin
   if type_tab[compteur,compteur2] then if not
   pos(stupcase(tableau[compteur,compteur2]),stupcase(grabword(S,1))) = 1
   then find := false else exist_file(path+Grabword(S,1));

   if not type_tab[compteur,compteur2] then if not
   (pos(stupcase(tableau[compteur,compteur2]),stupcase(S)) > 0)
   then find := false else exist_file(path+Grabword(S,1));

  end;

 if find = true then trouve := true;
 until nbr_item[compteur] = 0;


(*****************)
(*****************)


    if trouve then
    begin
     if not message then message := true;
     if yon then
     begin
      Writeln(out);
      Writeln(out,'Aire: ',desc);
      Writeln(out,'>-----------------------------------------------------------');
      Writeln(out);
      yon := false;
     end;
     comment := Copy(s,13,length(s)-12);
     Write(out,blankafter(grabword(s,1),13),Dirbuf.size :7);
     Wrt_com(comment);
     trouve := false;
    end;
   end;
   close(I); {Fermeture de files.bbs}
  end;
 end;
 Writeln(out);
 Writeln(out,'... Castlefix ? Simply the fastest file scanner !');
 Writeln(out);
 Writeln(out,'--- CSTLFIX+ 1.20');
 Writeln(out,' * Origin: Castle BBS, Toulouse, France 61734652 (2:324/109)');
 close(out); {Fermeture du fichire de sortie}
 close(list); {Fermeture du fichier de config}
end;



Procedure PostMessage(too,from, subj : string);
(********************************************)

Type texte = string[255];

Var hdr : Hdrrecord;
    txt,tampon : texte;
    txt2 : msgtoidxrecord;
    info : inforecord;
    idx : idxrecord;
    fich_txt : file of texte;
    txt_record : array[0..200] of texte; { Nombre de séries de 255 caractères}
    fichier : file of hdrrecord;
    fich_info : file of inforecord;
    fich_idx : file of idxrecord;     {variables ... Pfouuuu....}
    fich : file of msgtoidxrecord;
    answer : file of char;
    compteur,I,J : integer;
    total_a : integer;
    caractere : char;
    f_name : string[30];
    Attr : byte;
    Path : string[30];
    board : byte;
    item : string[80];
    option : char;
    node : string[5];
    erreur : integer;
    DestNet,
    DestNode,
    OrigNet,
    OrigNode,
    Destzone,
    Origzone : integer;
    unsent,priv,local,received : boolean;


Function time : string;
(*********************)
var item : string[30];
    hour,minute,second,sec100 : word;
    h,m : string[2];
begin
  gettime(hour,minute,second,sec100);
  str(minute:0,m);
  if length(m) < 2 then m := '0' + m;
  str(hour:0,h);
  if length(h) < 2 then h := '0' + h;
  item := h + ':' + m;
  time := item;
end;


Function date : string;
(*********************)
var item : string[30];
    var Year, Month, Day, DayOfWeek: Word;
    d,m : string[2];
    y : string[4];
begin
  getdate(Year,month,day,dayofweek);
  str(month:0,m);
  if length(m) < 2 then m := '0' + m;
  str(day:0,d);
  if length(d) < 2 then d := '0' + d;
  str(year,y);
  y[2] := Y[4];
  y[1] := y[3];
  y[0] := chr(2);
  item := m + '-' + d + '-' + y;
  date := item;
end;


begin

f_name := 'answer.lst';
origzone := 2;
orignet := 324;
orignode := 109;
destzone := 2;
destnet := 324;
destnode := 109;
from := 'CSTLFIX+ 2:324/109';
attr := 96;
path := 'j:\messages\';
board := 1;

   { Ouverture du fichier Texte }

 Assign(answer,f_name);
 {$I-} reset(answer); {$I+}
 if ioresult <> 0 then
  begin
   Writeln('Impossible d''ouvrir le fichier: ',f_name);
   halt;
  end;

   { Conversion du format .TXT au format MSGTXT }
   { C'est ca qui prend du temps... }
   { A voir pour une version plus rapide...}

 I := 0;
 J := 21;

 tampon := #1+'PID: CSTLFIX+ 1.20'+#13+#10;

 For compteur := 0 to filesize(answer)-1 do
   begin
     inc(J);
     seek(answer,compteur);
     read(answer,caractere);
     tampon[J] := caractere;
     if J = 255 then
     begin
       tampon[0] := chr(255);
       txt_record[I] := tampon;
       J := 0;
       inc(I);
     end;
   end;
   if J > 0 then
    begin
      tampon[0] :=chr(J);
      txt_record[I] := tampon;
    end;
  close(answer);
  total_a := I+1;


  { MISE A JOUR DU FICHIER MSGINFO.BBS }

  Assign(fich_info,path + 'msginfo.bbs');  {msginfo.bbs}
{$I-}  reset(fich_info); {$I+}
if ioresult <> 0 then
  begin
   Writeln('Impossible d''ouvrir le fichier: MSGINFO.BBS');
    ecris_log('Impossible d''accèder au fichier MSGINFO.BBS !!');
   halt;
  end;

  read(fich_info,info);
  seek(fich_info,0);
  info.highmsg := info.highmsg + 1;
  info.totalactive := info.totalactive + 1;
  info.activemsgs[board] := info.activemsgs[board] + 1;
  write(fich_info,info);
  close(fich_info);

 { MISE A JOUR DU FICHIER MSGHDR.BBS }

  Assign(fichier,path + 'msghdr.bbs');   {msghdr.bbs}
{$I-}  reset(fichier); {I+}
if ioresult <> 0 then
  begin
   Writeln('Impossible d''ouvrir le fichier: MSGHDR.BBS');
    ecris_log('Impossible d''accèder au fichier MSGHDR.BBS !! (postage)');
   halt;
  end;

  seek(fichier,filesize(fichier)-1);
  read(fichier,hdr);
  seek(fichier,filesize(fichier));
  hdr.MsgNum := info.highmsg;
  hdr.ReplyTo := 0;
  hdr.SeeAlsoNum := 0;
  hdr.TimesRead := 0;   { Not used}
  hdr.StartRec := hdr.startrec + hdr.Numrecs;
  hdr.NumRecs := Total_a;
  hdr.DestNet := destnet;
  hdr.DestNode := destnode;
  hdr.OrigNet := orignet;
  hdr.OrigNode := orignode;
  hdr.Destzone := destzone;
  hdr.Origzone := origzone;
  hdr.Cost := 0;
  hdr.MsgAttr := attr;
  hdr.Netattr := 0;
  hdr.Board := board;
  hdr.PostTime := time;
  hdr.PostDate := date;
  hdr.WhoTo := too;
  hdr.WhoFrom := from;
  hdr.Subj := subj;
  Write(fichier,hdr);
  close(fichier);

  { MISE A JOUR DU FICHIER MSGIDX.BBS }

  Assign(fich_idx,path + 'msgidx.bbs'); {msgidx.bbs}
 {I-}  reset(fich_idx); {I+}
 if ioresult <> 0 then
  begin
   Writeln('Impossible d''ouvrir le fichier: MSGIDX.BBS');
    ecris_log('Impossible d''accèder au fichier MSGIDX.BBS !!');
   halt;
  end;

  seek(fich_idx,filesize(fich_idx));
  idx.msgnum := hdr.msgnum;
  idx.board := hdr.board;
  write(fich_idx,idx);
  close(fich_idx);

  { MISE A JOUR DU FICHIER MSGTXT.BBS }

  Assign(fich_txt,path +'msgtxt.bbs');  {msgtxt.bbs}
{$I-}  reset(fich_txt); {I+}
if ioresult <> 0 then
  begin
   Writeln('Impossible d''ouvrir le fichier: MSGTXT.BBS');
    ecris_log('Impossible d''accèder au fichier MSGTXT.BBS !!');
   halt;
  end;

  seek(fich_txt,filesize(fich_txt));
    For I := 0 to total_a-1 do
  begin
    txt := txt_record[I];
    write(fich_txt,txt);
  end;
  close(fich_txt);

  { MISE A JOUR DU FICHIER MSGTOIDX.BBS }

  Assign(fich,path + 'msgtoidx.bbs');   {msgtoidx.bbs}
 {$I-} reset(fich); {$I+}
 if ioresult <> 0 then
  begin
   Writeln('Impossible d''ouvrir le fichier: MSGTOIDX.BBS');
   ecris_log('Impossible d''accèder au fichier MSGTOIDX.BBS !!');
   halt;
  end;

  seek(fich,filesize(fich));
  txt2 := too;
  write(fich,txt2);
  close(fich);
end;


Procedure GetAllfix;
(******************)

{Procedure qui va chercher les messages a allfix, décode la ligne de commande}
{lance la procédure de recherche, puis poste le messages}


Var
 hdr         : Hdrrecord; { type du fichier msghdr.bbs }
 compt       : word;
 fich_hdr    : file of hdrrecord;
 II          : byte;
 colonne     : byte;
 expediteur  : string[26];
 numero      : string[5];
 pour_allfix : byte;
 reponses    : byte;
 compteur,compteur2 : byte;

Begin

  pour_allfix := 0;
  reponses := 0;

 Print(49,8,'Scan de requètes pour AllFix');
 ecris_log('Scan de requètes pour AllFix...');
 compt := 1;

 Assign(fich_hdr,'j:\messages\msghdr.bbs');
 {$I-} reset(fich_hdr); {I+}        { Ouverture du fichier msghdr.bbs }
 if ioresult <> 0 then begin
 writeln('Fichier MSGHDR.BBS non accessible...');
 ecris_log('Impossible d''accèder au fichier MSGHDR.BBS !!');
 Halt;
end;

 For compt := 1 to filesize(fich_hdr)-1 do  { Scan des infos de msghdr.bbs}
   begin

    seek(fich_hdr,compt);
    read(fich_hdr,hdr);
    numero := strchar(hdr.msgnum);
    numero := numero + '     ';
    print(18,6,numero);
     numero := strchar(hdr.board);
         numero := numero + '     ';
    print(36,6,numero);
    expediteur := hdr.whofrom;
    expediteur := expediteur + '                          ';

    print(14,7,expediteur);

    if hdr.board = 1 then if ((stupcase(hdr.WhoTo) = 'ALLFIX') or (stupcase(hdr.WhoTo) = 'CSTLFIX')) then
    if hdr.msgattr and 128 <> 128 then if hdr.msgattr and 1 <> 1 then


       begin { Message pour allfix qui n'a jamais été scanné }
         inc(pour_allfix);
         print(24,2,strchar(pour_allfix));

         hdr.msgattr := hdr.msgattr or 128;{ Place le bit 7 a '1' pour attribut lu par }
         Seek(fich_hdr,compt); {se repositionne, c'est a cause du 'READ' }
{         write(fich_hdr,hdr); { Réécris cette info avec les changements }
         init_mot(hdr.subj+' '+#1); { Décode le sujet du message pour Allfix }

         colonne := 13;



 Repeat
  inc(compteur);

  for compteur2 := 1 to nbr_item[compteur] do

  begin
   if not type_tab[compteur][compteur2]  then writeln('Mot clé:',tableau[compteur][compteur2]);
   if type_tab[compteur][compteur2]  then writeln('fichier:',tableau[compteur][compteur2]);
  end;
  readln;

 until nbr_item[compteur] = 0;


         search;
         close(fich_hdr);
          if message then begin
           inc(reponses);
           print(47,2,strchar(reponses));
           Print(49,8,'Postage de la réponse   ');
           ecris_log('--- Trouvé: Postage de la réponse');
           postmessage(hdr.whofrom,hdr.whoto,hdr.subj);
          end else ecris_log('--- Pas de correspondance');

         efface;{ efface le fichier answer.lst }

         message := false;
         reset(fich_hdr);
       end;

   end; { boucle for}
  close(fich_hdr);
end; { procedure Getallfix }


Procedure affiche_menu_principal;
(*******************************)
Type ScreenType = array[0..3999] of byte;
var screen : ScreenType absolute $B800:0000;

begin
  move(imagedata,screen,4000);
end;


{**************************************************************************}
                          { Programme principal }
{**************************************************************************}

Begin
     message := false;

     Affiche_menu_principal;
     getallfix;
     window(1,1,80,25);
     textcolor(red);
     textbackground(black);
     clrscr;

     writeln('CASTLE BBS * Toulouse, France +33 61 73 46 52');
     ecris_log('==== Fin de CSTLFIX+ ====');
     saute_ligne;
end.



syntax highlighted by Code2HTML, v. 0.9.1