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

Pascal/Delphi Source File | 1991-04-13 | 12.4 KB | 438 lines

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

unit doors;

interface

uses crt,gentypes,modem,configrt,gensubs,subs1,subs2,userret,statret,
     textret,mainr1,mainr2;

procedure doorsmenu;

implementation

procedure doorsmenu;

  function numdoors:integer;
  begin
    numdoors:=filesize (dofile)
  end;

  procedure seekdofile (n:integer);
  begin
    seek (dofile,n-1)
  end;

  procedure opendofile;
  var arkanoid:integer;
  begin
    assign (dofile,bbsdatadir+'Doors.dat');
    reset (dofile);
    if ioresult<>0 then begin
      close (dofile);
      arkanoid:=ioresult;
      rewrite (dofile)
    end
  end;

  procedure maybemakebatch (fn:lstr);
  var tf:text;
      vallco:boolean;
  begin
    if not issysop then exit;
    writestr ('Make new batch file '+fn+'? *');
    if not yes then exit;
    assign (tf,fn);
    rewrite (tf);
    if ioresult<>0 then begin
      writeln (^M'Couldn''t create file!');
      exit
    end;
    writeln (^M'Enter Text, blank line to end.'^M);
    repeat
      writestr ('─> &');
      vallco:=length(input)=0;
      if not vallco then writeln (tf,input)
    until vallco;
    textclose (tf);
    writeln (^M'Batch file created!');
    writelog (10,4,fn)
  end;

  procedure getdoorinfo (var d:doorrec);
  var m:message;
  begin
    writeln (^B^M'Enter Info about this Door:'^M);
    delay (1000);
    titlestr:='Door Information';
    d.info:=editor (m,false,'Door Information')
  end;

  function checkbatchname (var qq):boolean;
  var i:lstr absolute qq;
      batman:integer;
  begin
    batman:=pos('.',i);
    if batman<>0 then i[0]:=chr(batman-1);
    i:=i+'.BAT';
    checkbatchname:=validfname(i)
  end;

  procedure maybemakedoor;
  var shy:integer;
      d:doorrec;
  begin
    if not issysop then exit;
    shy:=numdoors+1;
    writestr ('Make new Door #'+strr(shy)+'? *');
    if not yes then exit;
    writestr (^M'Name:');
    if length(input)<1 then exit;
    d.name:=input;
    writestr ('Access Level:');
    if length(input)<1 then exit;
    d.level:=valu(input);
    writestr ('Name/Path of batch file:');
    if length(input)<1 then exit;
    if not checkbatchname(input) then begin
      writeln ('Invalid filename: '^S,input);
      exit
    end;
    d.batchname:=doordir+input;
    getdoorinfo (d);
    if d.info<0 then exit;
    d.numused:=0;
    seekdofile (shy);
    write (dofile,d);
    if not exist (d.batchname) then begin
      writeln (^B'ERROR: Can''t open Batch file ',d.batchname);
      maybemakebatch (d.batchname)
    end;
    writeln (^B^M'Door created!');
    writelog (10,3,d.name)
  end;

  function haveaccess (n:integer):boolean;
  var d:doorrec;
  begin
    haveaccess:=false;
    seekdofile (n);
    read (dofile,d);
    if ulvl>=d.level
      then haveaccess:=true
      else writeln ('That Door is locked.')
  end;

  procedure listdoors;
  var d:doorrec;
      cnt:integer;
  begin
    if exist (textfiledir+'DoorList.BBS') then begin
     printfile (textfiledir+'DoorList.BBS');
      exit
     end;
    if not (asciigraphics in urec.config) then begin
    writehdr ('Available Doors');
    seekdofile (1);
    writeln (^M^R'## Online Door Name            Level Times used');
    for cnt:=1 to numdoors do begin
      read (dofile,d);
      if ulvl>=d.level then begin
        tab (strr(cnt)+'.',3);
        tab (d.name,27);
        writeln (d.level:3,d.numused:5);
        if break then exit
      end
    end;
    end else begin
    seekdofile (1);
    writeln (^M^R'┌──┬──────────────────────────────┬─────┬──────────┐');
    writeln (^R'│##│Online Door Name              │Level│Times Used│');
    writeln (^R'├──┼──────────────────────────────┼─────┼──────────┤');
    for cnt:=1 to numdoors do begin
       read (dofile,d);
       if ulvl>=d.level then begin
         tab (^R'│'^S+strr(cnt),5);
         tab (^R'│'^S+d.name,33);
         tab (^R'│'^S+strr(d.level),8);
         tab (^R'│ '^S+strr(d.numused),13);
         writeln (^R'│');
      if break then exit
    end
    end
   end;
  if (asciigraphics in urec.config) then
    writeln (^R'└──┴──────────────────────────────┴─────┴──────────┘')
  end;

  function getdoornum (txt:mstr):integer;
  var g:boolean;
      n:integer;
  begin
    getdoornum:=0;
    g:=false;
    repeat
      writestr (^R'Door Number to '^P+txt+^R' ['^S'?/List'^R']:');
      if input='?' then listdoors else g:=true
    until g;
    if length(input)=0 then exit;
    n:=valu(input);
    if (n<1) or (n>numdoors)
      then writeln ('Door number out of range!')
      else if haveaccess(n)
        then getdoornum:=n
  end;

  procedure opendoor;
  var n,bd,p:integer;
      d:doorrec;
      batchf,outf:text;
      q:boolean;
      tmp,params:lstr;
  begin
    n:=getdoornum ('open');
    if n=0 then exit;
    seekdofile (n);
    read (dofile,d);
    printtext (d.info);
    nobreak:=true;
    writestr (^B^M^P'Press ['^S'Space'^P'] to Open the Door, or ['^S'X'^P'] to Abort');
    if upcase(waitforchar)='X' then exit;
    writeln (^R'Opening door: '^S,d.name);
    q:=true;
    repeat
      assign (batchf,d.batchname);
      reset (batchf);
      if ioresult<>0 then begin
        q:=false;
        close (batchf);
        iocode:=ioresult;
        if not issysop then begin
          fileerror ('Opendoor',d.batchname);
         exit
        end else begin
          maybemakebatch (d.batchname);
         if not exist (d.batchname) then exit
        end
      end
    until q;
    assign (outf,'DOOR.BAT');
    rewrite (outf);
    writeln (outf,'TEMPDOOR ',params);
    textclose (outf);
    assign (outf,'TEMPDOOR.BAT');
    rewrite (outf);
    while not eof(batchf) do begin
      readln (batchf,tmp);
      writeln (outf,tmp)
    end;
    if online then bd:=baudrate else bd:=0;
    getdir (0,tmp);
    writeln (outf,'cd '+tmp);
    writeln (outf,'main.bat ',unum,' ',bd,' ',ord(parity),' D');
    textclose (batchf);
    textclose (outf);
    d.numused:=d.numused+1;
    seekdofile (n);
    write (dofile,d);
    writelog (9,1,d.name);
    updateuserstats (false);
    writeurec;
    writestatus;
    ensureclosed;
    halt (e_door)
  end;

  procedure getinfo;
  var n:integer;
      d:doorrec;
  begin
    n:=getdoornum ('get information on');
    if n=0 then exit;
    seekdofile (n);
    read (dofile,d);
    writeln;
    printtext (d.info)
  end;

  procedure changedoor;
  var n:integer;
      d:doorrec;
  begin
    n:=getdoornum ('Change');
    if n=0 then exit;
    seekdofile (n);
    read (dofile,d);
    writeln ('Name: ',d.name);
    writestr ('New name:');
    if length(input)>0 then d.name:=input;
    writeln (^M'Level: ',d.level);
    writestr ('New level:');
    if length(input)>0 then d.level:=valu(input);
    writeln (^M'Batch file name: ',d.batchname);
    writestr ('New batch file name:');
    if length(input)>0 then
     if checkbatchname (input)
      then d.batchname:=input
     else writeln ('Invalid filename: '^S,input);
    maybemakebatch (d.batchname);
    writeln;
    printtext (d.info);
    writestr (^M^R'Replace text ['^S'y/n'^R']:');
    if yes then repeat
     deletetext (d.info);
     getdoorinfo (d);
     if d.info<0 then writeln (^M'You must enter some information.')
    until d.info>=0;
    seekdofile (n);
    write (dofile,d);
    writelog (10,1,d.name)
  end;

  procedure deletedoor;
  var n,cnt:integer;
      td,d:doorrec;
      f:file;
  begin
    n:=getdoornum ('Delete');
    if n=0 then exit;
    seekdofile (n);
    read (dofile,d);
    writestr ('Delete '+d.name+' [y/n]:');
    if not yes then exit;
    writeln ('Deleting...');
    seekdofile (n+1);
    for cnt:=n to filesize(dofile)-1 do begin
      read (dofile,td);
      seekdofile (cnt);
      write (dofile,td)
    end;
    seek (dofile,filesize(dofile)-1);
    truncate (dofile);
    deletetext (d.info);
    writestr (^M'Erase disk file '+d.batchname+'? *');
     if yes then begin
      assign (f,d.batchname);
      erase (f);
      if ioresult<>0 then writeln ('(File not found)')
    end;
    writelog (10,2,d.name)
  end;

  procedure sysopdoors;
  var zebra:integer;
  begin
    if (not remotedoors) and carrier then begin
      writestr ('Sorry, remote door maintenance is not allowed!');
      writestr ('(Re-configure to change this setting)');
      exit
    end;
    repeat
      zebra:=menu('Doors Sysop','SDOORS','QCAD?');
      case zebra of
        2:changedoor;
        3:maybemakedoor;
        4:deletedoor;
        5:begin
