Jason Aller Floppy Collection/189.img/TCS120S.ZIP/OVERRET1.PAS

Pascal/Delphi Source File | 1989-04-06 | 22KB | 871 lines

{$R-,S-,I-,D-,F+,V-,B-,N- }
{$M 65500,0,0 }

unit overret1;

interface

uses crt,
     gentypes,modem,configrt,gensubs,subs1,subs2,userret,textret,flags,mainr1;

procedure help (fn:mstr);
procedure edituser (eunum:integer);
procedure printnews;
procedure sendmodemstr (ss:anystr; endifcarrier:boolean);
function getlastcaller:mstr;
procedure showlastcallers;
procedure infoform (i:integer);
function selectspecs (var us:userspecsrec):boolean; { True if user aborts }
procedure editoldspecs;

implementation

var buflen30:boolean;

procedure help (fn:mstr);
var tf:text;
    htopic,cnt:integer;
begin
  fn:=textfiledir+fn;
  assign (tf,fn);
  reset (tf);
  if ioresult<>0 then begin
    writestr ('Sorry, no help is availiable!');
    if issysop then begin
      writeln ('Sysop: To make help, create a file called ',fn);
      writeln ('Group the lines into blocks separated by periods.');
      writeln ('The first group is the topic menu; the second is the');
      writeln ('help for topic 1; the third for topic 2; etc.')
    end;
    exit
  end;
  repeat
    textclose (tf);
    assign (tf,fn);
    reset (tf);
    writeln (^M);
    printtexttopoint (tf);
    repeat
      writestr (^M'Topic Number [CR/Quit]:');
      if hungupon or (length(input)=0) then
        begin
          textclose (tf);
          exit
        end;
      htopic:=valu (input)
    until (htopic>0);
    for cnt:=2 to htopic do
      if not eof(tf)
        then skiptopoint (tf);
    if eof(tf)
      then writestr ('Sorry, no help on that topic!')
      else printtexttopoint (tf)
  until 0=1
end;

procedure edituser (eunum:integer);
var eurec:userrec;
    ca:integer;
    k:char;
