Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/FORUM25C.ZIP/MAINMENU.PAS

Pascal/Delphi Source File | 1989-02-05 | 29.7 KB | 1,270 lines

{$R-,S-,I-,D-,V-,B-,N-,L- }
{$O+}

unit mainmenu;


{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}

interface

USES Overlay,
     crt,
     dos,
     gentypes,
     configrt,
     statret,
     textret,
     userret,
     mailret,
     gensubs,
     subs1,
     subs2,
     windows,
     Shell,
     chatstuf,
     mainr1,
     mainr2,
     overret1;

{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}


Procedure editusers;
Procedure zapspecifiedusers;
Procedure summonsysop;
Procedure offtheforum;
Procedure listusers;
Procedure transfername;
Procedure editnews;
Procedure yourstatus;
Procedure delerrlog;
Procedure feedback;
Procedure settime;
Procedure changepwd;
Procedure requestraise;
Procedure makeuser;
Procedure infoformhunt;
Procedure donations;
Procedure viewsyslog;
Procedure delsyslog;
Procedure showsystemstatus;
Procedure showallforms;
Procedure showallsysops;
Procedure mainhelp;
Procedure otherbbs;
Procedure readerrlog;
Procedure showad;
Procedure setlastcall;
Procedure removeallforms;
Procedure readfeedback;
Procedure PriorityPage;
Procedure Convert_Mail;

{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}

implementation

{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}


{=============================================================================}

Procedure PriorityPage;                                {Mon  4 Jan 88}

          {This unit allows someone with priority access to page the
           sysop even when normally not available.}

CONST MaxPage = 10000;

        var
             count     : integer;
             c1        : integer;
             s         : SStr;
             z         : text;

        procedure makesound( which : byte );

          var
               c1, c2 : integer;

          begin
            which:= ( which mod 3 ) + 1;
            case which of
              1:
                  for c2:=1 to 50 do begin
                    if odd(c2) then
                      for c1:=500 to 2000 do Sound(c1)
                    else
                      for c1:=2000 downto 500 do Sound(c1);
                  end;
              2:
                  for c2:=1 to 200 do begin
                    for c1:=100 to 250 do Sound(c1*10);
                    for c1:=50 to 150 do Sound(c1*10);
                  end;
              3:
                  for c2:=1 to 25 do begin
                    Sound(1800); Delay(75);
                    Sound(1500); Delay(75);
                  end;
            end; {case}
            NoSound;
          end; {makesound}

        Begin
          Writehdr('Priority Page');
          ChainStr := '';
          Writestr(^M^P'Page Sysop? &');
          if (hungupon) or (not yes) then exit;
          write(^M^M'Paging...');
          count:=1;
          repeat
{            if count mod 10 = 0 then write('.');
            If KeyHit THEN
              Begin
                NoSound;
                Exit;
              End;
            if odd(count) then
              for c1:=500 to 2000 do Sound(c1)
            else
              for c1:=2000 downto 500 do Sound(c1);
            count:=count+1;
            if count=MaxPage then count:=0;
            NoSound;
            if count mod 100 = 0 then begin
              ChainStr := '';
              WriteStr(^M^M^S'Continue? &');
              if (hungupon) or (not yes) then exit;
            end;
}
            makesound(Random(3)+1);
            writestr(^M^M^P'Continue? &');
            if (hungupon) or (not yes) then exit;

          until hungupon;
        end; {PriorityPage}

{=============================================================================}

Procedure editusers;
VAR eunum:integer;
    matched:boolean;

  Procedure elistusers (getspecs:boolean);
  VAR cnt,f,l:integer;
      u:userrec;
      us:userspecsrec;

    Procedure listuser;
    begin
      write (cnt:4,' ');
      tab (u.handle,31);
      write (u.level:6,' ');
      tab (datestr(u.laston),8);
      writeln (u.nbu:6,u.numon:6,postcallratio(u):7:2)
    end;

  begin
    if getspecs
      then if selectspecs(us)
        then exit
        else
          begin
            f:=1;
            l:=numusers
          end
      else parserange (numusers,f,l);
    seek (ufile,f);
    matched:=false;
    writeln (^B^M^M' Num Name                            Level ',
             'Last on  Posts Calls PCR');
    for cnt:=f to l do begin
      read (ufile,u);
      if (not getspecs) or fitsspecs(u,us) then begin
        listuser;
        matched:=true
      end;
      handleincoming;
      if break then exit
    end;
    if not matched then
      if getspecs
        then writeln (^B^M'No users match specifications!')
        else writeln (^B^M'No users found in that range!')
  end;

