Jason Aller Floppy Collection/276.img/FORUM21S.ZIP/OVERRET1.PAS

Pascal/Delphi Source File | 1988-02-15 | 17.8 KB | 742 lines

{$R-,S-,I-,D-,T-,F-,V-,B-,N-,L+ }
{$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;
function selectspecs (var us:userspecsrec):boolean; { True if user aborts }
procedure editoldspecs;


implementation


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 quits]:');
      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..databasesysop] of string[20]=
        ('File transfer','Bulletin section','Voting booths',
         'E-mail section','Doors','Main menu','Databases');

  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 ('Status');
    with eurec do begin
      write (^M'Number:    '^S,eunum,
             ^M'Name:      '^S,handle,
             ^M'Phone #:   '^S,phonenum,
             ^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^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);
    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 ('Delete user --- confirm:');
    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? *');
        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 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 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, P)Doors:');
    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);
      'P':getsysop (doorssysop)
    end
  end;

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

var q:integer;
begin
  writeurec;
  seek (ufile,eunum);
  read (ufile,eurec);
  writelog (2,3,eurec.handle);
  repeat
    q:=menu('User edit','UEDIT','SDHPLOEWTBQYNI');
    case q of
      1:eustatus;
      2:eudel;
      3:euname;
      4:eupassword;
      5:eulevel;
      6:getlogint ('u/d points',eurec.udpoints,7);
      7:getlogint ('u/d level',eurec.udlevel,14);
      8:euwanted;
      9:getlogint ('time for today',eurec.timetoday,12);
      10:boardflags;
      12:specialsysop;
      13:euphone;
      14:showinfoforms(strr(eunum))
    end
  until hungupon or (q=11);
  writeufile (eurec,eunum);
  readurec
end;

procedure printnews;
var nfile:file of integer;
    line:integer;
begin
  assign (nfile,'News');
  reset (nfile);
  if ioresult<>0 then exit;
  if filesize (nfile)=0 then begin
    close (nfile);
    exit
  end;
  writehdr ('News: Hit <SPACE> to abort');
  while not (eof(nfile) or break or hungupon) do begin
    read (nfile,line);
    if line>=0 then begin
      writeln;
      printtext (line)
    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
  assign (qf,'Callers');
  reset (qf);
  if ioresult=0 then begin
    writehdr ('Recent caller list');
    break:=false;
    for cnt:=0 to filesize(qf)-1 do
      if not break then begin
        read (qf,l);
        tab (l.name,33);
        writeln (datestr(l.when)+' '+timestr(l.when))
      end
  end;
  close (qf)
end;

procedure infoform;
var ff:text;
    fn:lstr;
    k:char;
    me:message;
begin
  writeln;
  fn:=textfiledir+'InfoForm';
  if not exist (fn) then begin
    writestr ('There isn''t an information form 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 urec.infoform<>-1 then begin
    writestr ('You have an existing information form!  Replace it? *');
    if not yes then exit;
    deletetext (urec.infoform);
    urec.infoform:=-1;
    writeurec
  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;
      getstr;
      me.numlines:=me.numlines+1;
      me.text[me.numlines]:=input
    end else writechar (k)
  end;
  textclose (ff);
  urec.infoform:=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
end.