home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Jason Aller Floppy Collection
/
189.img
/
TCS120S.ZIP
/
FORUMTRM.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1989-02-25
|
19KB
|
817 lines
{$R-,S-,I-,D-,F+,V-,B-,N-,L+,O+ }
{$M 65500,0,0 }
unit forumtrm;
interface
uses crt,printer,
gentypes,modem,configrt,gensubs,subs1,subs2,windows,mainr2,protocol;
procedure forumterm;
implementation
procedure forumterm;
var dirloaded:boolean;
type dialrec=record
bbsname:string[35];
phonenum:string[14];
baudrate:integer;
databits:integer;
stopbits:integer;
dummy:byte;
scriptfile:string[12]
end;
prefixtype=(plus,minus,bang,atsign,poundsign);
var directory:array [1..200] of dialrec;
dfile:file of dialrec;
prefixes:array [prefixtype] of lstr;
funckeys:array [1..10] of lstr;
procedure loaddirectory;
var cnt:integer;
d:dialrec;
begin
assign (dfile,'TCS.Fon');
reset (dfile);
if ioresult<>0 then begin
close (dfile);
cnt:=ioresult;
rewrite (dfile);
fillchar (d,sizeof(d),0);
d.baudrate:=defbaudrate;
d.databits:=8;
d.stopbits:=1;
for cnt:=1 to 200 do begin
write (dfile,d);
directory[cnt]:=d
end
end else for cnt:=1 to 200 do read (dfile,directory[cnt])
end;
procedure savedirectory;
var cnt:integer;
begin
seek (dfile,0);
for cnt:=1 to 200 do write (dfile,directory[cnt])
end;
procedure writedfile (n:integer);
begin
seek (dfile,n-1);
write (dfile,directory[n])
end;
procedure loadfunckeys;
var kfile:text;
cnt:integer;
begin
for cnt:=1 to 10 do funckeys[cnt]:='';
assign (kfile,'TCS.Key');
reset (kfile);
if ioresult<>0 then exit;
cnt:=0;
while (not eof(kfile)) and (cnt<10) do begin
cnt:=cnt+1;
readln (kfile,funckeys[cnt])
end;
close (kfile)
end;
procedure savefunckeys;
var kfile:text;
cnt:integer;
begin
assign (kfile,'TCS.Key');
rewrite (kfile);
for cnt:=1 to 10 do writeln (kfile,funckeys[cnt]);
close (kfile)
end;
procedure loadprefixes;
var pfile:text;
cnt:integer;
p:prefixtype;
fnd:boolean;
begin
assign (pfile,'TCS.Pre');
reset (pfile);
fnd:=ioresult=0;
for p:=plus to poundsign do
if fnd
then readln (pfile,prefixes[p])
else prefixes[p]:='';
textclose (pfile);
cnt:=ioresult
end;
procedure saveprefixes;
var pfile:text;
p:prefixtype;
cnt:integer;
begin
assign (pfile,'TCS.Pre');
rewrite (pfile);
for p:=plus to poundsign do
writeln (pfile,prefixes[p]);
textclose (pfile);
cnt:=ioresult
end;
procedure superprint (q:lstr; attribute:integer);
var ss,loc:integer;
begin
textcolor (attribute and 15);
textbackground (attribute shr 4);
write (q);
(*****
loc:=(wherey*80+wherex-81) shl 1;
ss:=screenseg;
inline (
!{! ^179. New stack conventions require that many Inlines be rewritten.}
$06/ { PUSH ES }
$1E/ { PUSH DS }
$8B/$86/ss/ { MOV AX,ss[BP] }
$8E/$C0/ { MOV ES,AX }
$8C/$D0/ { MOV AX,SS }
$8E/$D8/ { MOV DS,AX }
$B8/q/ { MOV AX,q }
$01/$E8/ { ADD AX,BP }
$89/$C6/ { MOV SI,AX }
$8B/$86/loc/ { MOV AX,loc[BP] }
$89/$C7/ { MOV DI,AX }
$FC/ { CLD }
$AC/ { LODSB }
$30/$E4/ { XOR AH,AH }
$89/$C1/ { MOV CX,AX }
$8B/$86/attribute/ { MOV AX,attribute[BP] }
$88/$C4/ { MOV AH,AL }
$AC/ { LODSB }
$AB/ { STOSW }
$E2/$FC/ { LOOP <=back to LODSB=> }
$1F/ { POP DS }
$07 { POP ES } )
****)
end;
procedure displayentry (n,y:integer);
var q:lstr;
d:^dialrec;
procedure put (fragment:lstr; ps:integer);
begin
move (fragment[1],q[ps],length(fragment))
end;
var t:mstr;
begin
fillchar (q[1],80,32);
q[0]:=#80;
if n=0 then put ('No number specified',6) else begin
d:=addr(directory[n]);
str (n:3,t);
put (t+'.',1);
put (d^.bbsname,6);
t:=d^.phonenum;
while length(t)<14 do t:=' '+t;
put (t,42);
t:=strr(d^.baudrate);
if d^.databits=8 then t:=t+',N,8,' else t:=t+',E,7,';
if d^.stopbits=1 then t:=t+'1' else t:=t+'2';
put (t,57)
end;
gotoxy (1,y);
superprint (q,normtopcolor)
end;
procedure dialdirectory;
var page:integer;
done:boolean;
procedure refreshnums;
var cnt,x,y:integer;
begin
x:=wherex;
y:=wherey;
for cnt:=1 to 10 do displayentry (cnt+page,cnt);
gotoxy (x,y)
end;
procedure fullrefresh;
begin
refreshnums;
gotoxy (1,13);
write (usr,'Commands: PgUp PgDn D)ial R)evise Q)uit E)dit-prefixes');
clreol
end;
procedure changepage (d:integer);
begin
page:=page+d;
if page<0 then page:=page+200;
if page>199 then page:=page-200;
refreshnums
end;
function getnumber:mstr;
var q:mstr;
p:byte absolute q;
k:char;
procedure addchar (k:char);
begin
if p=20 then exit;
write (usr,k);
q:=q+k
end;
procedure delchar;
begin
if p=0 then exit;
write (usr,^H' '^H);
p:=p-1
end;
begin
gotoxy (20,14);
write (usr,'Number? ');
clreol;
p:=0;
repeat
k:=bioskey;
case k of
#201:changepage (-10);
#209:changepage (10);
'0'..'9','+','-','!','@','#',',':addchar (k);
#8:delchar
end
until k=#13;
getnumber:=q
end;
procedure dialdirectory;
var numstrs:array [1..10] of lstr;
ns:array [1..10] of integer;
num,cnt,n,p,pn:integer;
r:longint;
d:dialrec;
dstr:lstr;
inp,temp:mstr;
k:char;
procedure addprefix (p:prefixtype);
begin
dstr:=dstr+prefixes[p]
end;
begin
num:=0;
gotoxy (1,13);
write (usr,
'Please choose up to 10 numbers, separate with CR, blank to end.');
clreol;
repeat
inp:=getnumber+' ';
dstr:='';
temp:='';
n:=0;
for p:=1 to length(inp) do begin
k:=inp[p];
if k in ['0'..'9']
then temp:=temp+k
else
begin
if temp<>'' then begin
n:=valu(temp);
if (n<1) or (n>200)
then dstr:=dstr+temp
else dstr:=dstr+directory[n].phonenum;
temp:=''
end;
case k of
'+':addprefix(plus);
'-':addprefix(minus);
'!':addprefix(bang);
'@':addprefix(atsign);
'#':addprefix(poundsign)
end
end
end;
if dstr<>'' then begin
num:=num+1;
ns[num]:=n;
numstrs[num]:=dstr
end
until (num=10) or (dstr='');
if num=0 then begin
fullrefresh;
exit
end;
for cnt:=1 to num do displayentry (ns[cnt],cnt);
for cnt:=num+1 to 10 do begin
gotoxy (1,cnt);
clreol
end;
cnt:=0;
repeat
cnt:=cnt+1;
if cnt>num then cnt:=1;
n:=ns[cnt];
displayentry (n,13);
gotoxy (1,14);
write (usr,'Dialing: ');
clreol;
if n<>0 then begin
baudrate:=directory[n].baudrate;
parity:=directory[n].databits=7;
setparam (usecom,baudrate,parity)
end;
dstr:=numstrs[cnt];
write (usr,dstr);
bottom;
break:=false;
dialnumber (dstr);
r:=now+45;
while (now<r) and (not (keyhit or carrier)) do
if numchars>0
then writecon (getchar);
top;
done:=carrier;
if (keyhit or break) and not carrier then begin
gotoxy (1,14);
write (usr,'Aborted by operator!');
clreol;
sendchar (^M);
delay (1000);
sendchar (^M);
fullrefresh;
exit
end
until carrier
end;
procedure getitem (prompt:mstr; var q; len:integer);
var a:anystr absolute q;
t:anystr;
begin
writeln (usr,^M' Current ',prompt,' is: ',a);
write (usr,'Enter new ',prompt,' : ');
buflen:=len;
readline (t);
if length(t)>0 then a:=t
end;
procedure reviseentry;
procedure getinteger (prompt:mstr; var n:integer; r1,r2:integer);
var q:sstr;
begin
str (n,q);
repeat
getitem (prompt,q,4);
n:=valu (q);
if (n>=r1) and (n<=r2) then exit;
writeln (usr,' Sorry! Range is ',r1,' to ',r2,'!')
until 0=1
end;
var n:integer;
q:^dialrec;
begin
n:=valu(getnumber);
if (n<1) or (n>200) then exit;
q:=addr(directory[n]);
clrscr;
getitem ('BBS name',q^.bbsname,35);
getitem ('phone number',q^.phonenum,14);
getinteger ('baud rate',q^.baudrate,50,9600);
getinteger ('data bits',q^.databits,7,8);
writedfile (n);
fullrefresh
end;
procedure editprefixes;
procedure getprefix (p:prefixtype);
begin
gotoxy (1,13);
getitem ('prefix',prefixes[p],80)
end;
var k:char;
begin
repeat
clrscr;
writeln (usr,'Prefixes are: '^J);
writeln (usr,' + ',prefixes[plus]);
writeln (usr,' - ',prefixes[minus]);
writeln (usr,' ! ',prefixes[bang]);
writeln (usr,' @ ',prefixes[atsign]);
writeln (usr,' # ',prefixes[poundsign],^J^J);
write (usr,'Hit prefix to change, CR when done: ');
k:=bioskey;
case k of
'+':getprefix (plus);
'-':getprefix (minus);
'!':getprefix (bang);
'@':getprefix (atsign);
'#':getprefix (poundsign)
end
until (k=#27) or (k=#13);
saveprefixes;
fullrefresh
end;
var k:char;
begin
splitscreen (16);
top;
if not dirloaded then begin
writeln (usr,'Loading directory...');
dirloaded:=true;
loaddirectory;
loadprefixes
end;
page:=0;
fullrefresh;
done:=false;
repeat
gotoxy (1,14);
write (usr,'Your choice: ');
clreol;
k:=upcase(bioskey);
case k of
'9',#201:changepage (-10);
'3',#209:changepage (10);
'D':dialdirectory;
'R':reviseentry;
'E':editprefixes;
'Q':done:=true
end
until done;
unsplit
end;
var done,echoback,localecho,addlf,printerecho:boolean;
procedure splitit;
begin
splitscreen (5);
top;
gotoxy (1,1)
end;
procedure askquestion (prompt:lstr);
begin
splitit;
write (usr,prompt);
readline (input);
unsplit
end;
function getyn (prompt:mstr):boolean;
begin
askquestion (prompt+': Are you sure? ');
getyn:=yes
end;
procedure ansireset;
begin
writecon (#27);
writecon ('[');
writecon ('0');
writecon ('m')
end;
procedure help;
begin
if splitmode then begin
unsplit;
exit
end;
splitscreen (10);
top;
writeln (usr,'Alt-X: Exit');
writeln (usr,'Alt-I: Initialize ANSI');
writeln (usr,'Alt-H: Hang up');
writeln (usr,'Alt-Q: Goto DOS');
writeln (usr,'Alt-D: Dialing directory');
writeln (usr);
writeln (usr,'Alt-T: Transmit file');
writeln (usr,'Alr-R: Receive file');
window (40,1,80,10);
inuse:=-1;
gotoxy (1,1);
writeln (usr,'Alt-E: Toggle echo');
writeln (usr,'Alt-L: Toggle line feeds');
writeln (usr,'Alt-B: Set baud rate');
writeln (usr,'Alt-P: Set parity');
writeln (usr,'Alt-F: Function keys');
bottom
end;
procedure editfunckeys;
var q:lstr;
n,cnt:integer;
begin
splitscreen (15);
top;
repeat
for cnt:=1 to 10 do begin
gotoxy (1,cnt);
write (usr,'F',cnt,':');
gotoxy (6,cnt);
write (usr,funckeys[cnt]);
clreol
end;
gotoxy (1,12);
write (usr,'Enter number to edit, CR when done: ');
clreol;
buflen:=2;
readline (q);
if length(q)=0 then begin
savefunckeys;
unsplit;
exit
end;
n:=valu(q);
if (n>0) and (n<11) then begin
gotoxy (1,12);
write (usr,'Enter new setting:');
clreol;
write (usr,^M^J'-> ');
buflen:=70;
readline (q);
if length(q)<>0 then funckeys[n]:=q
end
until 0=1
end;
procedure setbaud;
var bd:integer;
begin
askquestion ('Enter baud rate: ');
bd:=valu(input);
if (bd>=110) and (bd<=9600) then begin
baudrate:=bd;
setparam (usecom,baudrate,parity)
end
end;
procedure setparity;
var k:char;
begin
askquestion ('Parity E)ven or N)one: ');
if length(input)=0 then exit;
k:=upcase(input[1]);
if k='E' then parity:=true else if k='N' then parity:=false;
setparam (usecom,baudrate,parity)
end;
procedure upload;
var fn:lstr;
f:file;
k:char;
b:integer;
begin
splitit;
write (usr,'Filename to upload: ');
readline (fn);
if length(fn)=0 then begin
unsplit;
exit
end;
assign (f,fn);
reset (f);
if ioresult<>0 then begin
writeln (usr,'File not found! Hit a key..');
k:=bioskey;
unsplit;
exit
end;
close (f);
write (usr,'Protocol (X=Xmodem, Y=Ymodem): ');
k:=upcase(bioskey);
unsplit;
b:=protocolxfer (true,true,k='Y',fn)
end;
procedure download;
var fn:lstr;
f:file;
k:char;
b,ymodem:boolean;
q:sstr;
ret:integer;
begin
splitit;
write (usr,'Filename to download: ');
readline (fn);
if length(fn)=0 then begin
unsplit;
exit
end;
assign (f,fn);
reset (f);
if ioresult=0 then begin
close (f);
write (usr,'Overwrite existing file? ');
readline (fn);
if (length(fn)=0) or (upcase(fn[1])<>'Y') then begin
unsplit;
exit
end
end;
write (usr,'Protocol (X=Xmodem, Y=Ymodem): ');
k:=upcase(bioskey);
ymodem:=k='Y';
if ymodem then q:='Y' else begin
write (usr,^M^J'CRC Mode? ');
q[1]:='Y';
readline (q)
end;
unsplit;
b:=upcase(q[1])='Y';
ret:=protocolxfer (false,b,ymodem,fn)
end;
procedure writetermchar (k:char);
begin
case k of
^J:if addlf then exit;
#255:if addlf then k:=^J
end;
case k of
^L:begin
ansireset;
clrscr
end;
^G:begin
nosound;
sound (50);
delay (50);
nosound
end
else writecon (k)
end;
if printerecho then write (lst,k);
case k of
^M:if addlf then writetermchar (#255);
end
end;
procedure received (k:char);
begin
writetermchar (k);
if echoback then sendchar (k)
end;
procedure typed (k:char);
begin
sendchar (k);
if localecho then begin
writecon (k);
if k=#13 then write (usr,^J)
end
end;
procedure checkwherey;
begin
if wherey>lasty then begin
gotoxy (wherex,lasty);
write (usr,^J)
end
end;
procedure doextended (b:byte);
procedure funckey (n:integer);
var cnt:integer;
begin
for cnt:=1 to length(funckeys[n]) do
sendchar (funckeys[n][cnt])
end;
begin
case b of
59..68:funckey (b-58);
119:help;
72:typed (^E);
75:typed (^S);
77:typed (^D);
80:typed (^X);
115:typed (^A);
116:typed (^F);
73:typed (^R);
81:typed (^C);
71:typed (^Q);
79:typed (^W);
83:typed (^G);
82:typed (^V);
117:typed (^P);
48:setbaud;
32:dialdirectory;
18:localecho:=not localecho;
33:editfunckeys;
35:if carrier then if getyn ('Hang up') then hangupmodem;
23:ansireset;
38:addlf:=not addlf;
25:setparity;
16:if getyn ('Go to DOS') then begin
ensureclosed;
if not carrier then dontanswer;
halt (4)
end;
19:download;
20:upload;
45:done:=getyn ('Resume waiting for calls');
(*
16..25:altq;
30..38:alta;
44..50:altz;
*)
end
end;
procedure showbottom;
var x,y,o:integer;
begin
o:=inuse;
usewind (0);
gotoxy (1,25);
textcolor (0);
textbackground (statlinecolor);
write (usr,'[TCS-Term] [Ctrl-Home for Help]');
if addlf then write (usr,' LF');
if localecho then write (usr,' Echo');
clreol;
textcolor (normbotcolor);
textbackground (0);
usewind (o)
end;
function basicterm:integer;
var k:char;
e:boolean;
begin
showbottom;
e:=false;
repeat
if numchars<>0 then begin
k:=getchar;
received (k)
end;
checkwherey;
if keyhit then begin
k:=bioskey;
if ord(k)<128 then typed (k) else e:=true
end
until e;
basicterm:=ord(k)-128
end;
procedure init;
var k:char;
begin
setparam (usecom,baudrate,parity);
done:=false;
echoback:=false;
localecho:=false;
addlf:=false;
printerecho:=false;
textcolor (normbotcolor);
window (1,1,80,25);
clrscr;
initwinds;
gotoxy (1,lasty);
bottom;
dirloaded:=false;
loadfunckeys;
while keyhit do k:=bioskey
end;
begin
init;
repeat
doextended (basicterm)
until done;
close (dfile);
window (1,1,25,80);
ansireset;
clrscr
end;
begin
end.