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

Pascal/Delphi Source File | 1989-02-11 | 12.4 KB | 604 lines

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

unit subs1;


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

interface

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


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


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 (time1,time2: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 ensureclosed;
Procedure clearbreak;
Procedure ansicolor (attrib:integer);
Procedure ansireset;
Procedure specialmsg (q:anystr);
Procedure writedataarea;
Procedure readdataarea;


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

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;
    tmp: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,tmp);
    val (tmp,n,s);
    if n=num then begin
      ioerrorstr:=tmp;
      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,'                        Forum 2.1 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,eventminute:integer;
ampm:string[1];
datefile:text;
begin
  if (length(eventtime)=0) or (length(eventbatch)=0) or
    (timedeventdate=datestr(now))
    then n:=1440
    else begin
      eventminute:=valu(copy(eventtime,1,pos(':',eventtime)-1))*60;
      eventminute:=eventminute+valu(copy(eventtime,pos(':',eventtime)+1,2));
      ampm:=copy(eventtime,pos(':',eventtime)+4,1);
      if (ampm='P') or (ampm='p') then eventminute:=eventminute+720;
      n:=eventminute-timer;
    end;
  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 write (' ')
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 withintime (time1,time2:sstr):boolean;
var t,a,u:integer;
ampm1,ampm2:string[1];
begin
  t:=timer;
{a=available  u=unavailable}
{compute minutes for time1}
  a:=valu(copy(time1,1,pos(':',time1)-1));
  if a=12 then a:=0 else a:=a*60;
  a:=a+valu(copy(time1,pos(':',time1)+1,2));
  ampm1:=copy(time1,pos(':',time1)+4,1);
  if (ampm1='P') or (ampm1='p') then a:=a+720;

{compute minutes for time2}
  u:=valu(copy(time2,1,pos(':',time2)-1));
  if u=12 then u:=0 else u:=u*60;
  u:=u+valu(copy(time2,pos(':',time2)+1,2));
  ampm2:=copy(time2,pos(':',time2)+4,1);
  if (ampm2='P') or (ampm2='p') then u:=u+720;


  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,'keepup')
    end else begin
      if online then bd:=baudrate else bd:=0;
      writeln (tf,'keepup ',unum,' ',bd,' ',ord(parity),' M')
    end;
  textclose (tf);
  writeln (usr,'  ( Type  RETURN  to return to Forum-PC )')
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,'Forum.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,'Forum.dat');
  rewrite (f);
  dos.filerec(f).recsize:=ofs(lastvariable)-ofs(firstvariable);
  write (f,firstvariable);
  close (f)
end;

Begin
end.