home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Jason Aller Floppy Collection
/
270.img
/
FORUM25C.ZIP
/
SUBS2.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1989-02-08
|
15KB
|
572 lines
{$R-,S-,I-,D-,V-,B-,N-,L- }
{$O+}
unit subs2;
{ $define testingdevices} (* Activate this define for test mode *)
{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}
interface
uses printer,
dos,
crt,
StrLib,
gentypes,
configrt,
gensubs,
subs1,
windows,
modem,
statret,
chatstuf,
flags;
{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}
TYPE AllignTypes = (Left,Right,Middle);
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);
{ KEVIN: These aren't necessary, are they?? }
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;
Function getinputchar:char;
Procedure getstr;
Procedure writestr (s: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 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);
Function Response(ChoiceList : String) : CHAR;
Procedure Center(CenterString : String; ScreenWidth : BYTE);
Procedure WaitReturn;
Procedure TopOfBox(ScreenWidth : BYTE);
Procedure BoxText(StringBox : String78; ScreenWidth : BYTE;
AllignMent : AllignTypes);
Procedure MiddleBar(ScreenWidth : BYTE);
Procedure BottomOfBox(ScreenWidth : BYTE);
Procedure BoxString(StringBox : String80; Size : BYTE);
Function WidthScreen : BYTE;
{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}
implementation
{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}
Procedure beepbeep;
begin
nosound;
sound (200);
delay (10);
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
Begin
TextTrap := TRUE;
Writeln(TtFile,'-%- Forum-PC Text Trap File -%-');
Writeln(TtFile,'Date: ',DateStr(Now),' ',TimeStr(Now),'');
Writeln(TtFile);
END
ELSE
abortttfile (n)
end;
{=============================================================================}
Procedure writecon (k:char);
VAR r:registers;
begin
if k=^J
then write (usr,k)
else
begin
r.dl:=ord(k);
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 (7);
top;
clrscr;
write (usr,'File Level: ',urec.udlevel,
^M^J'File Points: ',urec.udpoints,
^M^J'XMODEM uploads: ',urec.uploads,
^M^J'XMODEM dnloads: ',urec.downloads);
window (40,1,80,5);
gotoxy (1,1);
write (usr,'Posts: ',urec.nbu,
^M^J'Uploads: ',urec.nup,
^M^J'Downloads: ',urec.ndn,
^M^J'Total Time: ',urec.totaltime:0:0,
^M^J'Num. calls: ',urec.numon);
window (1,1,80,5);
bottom
end;
end;
Procedure showhelp;
begin
if splitmode
then unsplit
else begin
splitscreen (10);
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,
'Grant user more time: Alt-M Take away user''s time: Alt-L'^M^J,
'Take away ALL time: Alt-K Refresh the bottom line: Alt-B'^M^J,
'Toggle printer echo: Ctrl-PrtSc Toggle text trap: Alt-E'^M^J,
'View user''s status: Alt-V');
end;
end;
Procedure toggletexttrap;
VAR n:integer;
begin
if texttrap
then
begin
Writeln(TtFile,'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=');
Writeln(TtFile);
textclose (ttfile);
n:=ioresult;
if n<>0 then abortttfile (n);
texttrap:=false
end
else openttfile
end;
VAR k:char;
ret:char;
dorefresh:boolean;
begin
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
k := #0;
Command_proc;
If NOT InChat THEN Write(^B^M^M^P,lastprompt);
ChainStr := '';
End;
breakoutchar : halt(e_controlbreak);
lesstimechar : urec.timetoday:=urec.timetoday-1;
moretimechar : urec.timetoday:=urec.timetoday+1;
notimechar : settimeleft (-1);
Chatchar : Begin
If Inchat THEN
Begin
InChat := FALSE;
ChainStr := '';
write(^B^M^M^P,lastprompt);
End
ELSE
Begin
InChat := TRUE;
k := #0;
Chat_proc;
End;
End;
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;
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 : Begin
beepbeep;
SendChar(k);
End;
^L : Begin
cls;
SendChar(k);
End;
^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;
{=============================================================================}
{$I IOtxtFil.Sub}
{$I IOStrings.Sub}
{=============================================================================}
Procedure cls;
begin
bottom;
clrscr;
bottomline
end;
{=============================================================================}
Procedure writehdr (q:anystr);
VAR cnt:integer;
begin
writeln (^B^M);
for cnt:=1 to (40-length(q)) div 2 do write (' ');
write (q,^M^M^B)
end;
{=============================================================================}
Function issysop:boolean;
begin
issysop:=(ulvl>=sysoplevel) or (cursection in urec.config)
end;
{=============================================================================}
Procedure reqlevel (l:integer);
begin
writeln (^B'Nice try, but level ',l,' is required.')
end;
{=============================================================================}
{$I Prntfile.sub}
{$I Ranges.sub}
{$I Menu.sub}
{$I Password.sub}
{=============================================================================}
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;
{=============================================================================}
{$I Frmstf.pas}
begin
end.