Jason Aller Floppy Collection/189.img/TCS120S.ZIP/SUBS1.PAS

Pascal/Delphi Source File | 1989-04-01 | 14KB | 634 lines

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

unit subs1;

interface

uses crt,dos,
     gensubs,gentypes,statret,configrt,modem;

var firstvariable:byte;

    local,online,chatmode,disconnected:boolean;

    unum,ulvl,baudrate:integer;
    unam:mstr;
    baudstr:sstr;
    parity:boolean;
    urec:userrec;

    logontime,logofftime,logonunum:integer;
    laston:longint;

    dots,nochain,break,xpressed,
    requestchat,requestcom,requestbreak,reqspecial,forcehangup,
    modeminlock,modemoutlock,timelock,tempsysop,splitmode,
    fromdoor,texttrap,printerecho,uselinefeeds,usecapsonly,
    dontstop,nobreak,wordwrap,beginwithspacesok,sysnext,ingetstr:boolean;
    regularlevel,numusers,curboardnum,lasty,
    linecount,curattrib,
    firstfree,lockedtime,iocode,buflen:integer;
    screenseg:word;
    cursection:configtype;
    curboardname:sstr;
    input,chainstr:anystr;
    chatreason,lastprompt,errorparam,errorproc:lstr;
    curboard:boardrec;
    mes:message;
    syslogdat:array [0..maxsyslogdat] of syslogdatrec;
    numsyslogdat:integer;
    returnto:char;

    lastvariable:byte;

    usr,direct,directin:text;

const numsysfiles=20;
var tfile:file of buffer;
    mapfile:file of integer;
    ufile:file of userrec;
    uhfile:file of mstr;
    mfile:file of mailrec;
    udfile:file of udrec;
    afile:file of arearec;
    bfile:file of bulrec;
    bdfile:file of boardrec;
    bifile:file of sstr;
    ffile:file of filerec;
    tofile:file of topicrec;
    chfile:file of choicerec;
    ddfile:file of baserec;
    efile:file of entryrec;
    dofile:file of doorrec;
    gfile:file of grouprec;
    logfile:file of logrec;
    abfile:file of abrec;
    usfile:file of userspecsrec;
    sysfiles:array [1..numsysfiles] of file absolute tfile;
    ttfile:text;
    blfile:file of bbsrec;
    rfile:file of rumorrec;

procedure writelog (m,s:integer; prm:lstr);
procedure files30;
function ioerrorstr (num:integer):lstr;
procedure error (errorstr,proc,param:lstr);
procedure fileerror (procname,filename:mstr);
procedure che;
function timeleft:integer;
function timetillevent:integer;
procedure settimeleft (tl:integer);
procedure tab (n:anystr; np:integer);
function yes:boolean;
function yesno (b:boolean):sstr;
function timeontoday:integer;
function isopen (var ff):boolean;
procedure textclose (var f:text);
procedure close (var ff);
function withintime (t1,t2:sstr):boolean;
function hungupon:boolean;
function sysopisavail:boolean;
function sysopavailstr:sstr;
function singularplural (n:integer; m1,m2:mstr):mstr;
function s (n:integer):sstr;
function numthings (n:integer; m1,m2:mstr):lstr;
procedure thereisare (n:integer);
procedure thereare (n:integer; m1,m2:mstr);
procedure assignbdfile;
procedure openbdfile;
procedure formatbdfile;
procedure closebdfile;
procedure opentempbdfile;
procedure closetempbdfile;
function keyhit:boolean;
function bioskey:char;
procedure readline (var xx);
procedure writereturnbat;
procedure execcomcom;
procedure ensureclosed;
procedure clearbreak;
procedure ansicolor (attrib:integer);
procedure ansireset;
procedure specialmsg (q:anystr);
procedure writedataarea;
procedure readdataarea;
procedure ansimusic (m:lstr);

implementation

procedure writelog (m,s:integer; prm:lstr);
var n:integer;
    l:logrec;
