Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/FAQ-S.ZIP/OVERRET1.PAS

Pascal/Delphi Source File | 1991-04-16 | 30.1 KB | 1,004 lines

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

unit overret1;

interface

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

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 vot:integer;
var lev:real;
begin

 clearscr;
 movexy (1,8);
   writeln (^R'                    ╔═════════════════════════════════════╗');
   writeln (^R'                    ║        '^P'   User Main Level'^R'           ║');
   writeln (^R'                    ║ '^P'Name'^R'          :                     ║');
   writeln (^R'                    ║ '^P'Note'^R'          :                     ║');
   writeln (^R'                    ║ '^P'Level'^R'         :                     ║');
   writeln (^R'                    ║ '^P'Password'^R'      :                     ║');
   writeln (^R'                    ║ '^P'Phone'^R'         :                     ║');
   writeln (^R'                    ║ '^P'Time on'^R'       :                     ║');
   writeln (^R'                    ║ '^P'Time Left'^R'     :                     ║');
   writeln (^R'                    ║ '^P'Voting Record'^R' :                     ║');
   writeln (^R'                    ║ '^P'Wanted Status'^R' :                     ║');
     if useqr then begin
 with eurec do begin
  qr := qrmultifactor*(eurec.uploads+eurec.nbu)-eurec.downloads;
 end;
   writeln (^R'                    ║ '^P'Quality Rating'^R':                     ║');
  end;
   writeln (^R'                    ╚═════════════════════════════════════╝');
  printxy (39,10,eurec.handle);
  printxy (39,11,eurec.note);
  printxy (39,12,strr(eurec.level));
  printxy (39,13,eurec.password);
  printxy (39,14,eurec.phonenum);
  printxy (39,15,streal(eurec.totaltime));
  printxy (39,16,strr(eurec.timetoday));
  movexy (1,17);
   write (^R'                    ║ '^P'Voting Record'^R' : ');
   for vot:=1 to maxtopics do begin          { x,y = 38,18 }
      if vot<>1 then write (',');
     write (^S,eurec.voted[vot]);
   end;
  printxy (39,18,yesno(wanted in eurec.config)+^R);
  if useqr then begin
 with eurec do begin
  qr := qrmultifactor*(eurec.uploads+eurec.nbu)-eurec.downloads;
 end;
   printxy (39,19,strr(qr));
  end;
  printxy (1,1,^R+'╔══════════════════════════════════════════════════════════════════════════════╗');
  printxy (1,2,^R+'║                            '^P'File Transfer Section'^R'                             ║');
  printxy (1,3,^R+'║ '^P'Transfer Level '^R':                         '^P'Uploaded K  '^R':                       ║');
  printxy (1,4,^R+'║ '^P'Transfer Points'^R':                         '^P'Downloaded K'^R':                       ║');
  printxy (1,5,^R+'║ '^P'Uploads        '^R':                         '^P'File K Ratio'^R':                       ║');
  printxy (1,6,^R+'║ '^P'Downloads      '^R':                         '^P'U/D Ratio   '^R':                       ║');
  printxy (1,7,^R+'╚══════════════════════════════════════════════════════════════════════════════╝');
  printxy (20,3,strr(eurec.udlevel));
  printxy (20,4,strr(eurec.udpoints));
  printxy (20,5,strr(eurec.uploads));
  printxy (20,6,strr(eurec.downloads));
  printxy (58,3,streal(eurec.upk/1000));
  printxy (58,4,streal(eurec.downk/1000));
  printxy (58,5,streal(ratio(eurec.upk,eurec.downk))+'%');
  printxy (58,6,strr(percent(eurec.uploads,eurec.downloads))+'%');
  printxy (1,09,^R'┌──────────────────┐');
  printxy (1,10,^R'│ '^P'Level '^R'   :       │');
  printxy (1,11,^R'│ '^P'Uploads  '^R':       │');
  printxy (1,12,^R'│ '^P'Downloads'^R':       │');
  printxy (1,13,^R'│ '^P'Ratio '^R'   :       │');
  printxy (1,14,^R'└──────────────────┘');
  printxy (14,10,strr(eurec.gflevel));
  printxy (14,11,strr(eurec.gfuploads));
  printxy (14,12,strr(eurec.gfdownloads));
  printxy (14,13,strr(percent(eurec.gfuploads,eurec.gfdownloads))+'%');
  printxy (60,09,^R'┌───────────────────┐');
  printxy (60,10,^R'│ '^P'Posts'^R'    :        │');
  printxy (60,11,^R'│ '^P'Calls'^R'    :        │');
  printxy (60,12,^R'│ '^P'PCR  '^R'    :        │');
  printxy (60,13,^R'│ '^P'Last Date'^R':        │');
  printxy (60,14,^R'│ '^P'Last Time'^R':        │');
  printxy (60,15,^R'└───────────────────┘');
  printxy (73,10,strr(eurec.nbu));
  printxy (73,11,strr(eurec.numon));
  printxy (73,12,strr(percent(eurec.nbu,eurec.numon))+'%');
  if laston<>0 then printxy (73,13,datestr(eurec.laston)) else
         printxy (73,13,'None.');
  if laston<>0 then printxy (73,14,timestr(eurec.laston)) else
         printxy (73,14,'None.');
  movexy (1,20);
   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 ('Delete User? [y/n]: *');
    if yes then begin
      deleteuser (eunum);
      nuvit;
      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 ('Number of Uploads    : *');
   if (length(input)>0) and (valu(input)>-1) then
    eurec.uploads:=valu(input);
   writestr ('Number of Downloads  : *');
   if (length(input)>0) and (valu(input)>-1) then
    eurec.downloads:=valu(input);
   writestr ('Uploaded Kilobytes   : *');
   if yes then urec.upk:=0;
   writestr ('Downloaded Kilobytes : *');
   if yes then urec.downk:=0;
   writeufile (eurec,eunum);
  end;

  procedure conaccess;
  var q:char;
  begin
  repeat
  write ('[1] Conference #1 Message: ');
  if eurec.defcon[1] then writeln ('TRUE') else writeln ('FALSE');
  write ('[2] Conference #2 Message: ');
  if eurec.defcon[2] then writeln ('TRUE') else writeln ('FALSE');
  write ('[3] Conference #3 Message: ');
  if eurec.defcon[3] then writeln ('TRUE') else writeln ('FALSE');
  write ('[4] Conference #4 Message: ');
  if eurec.defcon[4] then writeln ('TRUE') else writeln ('FALSE');
  write ('[5] Conference #5 Message: ');
  if eurec.defcon[5] then writeln ('TRUE') else writeln ('FALSE');
  write ('[6] Conference #1 Xfer   : ');
  if eurec.defcon[6] then writeln ('TRUE') else writeln ('FALSE');
  write ('[7] Conference #2 Xfer   : ');
  if eurec.defcon[7] then writeln ('TRUE') else writeln ('FALSE');
  write ('[8] Conference #3 Xfer   : ');
  if eurec.defcon[8] then writeln ('TRUE') else writeln ('FALSE');
  write ('[9] Conference #4 Xfer   : ');
  if eurec.defcon[9] then writeln ('TRUE') else writeln ('FALSE');
  write ('[0] Conference #5 Xfer   : ');
  if eurec.defcon[10] then writeln ('TRUE') else writeln ('FALSE');
  writestr (^M'Conference Access, [Q]uit: *');
  q:=upcase(input[1]);
  case q of
  '1':if not eurec.defcon[1] then eurec.defcon[1]:=true else eurec.defcon[1]:=false;
  '2':if not eurec.defcon[2] then eurec.defcon[2]:=true else eurec.defcon[2]:=false;
  '3':if not eurec.defcon[3] then eurec.defcon[3]:=true else eurec.defcon[3]:=false;
  '4':if not eurec.defcon[4] then eurec.defcon[4]:=true else eurec.defcon[4]:=false;
  '5':if not eurec.defcon[5] then eurec.defcon[5]:=true else eurec.defcon[5]:=false;
  '6':if not eurec.defcon[6] then eurec.defcon[6]:=true else eurec.defcon[6]:=false;
  '7':if not eurec.defcon[7] then eurec.defcon[7]:=true else eurec.defcon[7]:=false;
  '8':if not eurec.defcon[8] then eurec.defcon[8]:=true else eurec.defcon[8]:=false;
  '9':if not eurec.defcon[9] then eurec.defcon[9]:=true else eurec.defcon[9]:=false;
  '0':if not eurec.defcon[10] then eurec.defcon[10]:=true else eurec.defcon[10]:=false;
  end
  until (q=upcase('Q'));