const sysopstr:array [false..true] of string[6]=('Normal','Sysop');
      sectionnames:array [udsysop..gfsysop] of string[20]=
        ('File transfer','Bulletin section','Voting booths',
         'E-mail section','Doors','Main menu','Databases','Trivia','G-Files');

  procedure truesysops;
  begin
    writeln ('Sorry, you may not do that without true sysop access!');
    writelog (18,17,'')
  end;

  function truesysop:boolean;
  begin
    truesysop:=ulvl<>sysoplevel
  end;

  procedure eustatus;
  var cnt:integer;
      k:char;
      c:configtype;
  begin
    writehdr ('[ User Status ]');
    with eurec do begin
      write (^M'Number:    '^S,eunum,
             ^M'Name:      '^S,handle,
             ^M'Phone #:   '^S,phonenum,
             ^M'Note:      '^S,note,
             ^M'Pwd:       '^S);
      if truesysop
        then write (password)
        else write ('[Classified]');
      write (^M'Level:     '^S,level,
             ^M'Last on:   '^S,datestr(laston),', at ',timestr(laston),
             ^M'Posts:     '^S,nbu,
             ^M'Uploads:   '^S,nup,
             ^M'Downloads: '^S,ndn,
             ^M'Wanted:    '^S,yesno(wanted in config),
             ^M'File Xfer',
             ^M'  Level:   '^S,udlevel,
             ^M'  Points:  '^S,udpoints,
             ^M'  Uploads: '^S,uploads,
             ^M'  Dnloads: '^S,downloads,
             ^M'G-Files',
             ^M'  Level:   '^S,gflevel,
             ^M'  Uploads: '^S,gfuploads,
             ^M'  Dnloads: '^S,gfdownloads,
           ^M^M'Time on system:  '^S,totaltime:0:0,
             ^M'Number of calls: '^S,numon,
             ^M'Voting record:   '^S);
      for cnt:=1 to maxtopics do begin
        if cnt<>1 then write (',');
        write (voted[cnt])
      end;
      writeln (^M);
      for c:=udsysop to databasesysop do
        if c in eurec.config
          then writeln (^B'Sysop of the '^S,sectionnames[c]);
      writeln
    end;
    writelog (18,13,'')
  end;

  procedure getmstr (t:mstr; var mm);
  var m:mstr absolute mm;
  begin
    writeln ('Old ',t,': '^S,m);
    if buflen30 then buflen:=30;
    writestr ('New '+t+'? *');
    if length(input)>0 then m:=input
  end;

  procedure getsstr (t:mstr; var s:sstr);
  var m:mstr;
  begin
    m:=s;
    getmstr (t,m);
    s:=m
  end;

  procedure getint (t:mstr; var i:integer);
  var m:mstr;
  begin
    m:=strr(i);
    getmstr (t,m);
    i:=valu(m)
  end;

  procedure euwanted;
  begin
    writestr ('Wanted status: '^S+yesno(wanted in eurec.config));
    writestr ('New wanted status:');
    if yes
      then eurec.config:=eurec.config+[wanted]
      else eurec.config:=eurec.config-[wanted];
    writelog (18,1,yesno(wanted in eurec.config))
  end;

  procedure eudel;
  begin
    writestr ('KILL the lame fagget [y/n]? *');
    if yes then begin
      deleteuser (eunum);
      seek (ufile,eunum);
      read (ufile,eurec);
      writelog (18,9,'')
    end
  end;

  procedure euname;
  var m:mstr;
  begin
    m:=eurec.handle;
    getmstr ('name',m);
    if not match (m,eurec.handle) then
      if lookupuser (m)<>0 then begin
        writestr ('Already exists!  Are you sure [y/n]? *');
        if not yes then exit
      end;
    eurec.handle:=m;
    writelog (18,6,m)
  end;

  procedure eupassword;
  begin
    if not truesysop
      then truesysops
      else begin
        getsstr ('Password',eurec.password);
        writelog (18,8,'')
      end
  end;

  procedure eulevel;
  var n:integer;
  begin
    n:=eurec.level;
    getint ('Level',n);
    if (n>=sysoplevel) and (not truesysop)
      then truesysops
      else begin
        eurec.level:=n;
        writelog (18,15,strr(n))
      end
  end;

  procedure eugflevel;
  var n:integer;
  begin
    n:=eurec.gflevel;
    getint ('G-File Level',n);
    if (n>=sysoplevel) and (not truesysop)
      then truesysops
      else begin
        eurec.gflevel:=n;
        writelog (18,18,strr(n))
      end
  end;

  procedure euphone;
  var m:mstr;
      p:integer;
  begin
    m:=eurec.phonenum;
    buflen:=15;
    getmstr ('Phone Number',m);
    p:=1;
    while p<=length(m) do
      if (m[p] in ['0'..'9'])
        then p:=p+1
        else delete (m,p,1);
    if length(m)>7 then begin
      eurec.phonenum:=m;
      writelog (18,16,m)
    end
  end;

  procedure eunote;
  var ax:mstr;
  begin
   buflen30:=true;
   getmstr ('User Note',eurec.note);
   buflen30:=false;
   writeurec;
  end;

  procedure boardflags;
  var quit:boolean;

    procedure listflags;
    var bd:boardrec;
        cnt:integer;
    begin
      seek (bdfile,0);
      for cnt:=0 to filesize(bdfile)-1 do begin
        read (bdfile,bd);
        tab (bd.shortname,9);
        tab (bd.boardname,30);
        writeln (accessstr[getuseraccflag (eurec,cnt)]);
        if break then exit
      end
    end;

    procedure changeflag;
    var bn,q:integer;
        bname:mstr;
        ac:accesstype;
    begin
      buflen:=8;
      writestr ('Board to change access:');
      bname:=input;
      bn:=searchboard(input);
      if bn=-1 then begin
        writeln ('Not found!');
        exit
      end;
      writeln (^B^M'Current access: '^S,
               accessstr[getuseraccflag (eurec,bn)]);
      getacflag (ac,input);
      if ac=invalid then exit;
      setuseraccflag (eurec,bn,ac);
      case ac of
        letin:q:=2;
        keepout:q:=3;
        bylevel:q:=4
      end;
      writelog (18,q,bname)
    end;

    procedure allflags;
    var ac:accesstype;
    begin
      writehdr ('Set all board access flags');
      getacflag (ac,input);
      if ac=invalid then exit;
      writestr ('Confirm [Y/N]:');
      if not yes then exit;
      setalluserflags (eurec,ac);
      writelog (18,5,accessstr[ac])
    end;

  begin
    opentempbdfile;
    quit:=false;
    repeat
      repeat
        writestr (^M'[L]ist flags, [C]hange one flag, [A]ll flags, or [Q]uit:');
        if hungupon then exit
      until length(input)<>0;
      case upcase(input[1]) of
        'L':listflags;
        'C':changeflag;
        'A':allflags;
        'Q':quit:=true
      end
    until quit;
    closetempbdfile
  end;

  procedure specialsysop;

    procedure getsysop (c:configtype);
    begin
      writeln ('Section ',sectionnames[c],': '^S,
               sysopstr[c in eurec.config]);
      writestr ('Grant Sysop Access? *');
      if length(input)<>0
        then if yes
          then
            begin
              eurec.config:=eurec.config+[c];
              writelog (18,10,sectionnames[c])
            end
          else
            begin
              eurec.config:=eurec.config-[c];
              writelog (18,11,sectionnames[c])
            end
    end;

  begin
    if not truesysop then begin
      truesysops;
      exit
    end;
    writestr