begin
  with l do begin
    menu:=m;
    subcommand:=s;
    when:=now;
    param:=copy(prm,1,41)
  end;
  seek (logfile,filesize(logfile));
  write (logfile,l)
end;

procedure files30;
begin
  writeln (usr,'You MUST put ''FILES=30'' in your CONFIG.SYS!!!');
  halt(4)
end;

function ioerrorstr (num:integer):lstr;
var tf:text;
    tmp1,tmp2:lstr;
    n,s:integer;
begin
  if num=243 then files30;
  assign (tf,'Ioerror.Lst');
  reset (tf);
  if ioresult<>0 then begin
    ioerrorstr:='[* Can''t open IOERROR.LST *]';
    exit
  end;
  while not eof(tf) do begin
    readln (tf,tmp1);
    val (tmp1,n,s);
    if n=num then begin
      readln (tf,tmp2);
      ioerrorstr:=tmp2;
      close (tf);
      exit
    end
  end;
  close (tf);
  ioerrorstr:='Unidentified I/O Error '+strr(num)
end;

procedure error (errorstr,proc,param:lstr);
var p,n:integer;
    pk:char;
    tf:text;
begin
  n:=ioresult;
  repeat
    p:=pos('%',errorstr);
    if p<>0 then begin
      pk:=errorstr[p+1];
      delete (errorstr,p,2);
      case upcase(pk) of
        '1':insert (param,errorstr,p);
        'P':insert (proc,errorstr,p);
        'I':insert (ioerrorstr(iocode),errorstr,p)
      end
    end
  until p=0;
  assign (tf,'ErrLog');
  append (tf);
  if ioresult<>0
    then
      begin
        close (tf);
        rewrite (tf);
        writeln (tf,'                        TCS '+ver+' Error Log                   ',datestr(now),' ',timestr(now));
        writeln (tf,'──────────────────────────────────────────────────────────────────────────────');
        writeln (tf);
      end;
  if unam='' then
  writeln (tf,'Someone was logging in on ',datestr(now), ' at ',timestr(now),' when:')
  else
  writeln (tf,unam,' was On-Line on ',datestr(now),' at ',timestr(now),' when:');
  writeln (tf,errorstr);
  writeln (tf);
  textclose (tf);
  n:=ioresult;
  writelog (0,4,errorstr);
  writeln (errorstr)
end;

procedure fileerror (procname,filename:mstr);
begin
  error ('%I accessing %1 in %P',procname,filename)
end;

procedure che;
var i:integer;
begin
  i:=ioresult;
  case i of
    0:;
    4:files30;
    else
      begin
        iocode:=i;
        error ('Unexpected I/O Error %I','','')
      end
  end
end;

function timeleft:integer;
var timeon:integer;
begin
  timeon:=timer-logontime;
  if timeon<0 then timeon:=timeon+1440;
  timeleft:=urec.timetoday-timeon
end;

function timetillevent:integer;
var n:integer;
begin
  if (length(eventtime)=0) or (length(eventbatch)=0) or
    (timedeventdate=datestr(now))
    then n:=1440
    else n:=timeval(eventtime)-timer;
  if n<0 then n:=n+1440;
  timetillevent:=n
end;

procedure settimeleft (tl:integer);
begin
  urec.timetoday:=timer+tl-logontime
end;

procedure tab (n:anystr; np:integer);
var cnt:integer;
begin
  write (n);
  for cnt:=length(n) to np-1 do begin
   if periods then write ('.') else write (' ');
  end;
  periods:=false
end;

function yes:boolean;
begin
  if length(input)=0
    then yes:=false
    else yes:=upcase(input[1])='Y'
end;

function yesno (b:boolean):sstr;
begin
  if b
    then yesno:='Yes'
    else yesno:='No'
end;

function timeontoday:integer;
var timeon:integer;
begin
  timeon:=timer-logontime;
  if timeon<0 then timeon:=timeon+1440;
  timeontoday:=timeon
end;

function isopen (var ff):boolean;
var fi:fib absolute ff;
begin
  isopen:=fi.handle<>0
