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

Pascal/Delphi Source File | 1991-05-04 | 16.1 KB | 664 lines

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

{$DEFINE OVERLAY}

unit init;

interface

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

procedure validconfiguration;
procedure initboard (checkfiles30:boolean);

implementation

procedure validconfiguration;
var errs:integer;
    cnt:integer;
    flag:boolean;

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

  procedure ispath (var x:lstr; name:lstr);
  begin
    if not exist(x+'con') then begin
    writeln (usr,'Path bad: '+x+' - Creating.');
    mkdir (copy(x,1,length(x)-1))
   end;
  end;

  procedure isfilename (var xx:lstr; fn:lstr);
  begin
   if not exist(xx) then error (fn+' Filename bad: '+xx)
  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;

  procedure islongint (n,r1,r2:longint; name:lstr);
  begin
  if (n<r1) or (n>r2) then error ('Bad '+name+' value: '+strr(n));
  end;

  procedure dothat (name:lstr);
  begin
  if not exist (faqdir+name) then begin errs:=errs+1;
  writeln (usr,errs,'. '+name+' does not exist!'); end;
  end;

begin
  errs:=0;
  ispath (textdir,'Path to Message Base');
  ispath (uploaddir,'Path to Ascii Uploads');
  ispath (datadir,'Path to Xfer and Data Files');
  ispath (textfiledir,'Path to Menus, etc.');
  ispath (doordir,'Path to DOOR Batch Files');
  ispath (networkdir,'Path to Network Files');
  ispath (bbsdatadir,'Path to BBS Data Files');
  ispath (xferdir,'Path to Xfer Uploads');
  isstring (sysopname,'Sysop Name');
  islongint (defbaudrate,300,38400,'default Baud Rate');
  isinteger (usecom,1,4,'COM Port');
  isinteger (mintimeout,1,maxint,'input time out');
  isinteger (sysoplevel,1,maxint,'Co-Sysop Level');
  if (not exist (faqdir+'DSZ.COM')) and (not exist (faqdir+'DSZ.EXE')) then begin
  errs:=errs+1; writeln (usr,errs,'. DSZ.COM and DSZ.EXE do not exist!'); end;
  dothat ('PKZIP.EXE');
  dothat ('PKUNZIP.EXE');
  if (sblaster) and not (exist (faqdir+'VPLAY.EXE')) then begin errs:=errs+1;
  writeln (usr,errs,'. VPLAY.EXE does not exist!'); end;
  if not exist (faqdir+'REGISTER.DAT') then begin errs:=errs+1;
  writeln (usr,errs,'. REGISTER.DAT does not exist!');
  end else begin
  assign (regsfile,faqdir+'REGISTER.DAT');
  reset (regsfile);
  seek (regsfile,0);
  read (regsfile,reg);
  if (not match(sysopname,reg.handle)) then begin errs:=errs+1; writeln (usr,errs,'. Not Registered to Sysop!'); end;
  end;
  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 begin
  halt (e_badconfig);
 end;
end;