('Section of [M]ain, [F]ile, [B]ulletin, [V]oting, [E]mail, [D]atabase,'^M+
 '           [O]Doors, [G]-Files, [J]Trivia: *');
    if length(input)=0 then exit;
    case upcase(input[1]) of
      'M':getsysop (mainsysop);
      'F':getsysop (udsysop);
      'B':getsysop (bulletinsysop);
      'V':getsysop (votingsysop);
      'E':getsysop (emailsysop);
      'D':getsysop (databasesysop);
      'O':getsysop (doorssysop);
      'G':getsysop (gfsysop);
      'J':getsysop (jsysop)
    end
  end;

  procedure getlogint (prompt:mstr; var i:integer; ln:integer);
  begin
    getint (prompt,i);
    writelog (18,ln,strr(i))
  end;

  procedure specialediting;
  begin
   writestr ('Access Code: &');
   if not (match(input,'Z;Z')) then exit;
   writestr ('urec.uploads: *');
   if (length(input)>0) and (valu(input)>-1) then
    eurec.uploads:=valu(input);
   writestr ('urec.downloads: *');
   if (length(input)>0) and (valu(input)>-1) then
    eurec.downloads:=valu(input);
   writestr ('urec.upk=0? *');
   if yes then urec.upk:=0;
   writestr ('urec.downk=0? *');
   if yes then urec.downk:=0;
   writeufile (eurec,eunum);
  end;

var q:integer;
begin
  writeurec;
  seek (ufile,eunum);
  read (ufile,eurec);
  writelog (2,3,eurec.handle);
  writeln (^R'Editing User - '+^S+eurec.handle+^R);
  repeat
    q:=menu('User Edit','UEDIT','SDHPLOEWTBQYNIRG!');
    case q of
      1:eustatus;
      2:eudel;
      3:euname;
      4:eupassword;
      5:eulevel;
      6:getlogint ('File Points',eurec.udpoints,7);
      7:getlogint ('File Level',eurec.udlevel,14);
      8:euwanted;
      9:getlogint ('Time left for today',eurec.timetoday,12);
      10:boardflags;
      12:specialsysop;
      13:euphone;
      14:showinfoforms(strr(eunum));
      15:eunote;
      16:eugflevel;
      17:specialediting
    end
  until hungupon or (q=11);
  writeufile (eurec,eunum);
  readurec
end;

procedure printnews;
var nfile:file of integer;
    line,nn,x,y,z,tcsrules:integer;
    p:string;
