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

Pascal/Delphi Source File | 1989-04-01 | 42KB | 1,704 lines

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

unit mainmenu;

interface

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

var userqr,userlistqr:integer;
    u,uu:userrec;
    totalused,totalidle,totalup,totaldown,totalmins,callsday,
    totaldisk,totalfree,filesizes,x,y,z:real;
    a,b,c:integer;
    totalfiles:integer;
    dofiles:boolean;

procedure calcuserqr;
procedure calcuserlistqr;
procedure editusers;
procedure zapspecifiedusers;
procedure summonsysop;
procedure offtcs;
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 viewsyslog2;
procedure delsyslog;
procedure showsystemstatus;
procedure showallforms;
procedure showallsysops;
procedure mainhelp;
procedure bbslist;
procedure readerrlog;
procedure showad;
procedure setlastcall;
procedure removeallforms;
procedure readfeedback;

implementation

procedure calcuserqr;
begin
 with u do begin
  userqr := qrmultifactor*(u.uploads+u.nbu)-u.downloads;
 end;
end;

procedure calcuserlistqr;
begin
 with uu do begin
  userlistqr := qrmultifactor*(uu.uploads+uu.nbu)-uu.downloads;
 end;
end;

procedure editusers;
var eunum:integer;
    matched:boolean;

  procedure elistusers (getspecs:boolean);
  var cnt,f,l:integer;
      us:userspecsrec;

    procedure listuser;
    begin
      write (cnt:4,' ');
      tab (u.handle,31);
      write (u.level:6,' ');
      if useqr then begin
       calcuserqr;
       tab (strr(userqr),8);
      end;
      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;
    write (^B^M^M' ID# Name                            Level ');
    if useqr then write ('QR         ');
    writeln ('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
  chatmode:=not chatmode;
  bottomline;
  if chatmode
    then
      if sysopisavail
        then
          begin
            writestr ('Enter a reason to chat: &');
            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 (false)
                  end
                end;
              textclose (tf)
            end;
            if chatmode
              then writestr (^M'Use [C] again to turn off page.')
              else unsplit
          end
        else
          begin
            if length(notavailstr)=0 then
            writestr ('Sorry, '+sysopname+
                      ' isn''t available right now!') else
            writeln (notavailstr);
            chatmode:=false;
            writelog (1,2,'')
          end
    else writestr ('Page off.  Use [C] to turn it back on.');
  clearbreak
end;

procedure offtcs;
var q,n:integer;
    tn:file of integer;
    m:message;
begin
  writestr ('Logoff now? *');
  if yes then begin
    if ulvl<msgnextlvl then begin
      printfile (textfiledir+'GoodBye');
     disconnect;
     end;
    writestr ('Change Auto-Message? *');
    if yes then begin
      titlestr:='Auto-Message';
      sendstr:='Next User';
      q:=editor(m,false,'Auto-Message');
      sendstr:='';
      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,u1,u2:integer;
begin
  if ulvl<listuserlvl then reqlevel (listuserlvl);
  writehdr ('List Users');
  parserange (numusers,u1,u2);
  if u1=0 then exit;
  write (^B'['^S'Name'^R']                           ['^S'Level'^R'] ['^S'Note'^R']');
  if useqr then writeln (^R'                          ['^S'QR'^R']  ')
  else writeln;
  if break then exit;
  if (asciigraphics in urec.config) then
   write (^B'───────────────────────────────────────────────') else
   write (^B'-----------------------------------------------');
  if (useqr) then begin
   if (asciigraphics in urec.config) then
    write (^B'────────────────────────────────') else
    write (^B'--------------------------------');
  end;
  writeln;
  if break then exit;
  for cnt:=u1 to u2 do
    begin
      seek (ufile,cnt);
      read (ufile,uu);
      che;
      if length(uu.handle)>0 then begin
        periods:=true;
        write (^R'['^S);
        tab (uu.handle,30);
        if break then exit;
        write (^R']-['^S);
        periods:=true;
        tab (strr(uu.level),5);
        if break then exit;
        write (^R']-['^S);
        periods:=true;
        tab (uu.note,29);
        write (^R']');
        if break then exit;
        if useqr then begin
         calcuserlistqr;
         write ('-['^S);
         tab (strr(userlistqr),4);
         write (^R']');
         if break then exit;
        end;
       writeln;
      end
    end
end;

procedure transfername;
var un,nlvl,ntime,tmp:integer;
    u:userrec;
    qaz:lstr;
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 ('Dumbass!! You can''t transfer to yourself!');
     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
  if ansi then write (#27+'[2J') else write (^L);
  if (asciigraphics in urec.config) then
  writeln (^P'────────────────────') else
  writeln (^P'--------------------');
  writeln (^P'[ Your User Status ]');
  if (asciigraphics in urec.config) then
  writeln (^P'────────────────────') else
  writeln (^P'--------------------');
  writeln (^R'Name:   '^S,unam,^R' [Level '^S,ulvl,^R']');
  writeln (^R'Calls:  '^S,urec.numon);
  writeln (^R'Note:   '^S,urec.note);
  writeln (^P'Message Section');
  writeln (^R' Posts:        '^S,urec.nbu);
  writeln (^R' Text Ups:     '^S,urec.nup);
  writeln (^R' Text Downs:   '^S,urec.ndn);
  writeln (^P'File Transfer');
  writeln (^R' File Level:   '^S,urec.udlevel);
  writeln (^R' File Points:  '^S,urec.udpoints);
  write   (^R' Uploaded:     '^S,urec.uploads,^R' time');
  if urec.uploads<>1 then write ('s');
  writeln (^R', '^S,streal(urec.upk),^R' bytes');
  write   (^R' Downloaded:   '^S,urec.downloads,^R' time');
  if urec.downloads<>1 then write ('s');
  writeln (^R', '^S,streal(urec.downk),^R' bytes');
  writeln (^P'G-Files');
  writeln (^R' G-File Level: '^S,urec.gflevel);
  writeln (^R' Uploads:      '^S,urec.gfuploads);
  writeln (^R' Downloads:    '^S,urec.gfdownloads);
  writeln (^R'Total time on: '^S,urec.totaltime:0:0);
  writeln (^R'Time left:     '^S,timeleft);
  if (useqr) then begin
   calcqr;
   writeln('Quality Rating:'^S,qr);
  end
end;

procedure delerrlog;
var e:text;
    i:integer;
begin
  writestr ('Delete Error Log [y/n]:');
  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 to '+sysopname+' [y/n]? *');
  if not yes then exit;
  m.line:=editor(me,true,'Feedback');
  if m.line<0 then exit;
  m.title:=me.title;
  m.sentby:=unam;
  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;
  writeln ('Enter new Password, or ');
  writeln ('Press [Return] to have one generated.');
  write ('-> ');
  if getpassword
    then begin
      writeurec;
      writestr ('Password changed.');
      writelog (1,1,'')
    end else
      writestr ('Not changed.')
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;
  titlestr:='Raise Request';
  sendstr:='Sysop';
  writestr ('Press [Return] to enter the a message concerning your request:');
  m.line:=editor (me,false,'Raise Request');
  sendstr:='';
  if m.line<0 then exit;
  m.anon:=false;
  m.title:='Raise Request (Now Level '+strr(ulvl)+')';
  m.sentby:=unam;
  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);
  u.note:=newusernote;
  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];
  writeufile (u,un);
  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 viewsyslog2;