begin
  repeat
    writestr (^M'User to edit [?,??=list]:');
    if (length(input)=0) or (match(input,'Q')) then exit;
    if input[1]='?'
      then elistusers (input='??')
      else begin
        eunum:=lookupuser (input);
        if eunum=0
          then writestr ('User not found!')
          else edituser (eunum)
      end
  until hungupon
end;

Procedure zapspecifiedusers;
VAR us:userspecsrec;
    confirm:boolean;
    u:userrec;
    cnt:integer;
    done:boolean;
begin
  if selectspecs (us) then exit;
  writestr ('Confirm each deletion individually? *');
  if length(input)=0 then exit;
  confirm:=yes;
  if not confirm then begin
    writestr (^M'Are you SURE you want to mass delete without confirmation? *');
    if not yes then exit
  end;
  for cnt:=1 to numusers do begin
    seek (ufile,cnt);
    read (ufile,u);
    if (length(u.handle)>0) and fitsspecs (u,us) then begin
      if confirm
        then
          begin
            done:=false;
            repeat
              writestr ('Delete '+u.handle+' (Y/N/X/E):');
              if length(input)>0 then case upcase(input[1]) of
                'Y':begin
                      done:=true;
                      writeln ('Deleting '+u.handle+'...');
                      deleteuser (cnt)
                    end;
                'N':done:=true;
                'X':exit;
                'E':begin
                      edituser(cnt);
                      writeln;
                      writeln
                    end
              end
            until done
          end
        else
          begin
            writeln ('Deleting '+u.handle+'...');
            if break then begin
              writestr ('Aborted!!');
              exit
            end;
            deleteuser (cnt)
          end
    end
  end
end;

Procedure summonsysop;
VAR tf:text;
    k:char;
begin
  Writeln;
  chatmode:=not chatmode;
  bottomline;
  if chatmode
    then
      if (sysopisavail) OR (Ulvl >= 90)
        then
          begin
            writestr ('Enter a short reason: &');
            chatreason:=input;
            if length(input)=0 then begin
              chatmode:=false;
              exit
            end;
            writelog (1,3,chatreason);
            splitscreen (4);
            top;
            clrscr;
            writeln (usr,unam,' wants to chat!  His reason:');
            write (usr,chatreason);
            bottom;
            assign (tf,textfiledir+'Summon');
            reset (tf);
            if ioresult=0 then begin
              while (not (eof(tf) or hungupon)) and chatmode do
                begin
                  read (tf,k);
                  nobreak:=true;
                  if ord(k)=7 then summonbeep else writechar (k);
                  if keyhit then begin
                    k:=bioskey;
                    clearbreak;
                    chat_proc;
                  end
                end;
              textclose (tf)
            end;
            if chatmode
              then writestr (^M'Use [C] again to turn off page.')
              else unsplit
          end
        else
          begin
            writestr ('Sorry, '+sysopname+
                      ' isn''t available right now!');
            chatmode:=false;
            writelog (1,2,'')
          end
    else writestr ('Page off.  Use [C] to turn it back on.');
  clearbreak
end;

Procedure offtheforum;
VAR q,n:integer;
    tn:file of integer;
    m:message;
begin
  writestr ('Hang up now? *');
  if yes then begin
    writestr ('Leave message to next user? *');
    if yes then begin
      q:=editor(m,false);
      if q>=0 then begin
        if tonext>=0 then deletetext (tonext);
        tonext:=q;
        writestatus
      end
    end;
    printfile (textfiledir+'GoodBye');
    disconnect
  end
end;

Procedure listusers;
VAR cnt:integer;
    u:userrec;
