Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/FORUM25C.ZIP/ABOUT.PAS

Pascal/Delphi Source File | 1988-12-27 | 6.6 KB | 290 lines

{$R-,S-,I-,D-,V-,B-,N-,L- }
{$O+}

unit about;


{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}

interface

uses gentypes,configrt,gensubs,subs1,subs2;

{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}

Procedure aboutthisbbs;

{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}

implementation

{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}

Procedure aboutthisbbs;
VAR ab:abrec;

  Function numabouts:integer;
  begin
    numabouts:=filesize(abfile)
  end;

  Procedure seekabfile (n:integer);
  begin
    seek (abfile,n-1)
  end;

  Procedure openabfile;
  VAR n:integer;
  begin
    n:=ioresult;
    assign (abfile,'Aboutbbs');
    reset (abfile);
    if ioresult<>0 then begin
      close (abfile);
      n:=ioresult;
      rewrite (abfile)
    end
  end;

  Procedure listabouts;
  VAR cnt:integer;
      b:boolean;
  begin
    writeln;
    b:=true;
    seekabfile (1);
    for cnt:=1 to numabouts do begin
      read (abfile,ab);
      if (ulvl>=ab.level) or issysop then begin
        if b then begin
          writestr (^M'Num Title'^M);
          b:=false
        end;
        tab (strr(cnt),4);
        writeln (ab.title);
        if break then exit
      end
    end;
    if b then writestr ('Sorry, no information files are available!')
  end;

  Function getaboutnum:integer;
  VAR n:integer;
  begin
    getaboutnum:=0;
    repeat
      writestr ('Information file number [?=list]:');
      if length(input)=0 then exit;
      if upcase(input[1])='?'
        then listabouts
        else begin
          n:=valu(input);
          if (n<1) or (n>numabouts) then begin
            writestr (^M'Sorry, file number out of range!');
            exit
          end;
          seekabfile (n);
          read (abfile,ab);
          if (ulvl<ab.level) and (not issysop) then begin
            reqlevel (ab.level);
            exit
          end;
          getaboutnum:=n;
          exit
        end
    until hungupon
  end;

  Procedure showaboutfile (n:integer);
  begin
    seekabfile (n);
    read (abfile,ab);
    if ulvl<ab.level then begin
      reqlevel (ab.level);
      exit
    end;
    writeln (^M'Title:   '^S,ab.title,
             ^M'Updated: '^S,timestr(ab.when),' at ',datestr(ab.when),^M);
    printfile (ab.fname)
  end;

  Procedure makeaboutfile;
  VAR t:text;
      b:boolean;
  begin
    assign (t,ab.fname);
    rewrite (t);
    writestr (^M'Enter text, /S to save:'^M);
    repeat
      lastprompt:='Continue...'^M;
      wordwrap:=true;
      getstr;
      b:=match(input,'/S');
      if not b then writeln (t,input)
    until b;
    textclose (t);
    writestr (^M'File created!');
    ab.when:=now;
    writelog (3,2,ab.fname)
  end;

  Procedure addabout;
  begin
    writestr ('Title:');
    if length(input)=0 then exit;
    ab.title:=input;
    writestr ('Level:');
    ab.level:=valu(input);
    writestr ('Filename (include path ['+textfiledir+']):');
    if length(input)=0 then exit;
    if pos('\',input)=0 then input:=textfiledir+input;
    ab.fname:=input;
    if not exist(ab.fname) then begin
      writestr ('File not found!  Enter file now? *');
      if yes then makeaboutfile
    end;
    ab.when:=now;
    seekabfile (numabouts+1);
    write (abfile,ab);
    writestr ('File added.');
    writelog (3,1,ab.title)
  end;

  Procedure changeabout;
  VAR n:integer;

    Procedure getstr (prompt:mstr; VAR ss; len:integer);
    VAR a:anystr absolute ss;
    begin
      writeln (^B^M'  Current ',prompt,' is: '^S,a);
      buflen:=len;
      writestr ('Enter new '+prompt+':');
      if length(input)>0 then a:=input;
    end;

    Procedure getint (prompt:mstr; VAR i:integer);
    VAR q:sstr;
        n:integer;
    begin
      str (i,q);
      getstr (prompt,q,5);
      n:=valu (q);
      if n<>0 then i:=n
    end;

  begin
    n:=getaboutnum;
    if n=0 then exit;
    seekabfile (n);
    read (abfile,ab);
    getstr ('title',ab.title,80);
    getint ('level',ab.level);
    getstr ('filename',ab.fname,80);
    if not exist (ab.fname) then write (^B^M,ab.fname,' not found!');
    writestr (^M'Create new file '+ab.fname+'? *');
    if yes then makeaboutfile;
    seekabfile (n);
    write (abfile,ab);
    writelog (3,3,ab.title);
  end;

  Procedure deleteabout;
  VAR cnt,n:integer;
      f:file;
  begin
    n:=getaboutnum;
    if n=0 then exit;
    seekabfile (n);
    read (abfile,ab);
    writestr ('Delete '+ab.title+'? *');
    if not yes then exit;
    writestr ('Erase disk file '+ab.fname+'? *');
    if yes then begin
      assign (f,ab.fname);
      erase (f);
      if ioresult<>0
        then writestr ('Couldn''t erase file.')
    end;
    for cnt:=n+1 to numabouts do begin
      seekabfile (cnt);
      read (abfile,ab);
      seekabfile (cnt-1);
      write (abfile,ab)
    end;
    seekabfile (numabouts);
    truncate (abfile);
    writestr (^M'Deleted.');
    writelog (3,4,ab.title)
  end;

  Procedure updateabout;
  VAR n:integer;
  begin
    n:=getaboutnum;
    if n=0 then exit;
    seekabfile (n);
    read (abfile,ab);
    ab.when:=now;
    seekabfile (n);
    write (abfile,ab);
    writeln ('File ',n,' time/date updated.');
    writelog (3,5,ab.title)
  end;

  Procedure sysopcommands;
  VAR q:integer;
  begin
    if not issysop then begin
      reqlevel (sysoplevel);
      exit
    end;
    repeat
      q:=menu ('ABOUT sysop','ABOUT','QACDU');
      case q of
        2:addabout;
        3:changeabout;
        4:deleteabout;
        5:updateabout;
      end
    until hungupon or (q=1)
  end;

label exit;
VAR prompt:lstr;
    n:integer;
    k:char;
begin
  openabfile;
  repeat
    prompt:=^M'Information file number [?=list';
    if issysop then prompt:=prompt+', %=sysop';
    prompt:=prompt+']:';
    writestr (prompt);
    if length(input)=0 then goto exit;
    k:=upcase(input[1]);
    case k of
      'Q':goto exit;
      '%':sysopcommands;
      '?':listabouts;
      else begin
        n:=valu(input);
        if n<>0 then
          if (n<0) or (n>numabouts)
            then writestr ('Out of range!')
            else showaboutfile (n)
      end
    end
  until hungupon;
  exit:
  close (abfile)
end;

{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}

{initialization}

{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}

begin
end.