var n:integer;
    l:logrec;
    kwit:boolean;

  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);
    if wherey>=23 then begin
     input:='';
     writestr ('[Enter] to Continue or [Q]uit: *');
     if (upcase(input[1])='Q') then kwit:=true;
     clrscr;
    end;
    writeln (q)
  end;

var b:boolean;
begin
  kwit:=false;
  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);
    if kwit then exit;
    b:=false;
  { if wherey>=23 then begin
     writestr ('[Enter] to continue or [Q]uit:');
     if upcase(input[1])='Q' then exit;
     clrscr;
     gotoxy (1,1);
    end; }
    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 [y/n]:');
  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;
    yiyiyi:integer;
    drv:array [1..15] of boolean;

  procedure diskcalcs;
  var cnt,cnt2,curarea:integer;
      ar,area:arearec;
      ud:udrec;
      inscan,showit,fast:boolean;

  procedure assignud;
  begin
    close (udfile);
    assign (udfile,'AREA'+strr(curarea))
  end;

  const beenaborted:boolean=false;

  function aborted:boolean;
  begin
    if beenaborted then begin
      aborted:=true;
      exit
    end;
    aborted:=xpressed or hungupon;
    if xpressed then begin
      beenaborted:=true;
      writeln (^B'Aborted!')
    end
  end;

  procedure setarea (n:integer);
  begin
    curarea:=n;
    seek (afile,n-1);
    read (afile,area);
    assignud;
    close (udfile);
    reset (udfile);
    if ioresult<>0 then rewrite (udfile);
  end;

  procedure checkdrive (dv:char);
  var n:byte;
      tempdisk,tempfree:real;

    procedure writefreespace (dr:byte);
    var r:registers;
        csize:real;

      function unsigned (i:integer):real;
      begin
        if i>=0 then unsigned:=i else unsigned:=65536.0+i
      end;

    begin
      r.ah:=$36;
      r.dl:=dr;
      intr ($21,r);
      if r.ax=-1 then exit;
      csize:=unsigned(r.ax)*unsigned(r.cx);
      tempfree:=(csize*unsigned(r.bx))/1000;
      tempdisk:=(csize*unsigned(r.dx))/1000;
    end;

  begin
    if (ord(dv)<65) or (ord(dv)>79) then exit;
    n:=ord(dv)-64;
    writefreespace(n);
    if not drv[n] then begin
      drv[n]:=true;
      totaldisk:=totaldisk+tempdisk;
      totalfree:=totalfree+tempfree;
    end;
  end;

  function getfname (path:lstr; name:mstr):lstr;
  var l:lstr;
  begin
    l:=path;
    if length(l)<>0 then if not (upcase(l[length(l)]) in [':','\'])
      then l:=l+'\';
    l:=l+name;
    getfname:=l
  end;

  begin
    totalfiles:=0;
    filesizes:=0;
    totaldisk:=0;
    totalFree:=0;
    for cnt:=1 to 15 do drv[cnt]:=false;
    assign (afile,'Areadir');
    if exist ('Areadir') then begin
     reset (afile);
     if filesize (afile)<0 then exit
    end
    else rewrite (afile);
    cnt:=1;
    while (cnt<=filesize(afile)) do begin
      seek (afile,cnt-1);
      read (afile,ar);
      checkdrive (upcase(ar.xmodemdir[1]));
      setarea (cnt);
      for cnt2:=filesize (udfile) downto 1 do begin
        seek (udfile,cnt2-1);
        read (udfile,ud);
        checkdrive (upcase(ud.path[1]));
        if aborted then begin
          totalfiles:=0;
          filesizes:=0;
          totaldisk:=0;
          totalfree:=0;
          exit;
        end;
        if exist (getfname(ud.path,ud.filename)) then begin
          totalfiles:=totalfiles+1;
          filesizes:=filesizes+ud.filesize;
        end;
      end;
      cnt:=cnt+1;
    end;
    filesizes:=filesizes/1000;
  end;

  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;

var ozzy,anarky:anystr;
    metallica:integer;
begin
  writehdr ('System Status');
  dofiles:=false;
  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;
  writestr ('Calculate Disk Storages & File Area Stats [y/n]? *');
  writeln;
  if yes then begin
   writeln ('Calculating...');
   dofiles:=true;
   diskcalcs;
  end;
  ozzy:=ver+' - '+parsedate(date);
  {
  write (^R'╒═══════════════════════════════════╤═══════════════════════════════════╕');
  writeln;
  write (^R'│ TCS Version: '^S);
  tab (ozzy,21);
  write (^R'│ ');
  write ('Time & Date: '^S);
  tab(timestr(now)+', '+datestr(now),21);
  writeln (^R'│');
  write (^R'│ Calls Today: '^S);
  tab (strr(callstoday),21);
  write (^R'│ ');
  write ('Total Callers: '^S);
  tab (streal(numcallers),19);
  writeln (^R'│');
  write ('│ Total Days up: '^S);
  tab (strr(numdaysup),19);
  write (^R'│ ');
  write ('Calls per day: '^S);
  tab (streal(callsday),19);
  writeln (^R'│');
  write ('│ Total mins in use: '^S);
  tab (streal(numminsused.total),15);
  write (^R'│ ');
  write ('Total mins idle: '^S);
  tab (streal(totalidle),17);
  writeln (^R'│');
  write ('│ Mins File Xfer: '^S);
  tab (streal(numminsxfer.total),18);
  write (^R'│ ');
  write ('Total mins Up: '^S);
  tab (streal(totalup),19);
  writeln (^R'│');
  write ('Total mins Down: '^S);
  tab (streal(totaldown),19);
  write (^R'│ '); }
  writeln ('TCS Version:       '^S,ozzy);
  writeln ('Time & Date:       '^S,timestr(now),', ',datestr(now));
  writeln ('Calls today:       '^S,callstoday);
  writeln ('Total callers:     '^S,numcallers:0:0);
  writeln ('Total days up:     '^S,numdaysup);
  writeln ('Calls per day:     '^S,callsday:0:1);
  writeln ('Total mins in use: '^S,numminsused.total:0:0);
  writeln ('Total mins idle:   '^S,totalidle:0:0);
  writeln ('Mins file xfer:    '^S,numminsxfer.total:0:0);
  writeln ('Total mins up:     '^S,totalup:0:0);
  writeln ('Total mins down:   '^S,totaldown:0:0);
  percent ('% BBS is in use:   '^S,totalused,totalmins);
  percent ('% BBS is idle:     '^S,totalidle,totalmins);
  percent ('% BBS is up:       '^S,totalup,totalmins);
  percent ('% BBS is down:     '^S,totaldown,totalmins);
  if dofiles then begin
  percent ('% Space Unused:    '^S,totalfree,totaldisk);
  percent ('% Space Used:      '^S,(totaldisk-totalfree),totaldisk);
  percent ('% Storage Online:  '^S,filesizes,totaldisk);
  writeln ('Files Online:      '^S,totalfiles);
  writeln ('Files Storage:     '^S,streal (filesizes/1000),' Megabytes');
  writeln ('Total Storage:     '^S,streal (totaldisk/1000),' Megabytes');
  writeln ('Upload Space:      '^S,streal (totalfree/1000),' Megabytes');
  write   ('Drives Online:     '^S);
  for yiyiyi:=1 to 15 do
   if drv[yiyiyi] then write (chr(yiyiyi+64),': ');
  end;
  writeln (^R);
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 bbslist;
var card,ugbot,p:lstr;
    b:bbsrec;

   function numbbses:integer;
   begin
     numbbses:=filesize(blfile)
   end;

   procedure seekblfile (n:integer);
   begin
     seek (blfile,n-1);
   end;

   function numbbs:integer;
   begin
    numbbs:=filesize (blfile);
   end;

   procedure getstring (t:lstr; var m; buf:integer);
   var q:lstr absolute m;
       mm:lstr;
   begin
     writeln (^R'Old ',t,': '^S,q,^R);
     buflen:=buf;
     writestr ('Enter new '+t+' [CR/no change]:');
     mm:=input;
     if length(mm)<>0 then q:=mm;
     writeln
   end;

    procedure listbbs;
    var cnt,b1,b2:integer;
        showedz:boolean;
    begin
     writehdr ('BBS List');
     reset (blfile);
     if ioresult<>0 then begin
      writeln ('There are no BBS''s in the list.  Add one!');
      exit;
     end
     else begin
     parserange (numbbs,b1,b2);
     writestr ('Show Extended BBS Descriptions [Y/n]? *');
     writeln;
     showedz:=true;
     if upcase(input[1])='N' then showedz:=false;
     if b1>0 then
     for cnt := b1 to b2 do
     begin
      seekblfile (cnt);
      read (blfile,b);
      write (^R'['^S);
      tab (b.number,12);
      write (^R'] ['^P);
      tab (b.name,48);
      write (^R'] ['^U);
      tab (b.maxbaud,4);
      write (^R'] ['^P);
      tab (b.ware,4);
      writeln (^R']');
      if showedz then
      begin
       write (^R' ['^U);
       tab (b.extdesc,76);
       writeln (^R']');
      end;
     end;
    end;
    end;

    procedure addbbs;
    begin
     writehdr ('Add a BBS');
     writeln (^R'Phone Number [12 Characters Max]');
     writeln (^R'  [------------]');
     buflen:=12;
     writestr ('-> &');
     b.number:=input;
     writeln;
     writeln (^R'Enter BBS Name [48 Characters Max]');
     writeln (^R'  [------------------------------------------------]');
     buflen:=48;
     writestr ('-> &');
     b.name:=input;
     writeln;
     writeln (^R'Maximum Baud [4 Digits] (ie 2400,9600,19.2)');
     writeln (^R'  [----]');
     buflen:=4;
     writestr ('-> &');
     b.maxbaud:=input;
     if valu(b.maxbaud)<=300 then
     writeln (^R^M'Man, your board must really suck!');
     writeln;
     writeln (^R'BBS Software [4 Characters Max] (ie TCS,EM/2,WWIV)');
     writeln (^R'  [----]');
     buflen:=4;
     writestr ('-> &');
     b.ware:=input;
     writeln;
     writeln (^R'Extended BBS Description [77 Characters Max - CR for none]');
     writeln (^R'  [-------------------------------------------------------------------------]');
     buflen:=77;
     writestr ('-> &');
     b.extdesc:=input;
     b.leftby:=unam;
     if (length(b.number)>0) and (length(b.name)>0) and (length(b.maxbaud)>0)
     and (length(b.ware)>0) then begin
      if not exist ('BBSList.Dat') then rewrite (blfile);
      seekblfile (numbbses+1);
      write (blfile,b);
      writeln (^M^S'BBS Added!'^R^M);
     end else
     writeln (^M^S'Entry incomplete!'^R^M);
     end;

  procedure changebbs;
  var q,spock:integer;
      doodzdomain:char;

   procedure showbbs (b:bbsrec);
   begin
   writeln (^M^R'[1] BBS Name:     '^S,b.name,
            ^M^R'[2] BBS Number:   '^S,b.number,
            ^M^R'[3] Max Baud:     '^S,b.maxbaud,
            ^M^R'[4] BBS Software: '^S,b.ware,
            ^M^R'[5] Extended BBS Description:',
            ^M^R'> '^S,b.extdesc,
            ^M^R'[Q] Quit');
   end;

   begin
       writehdr ('Change an Entry');
       writestr (^M'Entry to Change [?/List]: &');
       if input[1]='?' then listbbs;
       spock:=valu(input);
       if spock<1 then exit;
       if spock>numbbs then exit;
       seekblfile (spock);
       read (blfile,b);
       if not (match (b.leftby,unam)) then begin
        writeln (^M'You didn''t post that entry!'^M);
        exit;
       end;
       repeat
       showbbs (b);
       writestr ('[Edit BBS List Command]: *');
       doodzdomain:=upcase(input[1]);
       case doodzdomain of
        '1':getstring ('BBS Name',b.name,48);
        '2':getstring ('BBS Number',b.number,12);
        '3':getstring ('Maximum Baud',b.maxbaud,4);
        '4':getstring ('BBS Software',b.ware,4);
        '5':begin
             writeln ('Old Extended BBS Description:');
             writeln ('> ',b.extdesc);
             writeln ('Enter new Extended BBS Description [CR/no change]:');
             buflen:=77;
             writestr ('> &');
             if length(input)<>0 then b.extdesc:=input;
             writeln
            end;
        'Q':;
       end;
       until doodzdomain='Q';
       write (blfile,b);
       close (blfile);
      end;

  procedure deletebbs;
  begin
   writehdr ('Delete an Entry');
  end;

  procedure bbslistsysop;
  begin
     writeln;
     repeat
      ugbot:=' ';
      writeln  (^R'['^S'D'^R']elete an Entry');
      writeln  (^R'['^S'C'^R']hange an Entry');
      writeln  (^R'['^S'S'^R']ort Entries');
    { writeln  (^R'['^S'T'^R']Textfile'); }
      writeln  (^R'['^S'Q'^R']uit');
      writestr ('[BBS List Sysop Command]:');
      ugbot:=upstring(input);
      case ugbot[1] of
       'D':deletebbs;
       'C':changebbs;
       'S':begin
           end;
       'T':begin
           end;
       'Q':;
      end;
     until (ugbot[1]='Q');
    end;

label exit;
var q:integer;
begin
    assign (blfile,'BBSList.Dat');
    repeat
     q:=menu ('BBS List Menu','BBSLIST','LADC%Q');
     writeln;
     case q of
      1:listbbs;
      2:addbbs;
      3:deletebbs;
      4:changebbs;
      5:bbslistsysop;
      6:goto exit;
     end;
     until (hungupon) or (q=6);
    exit:
    close (blfile);
end;

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

procedure showad;
var fn:lstr;
begin
  fn:=textfiledir+'TCS.Ad';
  if exist (fn) then printfile (fn) else begin
  writeln (^M'No Advertisement.'^M);
  writeln (usr,'Sysop: To make one, create a file called TCS.AD in your Menus Directory.'^M);
  end;
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 of which Info-Form [#1-5]? *');
  if (valu(input)<1) or (valu(input)>5) then exit;
  writestr ('Erase ALL # '+strr(valu(input))+' Info-Forms -- Are you sure [y/n]? *');
  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 (valu(input)=1) then begin
    if u.infoform1>=0 then begin
      deletetext (u.infoform1);
      u.infoform1:=-1;
      seek (ufile,cnt);
      write (ufile,u);
      ndel:=ndel+1
    end
   end else
   if (valu(input)=2) then begin
    if u.infoform2>=0 then begin
      deletetext (u.infoform2);
      u.infoform2:=-1;
      seek (ufile,cnt);
      write (ufile,u);
      ndel:=ndel+1
    end
   end else
   if (valu(input)=3) then begin
    if u.infoform3>=0 then begin
      deletetext (u.infoform3);
      u.infoform3:=-1;
      seek (ufile,cnt);
      write (ufile,u);
      ndel:=ndel+1
    end
   end else
   if (valu(input)=4) then begin
    if u.infoform4>=0 then begin
      deletetext (u.infoform4);
      u.infoform4:=-1;
      seek (ufile,cnt);
      write (ufile,u);
      ndel:=ndel+1
    end
   end else
   if (valu(input)=5) then begin
    if u.infoform5>=0 then begin
      deletetext (u.infoform5);
      u.infoform5:=-1;
      seek (ufile,cnt);
      write (ufile,u);
      ndel:=ndel+1
    end
   end;
  end;
  writeln ('Done.');
  writestr (^M'All '+strr(ndel)+' Info-forms #'+strr(valu(input))+' 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,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 ',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:=lookupuser (m.sentby);
    if n=0
      then writestr ('User disappeared!')
      else edituser (n)
  end;

  procedure infoform;
  begin
    if checkcur then exit;
    showinfoforms (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 (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 Menu','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;

begin
end.