end;

var q,cnt: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!VC?');
    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;
      18:begin eurec.level:=qvmainl;
            eurec.udlevel:=qvxferl;
            eurec.udpoints:=qvxferp;
            eurec.gflevel:=qvgfile;
            eurec.note:=qvnote;
            cnt:=eurec.level;
            if cnt<1 then cnt:=1;
            if cnt>100 then cnt:=100;
            eurec.timetoday:=usertime[cnt];
            writeufile (eurec,eunum);
            writeln ('User Quick-Validated.');
         end;
      19:conaccess;
      20:begin
writeln ('C╔═════════════════════════════════════╗Hs');
writeln ('uC║ User Edit Section                   ║Hs');
writeln ('uC╚═════════════════════════════════════╝HHC╔═════s');
writeln ('u════════════════════════════════╗HC║ [B]  s');
writeln ('uEdit User Sub-Board Flags      ║HC║ [Cs');
writeln ('u]  Conference Access              ║HC║ [s');
writeln ('uD]  Delete User                    ║Hs');
writeln ('uC║ [E]  Edit Xfer Level                s');
writeln ('u║HC║ [G]  Edit G-File Level             s');
writeln ('u ║HC║ [H]  Change User ID          s');
writeln ('u       ║HC║ [I]  Show Infoforms    s');
writeln ('u             ║HC║ [L]  Edit Main Les');
writeln ('uvel                ║HC║ [N]  Edit Ps');
writeln ('uhone Number    ╔═════════════════════════════════════╗');
writeln ('HC║ [O]  Edit Xfer Points     s');
writeln ('u║ [R]  Edit User Note                 ║');
writeln ('HC║ [P]  Change Password      s');
writeln ('u║ [S]  Show Statistics                ║');
writeln ('HC║ [Q]  Quit                 s');
writeln ('u║ [T]  Edit Time                      ║');
writeln ('HC╚═══════════════════════════║ [Vs');
writeln ('u]  Quick Validate User            ║HC║ s');
writeln ('u[W]  Edit Wanted Flag               ║Hs');
writeln ('uC║ [Y]  Edit Sysop Status              s');
writeln ('u║HC║ [?]  View This Menu          s');
writeln ('u       ║HC╚═════════════════════════════════════╝');
write (^B^R' '^M);
pause;
           end;
    end
  until hungupon or (q=11);
  writeufile (eurec,eunum);
  readurec
