home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Jason Aller Floppy Collection
/
276.img
/
FORUM21S.ZIP
/
SUBS1.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-02-15
|
13KB
|
601 lines
{$R-,S-,I-,D-,T-,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;
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 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)
end;
writeln (tf,unam,' was on-line on ',datestr(now),' at ',timestr(now),' when:');
writeln (tf,errorstr);
writeln (tf);
close (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 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 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.