The World of Computer Software/World_Of_Computer_Software-02-385-Vol-1of3.iso/r/rusn-09.zip/RUSN-FUN.PAS

Pascal/Delphi Source File | 1992-11-03 | 18KB | 855 lines

{

rusn-fun.pas - rusnews functions

}

function integertozstring(i, width: integer): string;

var
  result: string;

begin
  str(i,result);
  while length(result)<width do
    result := '0'+result;
  integertozstring := result;
end;

function time: string;

var
  h,m,s,s00: word;

begin
  gettime(h,m,s,s00);
  time := integertozstring(h,2)+':'+integertozstring(m,2)+':'+
   integertozstring(s,2);
end;

function timedigits: string;

var
  h,m,s,s00: word;

begin
  gettime(h,m,s,s00);
  timedigits :=
   integertozstring(h,2)+integertozstring(m,2)+integertozstring(s,2);
end;

function cdow: string;

var
  y,m,d,dow: word;
  result: string;

begin
  getdate(y,m,d,dow);
  result := 'Sunday';
  if dow=1 then result := 'Monday';
  if dow=2 then result := 'Tuesday';
  if dow=3 then result := 'Wednesday';
  if dow=4 then result := 'Thursday';
  if dow=5 then result := 'Friday';
  if dow=6 then result := 'Saturday';
  cdow := result;
end;

function dayofmonth: integer;

var
  y,m,d,dow: word;

begin
  getdate(y,m,d,dow);
  dayofmonth := d;
end;

function month: integer;

var
  y,m,d,dow: word;

begin
  getdate(y,m,d,dow);
  month := m;
end;

function monthname: string;

var
  themonth: integer;
  result: string;

begin
  themonth := month;
  result := 'January';
  if themonth=2  then result := 'February';
  if themonth=3  then result := 'March';
  if themonth=4  then result := 'April';
  if themonth=5  then result := 'May';
  if themonth=6  then result := 'June';
  if themonth=7  then result := 'July';
  if themonth=8  then result := 'August';
  if themonth=9  then result := 'September';
  if themonth=10 then result := 'October';
  if themonth=11 then result := 'November';
  if themonth=12 then result := 'December';
  monthname := result;
end;

function year: integer;

var
  y,m,d,dow: word;

begin
  getdate(y,m,d,dow);
  year := y;
end;

function getenv(s: string): string;

var
  i: integer;
  envseg: word;
  envread: integer;
  firstb: byte;
  thisb: byte;
  varname: string;
  vardata: string;
  done: boolean;
  result: string;

begin
  result := '';
  envseg := memw[prefixseg:$2c];
  envread := 0;
  repeat
    firstb := mem[envseg:envread];
    if firstb>0 then
      begin
        varname := '';
        repeat
          thisb := mem[envseg:envread];
          inc(envread);
          if thisb<>ord('=') then
            varname := varname+chr(thisb);
        until thisb=ord('=');
        vardata := '';
        repeat
          thisb := mem[envseg:envread];
          inc(envread);
          if thisb>0 then
            vardata := vardata+chr(thisb);
        until thisb=0;
        done := (varname=s);
        if done then
          result := vardata;
    end;
  until (firstb=0) or done;
  getenv := result;
end;

function basesitename(s: string): string;

var
  atbang: integer;
  atpercent: integer;
  atat: integer;
  result: string;
  work: string;
  atdot: integer;

begin
  result := uucpname;
  atbang := pos('!',s);
  atpercent := pos('%',s);
  atat := pos('@',s);
  if atbang>0 then
    begin
      work := s;
      while atbang>0 do
        begin
          result := copy(work,1,atbang-1);
          work := copy(work,atbang+1,255);
          atbang := pos('!',work);
        end;
    end
  else if atpercent>0 then
    begin
      result := copy(s,atpercent+1,255);
      atat := pos('@',result);
      if atat>0 then
        result := copy(result,1,atat-1);
    end
  else if atat>0 then
    begin
      result := copy(s,atat+1,255);
    end;
  atdot := pos('.',result);
  if atdot>0 then
    result := copy(result,1,atdot-1);
  basesitename := result;
end;

function unquote(s: string): string;

begin
  if (copy(s,1,1)='"') and (copy(s,length(s),1)='"') then
    unquote := copy(s,2,length(s)-2)
  else
    unquote := s;
end;

function unslash(s: string): string;

var
  i: integer;
  result: string;

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

function ununderscore(s: string): string;

var
  i: integer;
  result: string;

begin
  result := s;
  for i := 1 to length(result) do
    if result[i]='_' then
      result[i] := ' ';
  ununderscore := result;