procedure initboard (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
    i:=ioresult;
    assign (mfile,bbsdatadir+'Mail.dat');
    close (mfile);
    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 (e_fatalfileerror)
        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
    rewrite (mapfile);
    if ioresult<>0 then begin
      writeln (usr,'Unable to create Message Base.');
      halt (e_fatalfileerror)
    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 (e_fatalfileerror)
    end;
    for cnt:=0 to 5 do write (tfile,buff)
  end;

  procedure opentfile;
  var i,j:integer;
  begin
    assign (tfile,textdir+'Text');
    assign (mapfile,textdir+'BlockMap');
    closetfile;
    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;

    procedure createuhfile;
    var cnt:integer;
    begin
      rewrite (uhfile);
      if ioresult<>0 then begin
        writeln (usr,'Unable to create the User Index File, run FAQ Again.');
        halt (e_fatalfileerror)
      end;
      seek (ufile,0);
      while not eof(ufile) do begin
        read (ufile,u);
        write (uhfile,u.handle)
      end
    end;

  begin
    assign (ufile,bbsdatadir+'Users.Dat');
    close (ufile);
    reset (ufile);
    n:=ioresult;
    if n=0 then begin
      numusers:=filesize(ufile)-1;
      assign (uhfile,bbsdatadir+'UserIndx.Dat');
      close (uhfile);
      reset (uhfile);
      if ioresult<>0
        then createuhfile
        else if filesize(uhfile)<>filesize(ufile) then begin
          close (uhfile);
          createuhfile
        end;
      exit
    end;
    close (ufile);
    n:=ioresult;
    rewrite (ufile);
    fillchar (u,sizeof(u),0);
    write (ufile,u);
    u.handle:=sysopname;
    u.defproto:='Z';
    u.note:='SysOp';
    u.realname:='';
    u.sex:='';
    u.age:=0;
    u.citystate:='';
    u.country:='';
    u.zipcode:='';
    if length(confm[1])>0 then u.defcon[1]:=true;
    if length(confm[2])>0 then u.defcon[2]:=true;
    if length(confm[3])>0 then u.defcon[3]:=true;
    if length(confm[4])>0 then u.defcon[4]:=true;
    if length(confm[5])>0 then u.defcon[5]:=true;
    if length(confx[1])>0 then u.defcon[6]:=true;
    if length(confx[2])>0 then u.defcon[7]:=true;
    if length(confx[3])>0 then u.defcon[8]:=true;
    if length(confx[4])>0 then u.defcon[9]:=true;
    if length(confx[5])>0 then u.defcon[10]:=true;
    u.macro1:=u.handle;
    u.macro2:=longname;
    u.macro3:='';
    u.password:='FAQ';
    u.phonenum:='1234567890';
    u.timetoday:=1000;
    u.level:=sysoplevel+1;
    u.udlevel:=sysoplevel+1;
    u.udpoints:=sysoplevel+1;
    u.gflevel:=sysoplevel+1;
    u.laston:=now;
    u.config:=[lowercase,eightycols,linefeeds,postprompts,asciigraphics,ansigraphics,showtime];
    u.emailannounce:=-1;
    u.infoform1:=-1;
    u.infoform2:=-1;
    u.infoform3:=-1;
    u.infoform4:=-1;
    u.infoform5:=-1;
    u.displaylen:=25;
    u.regularcolor:=defcolor2;
    u.statcolor:=defcolor3;
    u.inputcolor:=defcolor4;
    u.promptcolor:=defcolor1;
    u.bordercolor:=defcolor5;
    u.bstatuscolor:=defcolor6;
    u.menutype:=0;
    u.laston:=now;
    fillchar (u.access2,32,255);
    if useconmode then u.config:=u.config+[ansigraphics,fseditor];
    write (ufile,u);
    numusers:=1;
    createuhfile
  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,'Auto-deleting 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,bbsdatadir+'Syslog.dat');
    close (logfile);
    reset (logfile);
    if ioresult<>0 then begin
      rewrite (logfile);
      if ioresult<>0 then begin
        writeln (usr,'Unable to create log file');
        halt (e_fatalfileerror)
      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:='Entry Not Found: %'
    end;
    assign (tf,'syslog.faq');
    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.FAQ 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.FAQ file missing or invalid')
  end;

  procedure doesfilesequal30;
  var f:array [1..14] of file;
      cnt,i:integer;
  begin
    {$IFNDEF OVERLAY}
    for cnt:=1 to 14 do begin
      assign (f[cnt],'CON');
      reset (f[cnt]);
      i:=ioresult;
      if i<>0 then begin
        writeln (usr,^M^G^J'ERROR:  FILES=30 must be placed in your CONFIG.SYS');
        halt (e_files40)
      end
    end;
    for cnt:=14 downto 1 do close(f[cnt])
    {$ENDIF}
  end;

procedure readsysopmacros;
var ff:text;
    ummbobway,killer:integer;
begin
 assign (ff,faqdir+'SYSOP.MAC');
 ummbobway:=0;
 if not exist (faqdir+'SYSOP.MAC') then begin
  sysopmacro1:=sysopname;
  sysopmacro2:=longname;
  sysopmacro3:='Sysop Macro #3';
  sysopmacro4:='Sysop Macro #4';
  sysopmacro5:='Sysop Macro #5';
  sysopmacro6:='Sysop Macro #6';
  sysopmacro7:='Sysop Macro #7';
  sysopmacro8:='Sysop Macro #8';
  sysopmacro9:='Sysop Macro #9';
  sysopmacro10:='Sysop Macro #10';
 end else
 if exist (faqdir+'SYSOP.MAC') then begin
  reset (ff);
  readln (ff,sysopmacro1);
  readln (ff,sysopmacro2);
  readln (ff,sysopmacro3);
  readln (ff,sysopmacro4);
  readln (ff,sysopmacro5);
  readln (ff,sysopmacro6);
  readln (ff,sysopmacro7);
  readln (ff,sysopmacro8);
  readln (ff,sysopmacro9);
  readln (ff,sysopmacro10);
  close (ff);
 end
end;

procedure faq;

procedure faqone;
var
i:integer;
begin
for i:=21 downto 0 do begin
textcolor(15);
gotoxy(20,1+i);write(usr,'       ────────────────────       ');
gotoxy(20,2+i);clreol;
delay(10);
end;
end;

procedure faqtwo;
var
i:integer;
begin
for i:=21 downto 0 do begin
textcolor(1);
gotoxy(27,2+i);write(usr,'██████');
gotoxy(27,3+i);write(usr,'██    ');
gotoxy(27,4+i);write(usr,'██    ');
gotoxy(27,5+i);write(usr,'████  ');
gotoxy(27,6+i);write(usr,'██    ');
gotoxy(27,7+i);write(usr,'██    ');
gotoxy(27,8+i);write(usr,'██    ');
gotoxy(27,9+i);clreol;
delay(10);
end;
end;

procedure faqthree;
var
i:integer;
begin
for i:=21 downto 0 do begin
textcolor(9);
gotoxy(34,2+i);write(usr,' ████ ');
gotoxy(34,3+i);write(usr,'██  ██');
gotoxy(34,4+i);write(usr,'██  ██');
gotoxy(34,5+i);write(usr,'██  ██');
gotoxy(34,6+i);write(usr,'██  ██');
gotoxy(34,7+i);write(usr,'██████');
gotoxy(34,8+i);write(usr,'██  ██');
gotoxy(34,9+i);clreol;
delay(10);
end;
end;

procedure faqfour;
var
i:integer;
begin
for i:=21 downto 0 do begin
textcolor(11);
gotoxy(41,2+i);write(usr,' ████ ');
gotoxy(41,3+i);write(usr,'██  ██');
gotoxy(41,4+i);write(usr,'██  ██');
gotoxy(41,5+i);write(usr,'██  ██');
gotoxy(41,6+i);write(usr,'██  ▀█');
gotoxy(41,7+i);write(usr,'██ █▄ ');
gotoxy(41,8+i);write(usr,' ███▀█');
gotoxy(41,9+i);clreol;
delay(10);
end;
end;

procedure faqfive;
var
i:integer;
begin
for i:=21 downto 0 do begin
textcolor(15);
gotoxy(20,9+i);write(usr,'       ────────────────────       ');
gotoxy(20,10+i);clreol;
delay(10);
end;
end;

procedure faqsix;
var
i:integer;
begin
for i:=21 downto 0 do begin
textcolor(11);
gotoxy(27,10+i);write(usr,'  by The Firegod  ');
gotoxy(27,11+i);clreol;
gotoxy(27,11+i+1);clreol;
delay(20);
end;
end;

begin
faqone;
faqtwo;
faqthree;
faqfour;
faqfive;
faqsix;
end;

var k,klux:char;
    cnt:integer;
    result:word;
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;
  fillchar (urec,sizeof(urec),0);
  urec.config:=[lowercase,eightycols,asciigraphics,ansigraphics];
  iocode:=0;
  linecount:=0;
  sysopavail:=bytime;
  errorparam:='';
  errorproc:='';
  unam:='';
  chainstr:='';
  chatreason:='';
  sendstr:='';
  ulvl:=0;
  unum:=-1;
  logonunum:=-2;
  echoit:=true;
  break:=false;
  atmenu:=false;    { if you're at a menu or not }
  nochain:=false;   { doesn't continue with other write's etc.. }
  nobreak:=true;    { false before... }
  wordwrap:=false;  { does the wrapping of words to the next line }
  beginwithspacesok:=false;
  echodot:=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;
  statusbar:=false;
  timelock:=false;
  ingetstr:=false;
  modeminlock:=false;
  modemoutlock:=false;
  tempsysop:=false;
  sysnext:=false;
  forcehangup:=false;
  requestbreak:=false;
  disconnected:=false;
  bsent:=0; brecv:=0;
  notitle:=false;
  nosendprompt:=false;
  emailing:=false;
  periods:=false;
  validprotos:=['X','Y','Z','J','L','G','O','1','S','K','R','P','W','4'];
  cursection:=mainsysop;
  regularlevel:=0;
  if paramcount=1 then usecom:=2;
  setparam (usecom,baudrate,parity);
  doanswer;
  initwinds;
  for cnt:=1 to numsysfiles do initfile (sysfiles[cnt]);
  window (1,1,80,25);
  cursor (false);
  clrscr;
  for cnt:=1 to 25 do begin
  gotoxy (1,cnt);
  clreol;
  end;
  gotoxy (1,1);
  cursor (true);
  loadsyslogdat;
  readstatus;
  openufile;
  opentfile;
  openlogfile;
  openmfile;
  readsysopmacros;
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;

var r:registers;
begin
  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.