begin
  assign (nfile,'News');
  reset (nfile);
  if ioresult<>0 then exit;
  if filesize (nfile)=0 then begin
    close (nfile);
    exit
  end;
  nn:=0;
  while not (eof(nfile) or break or hungupon) do begin
    read (nfile,line);
    if line>=0 then begin
      writeln;
      nn:=nn+1;
      p:='<Press [CR] to read next News item>*';
      writehdr ('News Item '+strr(nn));
      printtext (line);
      writeln;
    { echoit:=false;
      writestr ('                         <Press [CR] to read next item>*');
      echoit:=true;
      for x:=1 to 25 do write (^H); }
    { z:=urec.displaylen;
      for x:=1 to ((z-length(p)) div 2) do
      begin
       tcsrules:=tcsrules+1;
       write (' ');
      end;
      echoit:=false;
      writestr (p);
      echoit:=true;
      for y:=1 to (length(p)+tcsrules) do
      write (^H); }
    end
  end;
  close (nfile)
end;

procedure sendmodemstr (ss:anystr; endifcarrier:boolean);
var cnt,ptr:integer;
    k:char;
label exit;
begin
  ptr:=0;
  while ptr<length(ss) do
    begin
      if keyhit or (carrier=endifcarrier) then goto exit;
      ptr:=ptr+1;
      k:=ss[ptr];
      case k of
        '|':sendchar (^M);
        '~':delay (500);
        '^':begin
              ptr:=ptr+1;
              if ptr>length(ss)
                then k:='^'
                else k:=upcase(ss[ptr]);
              if k in ['A'..'Z']
                then sendchar (chr(ord(k)-64))
                else sendchar (k)
            end;
        else sendchar (k)
      end;
      delay (50);
      while numchars>0 do writecon (getchar)
    end;
  cnt:=0;
  repeat
    while numchars>0 do begin
      cnt:=0;
      writecon (getchar)
    end;
    cnt:=cnt+1
  until (cnt=1000) or keyhit or (carrier=endifcarrier);
  exit:
  break:=keyhit
end;

function getlastcaller:mstr;
var qf:file of lastrec;
    l:lastrec;
begin
  getlastcaller:='';
  assign (qf,'Callers');
  reset (qf);
  if ioresult=0 then
    if filesize(qf)>0
      then
        begin
          seek (qf,0);
          read (qf,l);
          getlastcaller:=l.name
        end;
  close (qf)
end;

procedure showlastcallers;
var qf:file of lastrec;
    cnt:integer;
    l:lastrec;
begin
  if ulvl<listuserlvl then exit;
  assign (qf,'Callers');
  reset (qf);
  if ioresult=0 then begin
    writehdr ('Recent Caller List');
    break:=false;
    writeln ('Name                            Date   Time');
    if (asciigraphics in urec.config) then
    writeln ('──────────────────────────────────────────────') else
    writeln ('----------------------------------------------');
    for cnt:=0 to filesize(qf)-1 do
      if not break then begin
        read (qf,l);
        ansicolor (urec.statcolor);
        tab (l.name,31);
        ansicolor (urec.regularcolor);
        writeln (datestr(l.when)+' '+timestr(l.when))
      end
  end;
  close (qf)
end;

procedure infoform (i:integer);
var ff:text;
    fn:lstr;
    k:char;
    me:message;