begin
  writeln (^B'Name                             Level'^M);
  if break then exit;
  for cnt:=1 to numusers do
    begin
      seek (ufile,cnt);
      read (ufile,u); che;
      if length(u.handle)>0 then begin
        tab (u.handle,33);
        if break then exit;
        writestr (strr(u.level));
        if break then exit
      end
    end
end;

Procedure transfername;
VAR un,nlvl,ntime,tmp:integer;
    u:userrec;
begin
  if tempsysop then begin
    writestr ('Disabling temporary sysop powers...');
    ulvl:=regularlevel;
    tempsysop:=false
  end;
  writestr ('Transfer to user name:');
  if length(input)=0 then exit;
  un:=lookupuser(input);
  if unum=un then begin
    writestr ('You can''t transfer to yourself!');
    exit
  end;
  if un=0 then begin
    writestr ('No such user.');
    exit
  end;
  seek (ufile,un);
  read (ufile,u);
  if ulvl<sysoplevel then if not checkpassword(u) then begin
    writelog (1,5,u.handle);
    exit
  end;
  writelog (1,4,u.handle);
  updateuserstats (false);
  ntime:=0;
  if datepart(u.laston)<>datepart(now) then begin
    tmp:=ulvl;
    if tmp<1 then tmp:=1;
    if tmp>100 then tmp:=100;
    ntime:=usertime[tmp]
  end;
  if u.timetoday<10
    then if issysop or (u.level>=sysoplevel)
      then
        begin
          writestr ('The user has '+strr(u.timetoday)+' min(s) left!');
          writestr ('New time left:');
          ntime:=valu(input)
        end
      else
        if u.timetoday>0
          then writeln ('Warning: You have ',u.timetoday,' minutes left!')
          else
            begin
              writestr ('Sorry, that user doesn''t have any time left!');
              exit
            end;
  unum:=un;
  readurec;
  if ntime<>0 then begin
    urec.timetoday:=ntime;
    writeurec
  end;
end;

