Jason Aller Floppy Collection/341.img/TCS161S.ZIP/DOORS.PAS

Pascal/Delphi Source File | 1980-10-22 | 10KB | 406 lines

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

unit doors;

interface

uses crt,overlay,
     gentypes,modem,configrt,statret,gensubs,subs1,subs2,
     userret,textret,overret1,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 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 some Information 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;
      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:=doordir+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 writeln ('That Door is locked.')
  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,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);
    if d.getparams then writestr ('Parameters:') else input:='';
    params:=input;
    p:=pos('>',input);
    if p=0 then p:=pos('<',input);
    if p=0 then p:=pos('|',input);
    if p<>0 then begin
      writestr ('You may not specify pipes in door parameters.');
      exit
    end;
    writestr (^M'Press [Space] to Open the Door, or [X] to Abort');
    if upcase(waitforchar)='X' then exit;
    writeln ('Opening door: ',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;
    if online then bd:=baudrate else bd:=0;
    assign (outf,'DOOR.BAT');
    rewrite (outf);
    writeln (outf,'TEMPDOOR ',unum,' ',bd);
    textclose (outf);
    assign (outf,'TEMPDOOR.BAT');
    rewrite (outf);
    while not eof(batchf) do begin
      readln (batchf,tmp);
      writeln (outf,tmp)
    end;
    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'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+' [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 q: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
      q:=menu('Doors Sysop','DSYSOP','QCAD');
      case q of
        2:changedoor;
        3:maybemakedoor;
        4:deletedoor
      end
    until hungupon or (q=1) or (filesize(dofile)=0)
  end;

var q,x1,x2,x3,apex1,apex2:integer;
    y1,y2,y3:real;
begin
  writehdr ('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 TCS!');
    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 apex1:=1 to 3-(length(strr(doorpcr))) do write (' ');
  write (strr(doorpcr));
  writeln ('%'^R']');
  write (^R'Your Post/Call Ratio:     ['^S);
  for apex2:=1 to 3-(length(strr(x3))) do write (' ');
  write (strr(x3));
  writeln ('%'^R']');
  writeln;
  write (^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']');
  writeln;
  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;
  repeat
    q:=menu('Doors Command','DOORS','QLOIH%@');
    case q of
      2:listdoors;
      3:opendoor;
      4:getinfo;
      5:help ('Doors.hlp');
      6:sysopdoors
    end
  until hungupon or (q=1) or (filesize(dofile)=0);
  close (dofile)
end;

begin
end.