Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/FAQ-S.ZIP/MAINR1.PAS

Pascal/Delphi Source File | 1991-02-25 | 7.9 KB | 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.