Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/SYSPC22.ZIP/OVERRET1.PAS

Pascal/Delphi Source File | 1989-02-17 | 20.2 KB | 858 lines

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

  procedure clearvote;
var n,cnt:integer;
    u:userrec;



{****  procedure comrem;
   var
   comfile:file of commentrec;
   comstuf:commentrec;

  begin
    assign (comfile,'comments');
    if ioresult<>0 then exit;
    for cnt:=1 to (filesize(comfile)+1) do begin
    read (comfile,comstuf);
    if comstuf.num=eunum then comstuf.num:=0;
    write (comfile,comstuf);
    end;
    close (comfile);
    end;  ****}

  procedure dorem;
  begin
   cnt:=0;
   for cnt:=1 to 50 do begin
   if u.didvote[cnt]=eunum then begin
   u.didvote[cnt]:=0;
   cnt:=50;
   end;
  end;
  end;

begin
  writeln ('*> Removing vote records <*');
(*  comrem; *)
  for n:=1 to numusers do begin
    seek (ufile,n);
    read (ufile,u);
    if (u.level>=forvote) then dorem;
    writeurec;
    seek (ufile,n);
    write (ufile,u);
    readurec;
  end;
  end;


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

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

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

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

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

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

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

  procedure eudel;
  begin
    writestr ('Delete user --- confirm:');
    if yes then begin
      deleteuser (eunum);
      seek (ufile,eunum);
      read (ufile,eurec);
      clearvote;
      writelog (18,9,'')
    end
  end;

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

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

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

  procedure eugflvl;
  var n:integer;
   begin
    n:=eurec.gflvl;
    getint ('g-file level',n);
   if (n>=sysoplevel) and (not truesysop)
      then truesysops
      else begin
        eurec.gflvl:=n;
        end
   end;

  procedure euphone;
  var m:mstr;

  begin
    m:=eurec.phonenum;
    buflen:=15;
    getmstr ('phone number',m);
    if length(m)>7 then begin
      eurec.phonenum:=m;
      writelog (18,16,m)
    end
  end;

  procedure boardflags;
  var quit:boolean;

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

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

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

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

  procedure specialsysop;

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

  begin
    if not truesysop then begin
      truesysops;
      exit
    end;
    writestr
('Section of M)ain, F)ile, B)ulletin, V)oting, E)mail, D)atabase, P)Doors:');
    if length(input)=0 then exit;
    case upcase(input[1]) of
      'M':getsysop (mainsysop);
      'F':getsysop (udsysop);
      'B':getsysop (bulletinsysop);
      'V':getsysop (votingsysop);
      'E':getsysop (emailsysop);
      'D':getsysop (databasesysop);
      'P':getsysop (doorssysop)
    end
  end;

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

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

overlay procedure printnews;
var nfile:file of newsrec;
    line:newsrec;
begin
  assign (nfile,'News');
  reset (nfile);
  if ioresult<>0 then exit;
  if filesize (nfile)=0 then begin
    close (nfile);
    exit
  end;
  writehdr ('News Bulletins: <SPACE> to abort, ^S to stop, ^Q to continue');
  while not (eof(nfile) or break or hungupon) do begin
    read (nfile,line);
    if (line.where>=0) and (line.level<=ulvl) then begin
      writeln;
        ansireset;
        write ('Title: ['^S,line.title);
        ansireset;
        write (']  Date: ['^S,line.date,' at ',line.time);
        ansireset;
        write (']  Level: ['^S,line.level);
        ansireset;
        writeln (']');
      writeln ('------------------------------------------------------------------------------');
      printtext (line.where)
    end
  end;
  close (nfile)
end;

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

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

overlay procedure showlastcallers;
var qf:file of lastrec;
    cnt:integer;
    l:lastrec;
begin
  assign (qf,'Callers');
  reset (qf);
  if ioresult=0 then begin
    break:=false;
    for cnt:=0 to filesize(qf)-1 do
      if not break then begin
        read (qf,l);
       if not break then
        writeln ('[',l.caller:0:0,'] - ['+l.name+']  [Level: ',l.level:4,']');
        if not break then
        writeln ('Baud: [',l.baud,']  Called At: ['+l.da+'] at ['+l.ti+']');
      end
  end;
  close (qf)
end;

overlay procedure updateuserstats;
var timeon:integer;
begin
  with urec do begin
    timeon:=timeontoday;
    timetoday:=timetoday-timeon;
    if timetoday<0 then timetoday:=0;
    totaltime:=totaltime+timeon;
    if tempsysop then begin
      ulvl:=regularlevel;
      writeln (usr,'(Disabling temporary sysop powers)');
      writeurec
    end;
    if numon=1 then begin
      if (ulvl=1) and (level2nd<>0) then ulvl:=level2nd;
      if (udlevel=defudlevel) and (udlevel2nd<>0) then udlevel:=udlevel2nd;
      if (udpoints=defudpoints) and (udpoints2nd<>0)
        then udpoints:=udpoints2nd
    end
  end;
  writeurec