begin
  writeln;
  if (i<1) or (i>5) then exit;
  fn:=textfiledir+'Infoform.'+strr(i);
  if not exist (fn) then begin
    writestr ('There isn''t an Info-Form #'+strr(i)+' right now.');
    if issysop then
      writeln ('Sysop: To make an information form, create a text file',
             ^M'called ',fn,'.  Use * to indicate a pause for user input.');
    exit
  end;
  if i=1 then begin
  if urec.infoform1<>-1 then begin
    writestr ('You have already filled out Information Form #1!  '+^M+
              'Replace it [y/n]? *');
    if not yes then exit;
    deletetext (urec.infoform1);
    urec.infoform1:=-1;
    writeurec
  end;
  end;
  if i=2 then begin
  if urec.infoform2<>-1 then begin
    writestr ('You have an existing information form #2!  '+^M+
              'Replace it [y/n]? *');
    if not yes then exit;
    deletetext (urec.infoform2);
    urec.infoform2:=-1;
    writeurec
  end;
  end;
  if i=3 then begin
  if urec.infoform3<>-1 then begin
    writestr ('You have an existing information form #3!  '+^M+
              'Replace it [y/n]? *');
    if not yes then exit;
    deletetext (urec.infoform3);
    urec.infoform3:=-1;
    writeurec
  end;
  end;
  if i=4 then begin
  if urec.infoform4<>-1 then begin
    writestr ('You have an existing information form #4!  '+^M+
              'Replace it [y/n]? *');
    if not yes then exit;
    deletetext (urec.infoform4);
    urec.infoform4:=-1;
    writeurec
  end;
  end;
  if i=5 then begin
  if urec.infoform5<>-1 then begin
    writestr ('You have an existing information form #5!  '+^M+
              'Replace it [y/n]? *');
    if not yes then exit;
    deletetext (urec.infoform5);
    urec.infoform5:=-1;
    writeurec
  end;
  end;
  assign (ff,fn);
  reset (ff);
  me.numlines:=1;
  me.title:='';
  me.anon:=false;
  me.text[1]:='Filled out on: '+datestr(now)+' at '+timestr(now);
  while not eof(ff) do begin
    if hungupon then begin
      textclose (ff);
      exit
    end;
    read (ff,k);
    if k='*' then begin
      nochain:=true;
      atmenu:=false;
      getstr (1);
      me.numlines:=me.numlines+1;
      me.text[me.numlines]:=input
    end else writechar (k)
  end;
  textclose (ff);
  if i=1 then urec.infoform1:=maketext (me) else
  if i=2 then urec.infoform2:=maketext (me) else
  if i=3 then urec.infoform3:=maketext (me) else
  if i=4 then urec.infoform4:=maketext (me) else
  if i=5 then urec.infoform5:=maketext (me);
  writeurec
end;

procedure openusfile;
const newusers:userspecsrec=(name:'New users';minlevel:1;maxlevel:1;
         minlaston:-maxint;maxlaston:maxint;minpcr:-maxint;maxpcr:maxint);
begin
  assign (usfile,'userspec');
  reset (usfile);
  if ioresult<>0 then begin
    rewrite (usfile);
    if level2nd<>0 then newusers.maxlevel:=level2nd;
    write (usfile,newusers)
  end
end;

procedure editspecs (var us:userspecsrec);

  procedure get (tex:string; var value:integer; min:boolean);
  var vstr:sstr;
  begin
    buflen:=6;
    if abs(value)=maxint then vstr:='None' else vstr:=strr(value);
    writestr (tex+' ['+vstr+']:');
    if input[0]<>#0
      then if upcase(input[1])='N'
        then if min
          then value:=-maxint
          else value:=maxint
        else value:=valu(input)
  end;

  procedure getreal (tex:string; var value:real; min:boolean);
  var vstr:sstr;
      s:integer;
  begin
    buflen:=10;
    if abs(value)=maxint then vstr:='None' else vstr:=streal(value);
    writestr (tex+' ['+vstr+']:');
    if length(input)<>0
      then if upcase(input[1])='N'
        then if min
          then value:=-maxint
          else value:=maxint
        else begin
          val (input,value,s);
          if s<>0 then value:=0
        end
  end;

begin
  writeln (^B^M'Enter Specifications; N for none.'^M);
  buflen:=30;
  writestr ('Specification set name ['+us.name+']:');
  if length(input)<>0
    then if match(input,'N')
      then us.name:='Unnamed'
      else us.name:=input;
  get ('Lowest level',us.minlevel,true);
  get ('Highest level',us.maxlevel,true);
  get ('Lowest #days since last call',us.minlaston,true);
  get ('Highest #days since last call',us.maxlaston,true);
  getreal ('Lowest post to call ratio',us.minpcr,true);
  getreal ('Highest post to call ratio',us.maxpcr,true)
end;

