Category : BBS Programs+Doors
Archive   : TZBANK14.ZIP
Filename : TZCOMMON.PAS

 
Output of file : TZCOMMON.PAS contained in archive : TZBANK14.ZIP
{ COMMON.PAS for Turbo-Pascal 5.0 - will work with BBS monitoring DOS calls }
{ by Tony "Goose" Geisler, 1 @ 7312 }
{ This is a special version of COMMON5.PAS made for use with the TZCASINO }


{$R-} {Range checking off}
{$B+} {Boolean complete evaluation on}
{$S+} {Stack checking on}
{$I+} {I/O checking on}
{$N-} {No numeric coprocessor}
{$M 65500,16384,655360} {Turbo 3 default stack and heap}

Uses
Dos; {Unit found in TURBO.TPL}

TYPE
userrec=record
name:string[35];
realname:string[25];
laston:string[10];
linelen:byte;
pagelen:byte;
sl:byte;
age:byte;
sex:char;
callsign:string[8];
gold:longint;
uploaded:integer;
uk:longint;
downloaded:integer;
dk:longint;
timesaved:integer;
end;
regs=registers;

var
sysopf:text;
bf:array[1..1024] of char;
sysopffn,bbsname,sysopname:string[80];
gfilespath,datapath:string[80];
usernum,comrate:integer;
comport:byte;
incom,okansi,cs,so,hangup,expert:boolean;
timeon,timeleft,logontime:real;
thisuser:userrec;
scrbase,extratime:longint;
rp:regs;

function cstr(i:longint):string;
var c:string;
begin
str(i,c); cstr:=c;
end;

function timer:real;
var h,m,s,t:real;
begin
rp.ax:=44*256;
intr($21,rp);
h:=(rp.cx div 256);
m:=(rp.cx mod 256);
s:=(rp.dx div 256);
t:=(rp.dx mod 256);
timer:=h*3600+m*60+s+t/100;
end;

procedure delay(i:integer);
var tstart:real;
begin
tstart:=timer;
repeat until ((1000*(timer-tstart))>i);
end;

function nsl:real;
begin
if timer timeon:=timeon-24.0*3600.0;
nsl:=timeleft+extratime-(timer-timeon);
end;

function sysop1:boolean;
begin
if (thisuser.sl=255) or (so) then sysop1:=true
else sysop1:=false;
end;

function sysop:boolean;
begin
sysop:=sysop1;
end;

procedure sl1(i:string);
begin
{$I-}
writeln(sysopf,i);
if ioresult<>0 then begin end;
{$I+}
end;

procedure sysoplog(i:string);
begin
if (not sysop) or incom then
sl1(' '+i);
end;

function tch(i:string):string;
begin
if length(i)>2 then i:=copy(i,length(i)-1,2) else
if length(i)=1 then i:='0'+i;
tch:=i;
end;

function time:string;
var reg:registers;
zt:integer;
h,m,s:string[4];
begin
reg.ax:=$2c00; intr($21,Dos.Registers(reg));
zt:=reg.cx shr 8; h:=cstr(zt);
zt:=reg.cx mod 256; str(zt,m); str(reg.dx shr 8,s);
time:=tch(h)+':'+tch(m)+':'+tch(s);
end;

function date:string;
var reg:registers;
m,d,y:string[4];
begin
reg.ax:=$2a00; msdos(Dos.Registers(reg)); str(reg.cx,y);
str(reg.dx mod 256,d); str(reg.dx shr 8,m);
date:=tch(m)+'/'+tch(d)+'/'+tch(y);
end;

function value(I:string):integer;
var n,n1:integer;
begin
val(i,n,n1);
if n1<>0 then begin
i:=copy(i,1,n1-1);
val(i,n,n1)
end;
value:=n;
if i='' then value:=0;
end;

function strip(i:string):string;
var s:string;
i1:integer;
begin
s:='';
for i1 := 1 to length(i) do begin
if ((upcase(i(.i1.))>='A') and (upcase(i(.i1.))<='Z'))
then s:=s+upcase(i(.i1.));
if pos(i(.i1.),'1234567890')>0 then s:=s+i(.i1.);
end;
strip:=s;
end;

