home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
DP Tool Club 31
/
CDASC_31_1996_juillet_aout.iso
/
internet
/
rnr214.zip
/
RNRART.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-01-30
|
20KB
|
788 lines
unit rnrart;
{
rnrart.pas - rnr article-reading code
}
{$I rnr-def.pas}
interface
{
uses dos,crt,rnrglob,genericf,rnrfunc,rnrio,rnrproc,rnrkill,
rnrmous,rnrfile,rnrcrea
}
uses rnrglob,rnrconf,genericf,rnrfunc,rnrio,rnrproc
{$ifdef charset}
,rnrchar
{$endif};
const
yestoscreen=true;
notoscreen=false;
yesfullheaders=true;
nofullheaders=false;
var
artfn: string;
artf: text;
arteof: boolean;
startofline: boolean;
firstemptyline: integer;
showallheaders: boolean;
donebrowse: boolean;
rot13ing: boolean;
compactspaces: boolean;
highlightsearchhits: boolean;
usingalternatecolor: boolean;
shouldswitchcolor: boolean;
procedure getartl(var oneline: string; maxlen: integer; toscreen: boolean);
procedure artreset;
procedure artclose;
function isheaderline: boolean; {valid only once getartl has returned it}
procedure showartl(s: string);
procedure saveart;
procedure writeart;
function bestquotechar: char;
implementation
var
artlinebuf: string;
artcharbuf: char;
artcharbufused: boolean;
artwaslongline: boolean;
artlineno: integer;
artuheader: string;
artlinefirstchar: char;
artopen: boolean;
procedure getartl;
var
gotaline: boolean;
lenused: integer;
spaceat: integer;
lenread: integer;
donereading: boolean;
c: char;
begin
inc(artlineno);
startofline := false;
{ first, check if there was something left over from last getartl() call}
if artlinebuf<>'' then
begin
oneline := artlinebuf;
lenused := length(oneline);
{ look for line-feed }
if (pos(lf,oneline)<lenused) and (pos(lf,oneline)<>0) then
begin
lenused := pos(lf,oneline);
end;
{ try to break at a word boundary }
if artlineno>=firstemptyline then
if lenused>maxlen then
begin
spaceat := maxlen;
while spaceat>0 do
begin
if oneline[spaceat]=' ' then
begin
lenused := spaceat; {keep space on this line}
spaceat := 0; {end the loop}
end;
dec(spaceat);
end;
end;
if lenused>maxlen then
lenused := maxlen;
oneline := copy(artlinebuf,1,lenused);
if maxlen=255 then
artlinebuf := ''
else
artlinebuf := copy(artlinebuf,length(oneline)+1,255);
{ looks redundant with case below just like this, but isn't. really.}
if artlinebuf='' then
arteof := eof(artf);
end
else if eof(artf) then
begin
arteof := true;
oneline := '(internal error)'
end
else
{nothing left over, so try reading}
begin
gotaline := false;
while not gotaline and not arteof do
begin
startofline := not artwaslongline;
artwaslongline := false;
if crlf then
begin
read(artf,oneline);
if eoln(artf) then
readln(artf) {discard end of line}
else
artwaslongline := true;
end
else
begin
lenread := 0;
artwaslongline := true;
if artcharbufused then
oneline := artcharbuf
else
oneline := '';
artcharbufused := false;
donereading := false;
while not donereading do
begin
if eof(artf) then
donereading := true
else
begin
read(artf,artcharbuf);
if artcharbuf=lf then
begin
donereading := true;
artwaslongline := false;
end
else if artcharbuf<>cr then
begin
inc(lenread);
{ if we can fit it onto the string, just do it }
if ((lenread<maxlen) and (lenread<255)) then
oneline := oneline+artcharbuf
{ if it won't fit at all, just stop }
else if lenread>=255 then
begin
donereading := true;
artcharbufused := true;
end
{
it's longer than desired, so add it,
but stop if it was a good word break place
}
else
begin
oneline := oneline+artcharbuf;
if (artcharbuf=' ') or (artcharbuf=tab) then
donereading := true;
end;
end;
end;
end;
end;
if oneline='' then
if firstemptyline>artlineno then
firstemptyline := artlineno;
gotaline := true;
{$ifdef problemswithlf}
{}{}{}{}{} writeln('gotaline=true, oneline=',copy(oneline,1,10),
{}{}{}{}{} '..., len=',length(oneline));
{$endif}
{ don't use isheaderline here. if last header is hidden, first pass }
{ will set firstemptyline to a small number, which will then cause }
{ artlineno=firstemptyline before the first empty line is actually seen }
{$ifdef problemswithlf}
{}{}{}{}{} if artlineno>firstemptyline then writeln('uhoh lineno');
{}{}{}{}{} if not startofline then writeln('uhoh startofline');
{}{}{}{}{} if oneline='' then writeln('uhoh empty');
{}{}{}{}{} if oneline<>'' then if (oneline[1]=' ') or (oneline[1]=tab) then
{}{}{}{}{} writeln('uhoh ws');
{ it's `startofline' not being set -- weirdness. gotta move to a buffer }
{$endif}
if (artlineno<=firstemptyline) then
if startofline then
if (oneline<>'') then
if (oneline[1]<>' ') and (oneline[1]<>tab) then
artuheader := upper(getfirstw(oneline));
{$ifdef problemswithlf}
{}{}{}{}{} writeln('artuheader=>',artuheader,'<');
{$endif}
if (artlineno<=firstemptyline) and not showallheaders and
toscreen and (oneline<>'') then
if hideheaders<>'' then
begin
if isheaderinlist(artuheader,hideheaders) then
gotaline := false;
end
else if showheaders<>'' then
if pos(':'+artuheader,showheaders)=0 then
gotaline := false;
{$ifdef problemswithlf}
{}{}{}{}{} if not gotaline then
{}{}{}{}{} begin
{}{}{}{}{} writeln('now gotaline=false!');
{}{}{}{}{} if hideheaders<>'' then if isheaderinlist(artuheader,hideheaders)
{}{}{}{}{} then writeln('because of hideheaders');
{}{}{}{}{} if showheaders<>'' then if pos(':'+artuheader,showheaders)=0
{}{}{}{}{} then writeln('because of showheaders');
{}{}{}{}{} end;
{$endif}
{will trim() break _anything_? like, while reading in headers? mail? etc.}
{using trim() is _not_ evil on headers - is it ever a problem? what about}
{expanding tabs? except for Makefiles and map entries...}
{trim() messes up signatures, which are added after getartl is used}
{trim() messes up old-style uuencoded postings! taken out!}
{taken out trim() and expand() when not showing on screen (ie saving to disk) }
{}{}{} {unfortunately, this doesn't work when replying to long lines that}
{}{}{} {begin with a tab - the line overflows in the editor. needs work}
if gotaline then
begin
if toscreen then
oneline := trim(expand(oneline));
{ start by using all of it }
lenused := length(oneline);
{ look for linefeeds }
if (pos(lf,oneline)<lenused) and (pos(lf,oneline)<>0) then
begin
lenused := pos(lf,oneline);
end;
{ try to break at a word boundary }
if artlineno>=firstemptyline then
if lenused>maxlen then
begin
spaceat := maxlen;
while spaceat>0 do
begin
if oneline[spaceat]=' ' then
begin
lenused := spaceat; {keep space on this line}
spaceat := 0; {end the loop}
end;
dec(spaceat);
end;
end;
if lenused>maxlen then
lenused := maxlen;
{time-saver, probably, to skip over the copy/copy when possible}
if length(oneline)>lenused then
begin
artlinebuf := copy(oneline,lenused+1,255);
oneline := copy(oneline,1,lenused);
end;
end;
{ in case of malformed articles - prevent infinite loop }
if artlinebuf='' then
arteof := eof(artf);
end;
if not gotaline then
oneline := '(malformed article)';
if oneline='' then
artlinefirstchar := chr(0)
else
artlinefirstchar := oneline[1];
end;
if toscreen then
oneline := nonastychar(oneline);
if oneline<>'' then
if oneline[length(oneline)]=lf then
oneline[length(oneline)] := ' ';
end;
procedure artresetattempt;
{ don't bother with filemode here - tpascal doesn't use it on text files }
var
savedioresult: word;
begin
{
sometimes reset() takes a _long_ time, e.g., over a LAN with 4000 files
in one directory
}
if dotsonreset then
begin
xgotoxy(1,1);
xwrites('...');
end;
{
could use safereset here, but don't, since we don't want to do a
new assign each time
}
{$I-}
reset(artf);
{$I+}
{the write() in the dotsonreset stuff can change ioresult}
savedioresult := ioresult;
if dotsonreset then
begin
xgotoxy(1,1);
xwrites(' ');
xgotoxy(1,1);
end;
if savedioresult=0 then
begin
arteof := eof(artf);
artlinebuf := '';
artcharbufused := false;
artwaslongline := false;
artlineno := 0;
artuheader := '';
artopen := true;
artlinefirstchar := ' ';
end;
end;
procedure artreset;
var
givenup: boolean;
yn: char;
begin
givenup := false;
artopen := false;
while not artopen and not givenup do
begin
artresetattempt;
if not artopen then
begin
yn := onekeydef('unable to open '+right(artfn,40)+
' -- try again? {y}/{n}','yn','y');
if yn='n' then
givenup := true;
end;
end;
if not artopen then
begin
donebrowse := true;
arteof := true;
end;
end;
procedure artclose;
begin
if artopen then
close(artf);
artopen := false;
end;
function isheaderline; {valid only once getartl has returned it}
begin
isheaderline := artlineno<firstemptyline;
end;
procedure showartl;
var
changeds: string;
i: integer;
thisisfindhit: boolean;
thisisquoted: boolean;
thisisbreakline: boolean;
begin
if hideformfeeds then
changeds := crepl(s,^L,' ')
else
changeds := s;
if isheaderline then
begin
usingalternatecolor := true; {it gets toggled on empty line following}
if isheaderinlist(artuheader,highlightheaders) then
begin
{write first part and chop it so it isn't shown again}
if startofline then
xwritess(chopfirstw(changeds),' ');
xhighvideo;
xwritelns(screenline(changeds));
xlowvideo;
end
else
xwritelns(screenline(changeds));
end
else
begin
if compactspaces then
changeds := sreplmulti(changeds,' ',' ');
if rot13ing then
changeds := rot13(changeds);
{$ifdef charset}
if uselocalcharset then
linetolocal(changeds);
{$endif}
thisisfindhit := false;
if highlightsearchhits then
if textintext(browseuppersearchstring,upper(changeds)) then
thisisfindhit := true;
{quotecolor is just a time-waster if we're not on the console}
thisisquoted := (artlinefirstchar=quotechar) and console;
changeds := screenline(changeds);
if thisisfindhit then
{}{} {highlight just the word?}
begin
xhighvideo;
xwritelns(changeds);
xlowvideo;
end
else if thisisquoted then
begin
xsetcolor(quotecolor);
xwritelns(changeds);
xlowvideo;
end
else
begin
if not console then
xwritelns(changeds)
else
begin
thisisbreakline := false;
{only go through this effort if it will be visible!}
if alternatecolor<>lowcolor then
if isabreakline(changeds) then
thisisbreakline := true;
{don't switch colors twice on two empty lines in a row}
if shouldswitchcolor and not thisisbreakline then
begin
usingalternatecolor := not usingalternatecolor;
shouldswitchcolor := false;
end;
if usingalternatecolor then
xsetcolor(alternatecolor)
else
xlowvideo;
xwritelns(changeds);
if usingalternatecolor then
xlowvideo;
if thisisbreakline then
shouldswitchcolor := true; {duplicating true is ok}
end;
end;
end;
end;
procedure savewriteart(fullheaders: boolean);
var
outfilen: string;
outfile: text;
outfileisopen: boolean;
illegal: boolean;
doit: boolean;
appending: boolean;
oneline: string;
appendoverwriteforgetit: char;
{$ifdef charset}
yn: char;
foundemptyline: boolean;
saveusinglocal: boolean;
{$endif}
{for non-trusted users, make sure no : or \ in unslash(filename)}
{and try to make sure it's not a device driver (con, aux, lpt1, etc.)}
{then force it in the user's home directory}
begin
getfilename(outfilen,'file name (blank to abort):',lastfilen);
outfilen := ltrim(trim(outfilen));
if outfilen<>'' then
lastfilen := outfilen;
if tildehome then
if copy(outfilen,1,2)='~/' then
outfilen := home+copy(outfilen,2,255);
outfilen := unslash(outfilen);
doit := (outfilen<>'');
illegal := illegalfn(outfilen);
if doit and not trusted then
begin
illegal := illegal or suspiciousfn(outfilen);
end;
if doit and illegal then
begin
warn('unable to use that filename');
end;
if doit and not illegal then
begin
if not trusted then
outfilen := withbackslash(home)+outfilen;
appendoverwriteforgetit := 'o';
if fexists(outfilen) then
begin
xclreolxy(1,lpp);
appendoverwriteforgetit :=
onekeydef('{O}verwrite {a}ppend {f}orget it','Oaf','f');
end;
if appendoverwriteforgetit<>'f' then
begin
{$ifdef charset}
saveusinglocal := false;
if uselocalcharset then
begin
yn := onekeydef('Change to local charset? {y}/{n}','yn','y');
saveusinglocal := (yn = 'y');
end;
{$endif}
xclreolxy(1,lpp);
appending := (appendoverwriteforgetit='a');
if appending then
xwritesss('appending to ',outfilen,' ...')
else
xwritesss('writing to ',outfilen,' ...');
assign(outfile,outfilen);
outfileisopen := false;
if appending then
begin
{$I-}
append(outfile);
{$I+}
if ioresult<>0 then
begin
warn('could not append to '+outfilen);
end
else
begin
outfileisopen := true;
writeln(outfile);
writeln(outfile,outputseparator);
writeln(outfile);
end;
end
else
begin
{$I-}
rewrite(outfile);
{$I+}
if ioresult<>0 then
begin
warn('could not write to '+outfilen);
end
else
begin
outfileisopen := true;
end;
end;
{need to check fullheaders here!}
artreset;
{$ifdef charset}
foundemptyline:= false;
{$endif}
if outfileisopen then
begin
while not arteof do
begin
getartl(oneline,255,false);
{$ifdef charset}
if foundemptyline and saveusinglocal then
linetolocal(oneline)
else
if oneline='' then
foundemptyline := true;
{$endif}
writeln(outfile,oneline);
end;
close(outfile);
end;
xclreolxy(1,lpp);
xwrites('done.');
end;
end;
end;
procedure writeart;
begin
savewriteart(nofullheaders);
end;
procedure saveart;
begin
savewriteart(yesfullheaders);
end;
function bestquotechar;
var
result: char;
foundemptyline: boolean;
done: boolean;
prevchar: char;
wastes: string;
linesread: integer;
begin
result := '>';
artreset;
if artopen then
begin
foundemptyline := false;
while not foundemptyline and not arteof do
begin
getartl(wastes,255,notoscreen);
if not isheaderline then
foundemptyline := true;
end;
prevchar := #0; {unlikely to appear}
linesread := 0;
done := false;
while not done and (linesread<20) and not arteof do
begin
inc(linesread);
getartl(wastes,255,notoscreen);
{hit a signature -- give up}
{sigh -- @trn.com is right -- the dash-dash-space is often broken}
if (wastes='-- ') or (wastes='--') then
begin
done := true;
wastes := '';
end;
if wastes<>'' then
begin
if (wastes[1]=' ')
or (wastes[1]=tab)
or isalpha(wastes[1])
or isdigit(wastes[1]) then
prevchar := #0
else
begin
if wastes[1]=prevchar then
begin
result := prevchar;
done := true;
end;
prevchar := wastes[1];
if (prevchar=':') or (prevchar='>') or (prevchar='|') then
begin
result := prevchar;
done := true;
end;
end;
end;
end;
end;
bestquotechar := result;
end;
end.