end;

procedure textclose (var f:text);
var n:integer;
    fi:fib absolute f;
begin
  if isopen(f)
    then system.close (f);
  fi.handle:=0;
  n:=ioresult
end;

procedure close (var ff);
var f:file absolute ff;
    fi:fib absolute ff;
    n:integer;
begin
  if isopen(f)
    then system.close (f);
  fi.handle:=0;
  n:=ioresult;
end;

function withintime (t1,t2:sstr):boolean;
var t,a,u:integer;
begin
  t:=timer;
  a:=timeval(t1);
  u:=timeval(t2);
  if a<=u
    then withintime:=(t>=a) and (t<=u)
    else withintime:=(t>=a) or (t<=u)
end;

function hungupon:boolean;
begin
  hungupon:=forcehangup or
                (online and not (carrier or modeminlock or modemoutlock))
end;

function sysopisavail:boolean;
begin
  case sysopavail of
    available:sysopisavail:=true;
    notavailable:sysopisavail:=false;
    bytime:sysopisavail:=withintime (availtime,unavailtime)
  end
end;

function sysopavailstr:sstr;
const strs:array [available..notavailable] of string[9]=
        ('Yes','By time: ','No');
var tstr:sstr;
    tmp:availtype;
begin
  tstr:=strs[sysopavail];
  if sysopavail=bytime
    then
      begin
        if sysopisavail
          then tmp:=available
          else tmp:=notavailable;
        tstr:=tstr+strs[tmp]
      end;
  sysopavailstr:=tstr
end;

function singularplural (n:integer; m1,m2:mstr):mstr;
begin
  if n=1
    then singularplural:=m1
    else singularplural:=m2
end;

function s (n:integer):sstr;
begin
  s:=singularplural (n,'','s')
end;

function numthings (n:integer; m1,m2:mstr):lstr;
begin
  numthings:=strr(n)+' '+singularplural (n,m1,m2)
end;

procedure thereisare (n:integer);
begin
  write ('There ');
  if n=1
    then write ('is 1 ')
    else
      begin
        write ('are ');
        if n=0
          then write ('no ')
          else write (n,' ')
       end
end;

procedure thereare (n:integer; m1,m2:mstr);
begin
  thereisare (n);
  if n=1
    then write (m1)
    else write (m2);
  writeln ('.')
end;

procedure assignbdfile;
begin
  assign (bdfile,boarddir+'boarddir');
  assign (bifile,boarddir+'bdindex')
end;

procedure openbdfile;
var i:integer;
begin
  closebdfile;
  assignbdfile;
  reset (bdfile);
  i:=ioresult;
  reset (bifile);
  i:=i or ioresult;
  if i<>0 then formatbdfile
end;

procedure formatbdfile;
begin
  close (bdfile);
  close (bifile);
  assignbdfile;
  rewrite (bdfile);
  rewrite (bifile)
end;

procedure closebdfile;
begin
  close (bdfile);
  close (bifile)
end;

var wasopen:boolean;

procedure opentempbdfile;
begin
  wasopen:=isopen(bdfile);
  if not wasopen then openbdfile
end;

procedure closetempbdfile;
begin
  if not wasopen then closebdfile
end;

function keyhit:boolean;
var r:registers;
begin
  r.ah:=1;
  intr ($16,r);
  keyhit:=(r.flags and 64)=0
end;

function bioskey:char;
var r:registers;
begin
  r.ah:=0;
  intr ($16,r);
  if r.al=0
    then bioskey:=chr(r.ah+128)
    else bioskey:=chr(r.al)
end;

procedure readline (var xx);
var a:anystr absolute xx;
    l:byte absolute xx;
    k:char;

  procedure backspace;
  begin
    if l>0 then begin
      write (usr,^H,' ',^H);
      l:=l-1
    end
  end;

  procedure eraseall;
  begin
    while l>0 do backspace
  end;

  procedure addchar (k:char);
  begin
    if l<buflen then begin
      l:=l+1;
      a[l]:=k;
      write (usr,k)
    end
  end;