end;

  Procedure printnews;
    Var nfile:File Of newsrec;
      line:Integer;
      Ntmp:newsrec;cnt:Integer;
    Begin
      Assign(nfile,bbsdatadir+'News.dat');
      Reset(nfile);
      If IOResult<>0 Then exit;
      If FileSize(nfile)=0 Then Begin
        Close(nfile);
        exit
      End;
      writeln('News: [Ctrl-X] to abort');
      cnt:=0;
      While Not(EoF(nfile) Or break Or hungupon) Do Begin
        Read(nfile,Ntmp);
        If (ntmp.location>=0) And (ntmp.maxlevel>=urec.level) And (urec.level>=ntmp.level) Then Begin
          inc(cnt);
        WriteLn(^B'News Item #'^S,cnt,^R' - "'^S,ntmp.title,^R'" from '^S,ntmp.from,^R'');
        WriteLn(^B'Date: ['^S,datestr(ntmp.when),^R']    Level ['^S,ntmp.level,' - ',ntmp.maxlevel,^R']');
          printtext(Ntmp.location);
          writestr (^M^P'['^R'Enter'^P']'^S': '^U'*')
        End;
      End;
      Close(nfile)
    End;

procedure sendmodemstr (ss:anystr; endifcarrier:boolean);
var cnt,ptr:integer;
    k:char;

procedure sendit (s:char);
begin
 sendchar (s);
end;

begin
  ptr:=0;
  for ptr:=1 to length(ss) do
      begin
      if keyhit or (carrier=endifcarrier) then exit;
      k:=ss[ptr];
      case k of
        '|':sendit (^M);
        '~':delay (500);
        '^':begin
              ptr:=ptr+1;
              if ptr>length(ss)
                then k:='^'
                else k:=upcase(ss[ptr]);
              if k in ['A'..'Z']
                then sendit (chr(ord(k)-64))
                else sendit (k)
        end;
        else sendit(k);
       end;
       delay(50);
       end;

    end;

function getlastcaller:mstr;
var qf:file of lastrec;
    l:lastrec;
begin
  getlastcaller:='';
  assign (qf,bbsdatadir+'Callers.dat');
  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,bbsdatadir+'Callers.dat');
  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 showlastcallers;
    Var qf:File Of lastrec;
      cnt:Integer;
      l:lastrec;
    Begin
      if ulvl<listuserlvl then begin
        reqlevel (listuserlvl);
        exit; end;
      Assign(qf,bbsdatadir+'Callers.dat');
      Reset(qf);
      If ioresult=0 Then Begin
        writehdr('Recent Caller List');
    writeln (^P'┌──────────────────────────────────┬────────────┬────────────┬────────────┐');
    writeln (^P'│ '^R'User Handle                      '^P'│ '^R'Date       '^P'│ '^R'Time       '+
        ^P'│ '^R'Baud Rate  '^P'│');
    writeln (^P'├──────────────────────────────────┼────────────┼────────────┼────────────┤');
        For cnt:=0 To FileSize(qf)-1 Do begin
          Read(qf,l);
          tab (^P'│ '^S+l.name,37);
          tab (^P'│ '^S+(datestr(l.when)),15);
          tab (^P'│ '^S+(timestr(l.when)),15);
          tab (^P'│ '^S+l.baud,15);
          writeln (^P'│');
          if Break then Exit;
          End;
    writeln (^P'└──────────────────────────────────┴────────────┴────────────┴────────────┘'^M);
          Close(qf)
        End;
        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,bbsdatadir+'userspec.dat');
  reset (usfile);
  if ioresult<>0 then begin
    rewrite (usfile);
    if logonlevel<>0 then newusers.maxlevel:=logonlevel;
    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.