home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Jason Aller Floppy Collection
/
189.img
/
TCS120S.ZIP
/
SUBS2.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1989-04-06
|
34KB
|
1,494 lines
{$R-,S-,I-,D-,F+,V-,B-,N-,L+ }
{$M 65500,0,0 }
unit subs2;
{ $define testingdevices} { Activate this define for test mode }
interface
uses printer,dos,crt,overlay,gentypes,configrt,gensubs,subs1,windows,modem,
statret,chatstuf,flags,userret;
procedure beepbeep;
procedure summonbeep;
procedure abortttfile (er:integer);
procedure openttfile;
procedure writecon (k:char);
procedure toggleavail;
function charready:boolean;
function readchar:char;
function waitforchar:char;
procedure clearchain;
function charpressed (k:char):boolean; { TRUE if K is in typeahead }
procedure addtochain (l:lstr);
procedure directoutchar (k:char);
procedure handleincoming;
procedure writechar (k:char);
{F+}
function opendevice (var t:textrec):integer;
function closedevice (var t:textrec):integer;
function cleardevice (var t:textrec):integer;
function ignorecommand (var t:textrec):integer;
function directoutchars (var t:textrec):integer;
function writechars (var t:textrec):integer;
function directinchars (var t:textrec):integer;
function readcharfunc (var t:textrec):integer;
{F-}
function getinputchar:char;
procedure getstr (mode:integer);
procedure writestr (s:anystr);
procedure printxy (x,y:integer;str:anystr);
procedure cls;
procedure writehdr (q:anystr);
function issysop:boolean;
procedure reqlevel (l:integer);
procedure printfile (fn:lstr);
procedure printtexttopoint (var tf:text);
procedure skiptopoint (var tf:text);
function minstr (blocks:integer):sstr;
procedure parserange (numents:integer; var f,l:integer);
function menutype:integer;
function menu (mname:mstr; mfn:sstr; choices:anystr):integer;
function checkpassword (var u:userrec):boolean;
function getpassword:boolean;
procedure getacflag (var ac:accesstype; var tex:mstr);
procedure calcqr;
procedure overlayerror;
function parsedate (date:anystr):lstr;
function ansi:boolean;
function ascii:boolean;
procedure setmenutype;
procedure movexy (x,y:integer);
procedure ansicls;
implementation
procedure beepbeep;
begin
nosound;
sound (200);
delay (20);
nosound
end;
procedure summonbeep;
var cnt:integer;
begin
nosound;
cnt:=1330;
repeat
sound (cnt);
delay (10);
cnt:=cnt+200;
until cnt>4300;
nosound
end;
procedure abortttfile (er:integer);
var n:integer;
begin
specialmsg ('<Texttrap error '+strr(er)+'>');
texttrap:=false;
textclose (ttfile);
n:=ioresult
end;
procedure openttfile;
var n:integer;
begin
appendfile ('Texttrap',ttfile);
n:=ioresult;
if n=0
then texttrap:=true
else abortttfile (n)
end;
{-= BEGINNING OF SCRAMBLE PROCEDURES -=}
function scramble (s:char):char;
var f:text;
x,y:char;
z:integer;
begin
scramble:=s;
if noscramble then exit;
if not scrambled then exit;
if not exist (forumdir+'Scramble.Dat') then exit;
if not (ord(s) in [65..90,97..122]) then exit;
assign (f,forumdir+'Scramble.Dat');
reset (f);
for z:=1 to ord(s) do
read (f,x);
scramble:=x;
close (f);
end;
procedure overridescramble;
begin
if scrambled then begin
scrambled:=false;
end else
if not scrambled then begin
scrambled:=true;
end;
textcolor (12);
writeln (usr);
writeln (usr);
beepbeep;
writeln (usr,'┌─────────────────────────────┐');
write (usr,'│ ** ');
textcolor (9);
write (usr,'Data Scramble Override!!');
textcolor (12);
writeln (usr,' │');
write (usr,'│ ** ');
textcolor (10);
write (usr,'Data Scramble is now:');
textcolor (11);
if scrambled then write (usr,'ON ') else
if not scrambled then write (usr,'OFF ');
textcolor (12);
writeln (usr,'│');
writeln (usr,'└─────────────────────────────┘');
writeln (usr);
writeln (usr);
ansicolor (urec.regularcolor);
end;
{-= ENDING OF SCRAMBLE PROCEDURES -=}
procedure togglescreenoutput;
begin
if screenoutput then
screenoutput:=false else
screenoutput:=true;
end;
procedure writecon (k:char);
var r:registers;
kk:char;
begin
if k=^J
then write (usr,k)
else
begin
{ if scrambled then kk:=scramble (k)
else } kk:=k;
r.dl:=ord(kk);
r.ah:=2;
intr($21,r)
end
end;
procedure toggleavail;
begin
if sysopavail=notavailable
then sysopavail:=available
else sysopavail:=succ(sysopavail)
end;
function charready:boolean;
var k:char;
begin
if modeminlock then while numchars>0 do k:=getchar;
if hungupon or keyhit
then charready:=true
else if online
then charready:=(not modeminlock) and (numchars>0)
else charready:=false
end;
function readchar:char;
procedure toggletempsysop;
begin
if tempsysop
then ulvl:=regularlevel
else
begin
regularlevel:=ulvl;
ulvl:=sysoplevel
end;
tempsysop:=not tempsysop
end;
procedure togviewstats;
begin
if splitmode
then unsplit
else
begin
splitscreen (14);
top;
clrscr;
write (usr,'Level: ',urec.level,
^M^J'File Level: ',urec.udlevel,
^M^J'File Points: ',urec.udpoints,
^M^J'User Note: ',urec.note,
^M^J'# Downloads: ',urec.downloads,
^M^J'# Uploads: ',urec.uploads,
^M^J'# of Posts: ',urec.nbu,
^M^J'G-File Ups: ',urec.nup,
^M^J'G-File Downs: ',urec.ndn,
^M^J'Total Time: ',urec.totaltime:0:0,
^M^J'# of Calls: ',urec.numon);
bottom
end;
end;
procedure showhelp;
begin
if splitmode
then unsplit
else begin
splitscreen (12);
top;
clrscr;
write (usr,
'Chat with user: <F1> Sysop Commands: <F2>'^M^J,
'Sysop gets the system next: <F7> Lock the timer: <F8>'^M^J,
'Lock out all modem input: <F9> Lock all Modem output: <F10>'^M^J,
'Chat availabily toggle: <Alt-A> Grant temporary sysop powers: <Alt-T>'^M^J,
'Give User 1 min. time: <Right-Arrow> Take away 1 minute time: <Left-Arrow>'^M^J,
'Take away all time: <Alt-K> Refresh the Bottom line: <Alt-B>'^M^J,
'Toggle printer echo: <Ctrl-PrtScr> Toggle Text Trap: <Alt-E>'^M^J,
'View users Status: <Alt-V> Sysop Macros #1-10: <Alt-F1>-<Alt-F10>'^M^J,
'Override Data Scrambling: <Alt-O> ');
end;
end;
procedure toggletexttrap;
var n:integer;
begin
if texttrap
then
begin
textclose (ttfile);
n:=ioresult;
if n<>0 then abortttfile (n);
texttrap:=false
end
else openttfile
end;
procedure printsysopmacro (n:integer);
procedure doitbro (k:char);
var n:integer;
begin
if inuse<>1
then writecon (k)
else begin
bottom;
writecon (k);
top
end;
if wherey>lasty then gotoxy (wherex,lasty);
if online and (not modemoutlock) and ((k<>#10) or uselinefeeds)
then sendchar(k);
if texttrap then begin
write (ttfile,k);
n:=ioresult;
if n<>0 then abortttfile (n)
end;
if printerecho then write (lst,k)
end;
procedure domacro (var m:anystr);
var x:integer;
begin
for x:=1 to length(m) do begin
if m[x]='~' then writeln else
doitbro (m[x]);
end;
end;
begin
case n of
1:domacro (sysopmacro1);
2:domacro (sysopmacro2);
3:domacro (sysopmacro3);
4:domacro (sysopmacro4);
5:domacro (sysopmacro5);
6:domacro (sysopmacro6);
7:domacro (sysopmacro7);
8:domacro (sysopmacro8);
9:domacro (sysopmacro9);
10:domacro (sysopmacro10);
end;
end;
var k:char;
ret:char;
dorefresh:boolean;
begin
requestchat:=false;
requestcom:=false;
reqspecial:=false;
if keyhit
then
begin
k:=bioskey;
ret:=k;
if ord(k)>127 then begin
ret:=#0;
dorefresh:=ingetstr;
case ord(k)-128 of
availtogglechar:
begin
toggleavail;
chatmode:=false;
dorefresh:=true
end;
sysopcomchar:
begin
requestcom:=true;
requestchat:=true
end;
breakoutchar:halt(e_controlbreak);
lesstimechar:urec.timetoday:=urec.timetoday-1;
moretimechar:urec.timetoday:=urec.timetoday+1;
leftarrow:urec.timetoday:=urec.timetoday-1;
rightarrow:urec.timetoday:=urec.timetoday+1;
notimechar:settimeleft (-1);
chatchar:requestchat:=true;
sysnextchar:sysnext:=not sysnext;
timelockchar:if timelock then timelock:=false else begin
timelock:=true;
lockedtime:=timeleft
end;
inlockchar:modeminlock:=not modeminlock;
outlockchar:setoutlock (not modemoutlock);
tempsysopchar:toggletempsysop;
bottomchar:bottomline;
viewstatchar:togviewstats;
sysophelpchar:if dorefresh then showhelp;
texttrapchar:toggletexttrap;
printerechochar:printerecho:=not printerecho;
sm1char:printsysopmacro(1);
sm2char:printsysopmacro(2);
sm3char:printsysopmacro(3);
sm4char:printsysopmacro(4);
sm5char:printsysopmacro(5);
sm6char:printsysopmacro(6);
sm7char:printsysopmacro(7);
sm8char:printsysopmacro(8);
sm9char:printsysopmacro(9);
sm10char:printsysopmacro(10);
phunkey:write (direct,^G);
scroverride:overridescramble;
noscreenoutput:togglescreenoutput;
72:ret:=^E;
75:ret:=^S;
77:ret:=^D;
80:ret:=^X;
115:ret:=^A;
116:ret:=^F;
73:ret:=^R;
81:ret:=^C;
71:ret:=^Q;
79:ret:=^W;
83:ret:=^G;
82:ret:=^V;
117:ret:=^P;
end;
if dorefresh then bottomline
end
end
else
begin
k:=getchar;
if modeminlock
then ret:=#0
else ret:=k
end;
if ret='+' then write (' '^H);
readchar:=ret
end;
function waitforchar:char;
var t:integer;
k:char;
begin
t:=timer+mintimeout;
if t>=1440 then t:=t-1440;
repeat
if timer=t then forcehangup:=true
until charready;
waitforchar:=readchar
end;
procedure clearchain;
begin
chainstr[0]:=#0
end;
function charpressed (k:char):boolean; { TRUE if K is in typeahead }
begin
charpressed:=pos(k,chainstr)>0
end;
procedure addtochain (l:lstr);
begin
if length(chainstr)<>0 then chainstr:=chainstr+',';
chainstr:=chainstr+l
end;
procedure directoutchar (k:char);
var n:integer;
begin
if inuse<>1
then writecon (k)
else begin
bottom;
writecon (k);
top
end;
if wherey>lasty then gotoxy (wherex,lasty);
if online and (not modemoutlock) and ((k<>#10) or uselinefeeds)
then sendchar(k);
if texttrap then begin
write (ttfile,k);
n:=ioresult;
if n<>0 then abortttfile (n)
end;
if printerecho then write (lst,k)
end;
procedure handleincoming;
var k:char;
begin
k:=readchar;
case upcase(k) of
'X',^X,^K,^C,#27,' ':begin
writeln (direct);
break:=true;
linecount:=0;
xpressed:=(upcase(k)='X') or (k=^X);
if xpressed then clearchain
end;
^S:k:=waitforchar;
else if length(chainstr)<255 then chainstr:=chainstr+k
end
end;
procedure writechar (k:char);
procedure endofline;
procedure write13 (k:char);
var n:integer;
begin
for n:=1 to 13 do directoutchar (k)
end;
var b:boolean;
begin
writeln (direct);
if timelock then settimeleft (lockedtime);
if curattrib=urec.statcolor then ansicolor (urec.regularcolor);
linecount:=linecount+1;
if (linecount>=urec.displaylen-1) and (not dontstop)
and (moreprompts in urec.config) then begin
linecount:=1;
write (direct,'More (Y/N/C)?');
repeat
k:=upcase(waitforchar)
until (k in [^M,' ','C','N','Y']) or hungupon;
write13 (^H);
write13 (' ');
write13 (^H);
if k='N' then break:=true else if k='C' then dontstop:=true
end
end;
begin
if hungupon then exit;
if k<=^Z then
case k of
^J,#0:exit;
^Q:k:=^H;
^B:begin
clearbreak;
exit
end
end;
if break then exit;
if k<=^Z then begin
case k of
^G:beepbeep;
^L:cls;
^N,^R:ansireset;
^S:ansicolor (urec.statcolor);
^P:ansicolor (urec.promptcolor);
^U:ansicolor (urec.inputcolor);
^H:directoutchar (k);
^M:endofline
end;
exit
end;
if usecapsonly then k:=upcase(k);
directoutchar (k);
if (keyhit or ((not modemoutlock) and online and (numchars>0)))
and (not nobreak) then handleincoming
end;
function getinputchar:char;
var k:char;
begin
if length(chainstr)=0 then begin
getinputchar:=waitforchar;
exit
end;
k:=chainstr[1];
delete (chainstr,1,1);
if (k=',') and (not nochain) then k:=#13;
getinputchar:=k
end;
{$ifdef testingdevices}
procedure devicedone (var t:textrec; m:mstr);
var r:registers;
cnt:integer;
begin
write (usr,'Device ');
cnt:=0;
while t.name[cnt]<>#0 do begin
write (usr,t.name[cnt]);
cnt:=cnt+1
end;
writeln (usr,' ',m,'... press any key');
r.ax:=0;
intr ($16,r);
if r.al=3 then halt
end;
{$endif}
{$F+}
function opendevice;
begin
{$ifdef testingdevices} devicedone (t,'opened'); {$endif}
t.handle:=1;
t.mode:=fminout;
t.bufend:=0;
t.bufpos:=0;
opendevice:=0
end;
function closedevice;
begin
{$ifdef testingdevices} devicedone (t,'closed'); {$endif}
t.handle:=0;
t.mode:=fmclosed;
t.bufend:=0;
t.bufpos:=0;
closedevice:=0
end;
function cleardevice;
begin
{$ifdef testingdevices} devicedone (t,'cleared'); {$endif}
t.bufend:=0;
t.bufpos:=0;
cleardevice:=0
end;
function ignorecommand;
begin
{$ifdef testingdevices} devicedone (t,'ignored'); {$endif}
ignorecommand:=0
end;
function directoutchars;
var cnt:integer;
begin
for cnt:=t.bufend to t.bufpos-1 do
directoutchar (t.bufptr^[cnt]);
t.bufend:=0;
t.bufpos:=0;
directoutchars:=0
end;
function writechars;
var cnt:integer;
begin
for cnt:=t.bufend to t.bufpos-1 do
writechar (t.bufptr^[cnt]);
t.bufend:=0;
t.bufpos:=0;
writechars:=0
end;
function directinchars;
begin
with t do begin
bufptr^[0]:=waitforchar;
t.bufpos:=0;
t.bufend:=1
end;
directinchars:=0
end;
function readcharfunc;
begin
with t do begin
bufptr^[0]:=getinputchar;
t.bufpos:=0;
t.bufend:=1
end;
readcharfunc:=0
end;
procedure usermacro (m:string);
procedure doithonky (k:char);
var n:integer;
begin
if inuse<>1
then writecon (k)
else begin
bottom;
writecon (k);
top
end;
if wherey>lasty then gotoxy (wherex,lasty);
if online and (not modemoutlock) and ((k<>#10) or uselinefeeds)
then sendchar(k);
if texttrap then begin
write (ttfile,k);
n:=ioresult;
if n<>0 then abortttfile (n)
end;
if printerecho then write (lst,k)
end;
procedure domacro (var mm:anystr);
var x:integer;
begin
for x:=1 to length(mm) do begin
if mm[x]='~' then writeln else
doithonky (mm[x]);
end;
end;
begin
{case upstring (m) of
'^A':domacro (urec.amacro);
'^D':domacro (urec.dmacro);
'^F':domacro (urec.fmacro);
end; }
end;
{$F-}
procedure getstr (mode:integer);
var marker,cnt:integer;
p:byte absolute input;
k:char;
oldinput:anystr;
done,wrapped:boolean;
wordtowrap:lstr;
procedure bkspace;
procedure bkwrite (q:sstr);
begin
write (q);
if splitmode and dots then write (usr,q)
end;
begin
if p<>0
then
begin
if input[p]=^Q
then bkwrite (' ')
else bkwrite (k+' '+k);
p:=p-1
end
else if wordwrap
then
begin
input:=k;
done:=true
end
end;
procedure sendit (k:char; n:integer);
var temp:anystr;
begin
temp[0]:=chr(n);
fillchar (temp[1],n,k);
nobreak:=true;
write (temp)
end;
procedure superbackspace (r1:integer);
var cnt,n:integer;
begin
n:=0;
for cnt:=r1 to p do
if input[cnt]=^Q
then n:=n-1
else n:=n+1;
if n<0 then sendit (' ',-n) else begin
sendit (^H,n);
sendit (' ',n);
sendit (^H,n)
end;
p:=r1-1
end;
procedure cancelent;
begin
superbackspace (1)
end;
function findspace:integer;
var s:integer;
begin
s:=p;
while (input[s]<>' ') and (s>0) do s:=s-1;
findspace:=s
end;
procedure wrapaword (q:char);
var s:integer;
begin
done:=true;
if q=' ' then exit;
s:=findspace;
if s=0 then exit;
wrapped:=true;
wordtowrap:=copy(input,s+1,255)+q;
superbackspace (s)
end;
procedure deleteword;
var s,n:integer;
begin
if p=0 then exit;
s:=findspace;
if s<>0 then s:=s-1;
n:=p-s;
p:=s;
sendit (^H,n);
sendit (' ',n);
sendit (^H,n)
end;
procedure addchar (k:char);
begin
if p<buflen
then if (k<>' ') or (p>0) or wordwrap or beginwithspacesok
then begin
p:=p+1;
input[p]:=k;
if dots then begin
writechar (dotchar);
if splitmode then write (usr,k)
end
else writechar (k)
end
else
else if wordwrap then wrapaword (k)
end;
procedure addcharnoecho (k:char);
begin
if p<buflen
then if (k<>' ') or (p>0) or wordwrap or beginwithspacesok
then begin
p:=p+1;
input[p]:=k;
if dots then begin
{writechar (dotchar);}
if splitmode then {write (usr,k)}
end
else {writechar (k)}
end
else
else if wordwrap then wrapaword (k)
end;
procedure repeatent;
var cnt:integer;
begin
for cnt:=1 to length(oldinput) do addchar (oldinput[cnt])
end;
procedure tab;
var n,c:integer;
begin
n:=(p+8) and 248;
if n>buflen then n:=buflen;
for c:=1 to n-p do addchar (' ')
end;
procedure getinput;
begin
oldinput:=input;
ingetstr:=true;
done:=false;
slash:=false;
bottomline;
if splitmode and dots then top;
p:=0;
repeat
clearbreak;
nobreak:=true;
k:=getinputchar;
if hungupon then begin
input:='';
k:=#13;
done:=true
end;
case k of
^I:tab;
^H:bkspace;
^M:done:=true;
^R:repeatent;
^X,#27:cancelent;
^W:deleteword;
' '..'~':addchar (k);
^Q:if wordwrap and bkspinmsgs then addchar (k);
^A:usermacro ('^A');
^D:usermacro ('^D');
^F:usermacro ('^F');
end;
if (urec.menutype=1) and (atmenu) and (k='/') then begin
slash:=true;
end;
if requestchat then begin
p:=0;
writeln (^B^N^M^M^B);
chat (requestcom);
write (^B^M^M^P,lastprompt);
requestchat:=false
end;
if (urec.menutype=1) and (atmenu) and (not slash) then done:=true
until done;
if echoit then writeln;
if splitmode and dots then begin
writeln (usr);
bottom
end;
ingetstr:=false;
ansireset
end;
procedure onekeyinput;
begin
oldinput:=input;
ingetstr:=true;
done:=false;
slash:=false;
bottomline;
if splitmode and dots then top;
p:=0;
repeat
clearbreak;
nobreak:=true;
k:=getinputchar;
if hungupon then begin
input:='';
k:=#13;
done:=true
end;
case k of
^I:tab;
^H:bkspace;
^M:done:=true;
{ ^R:repeatent; }
^X,#27:cancelent;
^W:deleteword;
' '..'~':addcharnoecho (k);
^Q:if wordwrap and bkspinmsgs then addchar (k);
{ ^A:usermacro (A);
^D:usermacro (D);
^F:usermacro (F); }
end;
{}{}{} done:=true; {}{}{}
if (urec.menutype=1) and (atmenu) and (k='/') then begin
slash:=true;
end;
if requestchat then begin
p:=0;
writeln (^B^N^M^M^B);
chat (requestcom);
write (^B^M^M^P,lastprompt);
requestchat:=false
end;
if (urec.menutype=1) and (atmenu) and (not slash) then done:=true
until done;
{ if echoit then writeln; }
if splitmode and dots then begin
writeln (usr);
bottom
end;
ingetstr:=false;
ansireset
end;
procedure divideinput;
var p:integer;
begin
p:=pos(',',input);
if p=0 then exit;
addtochain (copy(input,p+1,255)+#13);
input[0]:=chr(p-1)
end;
begin
che;
clearbreak;
linecount:=1;
wrapped:=false;
nochain:=nochain or wordwrap;
ansicolor (urec.inputcolor);
if mode=1 then getinput else
if mode=2 then onekeyinput;
if not nochain then divideinput;
while input[length(input)]=' ' do input[0]:=pred(input[0]);
if not wordwrap then
while (length(input)>0) and (input[1]=' ') do delete (input,1,1);
if wrapped then chainstr:=wordtowrap;
wordwrap:=false;
nochain:=false;
beginwithspacesok:=false;
dots:=false;
buflen:=80;
linecount:=1
end;
procedure writestr (s:anystr);
var k:char;
ex:boolean;
begin
che;
clearbreak;
ansireset;
uselinefeeds:=linefeeds in urec.config;
usecapsonly:=not (lowercase in urec.config);
k:=s[length(s)];
s:=copy(s,1,length(s)-1);
case k of
':':begin
write (^P,s,': ');
lastprompt:=s+': ';
getstr (1)
end;
';':write (s);
'*':begin
write (^P,s);
lastprompt:=s;
getstr (1)
end;
'@':begin
write (^P,s);
lastprompt:=s;
getstr (2)
end;
'&':begin
nochain:=true;
write (^P,s);
lastprompt:=s;
getstr (1)
end
else writeln (s,k)
end;
clearbreak
end;
procedure printxy (x,y:integer; str:anystr);
var dum1,dum2:string;
begin
writestr(#27+'['+strr(y)+';'+strr(x)+'f'+^S+str+^R);
end;
procedure cls;
begin
bottom;
clrscr;
bottomline
end;
procedure writehdr (q:anystr);
var cnt,cnt2,x,xx,y,yy,z,zz:integer;
const l=30;
begin
{ if (asciigraphics in urec.config) and (urec.ansiwindows=1) then begin
writeln (^B^M);
write ('┌');
for x:=1 to (l-length(q)) div 2 do write ('─');
for z:=1 to length(q) do write ('─');
for xx:=1 to (l-length(q)) div 2 do write ('─');
writeln ('┐');
write ('│');
for cnt:=1 to (l-length(q)) div 2 do write (' ');
ansicolor (urec.statcolor);
write (q,^B);
ansicolor (urec.regularcolor);
for cnt2:=1 to (length(q)) div 2 do write (' ');
writeln ('│');
write ('└');
for y:=1 to (l-length(q)) div 2 do write ('─');
for zz:=1 to length(q) do write ('─');
for yy:=1 to (l-length(q)) div 2 do write ('─');
writeln ('┘');
end
else }
begin
writeln (^B^M);
for cnt:=1 to (40-length(q)) div 2 do write (' ');
ansicolor (urec.statcolor);
write (q,^M^M^B);
ansicolor (urec.regularcolor)
end;
end;
function issysop:boolean;
begin
issysop:=(ulvl>=sysoplevel) or (cursection in urec.config)
end;
procedure reqlevel (l:integer);
begin
writeln (^B'Level ',l,' is required for that!')
end;
procedure printfile (fn:lstr);
procedure getextension (var fname:lstr);
procedure tryfiles (a,b,c,d:integer);
var q:boolean;
function tryfile (n:integer):boolean;
const exts:array [1..4] of string[3]=('','ANS','ASC','40');
begin
if not exist (fname+'.'+exts[n]) then tryfile:=false else begin
tryfile:=true;
fname:=fname+'.'+exts[n]
end
end;
begin
if tryfile (a) then exit;
if tryfile (b) then exit;
if tryfile (c) then exit;
q:=tryfile (d)
end;
begin
if pos ('.',fname)<>0 then exit;
if ansigraphics in urec.config then tryfiles (2,3,1,4) else
if asciigraphics in urec.config then tryfiles (3,1,4,2) else
if eightycols in urec.config then tryfiles (1,4,3,2) else
tryfiles (4,1,3,2)
end;
var tf:text;
k:char;
begin
clearbreak;
writeln;
getextension (fn);
assign (tf,fn);
reset (tf);
iocode:=ioresult;
if iocode<>0 then begin
fileerror ('Printfile',fn);
exit
end;
clearbreak;
while not (eof(tf) or break or hungupon) do
begin
read (tf,k);
write (k)
end;
if break then writeln (^B);
writeln;
textclose (tf);
curattrib:=0;
ansireset
end;
procedure printtexttopoint (var tf:text);
var l:lstr;
begin
l:='';
clearbreak;
while not (eof(tf) or hungupon) and (l<>'.') do begin
if not break then writeln (l);
readln (tf,l)
end
end;
procedure skiptopoint (var tf:text);
var l:lstr;
begin
l:='';
while not eof(tf) and (l<>'.') do
readln (tf,l)
end;
function minstr (blocks:integer):sstr;
var min,sec:integer;
rsec:real;
ss:sstr;
begin
rsec:=1.38 * blocks * (1200/baudrate);
min:=trunc (rsec/60.0);
sec:=trunc (rsec-(min*60.0));
ss:=strr(sec);
if length(ss)<2 then ss:='0'+ss;
minstr:=strr(min)+':'+ss
end;
procedure parserange (numents:integer; var f,l:integer);
var rf,rl:mstr;
p,v1,v2:integer;
begin
f:=0;
l:=0;
if numents<1 then exit;
repeat
writestr ('Range [1-'+strr(numents)+'][CR/All][?/Help]:');
if input='?' then printfile (textfiledir+'Rangehlp');
if (length(input)>0) and (upcase(input[1])='Q') then exit
until (input<>'?') or hungupon;
if hungupon then exit;
if length(input)=0 then begin
f:=1;
l:=numents
end else begin
p:=pos('-',input);
v1:=valu(copy(input,1,p-1));
v2:=valu(copy(input,p+1,255));
if p=0 then begin
f:=v2;
l:=v2
end else if p=1 then begin
f:=1;
l:=v2
end else if p=length(input) then begin
f:=v1;
l:=numents
end else begin
f:=v1;
l:=v2
end
end;
if (f<1) or (l>numents) or (f>l) then begin
f:=0;
l:=0;
writestr ('Invalid range!')
end;
writeln (^B)
end;
function menutype:integer;
begin
menutype:=0;
if urec.menutype=0 then menutype:=0 else
if urec.menutype=1 then menutype:=1 else
if urec.menutype=2 then menutype:=2;
end;
function menu (mname:mstr; mfn:sstr; choices:anystr):integer;
var k:char;
sysmenu,percent,needsys:boolean;
n,p,i:integer;
prompt:lstr;
begin
sysmenu:=false;
percent:=false;
atmenu:=true;
for p:=1 to length(choices)-1 do
if choices[p]='%'
then if choices[p+1]='@'
then percent:=true
else
else if choices[p+1]='@'
then sysmenu:=true;
writeln (^B);
repeat
if chatmode
then for n:=1 to 3 do summonbeep;
if (timeleft<1) or (timetillevent<=3) then begin
if exist (textfiledir+'Timesup') then
printfile (textfiledir+'Timesup') else
begin
writeln;
writeln ('Sorry, your time''s up for today!');
writeln;
end;
forcehangup:=true;
menu:=0;
exit
end;
if showtime in urec.config
then prompt:=^R+'['^P+strr(timeleft)+' left'^R']'
else prompt:='';
prompt:=prompt+^R'['^P+mname+^R']['^P'?/Help'^R']';
prompt:=prompt+':';
writestr (prompt);
n:=0;
if length(input)=0
then k:='_'
else
begin
if (match(input,'/OFF')) or (match(input,'/OFFOFF')) or (match(input,'/OPH')) then begin
forcehangup:=true;
menu:=0;
exit
end;
n:=valu(input);
if n>0
then k:='#'
else k:=upcase(input[1])
end;
p:=1;
i:=1;
if k='?'
then
begin
printfile (textfiledir+mfn+'M');
if sysmenu and issysop then printfile (textfiledir+mfn+'S')
end
else
while p<=length(choices) do begin
needsys:=false;
if p<length(choices)
then if choices[p+1]='@'
then needsys:=true;
if upcase(choices[p])=k
then if needsys and (not issysop)
then
begin
reqlevel (sysoplevel);
p:=255;
needsys:=false
end
else p:=256
else
begin
p:=p+1;
if needsys then p:=p+1;
i:=i+1
end
end
until (p=256) or hungupon;
writeln (^B);
if hungupon
then menu:=0
else
if k='#' then menu:=-n else menu:=i;
atmenu:=false
end;
function getpassword:boolean;
var t,gog,p:sstr;
c:char;
frm,yiyiyi,ii:integer;
begin
getpassword:=false;
dots:=true;
buflen:=15;
getstr (1);
gog:=input;
p:='';
t:='';
frm:=6;
if gog='' then begin
randomize;
for yiyiyi:=1 to frm do begin
ii:=random(36);
if ii<10 then c:=chr(ord('0')+ii)
else c:=chr(ord('A')+ii-10);
gog:=gog+c;
end;
end;
{ repeat
frm:=random (15);
until frm in [6..10];
writeln ('frm:',frm);
for yiyiyi:=1 to frm do
begin
repeat
c[yiyiyi]:=chr(random(90));
until c[yiyiyi] in ['0'..'9','A'..'Z'];
writeln ('c[yiyiyi]:'+c[yiyiyi]);
p:=p+c[yiyiyi];
writeln ('p:'+p);
end;
gog:=p;
end; }
begin
t:=gog;
writeln (^R'Password: '^S+t);
dots:=true;
writestr (^R'Re-enter for verification:');
if not match(t,input) then begin
writeln ('They don''t match!');
getpassword:=hungupon;
exit
end;
urec.password:=t;
getpassword:=true
end
end;
function checkpassword (var u:userrec):boolean;
var tries:integer;
begin
tries:=0;
checkpassword:=true;
repeat
splitscreen (5);
top;
writeln (usr,'Password Entry');
writeln (usr,'[User Name]: ',u.handle);
writeln (usr,'[Password]: ',u.password);
write (usr,'Has entered so far: ');
bottom;
dots:=true;
writestr (^M'[Enter Password]:');
unsplit;
if hungupon then begin
checkpassword:=false;
exit
end;
if match(input,u.password)
then exit
else tries:=tries+1
until tries>3;
checkpassword:=false
end;
procedure getacflag (var ac:accesstype; var tex:mstr);
begin
writestr ('[K]ick off, [B]y level, [L]et in:');
ac:=invalid;
if length(input)=0 then exit;
case upcase(input[1]) of
'B':ac:=bylevel;
'L':ac:=letin;
'K':ac:=keepout
end;
tex:=accessstr[ac]
end;
procedure calcqr;
begin
with urec do begin
qr := qrmultifactor*(urec.uploads+urec.nbu)-urec.downloads;
end;
end;
procedure overlayerror;
begin
write ('Overlay Manager Error ',ovrresult,': ');
case ovrresult of
-1:write ('Overlay Manager Error.');
-2:write ('Overlay File not found.');
-3:write ('Not enough memory.');
-4:write ('I/O Error.');
-5:write ('EMS Driver not installed.');
-6:write ('Not enough EMS memory.');
end;
writeln;
halt(4);
end;
function parsedate (date:anystr):lstr;
var m,d,y,inc,gog:sstr;
year,month,day,dayofweek:word;
begin
if length(date)<>8 then begin
parsedate:=date;
exit;
end else
begin
m:=copy (date,1,2);
d:=copy (date,4,2);
y:=copy (date,7,2);
if m='01' then gog:='Jan.';
if m='02' then gog:='Feb.';
if m='03' then gog:='Mar.';
if m='04' then gog:='Apr.';
if m='05' then gog:='May.';
if m='06' then gog:='Jun.';
if m='07' then gog:='Jul.';
if m='08' then gog:='Aug.';
if m='09' then gog:='Sep.';
if m='10' then gog:='Oct.';
if m='11' then gog:='Nov.';
if m='12' then gog:='Dec.';
getdate (year,month,day,dayofweek);
inc:=copy (strr(year),1,2);
parsedate:=gog+' '+d+' '+inc+y;
end;
end;
function ansi:boolean;
begin
if (ansigraphics in urec.config) then ansi:=true else
ansi:=false;
end;
function ascii:boolean;
begin
if (asciigraphics in urec.config) then ascii:=true else
ascii:=false;
end;
procedure setmenutype;
var n:integer;
begin
writehdr ('Menu Type');
write ('Current setting: '^S);
case urec.menutype of
0:writeln ('Standard Menus');
1:writeln ('Hotkey Menus');
2:writeln ('Pulldown Menus');
end;
writeln (^B^M'Would you like:');
writeln;
writeln (' [0]: Standard Menus [probably use these]');
writeln (' [1]: Hotkey Menus [one-key]');
writeln (' [2]: Pulldown Menus [Ansi required]');
writeln;
writestr (^M'Your choice [CR/Exit]:');
if length(input)<1 then exit;
n:=valu(input);
if (n>-1) and (n<3) then begin
case n of
0:urec.menutype:=0;
1:urec.menutype:=1;
2:urec.menutype:=2;
end;
writeurec
end
end;
procedure movexy (x,y:integer);
begin
writestr (#27+'['+strr(y)+';'+strr(x)+'f');
end;
procedure ansicls;
begin
if (ansigraphics in urec.config) then
write (#27+'[2J') else
write (^L);
end;
begin
end.