Super Net 1/SUPERNET_1.iso/PC/OTROS/EXTRAS/UUCODE/UUCP/RSNU106A.ZIP/src/rusnproc.pas

Pascal/Delphi Source File | 1993-10-16 | 9.5 KB | 468 lines

unit rusnproc;

{

rusnproc.pas - rusnews procedures

}

{$I rusn-def.pas}

interface

uses dos,rusnglob,rusnfunc,rusnio,rusngenf,rusnmous;

procedure warn(warning: string);
procedure warn3(w1,w2,w3: string);
procedure warnerr(prg: string; doserr: integer);
procedure execp(cmd,cmdline: string);
procedure shellout;
procedure unfoldergroup(var group: string);
procedure pickagroup(var possgroup: string);
procedure updatejoin(highestnum: word);
procedure updatejoinunsubscribe;
procedure addnewmailgroup(newgroup: string);
procedure mkhier(hier: string);
procedure copyfile(oldfn,newfn: string);
procedure movefile(oldfn,newfn: string);

implementation

procedure warn;

var
  wastec: char;

begin
  xclreolxy(1,lpp);
  xwritess(warning,' - press any key ');
  wastec := xreadkey;
  xclreolxy(1,lpp);
end;

procedure warn3;

begin
  xwriteln;
  xwriteln;
  xclreolxy(1,lpp-2);
  xwrites(w1);
  xclreolxy(1,lpp-1);
  xwrites(w2);
  warn(w3);
  xclreolxy(1,lpp-2);
  xclreolxy(1,lpp-1);
end;

procedure warnerr;

var
  errstr: string;

begin
  errstr := itoa(doserr);
  if doserr=2 then errstr := '2 (file not found)'
  else if doserr=3 then errstr := '3 (path not found)'
  else if doserr=5 then errstr := '5 (access denied)'
  else if doserr=6 then errstr := '6 (invalid handle)'
  else if doserr=8 then errstr := '8 (not enough memory)'
  else if doserr=10 then errstr := '10 (invalid environment)'
  else if doserr=11 then errstr := '11 (invalid format)'
  else if doserr=18 then errstr := '18 (no more files)';

  warn('warning: '+prg+' failed (error '+errstr+')');
end;

procedure execp;

var
  path: string;
  success: boolean;
  el: string;
  at: integer;