writeln ('C╔═════════════════════════════════════╗Hs');
writeln ('uC║ Doors Sysop Section                 ║Hs');
writeln ('uC╚═════════════════════════════════════╝HHC╔════s');
writeln ('u═════════════════════════════════╗HC║ [A] s');
writeln ('uAdd Door                        ║HC║ [Cs');
writeln ('u] Change Door                     ║HC║ [s');
writeln ('uD] Delete Door                     ║Hs');
writeln ('uC║ [Q] Quit                            s');
writeln ('u║HC║ [?] View This Menu           s');
writeln ('u       ║HC╚═════════════════════════════════════╝');
writeln;
pause;
           end;
      end
    until hungupon or (zebra=1) or (filesize(dofile)=0)
  end;

var x1,x2,x3,space,harrier,zebra:integer;
    y1,y2,y3:real;
begin
  writeln ('On-Line Doors');
  if not allowdoors then begin
    writestr ('All doors are locked.');
    if issysop then writestr ('[Re-configure to change this setting]');
    exit
  end;
  if fromdoor then begin
    fromdoor:=false;
    if returnto='D' then writestr (^M^M'Welcome back to FAQ!');
    settimeleft (urec.timetoday)
  end;
  x1:=urec.nbu;
  x2:=urec.numon;
  if x1<1 then x1:=1;
  if x2<1 then x2:=1;
  y1:=int(x1);
  y2:=int(x2);
  y1:=y1;
  y2:=y2;
  y3:=y1/y2;
  y3:=y3*100;
  x3:=trunc(y3);
  write (^R'Required Post/Call Ratio: ['^S);
  for space:=1 to 3-(length(strr(doorpcr))) do write (' ');
  write (strr(doorpcr));
  writeln ('%'^R']');
  write (^R'Your Post/Call Ratio:     ['^S);
  for harrier:=1 to 3-(length(strr(x3))) do write (' ');
  write (strr(x3));
  writeln ('%'^R']');
  write (^M^R'PCR Status: ['^S);
  if ulvl>=pcrexempt then write ('Exempt from PCR.') else
  if (x3<doorpcr) and (ulvl<pcrexempt) then write ('PCR too low!') else
  if (x3>=doorpcr) and (ulvl<pcrexempt) then write ('Passed PCR check.');
  writeln (^R']'^M);
  if (x3<doorpcr) and (ulvl<pcrexempt) then begin
   writeln (^B^R'Your Posts-per-Call Ratio is too low!');
   writeln ('Go post a message or two.');
   exit;
  end;
  cursection:=doorssysop;
  opendofile;
  if numdoors=0 then begin
    writestr ('No doors exist!');
    maybemakedoor;
    if numdoors=0 then begin
      close (dofile);
      exit
    end
  end;
  writehdr ('Doors');
  repeat
    zebra:=menu('Doors','DOORS','QLOI%?');
    case zebra of
      2:listdoors;
      3:opendoor;
      4:getinfo;
      5:sysopdoors;
      6:begin
writeln ('C╔═════════════════════════════════════╗Hs');
writeln ('uC║ Doors Section                       ║Hs');
writeln ('uC╚═════════════════════════════════════╝HHC╔════s');
writeln ('u═════════════════════════════════╗HC║ [I]  s');
writeln ('uGet Info on Door               ║HC║ [Ls');
writeln ('u]  List Doors                     ║HC║ [s');
writeln ('uO]  Open (Run) Door                ║Hs');
writeln ('uC║ [Q]  Quit                           s');
writeln ('u║HC║ [%]  Doors Sysop Section     s');
writeln ('u       ║HC║ [?]  View This Menu   s');
writeln ('u              ║HC╚═══════════════════════════════A');
writeln ('C══════╝');
writeln;
pause;
           end;
    end
  until hungupon or (zebra=1) or (filesize(dofile)=0);
  close (dofile)
end;

begin
end.