Program Cstlfix; { VERSION 1.1 }
{ Objectifs: * Système 100% Autonome
* Multi-board en une passe
* interface améliorée }
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;
Tableau : array[1..10] of string[20]; { Mots clés du style /xxx ou "xx x"}
tab_fich : array[1..5] of string[10]; {nom de fichier du style toto*.*}
nbr_mots : word;
nbr_fich : word;
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;
function Get_sh(chaine : string) : string; {Fonction de traitement du sujet}
(****************************************)
Var compteur : byte;
Begin
if Chaine[1] = '/' then
begin
delete(chaine,1,1);
Get_sh := chaine;
exit;
end;
if Chaine[1] = '"' then
begin
compteur := 2;
Repeat
inc(compteur);
until chaine[compteur] = '"';
delete(chaine,compteur,1);
delete(chaine,1,1);
Get_sh := chaine;
exit;
end;
if not (Chaine[1] in ['/','"',#1]) then { C'est un nom de fichier }
begin
chaine := #2 + chaine;
end;
Get_sh := chaine;
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,J,K : byte;
ch,mot : string[20];
begin
I := 0;
J := 0;
K := 0;
Repeat
inc(I);
inc(J);
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;
mot := get_sh(ch); { décode chaque mot }
if mot[1] = #2 then { si le mot a été décodé comme fichier }
begin
delete(mot,1,1);
inc(K);
tab_fich[K] := init_fich(mot);
dec(J);
end
else tableau[J] := mot; { Le mot n'a pas été décodé comme fichier }
until ch = #1;
nbr_mots := J-1;
nbr_fich := K;
end;
Procedure Search;
(***************)
var
List : text;
I : text;
S : String;
Path : string;
comment : string;
yon : boolean;
trouve : boolean;
compteur : 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);
if nbr_fich > 0 then
begin
For compteur := 1 to nbr_fich do
begin
if pos(stupcase(tab_fich[compteur]),stupcase(grabword(S,1))) = 1 then
if exist_file(path+Grabword(S,1)) then trouve := true;
end;
end;
if nbr_mots > 0 then
begin
For compteur := 1 to nbr_mots do
begin
if pos(stupcase(tableau[compteur]),stupcase(S)) > 0 then
if exist_file(path+Grabword(S,1)) then trouve := true;
end;
end;
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.10');
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.10'+#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, pour le moment ca }
{déconne :-(}
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;
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;
for II := 1 to nbr_mots do
begin
print(colonne,8,tableau[ii]);
colonne := colonne + length(tableau[ii]) + 1;
end;
colonne := 13;
for II := 1 to nbr_fich do
begin
print(colonne,9,tab_fich[ii]);
colonne := colonne + length(tab_fich[ii]) + 1;
end;
ecris_log('Message ' + strchar(hdr.msgnum) + ' de ' + hdr.whofrom + ' traité:');
ecris_log('A rechercher:');
for II := 1 to nbr_mots do
begin
ecris_log(' - Mots clé ' + strchar(ii) + ': ' + tableau[ii]);
end;
for II := 1 to nbr_fich do
begin
ecris_log(' - Fichier ' + strchar(ii) + ': ' + tab_fich[ii]);
end;
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;
nbr_fich := 0;
nbr_mots := 0;
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