Jason Aller Floppy Collection/276.img/FORUM21S.ZIP/BULLETIN.PAS

Pascal/Delphi Source File | 1988-02-13 | 36.4 KB | 1,554 lines

{$R-,S-,I-,D-,T-,F-,V-,B-,N-,L+ }
{$M 65500,0,0 }

unit bulletin;

interface

uses crt,
     gentypes,configrt,statret,gensubs,subs1,subs2,
     userret,textret,mainr1,mainr2,overret1,flags;

procedure bulletinmenu;

implementation

procedure bulletinmenu;
var q,curbul,lastreadnum:integer;
    b:bulrec;

  procedure makeboard; forward;

  function sponsoron:boolean;
  begin
    sponsoron:=match(curboard.sponsor,unam)
  end;

  procedure clearorder (var bo:boardorder);
  var cnt:integer;
  begin
    for cnt:=0 to 255 do bo[cnt]:=cnt
  end;

  procedure carryout (var bo:boardorder);
  var u:userrec;
      cnt,un:integer;

    procedure doone;
    var cnt,q:integer;
        ns,a1,a2:set of byte;
    begin
      fillchar (ns,32,0);
      fillchar (a1,32,0);
      fillchar (a2,32,0);
      for cnt:=0 to 255 do begin
        q:=bo[cnt];
        if q in u.newscanconfig then ns:=ns+[cnt];
        if q in u.access1 then a1:=a1+[cnt];
        if q in u.access2 then a2:=a2+[cnt]
      end;
      u.newscanconfig:=ns;
      u.access1:=a1;
      u.access2:=a2;
      seek (ufile,un);
      write (ufile,u)
    end;

  begin
    writeln (^B'Adjusting user access flags...');
    seek (ufile,1);
    for un:=1 to numusers do begin
      if (un mod 10)=0 then write (' ',un);
      read (ufile,u);
      if length(u.handle)>0 then doone
    end
  end;

  procedure switchboards (bnum1,bnum2:integer; var bo:boardorder);
  var bd1,bd2:boardrec;
      n1:integer;
  begin
    seekbdfile (bnum1);
    read (bdfile,bd1);
    seekbdfile (bnum2);
    read (bdfile,bd2);
    seekbdfile (bnum1);
    writebdfile (bd2);
    seekbdfile (bnum2);
    writebdfile (bd1);
    n1:=bo[bnum1];
    bo[bnum1]:=bo[bnum2];
    bo[bnum2]:=n1
  end;

  procedure setfirstboard; forward;

  procedure seekffile (n:integer);
  begin
    seek (ffile,n-1)
  end;

  function numfiles:integer;
  begin
    numfiles:=filesize (ffile)
  end;

  procedure assignffile;
  begin
    assign (ffile,boarddir+curboardname+'.FIL')
  end;

  procedure formatffile;
  begin
    close (ffile);
    assignffile;
    rewrite (ffile)
  end;

  procedure openffile;
  var f:filerec;
      i:integer;
  begin
    close (ffile);
    assignffile;
    reset (ffile);
    i:=ioresult;
    if i<>0 then formatffile
  end;

  procedure addfile (f:filerec);
  begin
    seekffile (numfiles+1);
    write (ffile,f)
  end;

  procedure delfile (fn:integer);
  var f:filerec;
      cnt:integer;
  begin
    for cnt:=fn to numfiles-1 do begin
      seekffile (cnt+1);
      read (ffile,f);
      seekffile (cnt);
      write (ffile,f)
    end;
    seekffile (numfiles);
    truncate (ffile)
  end;

  procedure seekbfile (n:integer);
  begin
    seek (bfile,n-1); che
  end;

  function numbuls:integer;
  begin
    numbuls:=filesize(bfile)
  end;

  procedure getlastreadnum;
  var oldb:boolean;
      b:bulrec;
      lr:word;
  begin
    lastreadnum:=numbuls;
    oldb:=false;
    lr:=urec.lastread[curboardnum];
    if lr=0
      then lastreadnum:=0
      else
        while (lastreadnum>0) and (not oldb) do begin
          seekbfile (lastreadnum);
          read (bfile,b);
          oldb:=b.id=lr;
          if not oldb then lastreadnum:=lastreadnum-1
        end
  end;

  procedure assignbfile;
  begin
    assign (bfile,boarddir+curboardname+'.BUL')
  end;

  procedure formatbfile;
  begin
    assignbfile;
    rewrite (bfile);
    curboardnum:=searchboard(curboardname);
    if curboardnum=-1 then begin
      curboardnum:=filesize(bdfile);
      fillchar (curboard,sizeof(curboard),0);
      writecurboard
    end
  end;

  procedure openbfile;
  var b:bulrec;
      i:integer;
  begin
    curboardnum:=searchboard (curboardname);
    if curboardnum=-1 then begin
      makeboard;
      exit
    end;
    close (bfile);
    assignbfile;
    reset (bfile);
    i:=ioresult;
    if ioresult<>0 then formatbfile;
    seekbdfile (curboardnum);
    read (bdfile,curboard);
    getlastreadnum;
    openffile
  end;

  function boardexist(n:sstr):boolean;
  begin
    boardexist:=not (searchboard(n)=-1)
  end;

  procedure addbul (var b:bulrec);
  var b2:bulrec;
  begin
    if numbuls=0 then b.id:=1 else begin
      seekbfile (numbuls);
      read (bfile,b2);
      if b2.id=65535
        then b.id:=1
        else b.id:=b2.id+1
    end;
    seekbfile (numbuls+1);
    write (bfile,b)
  end;

  function checkcurbul:boolean;
  begin
    if (curbul<1) or (curbul>numbuls) then begin
      checkcurbul:=false;
      curbul:=0
    end else checkcurbul:=true
  end;

  procedure getbrec;
  begin
    if checkcurbul then begin
      seekbfile (curbul);
      read (bfile,b); che
    end
  end;

  procedure delbul (bn:integer; deltext:boolean);
  var c,un:integer;
      b:bulrec;
      u:userrec;
  begin
    if (bn<1) or (bn>numbuls) then exit;
    seekbfile (bn);
    read (bfile,b);
    if deltext then deletetext (b.line);
    for c:=bn to numbuls-1 do begin
      seekbfile (c+1);
      read (bfile,b);
      seekbfile (c);
      write (bfile,b)
    end;
    seekbfile (numbuls);
    truncate (bfile);
    getlastreadnum
  end;

  procedure delboard (bdn:integer);
  var bd1:boardrec;
      cnt,nbds:integer;
      bo:boardorder;
  begin
    clearorder (bo);
    nbds:=filesize(bdfile)-1;
    if nbds=0 then begin
      close (bdfile);
      rewrite (bdfile);
      exit
    end;
    for cnt:=bdn to nbds-1 do begin
      seekbdfile (cnt+1);
      read (bdfile,bd1);
      seekbdfile (cnt);
      writebdfile (bd1);
      bo[cnt]:=cnt+1
    end;
    seek (bdfile,nbds);
    truncate (bdfile);
    seek (bifile,nbds);
    truncate (bifile);
    carryout (bo)
  end;

  procedure sendfile (fn:integer);
  var f:filerec;
      cnt:integer;
      k:char;
      q:file of byte;
  label exit;
  begin
    seekffile (fn);
    read (ffile,f);
    assign (q,f.fname);
    reset (q);
    iocode:=ioresult;
    if iocode<>0 then begin
      fileerror (f.fname,'SENDFILE (Ascii download)');
      goto exit
    end;
    writelog (4,1,f.descrip);
    writeln ('File:        '^S,f.descrip);
    writeln ('Uploaded by: '^S,f.sentby);
    writeln ('Downloaded:  '^s,f.downloaded);
    writeln ('File size:   '^S,filesize(q),' characters'^M);
    writeln (^B'Press space when you''re ready, or [X] to abort...');
    repeat
      repeat until charready;
      k:=readchar;
      if hungupon then goto exit;
      if upcase(k)='X' then goto exit
    until k=' ';
    if not hungupon
      then
        begin
          printfile (f.fname);
          f.downloaded:=f.downloaded+1;
          seekffile (fn);
          write (ffile,f);
          writeln (^B^M+asciidownload+^M'Press a key...');
          repeat until charready;
          k:=readchar
        end;
    exit:
    close (q)
  end;

  procedure receivefile (f:filerec);
  var fn:lstr;
      cnt,timeul:integer;
      k:char;
      done:boolean;
      fff:text;
      last3:array [1..3] of char;

    procedure putchar (k:char);
    begin
      write (fff,k);
      write (usr,k)
    end;

  begin
    fn:='';
    cnt:=1;
    timeul:=timer;
    repeat
      if cnt<=length(f.descrip) then begin
        k:=upcase(f.descrip[cnt]);
        if k in ['A'..'Z'] then fn:=fn+k
      end;
      cnt:=cnt+1
    until cnt>length(f.descrip);
    if fn='' then fn:='Noname';
    fn:=copy(fn,1,8);
    while devicename(fn) do fn:=fn+chr(random(26)+64);
    fn:=uploaddir+fn+'.';
    cnt:=0;
    repeat
      cnt:=cnt+1
    until (cnt=1000) or (not exist(fn+strr(cnt)));
    if cnt=1000 then begin
      writeln ('Please try another description!');
      exit
    end;
    fn:=fn+strr(cnt);
    assign (fff,fn);
    rewrite (fff);
    iocode:=ioresult;
    if iocode<>0 then begin
      error ('%I opening %1 in RECEIVEFILE (ASCII upload)','',fn);
      exit
    end;
    f.fname:=fn;
    f.sentby:=unam;
    f.downloaded:=0;
    f.when:=now;
    writeln (^B'ASCII receive ready.'^M,
             'Press [CR] and /E to end, /X to abort.'^M);
    textcolor (outlockcolor);
    repeat
      repeat until charready;
      if hungupon
        then done:=true
        else
          begin
            k:=chr(ord(readchar) and 127);
            last3[1]:=last3[2];
            last3[2]:=last3[3];
            last3[3]:=upcase(k);
            done:=((last3[1]=^M) or (last3[1]=^J))
                  and (last3[2]='/') and ((last3[3]='E') or (last3[3]='X'));
            if not done then begin
              if (last3[2]=^M) and (k<>^J) then putchar (^J);
              if last3[2]='/' then putchar ('/');
              if k<>'/'
                then putchar (k)
            end
          end
    until done;
    textclose (fff);
    textcolor (normbotcolor);
    if last3[3]='E' then begin
      addfile (f);
      timeul:=timer-timeul;
      if timeul<0 then timeul:=timeul+1440;
      writeln (^B^M'That upload took ',timeul,' minutes.');
      logontime:=logontime+timeul;
      writelog (4,2,f.descrip)
    end else begin
      writestr (^M^M'Upload aborted!');
      erase (fff);
      iocode:=ioresult
    end
  end;

  procedure readcurbul;
  var q:anystr;
      t:sstr;
      cnt:integer;
  begin
    if checkcurbul then begin
      getbrec;
      writeln (^B'Bulletin '^S,curbul,^M'Title:   '^S,b.title);
      q:='Left by  '^S;
      if b.anon
        then
          begin
            q:=q+anonymousstr;
            if issysop then q:=q+' ('+b.leftby+')'
          end
        else
          begin
            if b.plevel=-1
              then t:='unknown'
              else t:=strr(b.plevel);
            q:=q+b.leftby+' (Level '+t+')'
          end;
      if issysop or (not b.anon)
        then writeln ('When:    '^S,datestr(b.when),' at ',timestr(b.when));
      writeln (q);
      if break then exit;
      printtext (b.line)
    end;
    if curbul>lastreadnum then begin
      lastreadnum:=curbul;
      urec.lastread[curboardnum]:=b.id
    end
  end;

  function queryaccess:accesstype;
  begin
    queryaccess:=getuseraccflag (urec,curboardnum)
  end;

  procedure autodelete;
  var cnt:integer;
  begin
    writeln ('Erasing first five posts...');
    for cnt:=6 downto 2 do delbul (cnt,true)
  end;

  procedure postbul;
  var l:integer;
      m:message;
      b:bulrec;
  begin
    if ulvl<postlevel then begin
      reqlevel(postlevel);
      exit
    end;
    l:=editor(m,true);
    if l>=0 then
      begin
        urec.nbu:=urec.nbu+1;
        writeurec;
        b.anon:=m.anon;
        b.title:=m.title;
        b.when:=now;
        b.leftby:=unam;
        b.line:=l;
        b.plevel:=ulvl;
        addbul (b);
        newposts:=newposts+1;
        with curboard do
          if autodel<=numbuls then autodelete
      end
  end;

  procedure getbnum (txt:mstr);
  var q:boolean;
  begin
    if length(input)>1
      then curbul:=valu(copy(input,2,255))
      else begin
        writestr (^M'Bulletin to '+txt+':');
        curbul:=valu(input)
      end;
    q:=checkcurbul
  end;

  procedure readbul;
  begin
    getbnum ('read');
    readcurbul
  end;

  procedure readnextbul;
  var t:integer;
  begin
    t:=curbul;
    curbul:=curbul+1;
    readcurbul;
    if curbul=0 then curbul:=t
  end;

  procedure readnum (n:integer);
  begin
    curbul:=n;
    readcurbul
  end;

  function haveaccess (n:integer):boolean;
  var a:accesstype;
  begin
    curboardnum:=n;
    seekbdfile (n);
    read (bdfile,curboard);
    a:=queryaccess;
    if a=bylevel
      then haveaccess:=ulvl>=curboard.level
      else haveaccess:=a=letin
  end;

  procedure makeboard;
  begin
    formatbfile;
    formatffile;
    with curboard do begin
      shortname:=curboardname;
      buflen:=30;
      writestr (^M'Board name: &');
      boardname:=input;
      buflen:=30;
      writestr ('Sponsor (C/R for '+unam+'):');
      if input='' then input:=unam;
      sponsor:=input;
      writestr ('Minimum level for entry:');
      level:=valu(input);
      writestr ('Autodelete after:');
      autodel:=valu(input);
      if autodel<10 then begin
        writeln ('Must be at least 10!');
        autodel:=10
      end;
      setallflags (curboardnum,bylevel);
      writecurboard;
      writeln ('Board created.');
      writelog (4,4,boardname+' ['+shortname+']')
    end
  end;

  procedure setactive (nn:sstr);

    procedure doswitch;
    begin
      openbfile;
      curbul:=lastreadnum;
      with curboard do
        writeln (^M'Sub-board: '^S,boardname,
                 ^M'Sponsor:   '^S,sponsor,
                 ^M'Bulletins: '^S,numbuls,
                 ^M'Last read: '^S,lastreadnum,
                 ^M'Files:     '^S,numfiles,^M)
    end;

    procedure tryswitch;
    var n,s:integer;

      procedure denyaccess;
      var b:bulrec;
      begin
        reqlevel (curboard.level);
        setfirstboard
      end;

    begin
      curboardname:=nn;
      curboardnum:=searchboard(nn);
      if haveaccess(curboardnum)
        then doswitch
        else denyaccess
    end;

  var b:bulrec;
  begin
    curbul:=0;
    close (bfile);
    close (ffile);
    curboardname:=nn;
    if boardexist(nn) then tryswitch else begin
      writeln ('No such board: ',curboardname,'!');
      if issysop
        then
          begin
            writestr (^M'Create one (Y/N)? *');
            if yes
              then
                begin
                  makeboard;
                  setactive (curboardname)
                end
              else setfirstboard
          end
        else setfirstboard
    end
  end;

  function validbname (n:sstr):boolean;
  var cnt:integer;
  begin
    validbname:=false;
    if (length(n)=0) or (length(n)>8) then exit;
    for cnt:=1 to length(n) do
      if not (upcase(n[cnt]) in ['0'..'9','A'..'Z']) then exit;
    validbname:=true
  end;

  procedure listboards;
  var cnt,oldcurboard:integer;
      printed:boolean;
  begin
    oldcurboard:=curboardnum;
    writeln (^M'Number   Name                      Level'^M);
    if break then exit;
    for cnt:=0 to filesize(bdfile)-1 do
      if haveaccess(cnt) then
        with curboard do begin
          tab (shortname,9);
          tab (boardname,26);
          writeln (level);
          if break then exit
        end;
    curboardnum:=oldcurboard;
    seekbdfile (curboardnum);
    read (bdfile,curboard)
  end;

  procedure activeboard;
  begin
    if length(input)>1
      then input:=copy(input,2,255)
      else
        repeat
          writestr (^M^M'Board number [?=List]:');
          if input='?' then listboards
        until (input<>'?') or hungupon;
    if hungupon or (length(input)=0) then exit;
    if input[1]='*' then input:=copy(input,2,255);
    if validbname(input)
      then setactive (input)
      else
        begin
          writeln (^M'Invalid board name!');
          setfirstboard
        end
  end;

  procedure setfirstboard; { FORWARD }
  var fbn:sstr;
  begin
    if filesize(bdfile)=0 then exit;
    if not haveaccess(0)
      then error ('User can''t access first board','','');
    seek (bifile,0);
    read (bifile,fbn);
    setactive (fbn)
  end;

  procedure listbuls;
  var cnt,bn:integer;
      q:boolean;
  begin
    if length(input)>1 then begin
      curbul:=valu(copy(input,2,255));
      q:=checkcurbul
    end;
    if curbul=0
      then
        begin
          writestr (^M'List titles starting at #*');
          curbul:=valu(input)
        end
      else
        if length(input)>1
          then curbul:=valu(input)
          else curbul:=curbul+10;
    if not checkcurbul then curbul:=1;
    writeln ('Titles:'^M);
    for cnt:=0 to 9 do
      begin
        bn:=curbul+cnt;
        if (bn>0) and (bn<=numbuls) then
          begin
            seekbfile (bn);
            read (bfile,b);
            write (bn,'. ',b.title,' by ');
            if b.anon
              then writeln (anonymousstr)
              else writeln (b.leftby);
            if break then exit
          end
      end
  end;

  procedure killbul;
  var un:integer;
      u:userrec;
  begin
    writehdr ('Bulletin Deletion');
    getbnum ('delete');
    if not checkcurbul then exit;
    getbrec;
    if (not match(b.leftby,unam)) and (not issysop) and (not sponsoron)
      then begin
        writeln ('You didn''t post that!');
        exit
      end;
    writeln ('Title:   ',b.title,
             ^M'Left by: ',b.leftby,^M^M);
    writestr ('Delete this? *');
    if not yes then exit;
    un:=lookupuser (b.leftby);
    if un<>0 then begin
      writeurec;
      seek (ufile,un);
      read (ufile,u);
      u.nbu:=u.nbu-1;
      seek (ufile,un);
      write (ufile,u);
      readurec
    end;
    delbul (curbul,true);
    writeln ('Bulletin deleted.');
    writelog (4,5,b.title)
  end;

  procedure editbul;
  var me:message;
  begin
    getbnum ('edit');
    if not checkcurbul then exit;
    getbrec;
    if (not match(b.leftby,unam)) and (not issysop) and (not sponsoron)
      then begin
        writeln ('You didn''t post that!');
        exit
      end;
    reloadtext (b.line,me);
    me.title:=b.title;
    me.anon:=b.anon;
    if reedit (me,true) then begin
      writelog (4,6,b.title);
      deletetext (b.line);
      b.line:=maketext (me);
      if b.line<0 then begin
        writestr (^M'Deleting bulletin...');
        delbul (curbul,false)
      end else begin
        seekbfile (curbul);
        write (bfile,b)
      end
    end
  end;


  procedure sendbreply;
  begin
    if checkcurbul then begin
      getbrec;
      sendmailto (b.leftby,b.anon)
    end else begin
      getbnum ('reply to');
      if checkcurbul then sendbreply
    end
  end;

  procedure listfiles;
  var cnt,r1,r2,nfiles:integer;
      f:filerec;
  begin
    nfiles:=numfiles;
    thereare (nfiles,'file','files');
    if nfiles=0 then exit;
    parserange (nfiles,r1,r2);
    if r1=0 then exit;
    for cnt:=r1 to r2 do begin
      seekffile (cnt);
      read (ffile,f); che;
      writeln (cnt,'. ',f.descrip);
      if break then exit
    end
  end;

  function getfilenumber (txt:lstr):integer;
  var fn:integer;
      gotten:boolean;
  begin
    getfilenumber:=0;
    input:=copy(input,2,255);
    if length(input)=0 then
      repeat
        gotten:=true;
        writestr (^M'File number to '+txt+' [?=List]:');
        if input='?' then
          begin
            writeln;
            listfiles;
            writeln;
            gotten:=false
          end
      until gotten;
    fn:=valu(input);
    if (fn<1) or (fn>numfiles) then fn:=0;
    getfilenumber:=fn
  end;

  procedure downloadfile;
  var fn:integer;
  begin
    fn:=getfilenumber ('download');
    if fn<>0 then
      begin
        sendfile (fn);
        urec.ndn:=urec.ndn+1
      end;
  end;

  procedure uploadfile;
  var f:filerec;
  begin
    writestr ('Describe the file'+^M+'=> *');
    if length(input)<>0 then begin
      f.descrip:=input;
      receivefile (f);
      urec.nup:=urec.nup+1
    end
  end;

  procedure boardsponsor;

    procedure getbgen (txt:mstr; var q);
    var s:lstr absolute q;
    begin
      writeln (^B'Current ',txt,': ',s);
      buflen:=30;
      writestr ('Enter new '+txt+':');
      if length(input)>0 then s:=input
    end;

    procedure getbint (txt:mstr; var i:integer);
    var a:anystr;
    begin
      a:=strr(i);
      getbgen (txt,a);
      i:=valu(a);
      writecurboard
    end;

    procedure getbstr (txt:mstr; var q);
    begin
      getbgen (txt,q);
      writecurboard
    end;

    procedure setacc (ac:accesstype; un:integer);
    var u:userrec;
    begin
      seek (ufile,un);
      read (ufile,u);
      setuseraccflag (u,curboardnum,ac);
      seek (ufile,un);
      write (ufile,u)
    end;

    function queryacc (un:integer):accesstype;
    var u:userrec;
    begin
      seek (ufile,un);
      read (ufile,u);
      queryacc:=getuseraccflag (u,curboardnum)
    end;

    procedure setnameaccess;
    var un,n:integer;
        ac:accesstype;
        q,unm:mstr;
    begin
      writestr (^M'Change access for user:');
      un:=lookupuser(input);
      if un=0 then begin
        writeln ('No such user!');
        exit
      end;
      unm:=input;
      ac:=queryacc(un);
      writeln (^B^M'Current access: ',accessstr[ac]);
      getacflag (ac,q);
      if ac=invalid then exit;
      if un=unum then writeurec;
      setacc (ac,un);
      if un=unum then readurec;
      case ac of
        letin:n:=1;
        keepout:n:=2;
        bylevel:n:=3
      end;
      writelog (5,n,unm)
    end;

    procedure setallaccess;
    var cnt:integer;
        ac:accesstype;
        q:mstr;
    begin
      writehdr ('Set Everyone''s Access');
      getacflag (ac,q);
      if ac=invalid then exit;
      writeurec;
      setallflags (curboardnum,ac);
      readurec;
      writeln ('Done.');
      writelog (5,4,accessstr[ac])
    end;

    procedure listaccess;

      procedure listacc (all:boolean);
      var cnt:integer;
          a:accesstype;
          u:userrec;

        procedure writeuser;
        begin
          if all
            then
              begin
                tab (u.handle,30);
                if a=bylevel
                  then writeln ('Level='+strr(u.level))
                  else writeln ('Let in')
              end
            else writeln (u.handle)
        end;

      begin
        seek (ufile,1);
        for cnt:=1 to numusers do begin
          read (ufile,u);
          a:=getuseraccflag (u,curboardnum);
          case a of
            letin:writeuser;
            bylevel:if all and (u.level>=curboard.level) then writeuser
          end;
          if break then exit
        end
      end;

    begin
      writestr (
'List A)ll users who have access, or only those with S)pecial access? *');
      if length(input)=0 then exit;
      case upcase(input[1]) of
        'A':listacc (true);
        'S':listacc (false)
      end
    end;

    procedure getblevel;
    var b:bulrec;
    begin
      getbint ('level',curboard.level);
      writelog (5,12,strr(curboard.level))
    end;

    procedure getautodel;
    var b:bulrec;
    begin
      with curboard do begin
        getbint ('auto-delete',autodel);
        if autodel<10
          then
            begin
              writeln (^B'HEY!  It can''t be less than ten!');
              autodel:=numbuls+1;
              if autodel<10 then autodel:=10;
              writeln (^B'Setting autodelete to ',autodel);
              writecurboard
            end
          else
            if autodel<=numbuls
              then
                begin
                  writeln (^B'Deleting bulletins...');
                  while autodel<=numbuls do delbul (2,true)
                end
      end;
      writelog (5,11,strr(curboard.autodel))
    end;

    procedure getfiletitle;
    var fn:integer;
        f:filerec;
    begin
      fn:=getfilenumber ('change the title of');
      if fn<>0 then begin
        seekffile (fn);
        read (ffile,f); che;
        writeln (^B'Old description: ',f.descrip);
        writestr ('New description [or CR]:');
        if length(input)>0 then begin
          f.descrip:=input;
          seekffile (fn);
          write (ffile,f);
          writelog (5,9,f.descrip)
        end
      end
    end;

    procedure movefile;
    var f:filerec;
        tcb:boardrec;
        tcbn,dbn,fn:integer;
        tcbname:sstr;
    begin
      writehdr ('File Move');
      fn:=getfilenumber ('move');
      if fn=0 then exit;
      seekffile (fn);
      read (ffile,f);
      writestr ('Move "'+f.descrip+'" to which board? *');
      if length(input)=0 then exit;
      tcb:=curboard;
      tcbn:=curboardnum;
      tcbname:=curboardname;
      dbn:=searchboard(input);
      if dbn=-1 then begin
        writeln ('No such board!');
        exit
      end;
      writeln ('Moving...');
      delfile (fn);
      close (bfile);
      close (ffile);
      seek (bdfile,dbn);
      read (bdfile,curboard);
      curboardnum:=dbn;
      curboardname:=curboard.shortname;
      openbfile;
      addfile (f);
      close (bfile);
      close (ffile);
      curboard:=tcb;
      curboardname:=tcbname;
      curboardnum:=tcbn;
      openbfile;
      writelog (5,6,f.descrip);
      writeln (^B'Done!')
    end;

    procedure movebulletin;
    var b:bulrec;
        tcb:boardrec;
        tcbn,dbn,bnum:integer;
        tcbname,dbname:sstr;
    begin
      writehdr ('Bulletin Move');
      getbnum ('move');
      if not checkcurbul then exit;
      bnum:=curbul;
      seekbfile (bnum);
      read (bfile,b);
      writestr ('Move "'+b.title+'" posted by '+b.leftby+
        ' to which board? *');
      if length(input)=0 then exit;
      tcbname:=curboardname;
      dbname:=input;
      dbn:=searchboard(dbname);
      if dbn=-1 then begin
        writeln ('No such board!');
        exit
      end;
      writeln ('Moving...');
      delbul (bnum,false);
      close (bfile);
      close (ffile);
      curboardname:=dbname;
      openbfile;
      addbul (b);
      close (bfile);
      close (ffile);
      curboardname:=tcbname;
      openbfile;
      writelog (5,13,b.title);
      writeln (^B'Done!')
    end;

    procedure wipeoutfile;
    var un,fn:integer;
        f:filerec;
        q:file;
        n:mstr;
        u:userrec;
    begin
      writehdr ('File Wipe-out');
      fn:=getfilenumber ('wipe out');
      if fn=0 then exit;
      seekffile (fn);
      read (ffile,f);
      writestr ('Wipe out: "'+f.descrip+'" ? *');
      if not yes then exit;
      writestr ('Erase disk file '+f.fname+'? *');
      if yes then begin
        assign (q,f.fname);
        erase (q);
        un:=ioresult
      end;
      delfile (fn);
      writelog (5,7,f.descrip);
      n:=f.sentby;
      un:=lookupuser(n);
      if un<>0
        then
          begin
            seek (ufile,un);
            read (ufile,u);
            u.nup:=u.nup-1;
            writeln (n,' now has ',u.nup,' uploads.');
            seek (ufile,un);
            write (ufile,u)
          end
    end;

    procedure setsponsor;
    var un:integer;
        b:bulrec;
    begin
      writestr ('New sponsor:');
      if length(input)=0 then exit;
      un:=lookupuser (input);
      if un=0
        then writeln ('No such user.')
        else
          begin
            curboard.sponsor:=input;
            writelog (5,8,input);
            writecurboard
          end
    end;

    procedure renameboard;
    var sn:sstr;
        nfp,nbf,nff:lstr;
        qf:file;
        d:integer;
    begin
      getbstr ('board name',curboard.boardname);
      sn:=curboard.shortname;
      getbgen ('access name/number',sn);
      writelog (5,5,curboard.boardname+' ['+sn+']');
      if match(sn,curboard.shortname) then exit;
      if not validbname(sn) then begin
        writeln ('Invalid board name!');
        exit
      end;
      if boardexist(sn) then begin
        writeln ('Sorry!  Board already exists!');
        exit
      end;
      curboard.shortname:=sn;
      writecurboard;
      close (bfile);
      close (ffile);
      nfp:=boarddir+sn+'.';
      nbf:=nfp+'BUL';
      nff:=nfp+'FIL';
      assign (qf,nbf);
      erase (qf);
      d:=ioresult;
      assign (qf,nff);
      erase (qf);
      d:=ioresult;
      rename (bfile,nbf);
      rename (ffile,nff);
      setfirstboard;
      q:=9
    end;

    procedure killboard;
    var cnt:integer;
        f:file;
        fr:filerec;
        bd:boardrec;
    begin
      writestr ('Kill board:  Are you sure? *');
      if not yes then exit;
      writelog (5,10,'');
      writeln (^B^M'Deleting messages...');
      for cnt:=numbuls downto 1 do
        begin
          delbul(cnt,true);
          write (cnt,' ')
        end;
      writeln (^B^M'Deleting files...');
      for cnt:=numfiles downto 1 do
        begin
          seekffile (cnt);
          read (ffile,fr);
          assign (f,fr.fname);
          erase (f);
          if ioresult<>0 then writeln (^B'Error erasing ',fr.fname);
          delfile (cnt);
          write (cnt,' ')
        end;
      writeln (^B^M'Deleting sub-board files...');
      close (bfile);
      assignbfile;
      erase (bfile);
      if ioresult<>0 then writeln (^B'Error erasing board file.');
      close (ffile);
      assignffile;
      erase (ffile);
      if ioresult<>0 then writeln (^B'Error erasing file directory file.');
      writeln (^M'Removing sub-board...');
      delboard (curboardnum);
      writeln (^B'Sub-board erased!');
      setfirstboard;
      q:=9
    end;

    procedure sortboards;
    var cnt,mark,temp:integer;
        bd1,bd2:boardrec;
        bn1,bn2:sstr;
        bo:boardorder;
    begin
      writestr ('Sort sub-boards: Are you sure? *');
      if not yes then exit;
      clearorder (bo);
      mark:=filesize(bdfile)-1;
      repeat
        if mark<>0 then begin
          temp:=mark;
          mark:=0;
          for cnt:=0 to temp-1 do begin
            seek (bifile,cnt);
            read (bifile,bn1);
            read (bifile,bn2);
            if upstring(bn1)>upstring(bn2) then begin
              mark:=cnt;
              switchboards (cnt,cnt+1,bo)
            end
          end
        end
      until mark=0;
      carryout (bo);
      writelog (5,16,'');
      setfirstboard;
      q:=9
    end;

    procedure orderboards;
    var numb,curb,newb:integer;
        bo:boardorder;
    label exit;
    begin
      clearorder (bo);
      writehdr ('Re-order sub-boards');
      numb:=filesize (bdfile);
      thereare (numb,'sub-board','sub-boards');
      for curb:=0 to numb-2 do begin
        repeat
          writestr ('New board #'+strr(curb+1)+' [?=List, CR to quit]:');
          if length(input)=0 then goto exit;
          if input='?'
            then
              begin
                listboards;
                newb:=-1
              end
            else
              begin
                newb:=searchboard(input);
                if newb<0 then writeln ('Not found!  Please re-enter...')
              end
        until (newb>=0);
        switchboards (curb,newb,bo)
      end;
      exit:
      carryout (bo);
      writelog (5,14,'');
      q:=9;
      setfirstboard
    end;

    procedure addresident;
    var f:filerec;
    begin
      writestr ('Filename (including path):');
      if hungupon or (length(input)=0) then exit;
      if devicename(input) then begin
        writeln ('That''s a DOS device name !');
        exit
      end;
      if not exist(input) then begin
        writeln ('File not found.');
        exit
      end;
      f.sentby:=unam;
      f.fname:=input;
      writestr ('Description:');
      if length(input)=0 then exit;
      f.descrip:=input;
      f.downloaded:=0;
      f.when:=now;
      addfile (f);
      writelog (5,15,f.fname)
    end;

  begin
    if (not sponsoron) and (not issysop) then begin
      writeln ('Nice try, except you aren''t the sponsor.');
      exit
    end;
    writelog (4,3,curboard.boardname+' ['+curboard.shortname+']');
    repeat
      q:=menu ('Sponsor','SPONSOR','DLSTMWUEQRKC@BO@VA@H');
      case q of
        1:getautodel;
        2:getblevel;
        3:setsponsor;
        4:getfiletitle;
        5:movefile;
        6:wipeoutfile;
        7:setnameaccess;
        8:setallaccess;
        10:renameboard;
        11:killboard;
        12:sortboards;
        13:movebulletin;
        14:orderboards;
        15:listaccess;
        16:addresident;
        17:help ('Sponsor.hlp')
      end
    until (q=9) or hungupon
  end;

  var beenaborted:boolean;

  function aborted:boolean;
  begin
    if beenaborted then begin
      aborted:=true;
      exit
    end;
    aborted:=xpressed or hungupon;
    if xpressed then begin
      beenaborted:=true;
      writeln (^B'Newscan aborted!')
    end
  end;

  procedure newscanboard;

    procedure shownewfiles;
    var cnt,first,numf:integer;
        f:filerec;
        nf:boolean;
    begin
      numf:=numfiles;
      cnt:=numf;
      nf:=true;
      while (cnt>0) and nf do begin
        seekffile (cnt);
        read (ffile,f);
        nf:=f.when>laston;
        if nf then cnt:=cnt-1
      end;
      first:=cnt+1;
      if first>numf then exit;
      writehdr ('New files');
      if aborted or break then exit;
      for cnt:=first to numf do begin
        seekffile (cnt);
        read (ffile,f);
        writeln (cnt,'. ',f.descrip);
        if aborted or break then exit
      end
    end;

  var newmsgs:boolean;
      oldb:boolean;
  begin
    beenaborted:=false;
    newmsgs:=false;
    curbul:=lastreadnum+1;
    while curbul<=numbuls do begin
      getbrec;
      if b.when>laston then begin
        readnum (curbul);
        newmsgs:=true
      end;
      curbul:=curbul+1;
      if aborted then exit
    end;
    shownewfiles;
    if (postprompts in urec.config) and newmsgs and (ulvl>=postlevel)
      then begin
        writestr (^M'Post now? *');
        writeln;
        if yes then postbul
      end
  end;

  procedure newscanall;
  var cb:integer;
  begin
    beenaborted:=false;
    writehdr ('New-scanning. [X] to abort.');
    if aborted then exit;
    for cb:=0 to filesize(bdfile)-1 do begin
      if aborted then exit;
      if haveaccess(cb) and (not (cb in urec.newscanconfig)) then begin
        curboardname:=curboard.shortname;
        openbfile;
        if aborted then exit;
        writeln (^B^M'Scanning ',curboard.boardname,'...'^M);
        if aborted then exit;
        newscanboard
      end
    end;
    writeln (^B^M'Newscan complete!'^G);
    setfirstboard
  end;

  procedure noboards;
  begin
    writeln ('No sub-boards exist!');
    if not issysop then exit;
    writestr ('Create the first sub-board now? *');
    if not yes then exit;
    writestr ('Enter its access name/number:');
    if not validbname(input) then writeln (^B'Invalid board name!') else begin
      curboardname:=input;
      makeboard
    end
  end;

  procedure togglenewscan;
  begin
    write ('Newscan this board: ');
    if curboardnum in urec.newscanconfig
      then
        begin
          writeln ('Yes');
          urec.newscanconfig:=urec.newscanconfig-[curboardnum]
        end
      else
        begin
          writeln ('No');
          urec.newscanconfig:=urec.newscanconfig+[curboardnum]
        end
  end;

  procedure nextsubboard;
  var cb:integer;
      obn:sstr;
  begin
    obn:=curboardname;
    cb:=curboardnum;
    while cb<filesize(bdfile)-1 do begin
      cb:=cb+1;
      if haveaccess (cb) then begin
        seek (bifile,cb);
        read (bifile,obn);
        setactive (obn);
        exit
      end
    end;
    writestr ('This is the last sub-board!');
    setactive (obn)
  end;

