Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/FORUM25C.ZIP/OVERRET2.PAS

Pascal/Delphi Source File | 1988-12-27 | 10.2 KB | 446 lines

{$R-,S-,I-,V-,B-,N-,L- }
{$O+}

unit overret2;


{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}

interface

uses crt,
     dos,
     gentypes,
     modem,
     statret,
     configrt,
     gensubs,
     subs1,
     windows,
     subs2;

{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}


Procedure validconfiguration;
Procedure init (checkfiles30:boolean);


{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}

implementation

{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}


Procedure validconfiguration;
VAR errs:integer;
    cnt:integer;
    flag:boolean;

  Procedure error (q:anystr);
  begin
    if errs=0 then writeln (usr,'Configuration Errors:');
    errs:=errs+1;
    writeln (usr,errs,'. ',q)
  end;

  Procedure ispath (VAR x:lstr; name:lstr);
  begin
    if not exist(x+'con') then error (name+' path bad: '+x)
  end;

  Procedure isstring (x:anystr; name:lstr);
  VAR cnt:integer;
  begin
    if length(x)=0 then begin
      error (name+' has not been set!');
      exit
    end;
    for cnt:=1 to length(x) do if not (x[cnt] in [#32..#255])
      then begin
        error ('Bad '+name+' string');
        exit
      end
  end;

  Procedure isinteger (n,r1,r2:integer; name:lstr);
  begin
    if (n<r1) or (n>r2) then error ('Bad '+name+' value: '+strr(n))
  end;

begin
  errs:=0;
  isstring (sysopname,'Sysop name');
  ispath (textdir,'Path to message base');
  ispath (uploaddir,'Path to ASCII uploads');
  ispath (boarddir,'Path to sub-board files');
  ispath (textfiledir,'Path to text files');
  ispath (doordir,'Path to door batch files');
  isinteger (defbaudrate,110,9600,'default baud rate');
  isinteger (usecom,1,2,'COM: port');
  isinteger (mintimeout,1,maxint,'input time out');
  isinteger (sysoplevel,1,maxint,'co-sysop level');
  flag:=true;
  for cnt:=1 to 100 do if flag and (usertime[cnt]<1) then begin
    flag:=false;
    error ('Time per day has non-positive entries')
  end;
  if errs>0 then halt(99)
end;

Procedure init (checkfiles30:boolean);

  Procedure formatmfile;
  VAR m:mailrec;
  begin
    rewrite (mfile);
    fillchar (m,sizeof(m),255);
    write (mfile,m)
  end;

  Procedure openmfile;
  VAR i:integer;
  begin
    close (mfile);
    i:=ioresult;
    assign (mfile,'Mail');
    reset (mfile);
    i:=ioresult;
    if i<>0
      then if i=2
        then formatmfile
        else begin
          writeln (usr,'Fatal error: Unable to open mail file!');
          halt (255)
        end
  end;

  Procedure closetfile;
  VAR n:integer;
  begin
    close (tfile);
    n:=ioresult;
    close (mapfile);
    n:=ioresult
  end;

  Procedure formattfile;
  VAR cnt,p:integer;
      r:real;
      buff:buffer;
      x:string[1];
  const dummystr:sstr='Blank!! ';
  begin
    write (usr,'Create new message base (y/n)? ');
    buflen:=1;
    readline (x);
    if (length(x)=0) or (upcase(x[1])<>'Y') then halt (90);
    rewrite (mapfile);
    if ioresult<>0 then begin
      writeln (usr,'Unable to create message base.');
      halt (91)
    end;
    p:=-2;
    for cnt:=0 to numsectors do write (mapfile,p);
    p:=1;
    for cnt:=1 to sectorsize do begin
      buff[cnt]:=dummystr[p];
      p:=p+1;
      if p>length(dummystr) then p:=1
    end;
    rewrite (tfile);
    if ioresult<>0 then begin
      writeln (usr,'Unable to create message base.');
      halt (91)
    end;
    for cnt:=0 to 5 do write (tfile,buff)
  end;

  Procedure opentfile;
  VAR i,j:integer;
  begin
    closetfile;
    assign (tfile,textdir+'Text');
    assign (mapfile,textdir+'BlockMap');
    reset (tfile);
    i:=ioresult;
    reset (mapfile);
    j:=ioresult;
    if (i<>0) or (j<>0) then formattfile;
    firstfree:=-1
  end;

  Procedure openufile;
  VAR u:userrec;
      n,cnt:integer;
  begin
    close (ufile);
    assign (ufile,'Users');
    reset (ufile);
    n:=ioresult;
    if n=0 then begin
      numusers:=filesize(ufile)-1;
      exit
    end;
    close (ufile);
    n:=ioresult;
    rewrite (ufile);
    fillchar (u,sizeof(u),0);
    write (ufile,u);
    u.handle:=sysopname;
    u.password:='Sysop';
    u.timetoday:=9999;
    u.level:=sysoplevel+1;
    u.udlevel:=10000;
    u.udpoints:=10000;
    u.config:=[lowercase,eightycols,linefeeds,postprompts];
    u.emailannounce:=-1;
    u.infoform:=-1;
    u.displaylen:=24;
    fillchar (u.access2,32,255);
    if useconmode
      then u.config:=u.config+[ansigraphics]
      else u.config:=u.config+[asciigraphics];
    write (ufile,u);
    numusers:=1
  end;

  Procedure initfile (VAR f:file);
  VAR fi:fib absolute f;
  begin
    fi.handle:=0;
    fi.name[0]:=chr(0)
  end;

  Procedure openlogfile;

    Procedure autodeletesyslog;
    VAR mx,cnt:integer;
        l:logrec;
    begin
      dontanswer;
      write (usr,'Autodeleting system log ... please stand by ... ');
      mx:=filesize(logfile) div 2;
      for cnt:=1 to mx do begin
        seek (logfile,cnt+mx-1);
        read (logfile,l);
        seek (logfile,cnt-1);
        write (logfile,l)
      end;
      seek (logfile,mx-1);
      truncate (logfile);
      writeln (usr,'Done.');
      doanswer
    end;

  begin
    assign (logfile,'Syslog');
    reset (logfile);
    if ioresult<>0 then begin
      rewrite (logfile);
      if ioresult<>0 then begin
        writeln (usr,'Unable to create log file');
        halt (92)
      end
    end;
    if filesize(logfile)>maxsyslogsize then autodeletesyslog
  end;

  Procedure loadsyslogdat;
  VAR tf:text;
      q:lstr;
      b1,b2,p,s,n:integer;
  begin
    numsyslogdat:=0;
    with syslogdat[0] do begin
      menu:=0;
      subcommand:=0;
      text:='SYSLOG.DAT entry not found: %'
    end;
    assign (tf,'syslog.dat');
    reset (tf);
    if ioresult=0 then begin
      while not eof(tf) do begin
        readln (tf,q);
        p:=pos(' ',q);
        if p<>0 then begin
          val (copy(q,1,p-1),b1,s);
          if s=0 then begin
            delete (q,1,p);
            p:=pos(' ',q);
            if p<>0 then begin
              val (copy(q,1,p-1),b2,s);
              if s=0 then begin
                delete (q,1,p);
                if numsyslogdat=maxsyslogdat
                  then writeln (usr,'Too many SYSLOG.DAT entries')
                  else begin
                    numsyslogdat:=numsyslogdat+1;
                    with syslogdat[numsyslogdat] do begin
                      menu:=b1;
                      subcommand:=b2;
                      text:=copy(q,1,30)
                    end
                  end
              end
            end
          end
        end
      end;
      textclose (tf)
    end;
    if numsyslogdat=0 then writeln (usr,'SYSLOG.DAT file missing or invalid')
  end;

  Procedure doesfilesequal30;
  VAR f:array [1..13] of file;
      cnt,i:integer;
  begin
    for cnt := 1 to 13 do begin
      assign (f[cnt],'CON');
      reset (f[cnt]);
      i:=ioresult;
      if i<>0 then begin

        Ext_code := 2;
        Halt(e_Extended_code)
      end
    end;
    for cnt := 13 downto 1 do close(f[cnt])
  end;

VAR k:char;
    cnt:integer;
begin
  with textrec(system.output) do begin
    openfunc:=@opendevice;
    closefunc:=@closedevice;
    flushfunc:=@writechars;
    inoutfunc:=@writechars
  end;
  with textrec(system.input) do begin
    inoutfunc:=@readcharfunc;
    openfunc:=@ignorecommand;
    closefunc:=@ignorecommand;
    flushfunc:=@ignorecommand
  end;
  if checkfiles30 then doesfilesequal30;
  if not driverpresent then
    Begin
     Ext_code := 1;
     Halt(e_Extended_code);
    End;
  FillChar (urec,sizeof(urec),0);
  urec.config:=[lowercase,eightycols,asciigraphics];
  iocode:=0;
  linecount:=0;
  sysopavail:=bytime;
  errorparam:='';
  errorproc:='';
  unam:='';
  chainstr:='';
  chatreason:='';
  ulvl:=0;
  unum:=-1;
  logonunum:=-2;
  break:=false;
  nochain:=false;
  nobreak:=false;
  wordwrap:=false;
  beginwithspacesok:=false;
  dots:=false;
  online:=false;
  local:=true;
  chatmode:=false;
  texttrap:=false;
  printerecho:=false;
  fillchar (urec,sizeof(urec),0);
  usecapsonly:=false;
  uselinefeeds:=true;
  curattrib:=0;
  buflen:=80;
  baudrate:=defbaudrate;
  parity:=false;
  timelock:=false;
  ingetstr:=false;
  modeminlock:=false;
  modemoutlock:=false;
  tempsysop:=false;
  sysnext:=false;
  forcehangup:=false;
  requestbreak:=false;
  disconnected:=false;
  cursection:=mainsysop;
  regularlevel:=0;
  setparam (usecom,baudrate,parity);
  doanswer;
  initwinds;
  for cnt:=1 to numsysfiles do initfile (sysfiles[cnt]);
  cls;
  loadsyslogdat;
  readstatus;
  openufile;
  opentfile;
  openlogfile;
  openmfile
end;

Procedure assignname (VAR t:text; nm:lstr);
begin
  with textrec(t) do begin
    move (nm[1],name,length(nm));
    name[length(nm)]:=#0
  end
end;


{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}

{initialization}

{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}


VAR r:registers;


begin
  textmode (bw80);
  checkbreak:=false;
  checkeof:=false;
  directvideo:=directvideomode;
  checksnow:=checksnowmode;
  r.ah:=15;
  intr ($10,r);

  if r.al=7
    then screenseg:=$b000
    else screenseg:=$b800;
  textrec(system.input).mode:=fminput;
  move (output,usr,sizeof(text));           { Set up device drivers }
  move (output,direct,sizeof(text));
  move (system.input,directin,sizeof(text));
  with textrec(direct) do begin
    openfunc:=@opendevice;
    closefunc:=@closedevice;
    flushfunc:=@directoutchars;
    inoutfunc:=@directoutchars;
    bufptr:=@buffer
  end;
  with textrec(directin) do begin
    mode:=fminput;
    inoutfunc:=@directinchars;
    openfunc:=@ignorecommand;
    flushfunc:=@ignorecommand;
    closefunc:=@ignorecommand;
    bufptr:=@buffer
  end;
  with textrec(usr) do bufptr:=@buffer;
  assignname (usr,'USR');
  assignname (direct,'DIRECT');
  assignname (directin,'DIRECT-IN');
  assignname (system.output,'OUTPUT');
  assignname (system.input,'INPUT');
End.