end;

overlay procedure question(which:integer);
var ff:text;
    k:char;
    me:message;
    z:integer;
    x:char;
    i:integer;

procedure dosee (c:integer; uname:mstr);
var lnum,un,cnt:integer;
    u:userrec;

  procedure showone;
  var ff:text;
      me:message;
      k:char;
      found:boolean;
      z:integer;
      l:anystr;

  begin
  begin
    z:=u.infoform[c];
    if z=-1 then begin
      writestr ('That user has not filled out that infoform.');
      exit
    end;
    end;
    assign (ff,textfiledir+'info'+strr(c));
    reset (ff);
    if ioresult<>0 then begin
      close (ff);
      lnum:=ioresult;
      writeln ('Information form not present.');
      exit
    end;
    reloadtext (u.infoform[c],me);
    writeln (^M,me.text[1],^M^M);
    lnum:=1;
    while not (break or eof(ff)) do begin
      read (ff,k);
      if k='*'
        then if lnum>me.numlines
          then writeln ('No answer')
          else begin
            lnum:=lnum+1;
            writeln (me.text[lnum])
          end
        else writechar (k);
    end;
   textclose (ff)
  end;

begin
    un:=lookupuser (uname);
    if un=0 then writestr ('No such user.') else begin
      seek (ufile,un);
      read (ufile,u);
      showone;
      nosys:=true;
    end
end;

 procedure viewinfo(l:integer; s:mstr);
  begin
    dosee(l,s);
 end;

begin
  if which>0 then i:=which else
  repeat
   i:=menu('InfoForms','Info','ABCDEFGHIQ');
   if i=10 then exit;
  until hungupon or (i>0);
  if i<10 then z:=urec.infoform[i];
  writeln;
  if not exist (textfiledir+'Info'+strr(i)) then begin
    writestr ('Information form #'+strr(i)+' does not exist.');
    if issysop then
      writeln ('Sysop: To make an information form, create a text file',
             ^M'called INFO(Number).  Use * to indicate a pause for user input.');
    exit
  end;
  if z<>-1 then begin
    writeln ('*> Infoform already filled out <*');
    writestr ('D)elete, R)eplace, V)iew or Q)uit: @');

    if upcase(input[1])='D' then begin
                                  Deletetext(z);
                                  urec.infoform[i]:=-1;
                                  writeurec;
                                  exit;
                                  end;

    if upcase(input[1])='V' then begin
                                  nosys:=true;
                                  viewinfo(i,unam);
                                  nosys:=false;
                                  exit;
                                  end;

    if upcase(input[1])='Q' then exit;

    deletetext (urec.infoform[i]);
    urec.infoform[i]:=-1;
    writeurec
  end;
  assign (ff,textfiledir+'Info'+strr(i));
  reset (ff);
  me.numlines:=1;
  me.title:='';
  me.anon:=false;
  me.text[1]:='Filled out on: '+datestr+' at '+timestr;
  while not eof(ff) do begin
    if hungupon then begin
      textclose (ff);
      exit
    end;
    read (ff,k);
    if k='*' then begin
      nochain:=true;
      getstr;
      me.numlines:=me.numlines+1;
      me.text[me.numlines]:=input
     end
    else writechar (k);
  end;
  textclose (ff);
  z:=maketext (me);
  urec.infoform[i]:=z;
  writeurec
end;

overlay procedure newvote;

var u:userrec;
    n,cnt1,cnt:integer;
    cv,alv:boolean;

