DP Tool Club 31/CDASC_31_1996_juillet_aout.iso/internet/rnr214.zip/RNRART.PAS

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.