home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-385-Vol-1of3.iso
/
f
/
faq-s.zip
/
MAINR1.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-02-25
|
8KB
|
351 lines
{$R-,S-,I-,D-,F+,V-,B-,N-,L+ }
{$M 65500,0,0 }
unit mainr1;
interface
uses modem,gentypes,configrt,textret,gensubs,subs1,userret,statret;
procedure showinfoform (var uname:mstr; ureq:integer); { UNAME='' shows all }
procedure showinfoforms (uname:mstr); { UNAME='' shows all }
function validfname (name:lstr):boolean;
function searchboard (name:sstr):integer;
function numfeedback:integer;
procedure trimmessage (var m:message);
implementation
procedure showinfoform (var uname:mstr; ureq:integer); { UNAME='' shows all }
var lnum,un,cnt:integer;
u:userrec;
procedure scold (u2:integer);
begin
writeln('Infoform '^S+strr(u2)+^R+' does not exist for this user.');
writeln;
end;
procedure showone (ureq:integer);
var ff:text;
fn:lstr;
me:message;
k:char;
found:boolean;
begin
case ureq of
1 :if u.infoform1=-1 then begin
scold(ureq);
exit;
end;
2 :if u.infoform2=-1 then begin
scold(ureq);
exit;
end;
3 :if u.infoform3=-1 then begin
scold(ureq);
exit;
end;
4 :if u.infoform4=-1 then begin
scold(ureq);
exit;
end;
5 :if u.infoform5=-1 then begin
scold(ureq);
exit;
end;
else begin
writeln('Valid choices are forms #1-5');
exit;
end;
end;
fn:=textfiledir+'Infoform.'+strr(ureq);
assign (ff,fn);
reset (ff);
if ioresult<>0 then begin
close (ff);
lnum:=ioresult;
writeln (^B'IOERROR'^R' loading Infoform ',ureq,'.');
exit
end;
case ureq of
1 : reloadtext(u.infoform1,me);
2 : reloadtext(u.infoform2,me);
3 : reloadtext(u.infoform3,me);
4 : reloadtext(u.infoform4,me);
5 : reloadtext(u.infoform5,me);
end;
writeln (^M,me.text[1],^M^M);
lnum:=1;
while not (break or eof(ff)) do begin
read (ff,k);
if k='*'
then if lnum>me.numlines
then writeln ('No answer')
else begin
lnum:=lnum+1;
writeln (me.text[lnum])
end
else write (k)
end;
textclose (ff)
end;
begin
if uname='' then begin
writeln (^B^M^S' Showing All Info-Forms'^R);
writeln;
seek (ufile,1);
for cnt:=1 to numusers do begin
read (ufile,u);
writeln (^M^M,u.handle,^M);
if u.infoform1<>-1 then showone (ureq);
if xpressed then exit
end
end else begin
un:=lookupuser (uname);
if un=0 then writeln (^B'No such user.') else begin
seek (ufile,un);
read (ufile,u);
showone (ureq);
end
end
end;
procedure showinfoforms (uname:mstr); { UNAME='' shows all }
var lnum,un,cnt:integer;
u:userrec;
procedure scold (u2:integer);
begin
writeln(^R'Infoform '^S+strr(u2)+^R+' does not exist for this user.');
writeln;
end;
procedure showone (ureq:integer);
var ff:text;
fn:lstr;
me:message;
k:char;
found:boolean;
begin
case ureq of
1 :if u.infoform1=-1 then begin
scold(ureq);
exit;
end;
2 :if u.infoform2=-1 then begin
scold(ureq);
exit;
end;
3 :if u.infoform3=-1 then begin
scold(ureq);
exit;
end;
4 :if u.infoform4=-1 then begin
scold(ureq);
exit;
end;
5 :if u.infoform5=-1 then begin
scold(ureq);
exit;
end;
else begin
writeln('Valid choices are forms #1-5');
exit;
end;
end;
fn:=textfiledir+'Infoform.'+strr(ureq);
assign (ff,fn);
reset (ff);
if ioresult<>0 then begin
close (ff);
lnum:=ioresult;
writeln (^B'IOERROR'^R' loading Infoform ',ureq,'.');
exit
end;
case ureq of
1 : reloadtext(u.infoform1,me);
2 : reloadtext(u.infoform2,me);
3 : reloadtext(u.infoform3,me);
4 : reloadtext(u.infoform4,me);
5 : reloadtext(u.infoform5,me);
end;
writeln (^M,me.text[1],^M^M);
lnum:=1;
while not (break or eof(ff)) do begin
read (ff,k);
if k='*'
then if lnum>me.numlines
then writeln ('No answer')
else begin
lnum:=lnum+1;
writeln (me.text[lnum])
end
else write (k)
end;
textclose (ff)
end;
begin
if uname='' then begin
writeln (^B^M^S' Showing All Info-Forms'^R);
writeln;
seek (ufile,1);
for cnt:=1 to numusers do begin
read (ufile,u);
writeln (^M^M,u.handle,^M);
if u.infoform1<>-1 then showone (1);
if u.infoform2<>-1 then showone (2);
if u.infoform3<>-1 then showone (3);
if u.infoform4<>-1 then showone (4);
if u.infoform5<>-1 then showone (5);
if xpressed then exit
end
end else begin
un:=lookupuser (uname);
if un=0 then writeln (^B'No such user.') else begin
seek (ufile,un);
read (ufile,u);
showone (1);
showone (2);
showone (3);
showone (4);
showone (5)
end
end
end;
function validfname (name:lstr):boolean;
const invalid:set of char=[#0..#31,'"',']','[',':','\','>','<','/','?','*',
'|','+','=',';', ',' ,#127..#255];
var p,cnt:integer;
k:char;
dotfound:boolean;
begin
validfname:=false;
dotfound:=false;
if (length(name)>12) or (length(name)<1) then exit;
for p:=1 to length(name) do begin
k:=upcase(name[p]);
if k in invalid then exit;
if k='.' then begin
if dotfound then exit;
dotfound:=true;
if (p<length(name)-3) or (p=1) then exit
end
end;
validfname:=not devicename(name);
if upstring(name)='USERS' then validfname:=false;
end;
function searchboard (name:sstr):integer;
var bi:sstr;
cnt:integer;
begin
seek (bifile,0);
for cnt:=0 to filesize(bifile)-1 do begin
read (bifile,bi);
if (bi=name) then begin
searchboard:=cnt;
exit
end
end;
searchboard:=-1
end;
function numfeedback:integer;
var ffile:file of mailrec;
begin
assign (ffile,bbsdatadir+'Feedback.dat');
reset (ffile);
if ioresult<>0 then begin
numfeedback:=0;
rewrite (ffile)
end else numfeedback:=filesize (ffile);
close (ffile)
end;
procedure trimmessage (var m:message);
var cnt:integer;
begin
for cnt:=1 to m.numlines do
while m.text[cnt][length(m.text[cnt])]=' ' do
m.text[cnt][0]:=pred(m.text[cnt][0]);
while (m.numlines>0) and (m.text[m.numlines]='') do
m.numlines:=m.numlines-1
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);
if k='`' then write (urec.timetoday) else
if k='~' then write (urec.handle) else
if k='@' then write (longname) else
write (k)
end;
if break then writeln (^B);
writeln;
textclose (tf);
curattrib:=0;
ansireset
end;
begin
end.