function ulstr(ts:string):string;
var s:string; i:integer; tf:boolean;
begin
s:=ts;
tf:=true;
for i:=1 to length(s) do
if s[i]<'A' then
tf:=true
else begin
if (s[i]<='Z') and not tf then
s[i]:=chr(ord(s[i])+32);
tf:=false;
end;
ulstr:=s;
end;

function nam:string;
begin
nam:=ulstr(thisuser.name)+' #'+cstr(usernum);
end;

function nam2:string;
begin
nam2:=ulstr(thisuser.name);
end;

function leapyear(yr:integer):boolean;
begin
leapyear:=(yr mod 4=0) and ((yr mod 100<>0) or (yr mod 400=0));
end;

function days(mo,yr:integer):integer;
var d:integer;
begin
d:=value(copy('312831303130313130313031',1+(mo-1)*2,2));
if (mo=2) and leapyear(yr) then d:=d+1;
days:=d;
end;

function daycount(mo,yr:integer):integer;
var m,t:integer;
begin
t:=0;
for m:=1 to (mo-1) do t:=t+days(m,yr);
daycount:=t;
end;

function daynum(dt:string):integer;
var d,m,y,t,c:integer;
begin
t:=0;
m:=value(copy(dt,1,2));
d:=value(copy(dt,4,2));
y:=value(copy(dt,7,2))+1900;
for c:=1985 to y-1 do
if leapyear(c) then t:=t+366 else t:=t+365;
t:=t+daycount(m,y)+(d-1);
daynum:=t;
if y<1985 then daynum:=0;
end;

function dat:string;
var ap,x,y:string; i:integer;
begin
case daynum(date) mod 7 of
0:x:='Tue';
1:x:='Wed';
2:x:='Thu';
3:x:='Fri';
4:x:='Sat';
5:x:='Sun';
6:x:='Mon';
end;
case value(copy(date,1,2)) of
1:y:='Jan';
2:y:='Feb';
3:y:='Mar';
4:y:='Apr';
5:y:='May';
6:y:='Jun';
7:y:='Jul';
8:y:='Aug';
9:y:='Sep';
10:y:='Oct';
11:y:='Nov';
12:y:='Dec';
end;
x:=x+' '+y+' '+copy(date,4,2)+', '+cstr(1900+value(copy(date,7,2)));
y:=time; i:=value(copy(y,1,2));
if i>11 then ap:='pm' else ap:='am';
if i>12 then i:=i-12;
if i=0 then i:=12;
dat:=cstr(i)+copy(y,3,3)+' '+ap+' '+x;
end;

procedure checkhangup;
begin
end;

procedure getkey(var c:char); forward;

procedure prompt(i:string); forward;

function wherex: integer;
begin
rp.ax:=$0300;
rp.bx:=0;
intr($10,rp);
wherex:=(rp.dx and $FF)+1;
end;

function wherey: integer;
begin
rp.ax:=$0300;
rp.bx:=0;
intr($10,rp);
wherey:=((rp.dx shr 8) and $FF)-2;
end;

procedure gotoxy(xc,yc : integer);
begin
rp.ax:=$0200;
rp.bx:=0;
rp.dx:=((yc+2) shl 8) + (xc-1);
intr($10,rp);
end;

procedure lfeed;
begin
if (wherey>=21) then
begin
rp.ax:=$0601;
rp.bx:=$0700;
rp.cx:=$0300;
rp.dx:=$194F;
intr($10,rp);
gotoxy(wherex,20);
end;
rp.ax:=$0200;
rp.dx:=$000A;
intr($21,rp);
end;


procedure topscr; forward;