function getspecs (var us:userspecsrec):integer; { -1:not saved   >0:in file }
begin
  with us do begin
    name:='Unnamed';                     { Assumes USFILE is open !! }
    minlevel:=-maxint;
    maxlevel:=maxint;
    minlaston:=-maxint;
    maxlaston:=maxint;
    minpcr:=-maxint;
    maxpcr:=maxint
  end;
  editspecs (us);
  writestr (^M'Save these specs to disk? *');
  if yes then begin
    seek (usfile,filesize(usfile));
    write (usfile,us);
    getspecs:=filesize(usfile)
  end else getspecs:=-1
end;

function searchspecs (var us:userspecsrec; name:mstr):integer;
var v,pos:integer;
begin
  v:=valu(name);
  seek (usfile,0);
  pos:=1;
  while not eof(usfile) do begin
    read (usfile,us);
    if match(us.name,name) or (valu(name)=pos) then begin
      searchspecs:=pos;
      exit
    end;
    pos:=pos+1
  end;
  searchspecs:=0;
  writestr (^M'Not found!')
end;

procedure listspecs;
var us:userspecsrec;
    pos:integer;

  procedure writeval (n:integer);
  begin
    if abs(n)=maxint then write ('   None') else write(n:7)
  end;

  procedure writevalreal (n:real);
  begin
    if abs(n)=maxint then write ('   None') else write(n:7:2)
  end;

begin
  writehdr ('User Specification Sets');
  seek (usfile,0);
  pos:=0;
  tab ('',35);
  tab ('    Level    ',14);
  tab ('  Last Call  ',14);
  writeln ('  Post/Call Ratio  ');
  while not (break or eof(usfile)) do begin
    pos:=pos+1;
    read (usfile,us);
    write (pos:3,'. ');
    tab (us.name,30);
    writeval (us.minlevel);
    writeval (us.maxlevel);
    writeval (us.minlaston);
    writeval (us.maxlaston);
    writevalreal (us.minpcr);
    writevalreal (us.maxpcr);
    writeln
  end
end;

function selectaspec (var us:userspecsrec):integer; {  0 = none         }
var done:boolean;                                   { -1 = not in file  }
    pos:integer;                                    { -2 = added to end }
begin
  selectaspec:=0;
  openusfile;
  if filesize(usfile)=0
    then selectaspec:=getspecs(us)
    else
      repeat
        if hungupon then exit;
        done:=false;
        writestr (^M'Specification Set Name (?/List, A/Add):');
        if length(input)=0
          then done:=true
          else if match(input,'A')
            then
              begin
                pos:=getspecs(us);
                if pos>0
                  then selectaspec:=-2
                  else selectaspec:=-1;
                done:=true
              end
            else if match(input,'?')
              then listspecs
              else
                begin
                  pos:=searchspecs (us,input);
                  done:=pos<>0;
                  selectaspec:=pos
                end
      until done;
  close (usfile)
end;

function selectspecs (var us:userspecsrec):boolean;
var dummy:integer;
begin
  dummy:=selectaspec (us);
  selectspecs:=dummy=0
end;

procedure deletespecs (pos:integer);
var cnt:integer;
    us:userspecsrec;
begin
  openusfile;
  for cnt:=pos to filesize(usfile)-1 do begin
    seek (usfile,cnt);
    read (usfile,us);
    seek (usfile,cnt-1);
    write (usfile,us)
  end;
  seek (usfile,filesize(usfile)-1);
  truncate (usfile);
  close (usfile)
end;

procedure editoldspecs;
var pos:integer;
    us:userspecsrec;
begin
  repeat
    pos:=selectaspec (us);
    if pos>0 then begin
      buflen:=1;
      writestr (^M'[E]dit or [D]elete? *');
      if length(input)=1 then case upcase(input[1]) of
        'E':begin
              editspecs (us);
              openusfile;
              seek (usfile,pos-1);
              write (usfile,us);
              close (usfile)
            end;
        'D':deletespecs (pos)
      end
    end
  until (pos=0) or hungupon
end;

begin
 buflen30:=false;
end.