begin
  l:=0;
  repeat
    k:=bioskey;
    case k of
      #8:backspace;
      #27:eraseall;
      #32..#126:addchar(k)
    end
  until k=#13;
  writeln (usr)
end;

procedure writereturnbat;
var tf:text;
    bd:integer;
    tmp:lstr;
begin
  assign (tf,'return.bat');
  rewrite (tf);
  getdir (0,tmp);
  writeln (tf,'cd '+tmp);
  if unum=0
    then begin
      writeln (tf,'PAUSE   ***  No one was logged in!');
      writeln (tf,'main.bat')
    end else begin
      if online then bd:=baudrate else bd:=0;
      writeln (tf,'main.bat ',unum,' ',bd,' ',ord(parity),' M')
    end;
  textclose (tf);
  writeln (usr,'  [ Type ''RETURN'' to return to TCS ]')
end;

procedure execcomcom;
var hosehead:anystr;
begin
 hosehead:=commandcom;
 clrscr;
 gotoxy (1,1);
 write (usr,'  [ Type ''EXIT'' to return to TCS ]');
 swapvectors;
 exec (hosehead,'');
 swapvectors;
 { chdir (forumdir); }
end;

procedure ensureclosed;
var cnt,i:integer;
begin
  stoptimer (numminsidle);
  stoptimer (numminsused);
  writestatus;
  textclose (ttfile);
  i:=ioresult;
  for cnt:=1 to numsysfiles do begin
    close (sysfiles[cnt]);
    i:=ioresult
  end
end;

procedure clearbreak;
begin
  break:=false;
  xpressed:=false;
  dontstop:=false;
  nobreak:=false
end;

procedure ansicolor (attrib:integer);
var tc:integer;
const colorid:array [0..7] of byte=(30,34,32,36,31,35,33,37);
begin
  if attrib=0 then begin
    textcolor (7);
    textbackground (0)
  end else begin
    textcolor (attrib and $8f);
    textbackground ((attrib shr 4) and 7)
  end;
  if not (ansigraphics in urec.config) or (attrib=0) or (usecapsonly)
     or (attrib=curattrib) or break then exit;
  curattrib:=attrib;
  write (direct,#27'[0');
  tc:=attrib and 7;
  if tc<>7 then write (direct,';',colorid[tc]);
  tc:=(attrib shr 4) and 7;
  if tc<>0 then write (direct,';',colorid[tc]+10);
  if (attrib and 8)=8 then write (direct,';1');
  if (attrib and 128)=128 then write (direct,';5');
  write (direct,'m')
end;

procedure ansireset;
begin
  textcolor (7);
  textbackground (0);
  if usecapsonly then exit;
  if urec.regularcolor<>0 then begin
    ansicolor (urec.regularcolor);
    exit
  end;
  if (not (ansigraphics in urec.config)) or (curattrib=0) or break then exit;
  write (direct,#27'[0m');
  curattrib:=0
end;

procedure specialmsg (q:anystr);
begin
  textcolor (outlockcolor);
  textbackground (0);
  writeln (usr,q);
  if not modemoutlock then textcolor (normbotcolor)
end;

procedure readdataarea;
var f:file of byte;
begin
  assign (f,'TCS.Dat');
  reset (f);
  if ioresult<>0
    then unum:=-1
    else begin
      dos.filerec(f).recsize:=ofs(lastvariable)-ofs(firstvariable);
      read (f,firstvariable);
      close (f)
    end
end;

procedure writedataarea;
var f:file of byte;
begin
  assign (f,'TCS.Dat');
  rewrite (f);
  dos.filerec(f).recsize:=ofs(lastvariable)-ofs(firstvariable);
  write (f,firstvariable);
  close (f)
end;

procedure ansimusic (m:lstr);
var a,b,c:string;
begin
 a:=m;
 if length(a)<1 then exit;
 write (direct,#27'[M',a,#14);
end;

begin
end.