end;

function atoi(s: string): integer;

var
  result: integer;
  code: word;

begin
  val(s,result,code);
  atoi := result;
end;

function itoa(i: integer): string;

begin
  itoa := integertozstring(i,0);
end;

function upper(s: string): string;

var
  result: string;
  i: integer;

begin
  result := s;
  for i := 1 to length(s) do
    result[i] := upcase(result[i]);
  upper := result;
end;

function lower(s: string): string;

var
  result: string;
  i: integer;

begin
  result := s;
  for i := 1 to length(s) do
    if (result[i]>='A') and (result[i]<='Z') then
      result[i] := chr(ord(result[i])-ord('A')+ord('a'));
  lower := result;
end;

function ltrim(s: string): string;

var
  result: string;

begin
  result := s;
  while ((result[1]=' ') or (result[1]=^I)) and (length(result)>0) do
    result := copy(result,2,255);
  ltrim := result;
end;

function trim(s: string): string;

var
  result: string;

begin
  result := s;
  while ((result[length(result)]=' ') or (result[length(result)]=^I)) and
   (length(result)>0) do
    result := copy(result,1,length(result)-1);
  trim := result;
end;

function newseqnumber: integer;

var
  seqf: text;
  seqfn: string;
  newseq: integer;

begin
  if wafversion='1.64' then
    seqfn := waffledir+'\system\'+'seqf'
  else
    seqfn := waffledir+'\uucp\'+'sequence';
  assign(seqf,seqfn);
  reset(seqf);
  readln(seqf,newseq);
  close(seqf);
  rewrite(seqf);
  writeln(seqf,integertozstring(newseq+1,4));
  close(seqf);
  newseqnumber := newseq;
end;

function randomletter: char;

begin
  if random(2)=0 then
    randomletter := chr(ord('a')+random(26))
  else
    randomletter := chr(ord('A')+random(26));
end;

function randomdigit: char;

begin
  randomdigit := chr(ord('0')+random(10));
end;

function newmessageid: string;

begin
  newmessageid :=
   '<'+itoa(year mod 100)+integertozstring(month,2)+
   integertozstring(dayofmonth,2)+'.'+timedigits+'.'+
   randomdigit+randomletter+randomdigit+'.'+newsreadername+'.'+
   'w'+copy(wafversion,1,1)+copy(wafversion,3,2)+'w'+'@'+node+'>';
end;

function getfromaddr(from: string): string;

var
  result: string;
  at: integer;

begin
  at := pos('<',from);
  if at>0 then
    result := copy(from,at+1,length(from)-at-1)
  else
    begin
      at := pos(' ',from);
      if at>0 then
        result := copy(from,1,at-1)
      else
        result := from;
    end;
  getfromaddr := result;
end;

function getfromname(from: string): string;

var
  result: string;
  at: integer;

begin
  at := pos('(',from);
  if at>0 then
    result := copy(from,at+1,length(from)-at-1)
  else
    begin
      at := pos('<',from);
      if at>1 then
        result := copy(from,1,at-2)
      else
        result := '';
    end;
  getfromname := result;
end;

function getgroup(s: string): string;

begin
  getgroup := ltrim(trim(copy(s,1,pos(' ',s)-1)));
end;

function getalreadyread(s: string): integer;

begin
  getalreadyread := atoi(ltrim(trim(copy(s,pos(' ',s)+1,255))));
end;

function joinedtogroup(group: string): boolean;

var
  result: boolean;
  s: string;

begin
  result := false;
  reset(joinf);
  while not eof(joinf) and not result do
    begin
      readln(joinf,s);
      if getgroup(s)=group then
        result := true;
    end;
  joinedtogroup := result;
end;

function parseheadername(s: string): string;

begin
  parseheadername := copy(s,1,pos(':',s)-1);
end;

function parseheadervalue(s: string): string;

begin
  parseheadervalue := copy(s,pos(':',s)+2,255);
end;

function chop(s: string; i: integer): string;

var
  result: string;

begin
  chop := copy(s,i+1,255);
end;

function nore(s: string): string;

begin
  if copy(s,1,4)='Re: ' then
    nore := chop(s,4)
  else
    nore := s;
end;

function subjkilled(subject: string): boolean;

var
  i: integer;
  result: boolean;

begin