procedure writec(c:char);
var i:boolean;
begin
if (c=#10) then lfeed else
begin
if (wherex=80) then if (wherey>=21) then begin
rp.ax:=$0601;
rp.bx:=$0700;
rp.cx:=$0300;
rp.dx:=$194F;
intr($10,rp);
gotoxy(80,20);
end;
rp.ax:=$0200;
rp.dx:=byte(c);
intr($21,rp);
if (c=#12) then begin
rp.ax:=$0600;
rp.bx:=$0700;
rp.cx:=$0300;
rp.dx:=$194F;
intr($10,rp);
topscr;
gotoxy(1,1);
end;
end;
end;

procedure writeline(i:string);
var j:byte;
begin
for j := 1 to length(i) do writec(i[j]);
lfeed;
writec(#13);
end;

procedure ansic(c:integer);
begin
if ((c>=0) and (c<=8)) then
begin
writec(#3);
writec(chr(ord('0')+c));
end;
end;

procedure sdc;
begin
ansic(0);
end;


procedure pausescr;
var i:integer; cc:char;
begin
ansic(3); prompt('[PAUSE]'); ansic(0);
getkey(cc);
for i:=1 to 7 do
prompt(#8#32#8);
end;

procedure prompt;
var c:integer; pp:byte; cc:char;
begin
if (not hangup) then
for c:=1 to length(i) do begin
if (i[c]=#10) then
ansic(0);
writec(i[c]);
end;
end;

procedure nl;
begin
writec(#13); writec(#10);
end;

procedure print(i:string);
begin
prompt(i);
nl;
end;

procedure prtx(x:integer; i:string);

begin
ansic(x); prompt(i); ansic(0);
end;

procedure prt(i:string);
begin
ansic(3); prompt(i); ansic(0);
end;

procedure ynq(i:string);
begin
ansic(5); prompt(i);
end;

procedure mpl(c:integer);
var n:integer; i:string;
begin
if okansi then begin
ansic(6);
i:='';
for n:=1 to c do i:=i+' ';
prompt(i);
prompt(#27+'['+cstr(c)+'D');
end;
end;

procedure tleft;
var x,y:integer;
begin
if timer if (nsl<0) then hangup:=true;
checkhangup;
end;


function empty:boolean;
begin
rp.ax:=$0b00;
intr($21,rp);
if (rp.ax and $00ff)=$00 then
empty:=true
else
empty:=false;
end;

function keypressed:boolean;
begin
keypressed:=not(empty);
end;

function inkey:char;
var ch:char;
begin
if (empty) then
inkey:=#0
else begin
rp.ax:=$0800;
intr($21,rp);
inkey:=chr(rp.ax and $00ff);
end;
end;

function inkeyt(i:real):char;
var ch:char;
ts,tx:real;
begin
ts:=timer;
repeat
if not(empty) then begin
rp.ax:=$0800;
intr($21,rp);
ch:=upcase(chr(rp.ax and $00ff));
if (ord(ch)>64) and (ord(ch)<91) then begin
inkeyt:=ch;
exit;
end;
end;
tx:=timer-ts;
if (tx<0) then tx:=tx+24.0*60*60;
until (tx>i);
inkeyt:=#0;
end;

procedure getkey;
var pp:byte;
begin
rp.ax:=$0800;
intr($21,rp);
c:=chr(rp.ax and $FF);
end;

procedure cls;
begin
writec(chr(12));
end;

procedure top_time;
var rl:real;
s:string;
i:integer;
begin
if (mem[scrbase:320]<>$CD) then begin
topscr;
exit;
end;
s := cstr(thisuser.gold);
while length(s)<6 do s := ' ' + s;
s := '$='+s;
for i:= 1 to length(s) do
mem[scrbase:2*(i-1)+64] := ord(s(.i.));
rl:=nsl/60.0;
str(rl:2:2,s);
s := 'T-'+s;
for i := 1 to length(s) do
mem[scrbase:2*(i-1)+296] := ord(s(.i.));
end;

function yn:boolean;
var c:char;
begin
if not hangup then begin
top_time;
ansic(1);
repeat
getkey(c);
c:=upcase(c);
until (c='Y') or (c='N') or (c=chr(13)) or hangup;
if c='Y' then begin print('Yes'); yn:=true; end else begin print('No'); yn:=false; end;
if hangup then yn:=false;
end;
end;

procedure input1(var i:string; ml:integer; tf,num:boolean);
var cp:integer;
c:char;
r:real;
begin
checkhangup;
if not hangup then begin
top_time;
r:=timer;
cp:=1;
repeat
getkey(c);
if c=#1 then r:=timer;
if not tf then c:=upcase(c);
if (c>=' ') and (c if (not(num) or (c=' ') or ((c>='0') and (c<='9'))) then begin
if cp<=ml then begin
i[cp]:=c;
cp:=cp+1;
prompt(c);
end;
end else else case ord(c) of
8:if cp>1 then begin
c:=chr(8);
prompt(#8#32#8);
cp:=cp-1;
end;
21,24:while cp<>1 do begin
cp:=cp-1;
prompt(#8#32#8);
end;
23: begin
if i[cp-1]=#32 then
while (cp<>1) and (i[cp-1]=#32) do begin
cp:=cp-1;
prompt(#8#32#8);
end else begin
while (cp<>1) and (i[cp-1]<>#32) do begin
cp:=cp-1;
prompt(#8#32#8);
end;
if (cp<>1) then begin
prompt(#8#32#8);
cp:=cp-1;
end;
end;
end;
end;
if (timer-r)>300.0 then hangup:=true;
until (c=#13) or (c=#14) or hangup;
i[0]:=chr(cp-1);
nl;
end;
end;

procedure input(var i:string; ml:integer);
begin
input1(i,ml,false,false);
end;


procedure inputl(var i:string; ml:integer);
begin
input1(i,ml,true,false);
end;

procedure inputn(var i:integer; ml:integer);
var i1:string;
begin
input1(i1,ml,true,true);
i:=value(i1);
end;

procedure inputt(var i:string; ml:integer; tl:real);
var cp:integer;
c:char;
r:real;
tout:boolean;
begin
top_time;
r:=timer;
cp:=1;
tout:=false;
repeat
getkey(c);
if c=#1 then r:=timer;
if (c>=' ') and (c if cp<=ml then begin
i[cp]:=c;
cp:=cp+1;
prompt(c);
end
else else case ord(c) of
8:if cp>1 then begin
c:=chr(8);
prompt(#8#32#8);
cp:=cp-1;
end;
21,24:while cp<>1 do begin
cp:=cp-1;
prompt(#8#32#8);
end;
23: begin
if i[cp-1]=#32 then
while (cp<>1) and (i[cp-1]=#32) do begin
cp:=cp-1;
prompt(#8#32#8);
end else begin
while (cp<>1) and (i[cp-1]<>#32) do begin
cp:=cp-1;
prompt(#8#32#8);
end;
if (cp<>1) then begin
prompt(#8#32#8);
cp:=cp-1;
end;
end;
end;
end;
if (timer-r)>tl then tout:=true;
until (c=#13) or (c=#14) or tout;
i[0]:=chr(cp-1);
if tout then i:='#0';
nl;
end;

procedure onek(var c:char; ch:string);
begin
top_time;
repeat
getkey(c);
c:=upcase(c);
until (pos(c,ch)>0) or hangup;
if hangup then c:=ch[1];
if c>#31 then print(''+c) else print('');
end;

procedure onekey(var c:char; ch:string);
begin
top_time;
repeat
getkey(c);
c:=upcase(c);
until (pos(c,ch)>0) or hangup;
if hangup then c:=ch[1];
if c>#31 then prompt(''+c);
end;

procedure key(var c:char; ch:string);
begin
top_time;
repeat
getkey(c);
c:=upcase(c);
until (pos(c,ch)>0) or hangup;
if hangup then c:=ch[1];
end;


procedure wkey(var abort,next:boolean);
var cc:char;
begin
while not (empty or hangup or abort) do begin
getkey(cc);
if (cc=' ') or (cc=chr(3)) or (cc=chr(24)) or (cc=chr(11)) then
abort:=true;
if (cc=chr(14)) then begin abort:=true; next:=true; end;
if (cc=chr(19)) or (cc='P') or (cc='p') then begin
getkey(cc);
end;
end;
end;

function ctim(rl:real):string;
var h,m,s:string;
i:integer;
begin
s:=tch(cstr(trunc(rl-int(rl/60.0)*60.0)));
m:=tch(cstr(trunc(int(rl/60.0)-int(rl/3600.0)*60.0)));
h:=cstr(trunc(rl/3600.0));
if length(h)=1 then h:='0'+h;
ctim:=h+':'+m+':'+s;
end;

function tlef:string;
begin
tlef:=ctim(nsl);
end;

function cstrr(rl:real; base:integer):string;
var c1,c2,c3:integer; i:string; r1,r2:real;
begin
if rl<=0.0 then cstrr:='0' else begin
r1:=ln(rl)/ln(1.0*base);
r2:=exp(ln(1.0*base)*(trunc(r1)));
i:='';
while (r2>0.999) do begin
c1:=trunc(rl/r2);
i:=i+copy('0123456789ABCDEF',c1+1,1);
rl:=rl-c1*r2;
r2:=r2/(1.0*base);
end;
cstrr:=i;
end;
end;

procedure printa1(i:string; var abort,next:boolean);
var c:integer;
begin
checkhangup;
if not hangup then begin
abort:=false; next:=false; c:=1;
if not empty then wkey(abort,next);
while (not abort) and (c-1 checkhangup;
if i[c]=#3 then
if i[c+1] in [#48..#56] then
if okansi then
ansic(ord(i[c+1])-48);
if not empty then wkey(abort,next);
if i[c]=#3 then
c:=c+1
else
writec(i[c]);
c:=c+1;
end;
end else abort:=true;
end;

procedure printa(i:string; var abort,next:boolean);
var s:string; p,op,rp,rop,nca:integer; crend:boolean;
begin
abort:=false;
crend:=(i[length(i)]=#1) and (i[length(i)-1]<>#3);
if crend then i:=copy(i,1,length(i)-1);
wkey(abort,next);
if i='' then nl;
while (i<>'') and (not abort) and (not hangup) do begin
rp:=0; nca:=thisuser.linelen-wherex-1; p:=0;
while (rp if i[p+1]=#8 then rp:=rp-1 else
if i[p+1]=#3 then
p:=p+1
else
if (i[p+1]<>#10) then rp:=rp+1;
p:=p+1;
end;
op:=p; rop:=rp;
if (rp>=nca) and (p while ((not (i[p] in [' ',#8,#10])) or (i[p-1]=#3)) and (p>1) do begin
rp:=rp-1; p:=p-1;
end;
if p=1 then
if not (i[1] in [' ',#8,#10]) then begin rp:=rp-1; p:=p-1; end;
end;
if abs(rop-rp)>=(thisuser.linelen div 2) then p:=op;
s:=copy(i,1,p); delete(i,1,p);
if (s[length(s)]=' ') then s[0]:=pred(s[0]);
printa1(s,abort,next);
if ((i='') and crend) or (i<>'') or abort then
nl
else
printa1(' ',abort,next);
end;
end;

procedure printacr(i:string; var abort,next:boolean);
begin
if not abort then
if i[length(i)]=#1 then
printa(i,abort,next)
else
printa(i+#1,abort,next);
end;

procedure pla(i:string; var abort:boolean);
var next:boolean;
begin
if not abort then begin
printa1(i,abort,next);
nl;
end
end;

procedure pfl(fn:string; var abort:boolean; cr:boolean);
var fil:text;
i:string;
next:boolean;
begin
if not hangup then begin
assign(fil,fn);
{$I-} reset(fil);
if ioresult<>0 then print('File not found.')
else begin
abort:=false;
while not eof(fil) and (not abort) and (not hangup) do begin
readln(fil,i);
if cr then
printacr(i,abort,next)
else
printa(i,abort,next);
end;
close(fil);
if ioresult<>0 then print('Error reading file.');
{$I+}
end;
nl;nl;
end;
end;

procedure printfile(fn:string);
var abort:boolean;
begin
pfl(fn,abort,true);
end;

procedure iport;
var f:text;
i:string;
n:integer;
x:real;
begin
if (wherey<1) then gotoxy(wherex,1);
if paramcount=0 then assign(f,'chain.txt') else
assign(f,paramstr(1));
{$I-} reset(f);
if ioresult=0 then begin
readln(f,usernum);
readln(f,thisuser.name);
readln(f,thisuser.realname);
readln(f,thisuser.callsign);
readln(f,thisuser.age);
readln(f,thisuser.sex);
readln(f,x);
thisuser.gold:=trunc(x);
readln(f,thisuser.laston);
readln(f,thisuser.linelen);
readln(f,thisuser.pagelen);
readln(f,thisuser.sl);
readln(f,n);
cs:=(n=1);
readln(f,n);
so:=(n=1);
readln(f,n);
okansi:=(n=1);
readln(f,n);
incom:=(n=1);
readln(f,timeleft);
readln(f,gfilespath);
readln(f,datapath);
readln(f,i);
sysopffn:=gfilespath+i;
readln(f,comrate);
readln(f,comport);
readln(f,bbsname);
readln(f,sysopname);
readln(f,i);
readln(f,i);
readln(f,thisuser.uk);
readln(f,thisuser.uploaded);
readln(f,thisuser.dk);
readln(f,thisuser.downloaded);
readln(f,i);
if ioresult<>0 then begin
print('Error reading parameter file.');
halt;
end;
readln(f,x);
if ioresult<>0 then begin
logontime:=timer;
expert:=false;
thisuser.timesaved:=0;
end else begin
logontime:=x;
readln(f,n);
expert:=(n=1);
readln(f,thisuser.timesaved);
end;
close(f);
n:=ioresult;
{$I+}
assign(sysopf,sysopffn);
SetTextBuf(sysopf,bf);
{$I-} append(sysopf);
if (ioresult<>0) then begin
rewrite(sysopf);
end;
{$I+}
end else begin
writeline('Parameter file not found.');
halt;
end;
hangup:=false;
timeon:=timer;
extratime:=0;
end;

procedure return;
begin
close(sysopf);
halt(0);
end;

procedure topscr;
var i: integer; s,s1:string; x:real;
begin
if mem[0:$417] = 7 then scrbase := $B000
else scrbase := $B800;
for i := 0 to 479 do
if ((i mod 2)=0) then
if (i>=320) then mem[scrbase:i] := $CD
else mem[scrbase:i] := $20
else if (i>=320) then mem[scrbase:i] := $0E
else mem[scrbase:i] := $1E;
s := nam;
for i := 1 to length(s) do
mem[scrbase:2*(i-1)] := ord(s(.i.));
for i := 1 to length(thisuser.realname) do
mem[scrbase:2*(i-1)+160] := ord(thisuser.realname(.i.));
s := cstr(thisuser.gold);
while length(s)<6 do s := ' ' + s;
s := '$='+s;
for i:= 1 to length(s) do
mem[scrbase:2*(i-1)+64] := ord(s(.i.));
for i:= 1 to length(thisuser.callsign) do
mem[scrbase:2*(i-1)+226] := ord(thisuser.callsign(.i.));
s := 'UL=';
s1 := cstr(thisuser.uploaded);
while length(s1)<4 do s1 := ' ' + s1;
s := s+s1+'/';
s1 := cstr(thisuser.uk);
while length(s1)<6 do s1 := ' ' + s1;
s := s+s1;
for i:= 1 to length(s) do
mem[scrbase:2*(i-1)+84] := ord(s(.i.));
s := 'DL=';
s1 := cstr(thisuser.downloaded);
while length(s1)<4 do s1 := ' ' + s1;
s := s+s1+'/';
s1 := cstr(thisuser.dk);
while length(s1)<6 do s1 := ' ' + s1;
s := s+s1;
for i:= 1 to length(s) do
mem[scrbase:2*(i-1)+244] := ord(s(.i.));
s := cstr(thisuser.sl);
while length(s)<3 do s := ' ' + s;
s := 'SL=' + s;
for i := 1 to length(s) do
mem[scrbase:2*(i-1)+116] := ord(s(.i.));
s := thisuser.sex+' '+cstr(thisuser.age);
for i := 1 to length(s) do
mem[scrbase:2*(i-1)+278] := ord(s(.i.));
for i := 1 to length(thisuser.laston) do
mem[scrbase:2*(i-1)+136] := ord(thisuser.laston(.i.));
x := (nsl/60.0);
str(x:2:2,s);
s := 'T-'+s;
for i := 1 to length(s) do
mem[scrbase:2*(i-1)+296] := ord(s(.i.));
end;

procedure backspace(i: integer);
var i1:integer;
begin
for i1 := 1 to i do
prompt(#8#32#8);
end;


  3 Responses to “Category : BBS Programs+Doors
Archive   : TZBANK14.ZIP
Filename : TZCOMMON.PAS

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/