home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / FORUM25C.ZIP / MAINR1.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-12-27  |  3.5 KB  |  154 lines
  1. {$R-,S-,I-,D-,V-,B-,N-,L- }
  2. {$O+}
  3.  
  4. unit mainr1;
  5.  
  6.  
  7. {/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}
  8.  
  9. interface
  10.  
  11. uses gentypes,configrt,textret,gensubs,subs1,userret,statret;
  12.  
  13. {/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}
  14.  
  15.  
  16. Procedure showinfoforms (uname:mstr);  { UNAME='' shows all }
  17. Function validfname (name:lstr):boolean;
  18. Function searchboard (name:sstr):integer;
  19. Function numfeedback:integer;
  20. Procedure trimmessage (VAR m:message);
  21.  
  22.  
  23. {/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}
  24.  
  25. implementation
  26.  
  27. {/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}
  28.  
  29.  
  30. Procedure showinfoforms (uname:mstr);  { UNAME='' shows all }
  31. VAR lnum,un,cnt:integer;
  32.     u:userrec;
  33.  
  34.   Procedure showone;
  35.   VAR ff:text;
  36.       fn:lstr;
  37.       me:message;
  38.       k:char;
  39.       found:boolean;
  40.   begin
  41.     if u.infoform=-1 then begin
  42.       writeln (^B'That user has no information form.');
  43.       exit
  44.     end;
  45.     fn:=textfiledir+'infoform';
  46.     assign (ff,fn);
  47.     reset (ff);
  48.     if ioresult<>0 then begin
  49.       close (ff);
  50.       lnum:=ioresult;
  51.       writeln (^B'No information form is present.');
  52.       exit
  53.     end;
  54.     reloadtext (u.infoform,me);
  55.     writeln (^M,me.text[1],^M^M);
  56.     lnum:=1;
  57.     while not (break or eof(ff)) do begin
  58.       read (ff,k);
  59.       if k='*'
  60.         then if lnum>me.numlines
  61.           then writeln ('No answer')
  62.           else begin
  63.             lnum:=lnum+1;
  64.             writeln (me.text[lnum])
  65.           end
  66.         else write (k)
  67.     end;
  68.     textclose (ff)
  69.   end;
  70.  
  71. begin
  72.   if uname='' then begin
  73.     writeln (^B^M'          Showing All Forms');
  74.     seek (ufile,1);
  75.     for cnt:=1 to numusers do begin
  76.       read (ufile,u);
  77.       if u.infoform<>-1 then begin
  78.         writeln (^M^M,u.handle,^M);
  79.         showone
  80.       end;
  81.       if xpressed then exit
  82.     end
  83.   end else begin
  84.     un:=lookupuser (uname);
  85.     if un=0 then writeln (^B'No such user.') else begin
  86.       seek (ufile,un);
  87.       read (ufile,u);
  88.       showone
  89.     end
  90.   end
  91. end;
  92.  
  93. Function validfname (name:lstr):boolean;
  94. const invalid:set of char=[#0..#31,'"',']','[',':','\','>','<','/','?','*',
  95.   '|','+','=',';', ',' ,#127..#255];
  96. VAR p,cnt:integer;
  97.     k:char;
  98.     dotfound:boolean;
  99. begin
  100.   validfname:=false;
  101.   dotfound:=false;
  102.   if (length(name)>12) or (length(name)<1) then exit;
  103.   for p:=1 to length(name) do begin
  104.     k:=upcase(name[p]);
  105.     if k in invalid then exit;
  106.     if k='.' then begin
  107.       if dotfound then exit;
  108.       dotfound:=true;
  109.       if (p<length(name)-3) or (p=1) then exit
  110.     end
  111.   end;
  112.   validfname:=not devicename(name)
  113. end;
  114.  
  115. Function searchboard (name:sstr):integer;
  116. VAR bi:sstr;
  117.     cnt:integer;
  118. begin
  119.   seek (bifile,0);
  120.   for cnt:=0 to filesize(bifile)-1 do begin
  121.     read (bifile,bi);
  122.     if match(bi,name) then begin
  123.       searchboard:=cnt;
  124.       exit
  125.     end
  126.   end;
  127.   searchboard:=-1
  128. end;
  129.  
  130. Function numfeedback:integer;
  131. VAR ffile:file of mailrec;
  132. begin
  133.   assign (ffile,'Feedback');
  134.   reset (ffile);
  135.   if ioresult<>0 then begin
  136.     numfeedback:=0;
  137.     rewrite (ffile)
  138.   end else numfeedback:=filesize (ffile);
  139.   close (ffile)
  140. end;
  141.  
  142. Procedure trimmessage (VAR m:message);
  143. VAR cnt:integer;
  144. begin
  145.   for cnt:=1 to m.numlines do
  146.     while m.text[cnt][length(m.text[cnt])]=' ' do
  147.       m.text[cnt][0]:=pred(m.text[cnt][0]);
  148.   while (m.numlines>0) and (m.text[m.numlines]='') do
  149.     m.numlines:=m.numlines-1
  150. end;
  151.  
  152. Begin
  153. end.
  154.