var boo:boolean;
label exit;
begin
  cursection:=bulletinsysop;
  openbdfile;
  if filesize(bdfile)=0 then begin
    noboards;
    if filesize(bdfile)=0 then begin
      closebdfile;
      goto exit
    end
  end;
  if not haveaccess(0)
    then
      begin
        writeln (^B'You do not have access to the first sub-board!');
        closebdfile;
        goto exit
      end;
  setfirstboard;
  repeat
    boo:=checkcurbul;
    with curboard do
      writeln (^M,boardname,' [',shortname,']: ',curbul,' of ',numbuls);
    if sponsoron or issysop
      then writeln ('%: Board sponsor commands');
    q:=menu ('Bulletin','BULLET','PRDFUKT*MQ#_%LNBAVCHES+W');
    case q of
      1:postbul;
      2:readbul;
      3:downloadfile;
      4,22:sendmailto (curboard.sponsor,false);
      5:uploadfile;
      6:killbul;
      8,16,17:activeboard;
      7:listbuls;
      9:sendbreply;
      12:if not hungupon then readnextbul;
      13:boardsponsor;
      14:listfiles;
      15:newscanall;
      18:newscanboard;
      19:togglenewscan;
      20:help ('Bulletin.hlp');
      21:editbul;
      23:nextsubboard;
      24:readnum (lastreadnum+1);
      else if q<0 then readnum (-q)
    end
  until (q=10) or hungupon or (filesize(bdfile)=0);
  exit:
  close (bfile);
  close (ffile);
  closebdfile
end;


begin
end.