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

Pascal/Delphi Source File | 1987-01-09 | 8.2 KB | 338 lines

overlay procedure doors;

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

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

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

  procedure maybemakebatch (fn:lstr);
  var tf:text;
      d:boolean;
  begin
    if not issysop then exit;
    writestr ('Make new batch file '+fn+'? *');
    writeln (^M);
    if not yes then exit;
    assign (tf,fn);
    rewrite (tf);
    if ioresult<>0 then begin
      writeln ('Couldn''t create file!');
      exit
    end;
    writeln ('*> Enter text, blank line to end <*'^M);
    repeat
      writestr ('=> &');
      d:=length(input)=0;
      if not d then writeln (tf,input)
    until d;
    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 information about this door:'^M);
    d.info:=editor (m,false)
  end;

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

  procedure maybemakedoor;
  var n:integer;
      d:doorrec;
  begin
    if not issysop then exit;
    n:=numdoors+1;
    writestr ('Make new door #'+strr(n)+'? *');
    if not yes then exit;
    writestr (^M'Name:');
    if length(input)=0 then exit;
    d.name:=input;
    writestr ('Access level:');
    if length(input)=0 then exit;
    d.level:=valu(input);
    writestr ('Name/path of batch file:');
    if length(input)=0 then exit;
    if not checkbatchname(input) then begin
      writeln ('Invalid filename: '^S,input);
      exit
    end;
    d.batchname:=input;
    writestr ('Ask user opening door for parameters? *');
    d.getparams:=yes;
    getdoorinfo (d);
    if d.info<0 then exit;
    d.numused:=0;
    seekdofile (n);
    write (dofile,d);
    if not exist (d.batchname) then begin
      writeln (^B'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 reqlevel (d.level)
  end;

  procedure listdoors;
  var d:doorrec;
      cnt:integer;
  begin
    writehdr ('Available Doors');
    seekdofile (1);
    writeln ('   [Name]                       [Level] [Times used]');
    for cnt:=1 to numdoors do begin
      read (dofile,d);
      if ulvl>=d.level then begin
        write (cnt:2,'. ');
        tab ('['+d.name+']',30);
        writeln ('[',d.level:3,']',' [',d.numused:5,']');
        if break then exit
      end
    end;
    writeln
  end;

  function getdoornum (txt:mstr):integer;
  var g:boolean;
      n:integer;
  begin
    getdoornum:=0;
    g:=false;
    repeat
      writestr ('Door number to '+txt+' [?=list]:');
      writeln;
      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:integer;
      d:doorrec;
      batchf,outf:text;
      q:boolean;
      tmp,params:lstr;
      nigger:text;
      bro:lstr;
  begin
    n:=getdoornum ('open');
    if n=0 then exit;
    seekdofile (n);
    read (dofile,d);
    printtext (d.info);
    params:='';
    writeln (^M'Press [Space to Use]  [X to Abort]');
    if upcase(waitforchar)='X' then exit;
    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;
    writeln ('Opening door: [',d.name,']');

    d.numused:=d.numused+1;
    updateuserstats;
    seekdofile (n);
    write (dofile,d);
    writeurec;
    writestatus;
    ensureclosed;
    bro:='Pcboard.sys';
    assign (nigger,bro);       { This Ensures Some Pc-Board Compatibility }
    rewrite (nigger);
    if baudrate<1200 then
    writeln (nigger,'          '+strr(baudrate)+' '+urec.handle+'                               ') ELSE
    writeln (nigger,'          '+strr(baudrate)+urec.handle+'                               ');
    textclose(nigger);
    dos_Shell(d.batchname);
    setparam (usecom,baudrate,parity);
  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'Replace text [y/n]:');
    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+': Confirm:');
    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 q:integer;
  begin
    if (not remotedoors) and carrier then begin
      writestr ('Sorry, remote door maintenance is not allowed!');
      writestr ('(Please re-configure to change this setting)');
      exit
    end;
    repeat
      q:=menu('Sysop door','SDOORS','QCAD');
      case q of
        2:changedoor;
        3:maybemakedoor;
        4:deletedoor
      end
    until hungupon or (q=1) or (filesize(dofile)=0)
  end;

var q:integer;
begin
  if not allowdoors then begin
    writeln ('*> All doors are locked <*');
    if issysop then writestr ('(Please re-configure to change this setting)');
    exit
  end;
  if fromdoor then begin
    fromdoor:=false;
    writestr (^M^M^M'Welcome back!')
  end;
  cursection:=doorssysop;
  opendofile;
  if numdoors=0 then begin
    writestr ('No doors exist!');
    maybemakedoor;
    if numdoors=0 then begin
      close (dofile);
      exit
    end
  end;
  repeat
    q:=menu('Doors','DOORS','QLOIH%@');
    case q of
      2:listdoors;
      3:opendoor;
      4:getinfo;
      5:;
      6:sysopdoors
    end
  until hungupon or (q=1) or (filesize(dofile)=0);
  close (dofile)
end;