{Subject: only match if exact - it'll be put in the kill file that way}
{anyway modulo Re: of course}

  result := false;
  for i := 1 to numkillss do
    if killsubjsp^[i]=nore(subject) then
      result := true;
  subjkilled := result;
end;

function fromkilled(from: string): boolean;

var
  i: integer;
  result: boolean;

begin
{From: match if that address found anywhere - so that if they change their}
{posting software or whatever you'll still find it.}

  result := false;
  for i := 1 to numkillfs do
    if pos(killfromsp^[i],from)>0 then
      result := true;

  fromkilled := result;
end;

function getstaticvalue(name: string): string;

var
  result: string;
  infile: text;
  s: string;
  foundname: string;

begin
  result := '';
  assign(infile,wafenv);
  reset(infile);
  while (result='') and not eof(infile) do
    begin
      readln(infile,s);
      if s<>'' then
        if copy(s,1,1)<>'#' then
          begin
            foundname := trim(ltrim(copy(s,1,pos(':',s)-1)));
            if foundname=name then
              begin
                result := trim(ltrim(copy(s,pos(':',s)+1,255)));
              end;
          end;
    end;
  close(infile);
  getstaticvalue := result;
end;

function getheaderline(infilename, fieldname: string): string;

var
  infile: file;
  foundblank: boolean;
  foundline: boolean;
  result: string;
  s: string;
  ufieldname: string;
  headerbytesseen: integer;
  morelinesinheader: boolean;

function nextlinefrombuf: string;

var
  result: string;
  gotcrlf: boolean;
  c: char;

begin
  result := '';
  gotcrlf := false;
  while (headerbytesseen<headerbytesinmem) and not gotcrlf do
    begin
      inc(headerbytesseen);
      c := headerbuf[headerbytesseen];
      if (c=#13) then
        gotcrlf := true
      else if c<>#10 then
        result := result+c;
    end;
  nextlinefrombuf := result;
end;

begin
  result := '';
  ufieldname := upper(fieldname);
  if headerinmem<>infilename then
    begin
      assign(infile,infilename);
      reset(infile,1);
      blockread(infile,headerbuf,headerbufsize,headerbytesinmem);
      headerinmem := infilename;
      close(infile);
    end;
  foundblank := false;
  foundline := false;
{$ifdef oldheader}
  while (not eof(f)) and (not foundblank) and (not foundline) do
    begin
      readln(f,s);
      if copy(upper(ltrim(s)),1,length(fieldname))=ufieldname then
        begin
          foundline := true;
          result := ltrim(trim(copy(trim(s),length(fieldname)+1,255)));
          if not eof(f) then
            begin
              readln(f,s);
              if copy(s,1,1)=' ' then
                result := result+s;
            end;
        end
      else if length(trim(s))=0 then
        foundblank := true;
    end;
  close(f);
{$endif}
  headerbytesseen := 0;
  while (headerbytesseen<headerbytesinmem) and
   (not foundblank) and (not foundline) do
    begin
      s := nextlinefrombuf;
      if copy(upper(ltrim(s)),1,length(fieldname))=ufieldname then
        begin
          foundline := true;
          result := ltrim(trim(copy(trim(s),length(fieldname)+1,255)));
          if headerbytesseen<headerbytesinmem then
            begin
              morelinesinheader := true;
              while morelinesinheader do
                begin
                  s := nextlinefrombuf;
                  if copy(s,1,1)=' ' then
                    result := result+' '+ltrim(s)
                  else
                    morelinesinheader := false;
                end;
            end;
        end
      else if length(trim(s))=0 then
        foundblank := true;
    end;
  getheaderline := result
end;

function monthstringtointeger(monthstr: string): integer;

var
  result: integer;
  lowermonthstr: string;

begin
  result := 12;
  lowermonthstr := lower(monthstr);
  if lowermonthstr='jan' then result := 1
  else if lowermonthstr='feb' then result := 2
  else if lowermonthstr='mar' then result := 3
  else if lowermonthstr='apr' then result := 4
  else if lowermonthstr='may' then result := 5
  else if lowermonthstr='jun' then result := 6
  else if lowermonthstr='jul' then result := 7
  else if lowermonthstr='aug' then result := 8
  else if lowermonthstr='sep' then result := 9
  else if lowermonthstr='oct' then result := 10
  else if lowermonthstr='nov' then result := 11;
  monthstringtointeger := result;
end;

function isdigit(c: char): boolean;

begin
  isdigit := (c>='0') and (c<='9');
end;

function islower(c: char): boolean;

begin
  islower := (c>='a') and (c<='z');
end;

function snatchint(var s: string): integer;

var
  intsofar: integer;

begin
  intsofar := 0;
  while (length(s)>0) and not isdigit(s[1]) do
    s := chop(s,1);
  while (length(s)>0) and isdigit(s[1]) do
    begin
      intsofar := 10*intsofar+ord(s[1])-ord('0');
      s := chop(s,1);
    end;
  snatchint := intsofar;
end;

function stringtodatestring(datestr: string): datestringt;

var
  result: datestringt;
  workstr: string;
  dayofmonth: integer;
  monthstr: string;
  year: integer;

begin
  if datestr='' then
    result := '99991231'
  else
    begin
      workstr := datestr;
      dayofmonth := snatchint(workstr);
      workstr := ltrim(workstr);
      monthstr := copy(workstr,1,3);
      workstr := ltrim(chop(workstr,4));
      year := snatchint(workstr);
      if year<100 then
        inc(year,1900);
      result := integertozstring(year,4)+
       integertozstring(monthstringtointeger(monthstr),2)+
       integertozstring(dayofmonth,2);
    end;
  stringtodatestring := result;
end;

function firstartfirst(a,b: integer): boolean; {assuming subject the same}

var
  result: boolean;

begin
  result := true;
  if indents[a]>indents[b] then
    result := false;
  if (indents[a]=indents[b]) and (datesp^[a]>datesp^[b]) then
    result := false;
  firstartfirst := result;
end;

function max(a,b: integer): integer;

begin
  if a>b then max := a else max := b;
end;

function min(a,b: integer): integer;

begin
  min := -max(-a,-b);
end;

function getuniqfile(basename: string): string;

var
  result: integer;
  fileinfo: searchrec;
  filefound: string;

begin
  result := 0;
  findfirst(basename+'.*',archive,fileinfo);
  while doserror=0 do
    begin
      filefound := fileinfo.name;
      while pos('.',filefound)>0 do
        filefound := copy(filefound,pos('.',filefound)+1,255);
      result := max(result,atoi(filefound));
      findnext(fileinfo);
    end;
  getuniqfile := basename+'.'+itoa(result+1);
end;

function getbasedir(group: string): string;

var
  result: string;
  infilen: string;
  infile: text;
  s: string;
  mangledgroup: string;

begin
  result := '';
  infilen := waffledir+'\system\'+'usenet';
  assign(infile,infilen);
  {$I-}
  reset(infile);
  {$I+}
  if ioresult=0 then
    begin
      while (result='') and not eof(infile) do
        begin
          readln(infile,s);
          if (copy(ltrim(s),1,length(group))=group) and
           (pos('/dir=',s)>0) then
            begin
              result := trim(ltrim(copy(s,pos('/dir=',s)+5,255)));
            end;
        end;
      close(infile);
    end;
  if result='' then
    begin
      mangledgroup := currgroup;
      while pos('.',mangledgroup)>0 do
        begin
          result := result+
           copy(mangledgroup,1,min(8,pos('.',mangledgroup)-1))+'\';
          mangledgroup := copy(mangledgroup,pos('.',mangledgroup)+1,255);
        end;
      result := mainnewsdir+mainnewsdirsuf+result+
       copy(mangledgroup,1,min(8,length(mangledgroup)));
    end;
  getbasedir := unquote(unslash(result));
end;

function getnextgroup: string;

var
  foundgroup: string;
  result: string;

begin
  result := '';
  reset(joinf);
  foundgroup := '';

  if not eof(joinf) then
    begin
      if currgroup='' then
        begin
          readln(joinf,foundgroup);
          result := getgroup(foundgroup);
        end
      else
        begin
          while not eof(joinf) and (foundgroup<>currgroup) do
            begin
              readln(joinf,foundgroup);
              foundgroup := getgroup(foundgroup);
            end;
          if not eof(joinf) then
            begin
              readln(joinf,foundgroup);
              result := getgroup(foundgroup);
            end;
        end;
    end;
  getnextgroup := result;
end;

function alreadyseen(newsgroups: string): boolean;

var
  i: integer;
  newsglist: string;
  result: boolean;
  found: boolean;

begin
  result := false;
  if currgroup<>'control' then
    begin
      found := false;
      newsglist := ','+newsgroups+',';
      i := 1;
      while (i<numjoined) and not found do
        begin
          if (joinedgroups[i]<>'news.answers') and
           (pos(','+joinedgroups[i]+',',newsglist)<>0) then
            begin
              found := true;
              result := (joinedgroups[i]<>currgroup);
            end;
          inc(i);
        end;
    end;
  alreadyseen := result;
end;

function screenline(s: string): string;

begin
  if length(trim(s))<=79 then
    screenline := trim(s)
  else
    screenline := copy(s,1,78)+'<';
end;