home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / SYSPC22.ZIP / MAINR1.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-02-16  |  3.6 KB  |  154 lines
  1. overlay procedure showinfoforms (uname:mstr);  { UNAME='' shows all }
  2. var lnum,un,cnt:integer;
  3.     u:userrec;
  4.  
  5.   procedure showone(ask:boolean);
  6.   var ff:text;
  7.       me:message;
  8.       k:char;
  9.       found:boolean;
  10.       z:integer;
  11.       l:anystr;
  12.       w:integer;
  13.   begin
  14.   begin
  15.     input:='1';
  16.     if ask then begin
  17.     Writestr ('Which InfoForm(1-9): @');
  18.     w:=valu(input);
  19.     end else w:=1;
  20.     if w<1 then exit;
  21.     z:=u.infoform[w];
  22.     if z=-1 then begin
  23.       writestr ('That user has not filled out that infoform.');
  24.       exit
  25.     end;
  26.     end;
  27.     assign (ff,textfiledir+'Info'+input);
  28.     reset (ff);
  29.     if ioresult<>0 then begin
  30.       close (ff);
  31.       lnum:=ioresult;
  32.       writeln ('That information form is not present.');
  33.       exit
  34.     end;
  35.     reloadtext(u.infoform[w],me);
  36.     writeln (^M,me.text[1],^M^M);
  37.     lnum:=1;
  38.     while not (break or eof(ff)) do begin
  39.       read (ff,k);
  40.       if k='*'
  41.         then if lnum>me.numlines
  42.           then writeln ('No answer')
  43.           else begin
  44.             lnum:=lnum+1;
  45.             writeln (me.text[lnum])
  46.           end
  47.         else writechar (k);
  48.     end;
  49.    textclose (ff)
  50.   end;
  51.  
  52. begin
  53.   if uname='' then begin
  54.     writehdr ('Showing Infoform #1 for all users');
  55.     seek (ufile,1);
  56.     for cnt:=1 to numusers do begin
  57.       read (ufile,u);
  58.       if u.infoform[1]<>-1 then begin
  59.         writestr (^M^M+u.handle+^M);
  60.         showone(false);
  61.       end;
  62.       if xpressed then exit
  63.     end
  64.   end else begin
  65.     un:=lookupuser (uname);
  66.     if un=0 then writestr ('No such user.') else begin
  67.       seek (ufile,un);
  68.       read (ufile,u);
  69.       showone(true);
  70.       nosys:=true;
  71.     end
  72.   end
  73. end;
  74.  
  75. overlay function validfname (name:lstr):boolean;
  76. const invalid:set of char=[#0..#31,'"',']','[',':','\','>','<','/','?','*',
  77.   '|','+','=',';', ',' ,#127..#255];
  78. var p,cnt:integer;
  79.     k:char;
  80.     dotfound:boolean;
  81. begin
  82.   validfname:=false;
  83.   dotfound:=false;
  84.   if (length(name)>12) or (length(name)<1) then exit;
  85.   for p:=1 to length(name) do begin
  86.     k:=upcase(name[p]);
  87.     if k in invalid then exit;
  88.     if k='.' then begin
  89.       if dotfound then exit;
  90.       dotfound:=true;
  91.       if (p<length(name)-3) or (p=1) then exit
  92.     end
  93.   end;
  94.   validfname:=not devicename(name)
  95. end;
  96.  
  97. overlay function searchboard (name:sstr):integer;
  98. var bi:sstr;
  99.     cnt:integer;
  100. begin
  101.   seek (bifile,0);
  102.   for cnt:=0 to filesize(bifile)-1 do begin
  103.     read (bifile,bi);
  104.     if match(bi,name) then begin
  105.       searchboard:=cnt;
  106.       exit
  107.     end
  108.   end;
  109.   searchboard:=-1
  110. end;
  111.  
  112. overlay function numfeedback:integer;
  113. var ffile:file of mailrec;
  114. begin
  115.   assign (ffile,'Feedback');
  116.   reset (ffile);
  117.   if ioresult<>0 then begin
  118.     numfeedback:=0;
  119.     rewrite (ffile)
  120.   end else numfeedback:=filesize (ffile);
  121.   close (ffile)
  122. end;
  123.  
  124. overlay procedure writestatus;
  125. const numtimers=3;
  126. type timerset=array [1..numtimers] of minuterec;
  127. var realt:timerset absolute numminsidle;
  128.     t:timerset;
  129.     cnt:integer;
  130.     ss:systemstatus absolute numcallers;
  131.     f:file of systemstatus;
  132. begin
  133.   assign (f,'Status');
  134.   rewrite (f);
  135.   t:=realt;
  136.   for cnt:=1 to numtimers do
  137.     if realt[cnt].started
  138.      then stoptimer (realt[cnt]);
  139.   write (f,ss);
  140.   realt:=t;
  141.   close (f)
  142. end;
  143.  
  144. overlay procedure trimmessage (var m:message);
  145. var cnt:integer;
  146. begin
  147.   for cnt:=1 to m.numlines do
  148.     while m.text[cnt][length(m.text[cnt])]=' ' do
  149.       m.text[cnt][0]:=pred(m.text[cnt][0]);
  150.   while (m.numlines>0) and (m.text[m.numlines]='') do
  151.     m.numlines:=m.numlines-1
  152. end;
  153.  
  154.