(***  procedure makecomment;
  var
  com:string[80];
  comstuf:commentrec;
  comfile:file of commentrec;
  C:integer;
  temp:commentrec;
  here:boolean;

  begin
  writestr ('Would you like to insert a comment? *');
  if yes then begin
  assign (comfile,'comments');
  reset (comfile);
  if ioresult <> 0 then rewrite (comfile);
  Writeln ('You have one line (80 chr.)');
  repeat
  writeln ('------------------------------------------------------------------------------');
  getstr;
  if hungupon then exit;
  com:=input;
  writeln (com);
  writestr ('Is this ok? *');
  until yes or hungupon;
  C:=0;
  here:=false;
  repeat
  C:=c+1;
  seek (comfile,c);
  read (comfile,temp);
  if temp.num<1 then here:=true;
  until (c=filesize(comfile)) or here;
  if not here then seek(comfile,filesize(comfile)+1) else seek (comfile,c);
       comstuf.num:=n;
       comstuf.comment:=com;
       comstuf.who:=unam;
write (comfile,comstuf);
writeln ('Comment Saved');
  close (comfile);
  end;
  end;   ***)


  procedure lookinfo (uname:mstr);
  var ff:text;
      me:message;
      k:char;
      found:boolean;
      z,lnum,g:integer;
      l:anystr;
      b:userrec;

  begin
    g:=lookupuser(uname);
    if g=0 then writestr ('No such user.') else begin
      seek (ufile,g);
      read (ufile,b);
     z:=b.infoform[1];
    if z=-1 then begin
      writestr ('User did not fill it out');
      exit
    end;
    assign (ff,textfiledir+'Info1');
    reset (ff);
    if ioresult<>0 then begin
      close (ff);
      lnum:=ioresult;
      writeln ('That information form is not present.');
      exit
     end;
    reloadtext (b.infoform[1],me);
    writeln (^M,me.text[1],^M^M);
    lnum:=1;
    while not (break or eof(ff)) do begin
      read (ff,k);
      if k='*'
        then if lnum>me.numlines
          then writeln ('No answer')
          else begin
            lnum:=lnum+1;
            writeln (me.text[lnum])
          end
        else writechar (k);
    end;
   textclose (ff)
  end;
  end;

  procedure look;
   begin
   cnt1:=0;
   alv:=false;
   for cnt1:=1 to 50 do begin
    if urec.didvote[cnt1]=n then begin
     alv:=true;
     cnt1:=50;
     end;
    end;
   end;

(****   procedure comview;
   var
     comfile:file of commentrec;
     comstuf:commentrec;
     cnt:integer;

   begin
   writeln ('Comments on ',u.handle,':');
   assign (comfile,'comments');
   if ioresult<>0 then exit;
   for cnt:=1 to filesize(comfile) do begin
   read (comfile,comstuf);
   if comstuf.num=n then begin
   writeln ('----------------------');
   writeln ('Comment left by: ',comstuf.who);
   writeln (comstuf.comment);
   end;
   end;
   close (comfile);
   end;   ***)

  procedure showuser;
  begin
    look;
    if not alv then begin
    writeln (^M'Name       : '^S,u.handle,^M);
    writeln ('--Current Voting--');
    writeln ('Yes          : '^S,u.votey);
    writeln ('No           : '^S,u.voten,^M);
    writestr ('Vote on user? *');
    if not yes then alv:=true;
    if not alv then begin
    write ('View ',u.handle,'''s infoform? ');
    getstr;
    if yes then lookinfo(u.handle);
(***    writestr ('View other voters comments? *');
    if yes then comview; ***)
    end;
    end;
    repeat
    if alv then input:='3' else begin
    writeln ('Please make your decision:',^M^M
            ,'1) Yes, let him in',^M
            ,'2) No, don''t let him in',^M
            ,'3) Undecided, I will vote later');
    writestr (^M'Please enter your choice: *');
    end;
    if (length(input)<1) then input:=('3');
    case input of
    '1':begin
         cv:=false;
         cnt:=0;
         seek (ufile,n);
         u.votey:=u.votey+1;
         while cnt<=50 do begin
         if urec.didvote[cnt]=0 then begin
         urec.didvote[cnt]:=n;
         cnt:=50;
         Writeln ('*> Vote recorded <*');
         cv:=true;
         writeurec;
         end;
         cnt:=cnt+1;
         end;
         nnu:=nnu-1;
(***         makecomment;   ***)
        end;

    '2':begin
         cv:=false;
         cnt:=0;
         seek (ufile,n);
         u.voten:=u.voten+1;
         while cnt<=50 do begin
         if urec.didvote[cnt]=0 then begin
         urec.didvote[cnt]:=n;
         cnt:=50;
         Writeln ('*> Vote recorded <*');
         cv:=true;
         writeurec;
         end;
         cnt:=cnt+1;
         end;
         nnu:=nnu-1;
(***         makecomment;   ***)
         end;

    '3':begin
         cv:=false;
         if not alv then writeln ('*> Please vote soon! <*');
         cv:=true;
         end;

   end;{case}
   until cv;
  end;{showuser}

begin
  if nnu<1 then begin
  Writeln ('*> No new users <*');
  exit;
  end;
  writeln ('*> Please wait. Scanning User File <*');
  for n:=1 to numusers do begin
    seek (ufile,n);
    read (ufile,u);
    if (u.level<=level2nd) then if (length(u.handle)>0) then showuser;
    writeurec;
    seek (ufile,n);
    write (ufile,u);
    readurec;
  end
end;