begin
  if (pos(':',cmd)<>0) or (pos('\',cmd)<>0) then
    exec(cmd,cmdline)
  else if indir(cmd,'.') then
    exec(cmd,cmdline)
  else
    begin
      path := getenv('PATH');
      success := false;
      while not success and (path<>'') do
        begin
          if copy(path,length(path),255)<>';' then
            path := path+';';
          at := pos(';',path);
          el := copy(path,1,at-1);
          path := copy(path,at+1,255);
          if indir(cmd,el) then
            begin
              success := true;
              exec(el+'\'+cmd,cmdline);
            end;
        end;
    end;
end;

procedure shellout;

var
  comspec: string;
  doserr: integer;
  wastec: char;

begin
  if console and trusted then
    begin
      xgotoxy(1,lpp);
      xwriteln;
      xwriteln;
      xwriteln;
      xwritelns('use `EXIT'' to return to rusnews');
      xwritelns('be careful - you probably don''t have a lot of memory left');
      xwriteln;
      comspec := getenv('COMSPEC');
      if comspec='' then
        if indir('c:\.','command.com') then
          comspec := 'c:\command.com';
      if comspec='' then
        begin
          warn('could not find what shell to run - no COMSPEC variable');
        end
      else
        begin
          mousehide;
          execp(comspec,'');
          mouseshow;
          doserr := doserror;
          xgotoxy(1,lpp);
          xwriteln;
          xwriteln;
          xwriteln;
          if doserr<>0 then
            xwrites('(error) press any key to return to rusnews ')
          else
            xwrites('press any key to return to rusnews ');
          wastec := xreadkey;
          xwrites(^M);
          xclreol;
          if doserr<>0 then
            warnerr('shell',doserr);
        end
    end;
end;

procedure unfoldergroup;

begin
  if length(group)>0 then
    if group[1]='=' then
      begin
        if length(group)=1 then
          group := mailprefix
        else
          group := mailprefix+'.'+copy(group,2,255);

{ prevent possible security hole }

        if (numoccur('\',unslash(group))<>0) or
         (numoccur(':',group)<>0) or (pos('..',group)<>0) then
          group := mailprefix;
      end;
end;

procedure pickagroup;

var
  howto: char;

begin
  xclreolxy(1,lpp);
  if possgroup='' then
    begin
      xwrites('Goto group (or initials): ');
      possgroup := currgroup;

{ changed true to false - it was a pain having to hit ^U to cancel this }

{
      xreadlnsp(possgroup,cols-30,true);
}

      xreadlnsp(possgroup,cols-30,false);

{mail folder support}

      unfoldergroup(possgroup);

    end;

  if (possgroup='') then
    xclreolxy(1,lpp)
  else
    if joinedtogroup(possgroup) then
      begin
        xclreolxy(1,lpp-1);
        xwritelnss('found group: ',possgroup);
        howto :=
         onekey('<j>ump normally, <a>ll, last <1>-<9> pages (default=j) ',
         'ja123456789 '+#13);
        if (howto=' ') or (howto=#13) then
          howto := 'j';
        if howto='a' then
          readallarts := true;
        if (howto>='1') and (howto<='9') then
          readpagesback := ord(howto)-ord('0');
        xclreolxy(1,lpp);
      end
    else
      begin
        warn('could not find a group to match');
        possgroup := '';
      end;
end;

procedure updatejoin;

var
  s: string;
  tempf: text;

begin
  if highestnum>alreadyread then
    begin
      xwritelns('Updating join file...');
      assign(tempf,temporarydir+'\'+userid);
      reset(joinf);
      rewrite(tempf);
      while not eof(joinf) do
        begin
          readln(joinf,s);
          if getfirstw(s)=currgroup then
            writeln(tempf,currgroup,' ',highestnum)
          else
            writeln(tempf,s);
        end;
      close(joinf);
      close(tempf);

      reset(tempf);
      rewrite(joinf);
      while not eof(tempf) do
        begin
          readln(tempf,s);
          writeln(joinf,s);
        end;
      close(tempf);
      close(joinf);

      erase(tempf);

      reset(joinf);
    end;
end;

procedure updatejoinunsubscribe;

var
  s: string;
  firstw: string;
  tempf: text;

begin
  xwritelns('Updating join file...');
  assign(tempf,temporarydir+'\'+userid);
  reset(joinf);
  rewrite(tempf);
  numjoined := 0;
  while not eof(joinf) do
    begin
      readln(joinf,s);
      firstw := getfirstw(s);
      if firstw<>currgroup then
        begin
          if numjoined<maxjoined then
            begin
              inc(numjoined);
              joinedgroups[numjoined] := firstw;
            end;
          writeln(tempf,s);
        end;
    end;
  close(joinf);
  close(tempf);

  reset(tempf);
  rewrite(joinf);
  while not eof(tempf) do
    begin
      readln(tempf,s);
      writeln(joinf,s);
    end;
  close(tempf);
  close(joinf);

  erase(tempf);

  reset(joinf);
end;

procedure addnewmailgroup;

var
  seenmailbutnotnew: boolean;
  s: string;
  firstw: string;
  tempf: text;

begin
  seenmailbutnotnew := false;
  xwritelns('Updating join file...');
  assign(tempf,temporarydir+'\'+userid);
  reset(joinf);
  rewrite(tempf);
  numjoined := 0;
  while not eof(joinf) do
    begin
      readln(joinf,s);
      firstw := getfirstw(s);

      if firstw=mailprefix then
        seenmailbutnotnew := true;

{insert the new group alphabetically in the mail groups, or after}
{the last one if it's the biggest alphabetically of them all}

      if (seenmailbutnotnew and not ismailgroup(firstw)) or
       (ismailgroup(firstw) and (firstw>newgroup)) then
        begin
          if numjoined<maxjoined then
            begin
              inc(numjoined);
              joinedgroups[numjoined] := newgroup;
            end;
          writeln(tempf,newgroup,' 0');
          seenmailbutnotnew := false;
        end;

      if numjoined<maxjoined then
        begin
          inc(numjoined);
          joinedgroups[numjoined] := firstw;
        end;
      writeln(tempf,s);
    end;

  if seenmailbutnotnew then
    begin
      if numjoined<maxjoined then
        begin
          inc(numjoined);
          joinedgroups[numjoined] := newgroup;
        end;
      writeln(tempf,newgroup,' 0');
    end;

  close(joinf);
  close(tempf);

  reset(tempf);
  rewrite(joinf);
  while not eof(tempf) do
    begin
      readln(tempf,s);
      writeln(joinf,s);
    end;
  close(tempf);
  close(joinf);

  erase(tempf);

  reset(joinf);
end;

procedure mkhier;

var
  s: string;
  i: integer;
  fileinfo: searchrec;
  dir: string;

begin

{$I-}

{if the directory already exists, don't worry about an error}

{WHY DOESN'T THIS WORK WITH TP6 ?!?!?!}

  s := hier;

  for i := 1 to length(s) do
    if s[i]='/' then
      s[i] := '\';

  if length(s)>0 then
    if s[length(s)]='\' then
      s := copy(s,1,length(s)-1);

  for i := 2 to length(s) do
    if (s[i]='\') and (s[i-1]<>':') then
      begin
        dir := copy(s,1,i-1);
        findfirst(dir,directory,fileinfo);
        if doserror<>0 then
          mkdir(dir);
      end;

  findfirst(s,directory,fileinfo);
  if doserror<>0 then
    mkdir(s);

{$I+}

end;

procedure copyfile;

const
  bufsize=1024;

var
  infile, outfile: file;
  done: boolean;
  numread: word;
  buffer: array[1..bufsize] of char;

begin
  assign(infile,oldfn);
  reset(infile,1);
  assign(outfile,newfn);
  rewrite(outfile,1);
  done := false;
  while not done do
    begin
      blockread(infile,buffer,bufsize,numread);
      blockwrite(outfile,buffer,numread);
      done := (numread<bufsize);
    end;
  close(infile);
  close(outfile);
end;

procedure movefile;

var
  f: file;

begin
  copyfile(oldfn,newfn);
  assign(f,oldfn);
  erase(f);
end;

end.