home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
DP Tool Club 31
/
CDASC_31_1996_juillet_aout.iso
/
internet
/
rnr214.zip
/
RNRKILL.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1995-12-31
|
30KB
|
1,178 lines
unit rnrkill;
{
rnrkill.pas - rnr killfile and antikillfile processing
}
{$I rnr-def.pas}
interface
uses genericf,rnrglob,rnrconf,rnrfunc,rnrio,rnrproc,rnrfile;
const
yesbackupkill=true;
nobackupkill=false;
maxkillheaderlen=18;
maxkilltextlen=75;
type
killheadert=string[maxkillheaderlen];
killtextt=string[maxkilltextlen];
killt=record
header: killheadert;
text: killtextt;
end;
killsarr=array[1..maxkills] of killt;
killsarrp=^killsarr;
var
killsp: killsarrp;
antikillsp: killsarrp;
groupkillsp: killsarrp;
groupantikillsp: killsarrp;
procedure addtokill(header,words: string; isglobal: boolean);
procedure addtoantikill(header,words: string; isglobal: boolean);
procedure readinkill(backup: boolean);
procedure readinantikill(backup: boolean);
procedure groupinitkills;
procedure groupinitantikills;
function artkilled(subject, from, refs, fn: string): boolean;
function artantikilled(subject, from, refs, fn: string): boolean;
implementation
var
killfn,antikillfn: pathstring;
killfileinmem, antikillfileinmem: boolean;
numkills, numantikills: integer;
groupnumkills, groupnumantikills: integer;
groupkillfileinmem, groupantikillfileinmem: boolean;
nonglobalkills, nonglobalantikills: boolean;
function killseparator(s: string): boolean;
begin
killseparator := (parseheadername(s)='Newsgroups') or (copy(s,1,1)=':');
end;
{$ifdef fixedkill}
procedure addtosomekill(usekill: boolean; var somekillf: file;
header,words: string; isglobal: boolean);
var
spaceneeded: integer;
i,j: integer;
s: string;
tempf: text;
newsomekillwritten: boolean;
nonglobalsomekills: boolean;
numsomekills: integer;
somekillsubjsp,somekillfromsp,somekilltextp: killsarrp;
begin
if usekill then
begin
xwritelns('Updating kill file...');
nonglobalsomekills := nonglobalkills;
numsomekills := numkills;
somekillsubjsp := killsubjsp;
somekillfromsp := killfromsp;
somekilltextp := killtextp;
end
else
begin
xwritelns('Updating antikill file...');
nonglobalsomekills := nonglobalantikills;
numsomekills := numantikills;
somekillsubjsp := antikillsubjsp;
somekillfromsp := antikillfromsp;
somekilltextp := antikilltextp;
end;
spaceneeded := 1;
if not isglobal then
if not nonglobalsomekills then
spaceneeded := 2;
if numsomekills+spaceneeded<=maxkills then
begin
if isglobal then
begin
for i := numsomekills downto 1 do
somekilltextp^[i+1] := somekilltextp^[i];
somekilltextp^[1] := header+': '+words;
end
else if spaceneeded=2 then
begin
somekilltextp^[numsomekills+1] := ': '+currsource;
somekilltextp^[numsomekills+2] := header+': '+words;
end
else
begin
for i := 1 to numsomekills do
begin
s := somekilltextp^[i];
if killseparator(s) and (parseheadervalue(s)=currsource) then
begin
for j := numsomekills downto i+1 do
somekilltextp^[j+1] := somekilltextp^[j];
somekilltextp^[i+1] := header+': '+words;
end;
end;
end;
if usekill then
inc(numkills,spaceneeded)
else
inc(numantikills,spaceneeded);
inc(numsomekills,spaceneeded);
end
else
{it definitely won't all fit in memory now}
if usekill then
killfileinmem := false
else
antikillfileinmem := false;
if header='Subject' then
begin
if numsubjks<maxkills then
begin
inc(numsubjks);
killsubjsp^[numsubjks] := words;
end
else
{}{} {should delete the oldest one}
warn('kill file too large');
end
else
begin
if numfromks<maxkills then
begin
inc(numfromks);
killfromsp^[numfromks] := words;
end
else
{}{} {should delete the oldest one}
warn('kill file too large');
end;
if haskillfile then
begin
newsomekillwritten := false;
assign(tempf,withbackslash(temporarydir)+userid);
reset(killf);
rewrite(tempf);
if isglobal then
begin
writeln(tempf,header,': ',words);
newsomekillwritten := true;
end;
while not eof(killf) do
begin
readln(killf,s);
if killseparator(s) then
begin
writeln(tempf,': ',parseheadervalue(s));
if parseheadervalue(s)=currsource then
begin
writeln(tempf,header,': ',words);
newsomekillwritten := true;
end;
end
else
writeln(tempf,s);
end;
if not newsomekillwritten then {this group had no kill information}
begin
writeln(tempf,': ',currsource);
writeln(tempf,header,': ',words);
newsomekillwritten := true;
end;
close(killf);
close(tempf);
reset(tempf);
rewrite(killf);
while not eof(tempf) do
begin
readln(tempf,s);
writeln(killf,s);
end;
close(tempf);
close(killf);
erase(tempf);
end
else
begin
haskillfile := true;
assign(killf,killfn);
rewrite(killf);
if not isglobal then
writeln(killf,': ',currsource);
writeln(killf,header,': ',words);
end;
reset(killf);
end;
{$endif} {fixedkill}
procedure addtokill;
var
spaceneeded: integer;
i,j: integer;
s: string;
tempf: text;
newkillwritten: boolean;
begin
xwritelns('Updating kill file...');
spaceneeded := 1;
if not isglobal then
if not nonglobalkills then
spaceneeded := 2;
if numkills+spaceneeded<=maxkills then
begin
if isglobal then
begin
for i := numkills downto 1 do
killsp^[i+1] := killsp^[i];
killsp^[1].header := header;
killsp^[1].text := words;
end
else if spaceneeded=2 then
begin
killsp^[numkills+1].header := ':';
killsp^[numkills+1].text := currsource;
killsp^[numkills+2].header := header;
killsp^[numkills+2].text := words;
end
else
begin
for i := 1 to numkills do
begin
if killsp^[i].header=':' then
if killsp^[i].text=currsource then
begin
for j := numkills downto i+1 do
killsp^[j+1] := killsp^[j];
killsp^[i+1].header := header;
killsp^[i+1].text := words;
end;
end;
end;
inc(numkills,spaceneeded);
end
else
killfileinmem := false; {it definitely won't all fit in memory now}
if groupnumkills<maxkills then
begin
inc(groupnumkills);
groupkillsp^[groupnumkills].header := header;
groupkillsp^[groupnumkills].text := words;
end
else
begin
{}{} {should delete the oldest one}
warn('kill file too large');
end;
if haskillfile then
begin
newkillwritten := false;
assign(tempf,withbackslash(temporarydir)+userid);
reset(killf);
rewrite(tempf);
if isglobal then
begin
writeln(tempf,header,': ',words);
newkillwritten := true;
end;
while not eof(killf) do
begin
readln(killf,s);
if killseparator(s) and not newkillwritten then
begin
writeln(tempf,': ',parseheadervalue(s));
if parseheadervalue(s)=currsource then
begin
writeln(tempf,header,': ',words);
newkillwritten := true;
end;
end
else
writeln(tempf,s);
end;
if not newkillwritten then {this group had no kill information}
begin
writeln(tempf,': ',currsource);
writeln(tempf,header,': ',words);
newkillwritten := true;
end;
close(killf);
close(tempf);
reset(tempf);
rewrite(killf);
while not eof(tempf) do
begin
readln(tempf,s);
writeln(killf,s);
end;
close(tempf);
close(killf);
erase(tempf);
end
else
begin
haskillfile := true;
assign(killf,killfn);
rewrite(killf);
if not isglobal then
writeln(killf,': ',currsource);
writeln(killf,header,': ',words);
end;
reset(killf);
end;
procedure addtoantikill;
var
spaceneeded: integer;
i,j: integer;
s: string;
tempf: text;
newantikillwritten: boolean;
begin
xwritelns('Updating antikill file...');
spaceneeded := 1;
if not isglobal then
if not nonglobalantikills then
spaceneeded := 2;
if numantikills+spaceneeded<=maxkills then
begin
if isglobal then
begin
for i := numantikills downto 1 do
antikillsp^[i+1] := antikillsp^[i];
antikillsp^[1].header := header;
antikillsp^[1].text := words;
end
else if spaceneeded=2 then
begin
antikillsp^[numantikills+1].header := ':';
antikillsp^[numantikills+1].text := currsource;
antikillsp^[numantikills+2].header := header;
antikillsp^[numantikills+2].text := words;
end
else
begin
for i := 1 to numantikills do
begin
if antikillsp^[i].header=':' then
if antikillsp^[i].text=currsource then
begin
for j := numantikills downto i+1 do
antikillsp^[j+1] := antikillsp^[j];
antikillsp^[i+1].header := header;
antikillsp^[i+1].text := words;
end;
end;
end;
inc(numantikills,spaceneeded);
end
else
antikillfileinmem := false; {it definitely won't all fit in memory now}
if groupnumantikills<maxkills then
begin
inc(groupnumantikills);
groupantikillsp^[groupnumantikills].header := header;
groupantikillsp^[groupnumantikills].text := words;
end
else
begin
{}{} {should delete the oldest one}
warn('antikill file too large');
end;
if hasantikillfile then
begin
newantikillwritten := false;
assign(tempf,withbackslash(temporarydir)+userid);
reset(antikillf);
rewrite(tempf);
if isglobal then
begin
writeln(tempf,header,': ',words);
newantikillwritten := true;
end;
while not eof(antikillf) do
begin
readln(antikillf,s);
if killseparator(s) and not newantikillwritten then
begin
writeln(tempf,': ',parseheadervalue(s));
if parseheadervalue(s)=currsource then
begin
writeln(tempf,header,': ',words);
newantikillwritten := true;
end;
end
else
writeln(tempf,s);
end;
if not newantikillwritten then {this group had no antikill information}
begin
writeln(tempf,': ',currsource);
writeln(tempf,header,': ',words);
newantikillwritten := true;
end;
close(antikillf);
close(tempf);
reset(tempf);
rewrite(antikillf);
while not eof(tempf) do
begin
readln(tempf,s);
writeln(antikillf,s);
end;
close(tempf);
close(antikillf);
erase(tempf);
end
else
begin
hasantikillfile := true;
assign(antikillf,antikillfn);
rewrite(antikillf);
if not isglobal then
writeln(antikillf,': ',currsource);
writeln(antikillf,header,': ',words);
end;
reset(antikillf);
end;
{$ifdef oldaddtoantikill}
procedure addtoantikill(header,words: string; isglobal: boolean);
var
s: string;
tempf: text;
newantikillwritten: boolean;
begin
xwritelns('Updating antikill file...');
if numantikills<maxkills then
begin
inc(numantikills);
antikilltextp^[numantikills] := header+': '+words;
end
else
antikillfileinmem := false;
if header='Subject' then
begin
if numsubjaks<maxkills then
begin
inc(numsubjaks);
antikillsubjsp^[numsubjaks] := words;
end
else
{}{} {should delete the oldest one?}
warn('antikill file too large');
end
else
begin
if numfromaks<maxkills then
begin
inc(numfromaks);
antikillfromsp^[numfromaks] := words;
end
else
{}{} {should delete the oldest one?}
warn('antikill file too large');
end;
if hasantikillfile then
begin
newantikillwritten := false;
assign(tempf,withbackslash(temporarydir)+userid);
reset(antikillf);
rewrite(tempf);
if isglobal then
begin
writeln(tempf,header,': ',words);
newantikillwritten := true;
end;
while not eof(antikillf) do
begin
readln(antikillf,s);
if killseparator(s) then
begin
writeln(tempf,': ',parseheadervalue(s));
if parseheadervalue(s)=currsource then
begin
writeln(tempf,header,': ',words);
newantikillwritten := true;
end;
end
else
writeln(tempf,s);
end;
if not newantikillwritten then {this group had no antikill information}
begin
writeln(tempf,': ',currsource);
writeln(tempf,header,': ',words);
newantikillwritten := true;
end;
close(antikillf);
close(tempf);
reset(tempf);
rewrite(antikillf);
while not eof(tempf) do
begin
readln(tempf,s);
writeln(antikillf,s);
end;
close(tempf);
close(antikillf);
erase(tempf);
end
else
begin
hasantikillfile := true;
assign(antikillf,antikillfn);
rewrite(antikillf);
if not isglobal then
writeln(antikillf,': ',currsource);
writeln(antikillf,header,': ',words);
end;
reset(antikillf);
end;
{$endif}
procedure readinkill;
var
s: string;
tempf: text;
begin
killfileinmem := true;
numkills := 0;
if haskillfile then
close(killf);
haskillfile := true;
killfn := home+'\kill';
safereset(killf,killfn);
if fileresult<>0 then
begin
haskillfile := false;
xwritelns('(no kill file found)');
end;
if haskillfile then
begin
if backup then
begin
xwritelns('Backing up kill file...');
assign(tempf,home+'\kill.bak');
rewrite(tempf);
end
else
xwritelns('Reading in kill file...');
reset(killf);
while not eof(killf) do
begin
readln(killf,s);
if backup then
writeln(tempf,s);
if numkills<maxkills then
begin
inc(numkills);
if killseparator(s) then
killsp^[numkills].header := ':'
else
killsp^[numkills].header := parseheadername(s);
killsp^[numkills].text := parseheadervalue(s);
end
else
killfileinmem := false;
end;
if backup then
close(tempf);
reset(killf);
end;
end;
procedure readinantikill;
var
s: string;
tempf: text;
begin
if hasantikillfile then
close(antikillf);
antikillfileinmem := true;
numantikills := 0;
hasantikillfile := true;
antikillfn := home+'\antikill';
safereset(antikillf,antikillfn);
if fileresult<>0 then
begin
hasantikillfile := false;
xwritelns('(no antikill file found)');
end;
if hasantikillfile then
begin
if backup then
begin
xwritelns('Backing up antikill file...');
assign(tempf,home+'\antikill.bak');
rewrite(tempf);
end
else
xwritelns('Reading in antikill file...');
reset(antikillf);
while not eof(antikillf) do
begin
readln(antikillf,s);
if backup then
writeln(tempf,s);
if numantikills<maxkills then
begin
inc(numantikills);
if killseparator(s) then
antikillsp^[numantikills].header := ':'
else
antikillsp^[numantikills].header := parseheadername(s);
antikillsp^[numantikills].text := parseheadervalue(s);
end
else
antikillfileinmem := false;
end;
if backup then
close(tempf);
reset(antikillf);
end;
end;
procedure groupinitkills;
var
akill: killt;
killgroup: string;
inglobals: boolean;
killline: integer;
sizewarned: boolean;
function killeof: boolean;
begin
if killfileinmem then
killeof := (killline>=numkills)
else
killeof := eof(killf);
end;
procedure getnextkillline(var akill: killt);
var
s: string;
begin
if killfileinmem then
begin
inc(killline);
akill := killsp^[killline];
end
else
begin
readln(killf,s);
if killseparator(s) then
akill.header := ':'
else
akill.header := parseheadername(s);
akill.text := parseheadervalue(s);
end;
end;
begin { groupinitkills }
{read in kill file for this group}
groupnumkills := 0;
nonglobalkills := false;
killline := 0;
inglobals := true;
sizewarned := false;
if haskillfile then
begin
if not killfileinmem then
begin
notquietlns('reading in kill file...');
reset(killf);
end;
{allow defaults to come before the first `: newsgroup' line}
killgroup := currsource;
while not killeof do
begin
getnextkillline(akill);
{if it's a new `: newsgroup' selection, then check it - otherwise, process}
if akill.header=':' then
begin
killgroup := akill.text;
inglobals := false;
end
else if killgroup=currsource then
begin
if showkills then
xwritelnssss('kill: ',
akill.header,' ',akill.text)
else
begin
if showsubjectkills then
if akill.header='Subject' then
xwritelnssss('kill: ',
akill.header,' ',akill.text);
if showfromkills then
if akill.header='From' then
xwritelnssss('kill: ',
akill.header,' ',akill.text);
end;
if groupnumkills<maxkills then
begin
inc(groupnumkills);
groupkillsp^[groupnumkills] := akill;
if not inglobals then
nonglobalkills := true;
end
else
begin
{}{} {too many kills - ignore}
{}{} {should discard the oldest one}
if not sizewarned then
warn('kill file is larger than memory allocated');
sizewarned := true;
end;
end;
end;
end;
end;
procedure groupinitantikills;
var
anantikill: killt;
antikillgroup: string;
inglobals: boolean;
antikillline: integer;
sizewarned: boolean;
function antikilleof: boolean;
begin
if antikillfileinmem then
antikilleof := (antikillline>=numantikills)
else
antikilleof := eof(antikillf);
end;
procedure getnextantikillline(var anantikill: killt);
var
s: string;
begin
if antikillfileinmem then
begin
inc(antikillline);
anantikill := antikillsp^[antikillline];
end
else
begin
readln(antikillf,s);
if killseparator(s) then
anantikill.header := ':'
else
anantikill.header := parseheadername(s);
anantikill.text := parseheadervalue(s);
end;
end;
begin { groupinitantikills }
{read in antikill file for this group}
groupnumantikills := 0;
nonglobalantikills := false;
antikillline := 0;
inglobals := true;
sizewarned := false;
if hasantikillfile then
begin
if not antikillfileinmem then
begin
notquietlns('reading in antikill file...');
reset(antikillf);
end;
{allow defaults to come before the first `: newsgroup' line}
antikillgroup := currsource;
while not antikilleof do
begin
getnextantikillline(anantikill);
{if it's a new `: newsgroup' selection, then check it - otherwise, process}
if anantikill.header=':' then
begin
antikillgroup := anantikill.text;
inglobals := false;
end
else if antikillgroup=currsource then
begin
if showantikills then
xwritelnssss('antikill: ',
anantikill.header,' ',anantikill.text)
else
begin
if showsubjectantikills then
if anantikill.header='Subject' then
xwritelnssss('antikill: ',
anantikill.header,' ',anantikill.text);
if showfromantikills then
if anantikill.header='From' then
xwritelnssss('antikill: ',
anantikill.header,' ',anantikill.text);
end;
if groupnumantikills<maxkills then
begin
inc(groupnumantikills);
groupantikillsp^[groupnumantikills] := anantikill;
if not inglobals then
nonglobalantikills := true;
end
else
begin
{}{} {too many antikills - ignore}
{}{} {should discard the oldest one}
if not sizewarned then
warn('antikill file is larger than memory allocated');
sizewarned := true;
end;
end;
end;
end;
end;
function killmatch(killtext,headertext: string;
caseinsensitive,substring: boolean): boolean;
{ if caseinsensitive, then headertext is already uppercased }
begin
if caseinsensitive then
if substring then
killmatch := textintext(upper(killtext),headertext)
else
killmatch := (upper(killtext)=headertext)
else
if substring then
killmatch := textintext(killtext,headertext)
else
killmatch := (killtext=headertext);
end;
{$ifdef oldkill}
function subjkilled(subject: string): boolean;
var
result: boolean;
i: integer;
noresubject: string;
begin
result := false;
{ subject matching always done modulo Re: }
noresubject := nore(subject);
if caseinsensitivekill then
noresubject := upper(noresubject);
for i := 1 to numsubjks do
if not result then
result := killmatch(killsubjsp^[i],noresubject,
caseinsensitivekill,substringsubjectkill);
subjkilled := result;
end;
function fromkilled(from: string): boolean;
var
result: boolean;
i: integer;
newfrom: string;
begin
result := false;
{From: match if that address found anywhere - so that if they change their}
{posting software or whatever you'll still find it.}
newfrom := from;
if caseinsensitivekill then
newfrom := upper(newfrom);
for i := 1 to numfromks do
if not result then
result := killmatch(killfromsp^[i],newfrom,
caseinsensitivekill,substringfromkill);
fromkilled := result;
end;
{$endif}
function artkilled;
var
result: boolean;
whichkillline: integer;
upsubject: string;
upfrom: string;
whichkill: integer;
oneartheader: string;
onekillheader: string;
onekilltext: string;
upkilltext: string;
begin
result := false;
upsubject := subject;
if caseinsensitivekill then
upsubject := upper(upsubject);
upfrom := from;
if caseinsensitivekill then
upfrom := upper(upfrom);
for whichkill := 1 to groupnumkills do
if not result then
begin
onekillheader := lower(groupkillsp^[whichkill].header);
onekilltext := groupkillsp^[whichkill].text;
upkilltext := upper(onekilltext);
if onekillheader='subject' then
result := killmatch(onekilltext,upsubject,
caseinsensitivekill,substringsubjectkill)
else if onekillheader='from' then
result := killmatch(onekilltext,upfrom,
caseinsensitivekill,substringfromkill)
else if onekillheader='references' then
result := killmatch(upkilltext,upper(refs),false,true)
else if fn<>'' then
begin
if showdebug('slowkill') then
xwritelnssss('going to disk (',fn,') for header ',onekillheader);
oneartheader := getheaderline(fn,onekillheader+':');
if caseinsensitivekill then
oneartheader := upper(oneartheader);
if oneartheader<>'' then
result := killmatch(
onekilltext,oneartheader,caseinsensitivekill,true);
end;
end;
artkilled := result;
end;
{$ifdef oldkill}
function subjantikilled(subject: string): boolean;
var
result: boolean;
i: integer;
noresubject: string;
begin
result := false;
{ subject matching always done modulo Re: }
noresubject := nore(subject);
if caseinsensitiveantikill then
noresubject := upper(noresubject);
for i := 1 to numsubjaks do
if not result then
result := killmatch(antikillsubjsp^[i],noresubject,
caseinsensitiveantikill,substringsubjectantikill);
subjantikilled := result;
end;
function fromantikilled(from: string): boolean;
var
result: boolean;
i: integer;
newfrom: string;
begin
result := false;
{From: match if that address found anywhere - so that if they change their}
{posting software or whatever you'll still find it.}
newfrom := from;
if caseinsensitiveantikill then
newfrom := upper(newfrom);
for i := 1 to numfromaks do
if not result then
result := killmatch(antikillfromsp^[i],newfrom,
caseinsensitiveantikill,substringfromantikill);
fromantikilled := result;
end;
{$endif} {oldkill}
function artantikilled;
var
result: boolean;
whichantikillline: integer;
upsubject: string;
upfrom: string;
whichantikill: integer;
oneartheader: string;
oneantikillheader: string;
oneantikilltext: string;
upantikilltext: string;
begin
result := false;
upsubject := subject;
if caseinsensitiveantikill then
upsubject := upper(upsubject);
upfrom := from;
if caseinsensitiveantikill then
upfrom := upper(upfrom);
for whichantikill := 1 to groupnumantikills do
if not result then
begin
oneantikillheader := lower(groupantikillsp^[whichantikill].header);
oneantikilltext := groupantikillsp^[whichantikill].text;
upantikilltext := upper(oneantikilltext);
if oneantikillheader='subject' then
result := killmatch(oneantikilltext,upsubject,
caseinsensitiveantikill,substringsubjectantikill)
else if oneantikillheader='from' then
result := killmatch(oneantikilltext,upfrom,
caseinsensitiveantikill,substringfromantikill)
else if oneantikillheader='references' then
result := killmatch(upantikilltext,upper(refs),false,true)
else if fn<>'' then
begin
if showdebug('slowkill') then
xwritelnssss('going to disk (',fn,') for header ',
oneantikillheader);
oneartheader := getheaderline(fn,oneantikillheader+':');
if caseinsensitiveantikill then
oneartheader := upper(oneartheader);
if oneartheader<>'' then
result := killmatch(
oneantikilltext,oneartheader,caseinsensitiveantikill,true);
end;
end;
artantikilled := result;
end;
end.