Procedure editnews;
VAR nn,numnews:integer;
    nf:file of integer;

  Procedure getnn (txt:mstr);
  begin
    writestr ('News number to '+txt+':');
    nn:=valu(input);
    if (nn<1) or (nn>numnews) then nn:=0
  end;

  Procedure delnews;
  VAR cnt:integer;
      r:integer;
  begin
    if nn=0 then getnn ('delete');
    if nn<>0 then begin
      seek (nf,nn-1);
      read (nf,r); che;
      deletetext (r);
      numnews:=filesize(nf)-1;
      for cnt:=nn to numnews do
        begin
          seek (nf,cnt);
          read (nf,r);
          seek (nf,cnt-1);
          write (nf,r)
        end;
      seek (nf,numnews);
      truncate (nf)
    end
  end;

  Procedure listnews;
  VAR cnt:integer;
      r,sector:integer;
      q:buffer;
      l:anystr;
      k:char;
  begin
    clearbreak;
    for cnt:=1 to numnews do begin
      seek (nf,cnt-1);
      read (nf,r);
      seek (tfile,r);
      read (tfile,q);
      write (strr(cnt)+'. ');
      r:=1;
      k:=' ';
      l:='';
      while (ord(k)<>13) and not hungupon do begin
        k:=q[r];
        r:=r+1;
        if (k=#0) or (r>sectorsize) then k:=chr(13);
        l:=l+k
      end;
      writeln (l);
      if break then exit
    end;
    writeln
  end;

  Procedure viewnews;
  VAR r:integer;
  begin
    if nn=0 then getnn ('view');
    if nn<>0 then begin
      seek (nf,nn-1);
      read (nf,r); che;
      printtext (r)
    end
  end;

  Procedure adddnews;
  begin
    close (nf);
    addnews;
    assign (nf,'News');
    reset (nf)
  end;

VAR q:integer;
begin
  assign (nf,'News');
  reset (nf);
  if ioresult<>0 then writestr ('No news!  Use [A] to add some!') else begin
    repeat
      numnews:=filesize(nf);
      write (^B^M'News entries: ',numnews);
      q:=menu ('News edit','NEWS','ADLVQ');
      nn:=valu(copy(input,2,255));
      if (nn<1) or (nn>numnews) then nn:=0;
      case q of
        1:adddnews;
        2:delnews;
        3:listnews;
        4:viewnews
      end;
      if numnews=0 then begin
        close (nf);
        erase (nf);
        writestr ('No more news!  Use [A] to add some.');
        q:=5
      end
    until (q=5) or hungupon
  end;
  close (nf)
end;

Procedure yourstatus;
begin
  writehdr ('Your Status');
  writeln ('Name:   '^S,unam,
         ^M'Level:  '^S,ulvl,
         ^M'Calls:  '^S,urec.numon,
         ^M'Posted: '^S,urec.nbu,
       ^M^M'Ascii',
         ^M'  Uploads:     '^S,urec.nup,
         ^M'  Downloads:   '^S,urec.ndn,
         ^M'XMODEM',
         ^M'  Uploads:     '^S,urec.uploads,
         ^M'  Downloads:   '^S,urec.downloads,
       ^M^M'Total time on: '^S,urec.totaltime:0:0,
         ^M'Time left:     '^S,timeleft)
end;

Procedure delerrlog;
VAR e:text;
    i:integer;
begin
  writestr ('Delete error log:  Confirm:');
  if not yes then exit;
  assign (e,'errlog');
  reset (e);
  i:=ioresult;
  if ioresult=1
    then writeln (^M'No error log!')
    else begin
      textclose (e);
      erase (e);
      writestr ('Error log deleted.');
      if ioresult>1
        then writeln ('I/O error ',i,' deleting error log!');
      writelog (2,2,'')
    end
end;

Procedure feedback;
VAR m:mailrec;
    me:message;
begin
  writestr ('Leave feedback? *');
  if not yes then exit;
  m.line:=editor(me,true);
  if m.line<0 then exit;
  m.title:=me.title;
  m.sentby:=unum;
  m.anon:=false;
  m.when:=now;
  addfeedback (m);
  writestr ('Feedback sent.')
end;

Procedure settime;
VAR t:integer;
    n:longint;
    r:registers;
    d:datetime;
begin
  writestr ('Current time: '+timestr(now));
  writestr ('Current date: '+datestr(now));
  writestr ('Enter new time:');
  if length(input)<>0
    then begin
      t:=timeleft;
      unpacktime (timeval(input),d);
      r.ch:=d.hour;
      r.cl:=d.min;
      r.dh:=0;
      r.dl:=0;
      r.ah:=$2d;
      intr ($21,r);
      if r.al=$ff then writestr ('Invalid time!');
      settimeleft (t)
    end;
  writestr ('Enter new date:');
  if length(input)<>0
    then begin
      unpacktime (dateval(input),d);
      r.dl:=d.day;
      r.dh:=d.month;
      r.cx:=d.year;
      r.ah:=$2b;
      intr ($21,r);
      if r.al=$ff then writestr ('Invalid date!')
    end;
  writelog (2,4,'')
end;

Procedure changepwd;
VAR t:sstr;
begin
  writehdr ('Password Change');
  dots:=true;
  buflen:=15;
  write ('Enter new password: ');
  if getpassword
    then begin
      writeurec;
      writestr ('Password changed.');
      writelog (1,1,'')
    end else
      writestr ('No change.')
end;

Procedure requestraise;
VAR t:text;
    q:lstr;
    p,l1,l2:integer;
    s1,s2:sstr;
    me:message;
    m:mailrec;
label nope,found;
begin
  assign (t,textfiledir+'RAISEREQ');
  reset (t);
  if ioresult<>0 then goto nope;
  printtexttopoint (t);
  while not eof(t) do begin
    readln (t,q);
    p:=pos('-',q);
    if p>0
      then
        begin
          s1:=copy(q,1,p-1);
          s2:=copy(q,p+1,255)
        end
      else
        begin
          s1:=copy(q,1,15);
          s2:=s1
        end;
    val (s1,l1,p);
    if p=0 then val (s2,l2,p);
    if p<>0 then begin
      textclose (t);
      error ('Invalid range in RAISEREQ: %1','',q);
      exit
    end;
    if (ulvl>=l1) and (ulvl<=l2) then goto found;
    skiptopoint (t)
  end;
  nope:
  error ('No text for level %1','',strr(ulvl));
  textclose (t);
  p:=ioresult;
  exit;
  found:
  printtexttopoint (t);
  textclose (t);
  if hungupon then exit;
  m.line:=editor (me,false);
  if m.line<0 then exit;
  m.anon:=false;
  m.title:='Raise request; now lvl='+strr(ulvl);
  m.sentby:=unum;
  m.when:=now;
  addfeedback (m);
end;

Procedure makeuser;
VAR u:userrec;
    un,ln:integer;
begin
  writehdr ('Add a user');
  writestr ('Name:');
  if length(input)=0 then exit;
  if lookupuser(input)<>0 then begin
    writestr ('Sorry!  Already exists!');
    exit
  end;
  u.handle:=input;
  writestr ('Password:');
  u.password:=input;
  writestr ('Level:');
  if length(input)=0 then exit;
  u.level:=valu(input);
  un:=adduser(u);
  if un=-1 then begin
    writestr ('Sorry, no room for new users!');
    exit
  end;
  ln:=u.level;
  if ln<1 then ln:=1;
  if ln>100 then ln:=100;
  u.timetoday:=usertime[ln];
  seek (ufile,un);
  write (ufile,u);
  writestr ('User added as #'+strr(un)+'.');
  writelog (2,8,u.handle)
end;

Procedure infoformhunt;
begin
  writestr ('User to search for [CR=all users]:');
  writeln (^M);
  showinfoforms (input)
end;

Procedure donations;
VAR fn:lstr;
begin
  fn:=textfiledir+'Donation';
  if exist (fn)
    then printfile (fn)
    else begin
      writestr ('I''m sorry, no information is currently available.');
      if issysop
        then writestr (
'Sysop:  To create donation information text, make a file called '+fn)
    end
end;

Procedure viewsyslog;
VAR n:integer;
    l:logrec;

  Function lookupsyslogdat (m,s:integer):integer;
  VAR cnt:integer;
  begin
    for cnt:=1 to numsyslogdat do with syslogdat[cnt] do
      if (menu=m) and (subcommand=s) then begin
        lookupsyslogdat:=cnt;
        exit
      end;
    lookupsyslogdat:=0
  end;

  Function firstentry:boolean;
  begin
    firstentry:=(l.menu=0) and (l.subcommand in [1..2])
  end;

  Procedure backup;
  begin
    while n<>0 do begin
      n:=n-1;
      seek (logfile,n);
      read (logfile,l);
      if firstentry then exit
    end;
    n:=-1
  end;

  Procedure showentry (includedate:boolean);
  VAR q:lstr;
      p:integer;
  begin
    q:=syslogdat[lookupsyslogdat(l.menu,l.subcommand)].text;
    p:=pos('%',q);
    if p<>0 then q:=copy(q,1,p-1)+l.param+copy(q,p+1,255);
    if includedate then q:=q+' on '+datestr(l.when);
    q:=q+' at '+timestr(l.when);
    writeln (q)
  end;

VAR b:boolean;
begin
  writehdr ('View system log');
  writeln ('Press space to advance to the previous caller, X to abort.');
  writeln;
  writelog (2,6,'');
  n:=filesize(logfile);
  repeat
    clearbreak;
    writeln (^M);
    backup;
    if n=-1 then exit;
    seek (logfile,n);
    read (logfile,l);
    showentry (true);
    b:=false;
    while not (eof(logfile) or break or xpressed or b) do begin
      read (logfile,l);
      b:=firstentry;
      if not b then showentry (false);
    end
  until xpressed
end;

Procedure delsyslog;
begin
  writestr ('Delete system log: Confirm:');
  if not yes then exit;
  close (logfile);
  rewrite (logfile);
  writeln (^M'System log deleted.');
  writelog (2,7,unam)
end;

Procedure showsystemstatus;
VAR totalused,totalidle,totalup,totaldown,totalmins,callsday:real;

  Procedure percent (prompt:mstr; top,bot:real);
  VAR p:real;
  begin
    write (prompt);
    if bot<1 then begin
      writeln ('N/A');
      exit
    end;
    p:=round(1000*top/bot)/10;
    writeln (p:0:1,'%')
  end;

begin
  totalused:=numminsused.total+elapsedtime(numminsused);
  totalidle:=numminsidle.total;
  totalup:=totalidle+numminsused.total;
  totalmins:=1440.0*(numdaysup-1.0)+timer;
  totaldown:=totalmins-totalup;
  callsday:=round(10*numcallers/numdaysup)/10;
  writehdr ('System Status');
  writeln ('Time & date:       '^S,timestr(now),', ',datestr(now),
       ^M^J'Calls today:       '^S,callstoday,
       ^M^J'Total callers:     '^S,numcallers:0:0,
       ^M^J'Total days up:     '^S,numdaysup,
       ^M^J'Calls per day:     '^S,callsday:0:1,
       ^M^J'Total mins in use: '^S,numminsused.total:0:0,
       ^M^J'Total mins idle:   '^S,totalidle:0:0,
       ^M^J'Mins file xfer:    '^S,numminsxfer.total:0:0,
       ^M^J'Total mins up:     '^S,totalup:0:0,
       ^M^J'Total mins down:   '^S,totaldown:0:0);
  percent ('Percent in use:    '^S,totalused,totalmins);
  percent ('Percent idle:      '^S,totalidle,totalmins);
  percent ('Percent up:        '^S,totalup,totalmins);
  percent ('Percent down:      '^S,totaldown,totalmins);
end;

Procedure showallforms;
begin
  showinfoforms ('')
end;

Procedure showallsysops;
VAR n:integer;
    u:userrec;
    q:set of configtype;
    s:configtype;

  Procedure showuser;
  const sectionnames:array [udsysop..databasesysop] of string[20]=
         ('File transfer','Bulletin section','Voting booths',
          'E-mail section','Doors','Main menu','Databases');
  VAR s:configtype;
  begin
    writeln (^B^M'Name:  '^S,u.handle,
               ^M'Level: '^S,u.level,^M);
    for s:=udsysop to databasesysop do
      if s in u.config then
        writeln ('Sysop of the ',sectionnames[s]);
    writestr (^M'Edit user? *');
    if yes then edituser (n)
  end;

begin
  q:=[];
  for s:=udsysop to databasesysop do q:=q+[s];
  for n:=1 to numusers do begin
    seek (ufile,n);
    read (ufile,u);
    if (u.level>=sysoplevel) or (q*u.config<>[]) then showuser
  end
end;

Procedure mainhelp;
begin
  help ('Mainmenu.hlp')
end;

Procedure otherbbs;
begin
  printfile (textfiledir+'Otherbbs')
end;

Procedure readerrlog;
begin
  if exist ('Errlog')
    then printfile ('Errlog')
    else writestr ('No error file!')
end;

Procedure showad;
VAR fn:lstr;
begin
  fn:=textfiledir+'Forum.AD';
  if exist (fn) then printfile (fn)
end;

Procedure setlastcall;

  Function digit (k:char):boolean;
  begin
    digit:=ord(k) in [48..57]
  end;

  Function validtime (inp:sstr):boolean;
  VAR c,s,l:integer;
      d1,d2,d3,d4:char;
      ap,m:char;
  begin
    validtime:=false;
    l:=length(inp);
    if (l<7) or (l>8) then exit;
    c:=pos(':',inp);
    if c<>l-5 then exit;
    s:=pos(' ',inp);
    if s<>l-2 then exit;
    d2:=inp[c-1];
    if l=7
      then d1:='0'
      else d1:=inp[1];
    d3:=inp[c+1];
    d4:=inp[c+2];
    ap:=upcase(inp[s+1]);
    m:=upcase(inp[s+2]);
    if d1='1' then if d2>'2' then d2:='!';
    if (d1>='0') and (d1<='1') and digit(d2) and (d3>='0') and (d3<='5')
       and digit(d4) and ((ap='A') or (ap='P')) and (m='M')
         then validtime:=true
  end;

  Function validdate (inp:sstr):boolean;
  VAR k,l:char;

    Function gchar:char;
    begin
      if length(inp)=0 then begin
        gchar:='?';
        exit
      end;
      gchar:=inp[1];
      delete (inp,1,1)
    end;

  begin
    validdate:=false;
    k:=gchar;
    l:=gchar;
    if not digit(k) then exit;
    if l='/'
      then if k='0'
        then exit
        else
      else begin
        if k>'1' then exit;
        if not digit(l) then exit;
        if (l>'2') and (k='1') then exit;
        l:=gchar;
        if l<>'/' then exit
      end;
    k:=gchar;
    l:=gchar;
    if l='/'
      then if k='0'
        then exit
        else
      else begin
        if k>'3' then exit;
        if not digit(l) then exit;
        if (k='3') and (l>'1') then exit;
        l:=gchar;
        if l<>'/' then exit
      end;
    if digit(gchar) and digit(gchar) then validdate:=true
  end;

begin
  writeln (^M'Your last call was: '^S,datestr(laston),' at ',timestr(laston));
  writestr (^M'Enter new date (mm/dd/yy):');
  if length(input)>0
    then if validdate (input)
      then laston:=dateval(input)+timepart(laston)
      else writestr ('Invalid date!');
  writestr (^M'Enter new time (hh:mm am/pm):');
  if length(input)>0
    then if validtime(input)
      then laston:=timeval(input)+datepart(laston)
      else writestr ('Invalid time!')
end;

Procedure removeallforms;
VAR cnt,ndel:integer;
    u:userrec;
begin
  writestr ('Erase ALL info-forms:  Are you sure? *');
  if not yes then exit;
  writeurec;
  writestr (^M'Erasing... please stand by...');
  ndel:=0;
  for cnt:=1 to numusers do begin
    if (cnt mod 10)=0 then write (cnt,', ');
    seek (ufile,cnt);
    read (ufile,u);
    if u.infoform>=0 then begin
      deletetext (u.infoform);
      u.infoform:=-1;
      seek (ufile,cnt);
      write (ufile,u);
      ndel:=ndel+1
    end
  end;
  writeln ('done.');
  writestr (^M'All '+strr(ndel)+' forms erased.');
  readurec
end;

Procedure readfeedback;
VAR ffile:file of mailrec;
    m:mailrec;
    me:message;
    cur:integer;

  Function nummessages:integer;
  begin
    nummessages:=filesize(ffile)
  end;

  Function checkcur:boolean;
  begin
    if length(input)>1 then cur:=valu(copy(input,2,255));
    if (cur<1) or (cur>nummessages) then begin
      writestr (^M'Message out of range!');
      cur:=0;
      checkcur:=true
    end else begin
      checkcur:=false;
      seek (ffile,cur-1);
      read (ffile,m)
    end
  end;

  Procedure readnum(n:integer);
  begin
    cur:=n;
    input:='';
    if checkcur then exit;
    writeln (^B^M'Message: '^S,cur,
               ^M'Title:   '^S,m.title,
               ^M'Sent by: '^S,LookUpUName(m.sentby),
               ^M'Sent on: '^S,datestr(m.when),' at ',timestr(m.when),^M);
    if break then exit;
    printtext (m.line)
  end;

  Procedure writecurmsg;
  begin
    if (cur<1) or (cur>nummessages) then cur:=0;
    write (^B^M'Current msg: '^S);
    if cur=0 then write ('None') else begin
      seek (ffile,cur-1);
      read (ffile,m);
      write (m.title,' by ',LookUpuname(m.sentby));
    end
  end;

  Procedure delfeedback;
  VAR cnt:integer;
  begin
    if checkcur then exit;
    deletetext (m.line);
    for cnt:=cur to nummessages-1 do begin
      seek (ffile,cnt);
      read (ffile,m);
      seek (ffile,cnt-1);
      write (ffile,m)
    end;
    seek (ffile,nummessages-1);
    truncate (ffile);
    cur:=cur-1
  end;

  Procedure editusr;
  VAR n:integer;
  begin
    if checkcur then exit;
    n:=m.sentby;
    if n=0
      then writestr ('User disappeared!')
      else edituser (n)
  end;

  Procedure infoform;
  begin
    if checkcur then exit;
    showinfoforms (LookUpUname(m.sentby));
  end;

  Procedure nextfeedback;
  begin
    cur:=cur+1;
    if cur>nummessages then begin
      writestr (^M'Sorry, no more feedback!');
      cur:=0;
      exit
    end;
    readnum (cur)
  end;

  Procedure readagain;
  begin
    if checkcur then exit;
    readnum (cur)
  end;

  Procedure replyfeedback;
  begin
    if checkcur then exit;
    sendmailto (m.sentby,false)
  end;

  Procedure listfeedback;
  VAR cnt:integer;
  begin
    if nummessages=0 then exit;
    thereare (nummessages,'piece of feedback','pieces of feedback');
    if break then exit;
    writeln (^M'Num Title                          Left by'^M);
    seek (ffile,0);
    for cnt:=1 to nummessages do begin
      read (ffile,m);
      tab (strr(cnt),4);
      if break then exit;
      tab (m.title,31);
      writeln (LookUpUname(m.sentby));
      if break then exit
    end
  end;

VAR q:integer;
label exit;
begin
  assign (ffile,'Feedback');
  reset (ffile);
  if ioresult<>0 then rewrite (ffile);
  cur:=0;
  repeat
    if nummessages=0 then begin
      writestr ('Sorry, no feedback!');
      goto exit
    end;
    writecurmsg;
    q:=menu ('Feedback','FEED','Q#DEIR_AL');
    if q<0
      then readnum (-q)
      else case q of
        3:delfeedback;
        4:editusr;
        5:infoform;
        6:replyfeedback;
        7:nextfeedback;
        8:readagain;
        9:listfeedback;
      end
  until (q=1) or hungupon;
  exit:
  close (ffile)
end;

TYPE mail_rec = RECORD
       title,
       sentby    : mstr;
       when      : longint;
       anon,
       read      : boolean;
       sentto,
       line,
       fileindex : integer;
{       AnonPost  : BOOLEAN;   }
     End;

VAR Mail1 : FILE OF Mail_Rec;
    Mail2 : FILE Of mailRec;
    c1    : LONGINT;
    Inrec : Mail_Rec;
    OutRec : mailRec;

Procedure Convert_mail;
VAR c1 : LONGINT;
Begin
  Writeln('Converting mail');
  Assign(Mail1,'MAIL');
  Assign(Mail2,'NewMail');
  Reset(Mail1);
  Rewrite(Mail2);
  For c1 := 0 TO FileSize(Mail1)-1 DO
    Begin
      Seek(Mail1,c1);
      Read(Mail1,Inrec);
      OutRec.title := InRec.Title;
      OutRec.sentby := LookUpUser(InRec.SentBy);
      OutRec.when := inRec.When;
      OutRec.anon := inRec.Anon;
      Outrec.read := InRec.Read;
      Outrec.sentto := InRec.SentTo;
      Outrec.line := InRec.Line;
      OutRec.fileindex := Inrec.FileIndex;
      OutRec.AnonPost := FALSE;
      Seek(Mail2,c1);
      Write(Mail2,OutRec);
      Write(c1,'  ');
    End;
  Close(Mail2);
  Close(Mail1);
  Erase(Mail1);
  Rename(Mail2,'Mail');

  Writeln;
  Writeln('Converting Feedback');
  Assign(Mail1,'Feedback');
  Assign(Mail2,'NewFeed');
  Reset(Mail1);
  Rewrite(Mail2);
  For c1 := 0 TO FileSize(Mail1)-1 DO
    Begin
      Seek(Mail1,c1);
      Read(Mail1,Inrec);
      OutRec.title := InRec.Title;
      OutRec.sentby := LookUpUser(InRec.SentBy);
      OutRec.when := inRec.When;
      OutRec.anon := inRec.Anon;
      Outrec.read := InRec.Read;
      Outrec.sentto := InRec.SentTo;
      Outrec.line := InRec.Line;
      OutRec.fileindex := Inrec.FileIndex;
      OutRec.AnonPost := FALSE;
      Seek(Mail2,c1);
      Write(Mail2,OutRec);
      Write(c1,'  ');
    End;
  Close(Mail2);
  Close(Mail1);
  Erase(Mail1);
  Rename(Mail2,'FeedBack');
End;

Begin
End.