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

unit bulletin;               (* Message Section for ViSiON *)

interface

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

procedure bulletinmenu;

implementation

procedure bulletinmenu;
var q,curbul,lastreadnum:integer;
    b:bulrec;
    reading,quitmasterinc,cscan:boolean;

procedure readfromtext; forward;

  procedure togglecscan;
  begin
   if cscan then cscan:=false else
    cscan:=true;
   writeln;
   write (^R'Auto-Scan is now: '^S);
   if cscan then writeln ('On') else writeln ('Off');
   writeln;
  end;

  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'Now Adjusting the 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 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+(50*(CurrentConference-1))];
    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;
        if (lastreadnum=0) then urec.lastread[curboardnum+(50*(currentconference-1))]:=0;
  end;

  procedure assignbfile;
  Var S:Mstr;
  begin
  close(bfile);
    S:=ConfigSet.BoardDi+CurBoardName;
    If CurrentConference=1 then S:=S+'.BUL'
       Else
    S:=S+'.BU'+Strr(CurrentConference);
    assign (bfile,s)
  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;
  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;
  var n:integer;
      u:userrec;
  begin
    if checkcurbul then begin
      seekbfile (curbul);
      read (bfile,b); che;
      n:=lookupuser(b.leftby);
      b.status:='';
      if n>0 then begin
      seek(ufile,n);
      read(ufile,u);
      b.status:='['+u.usernote+']';
      end;
    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 getbnum (txt:mstr);
  var q:boolean;
  begin
    if length(input)>1
      then curbul:=valu(copy(input,2,255))
      else begin
        writestr (^M'Message to '+txt+':');
        curbul:=valu(input)
      end;
    q:=checkcurbul
  end;

procedure killbul;
  var un:integer;
      u:userrec;
  begin
    writehdr ('Message Deletion');
    if not reading then
    getbnum ('delete');
    if not checkcurbul then exit;
    getbrec;
    if (not match(b.leftby,unam)) and (not issysop) and (not sponsoron)
      then begin
        writeln ('Hey You didnt post that!');
        exit
      end;
    writeln ('Subject: ',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 ('Message deleted.');
    writelog (4,5,b.title)
  end;

  procedure autodelete;
  var c,un,bn,cnt:integer;
      B:bulrec;
      u:userrec;
  begin
    bn:=2;
    if (bn<1) or (bn>numbuls) then exit;
    writeln (^R^A'Please wait... Deleting first 5 messages..');
    for cnt:=6 downto 2 do begin
     {delbul (cnt,true) }
    seekbfile(cnt);
    read(bfile,b);
    deletetext(b.line);
    end;
    for c:=bn to numbuls-5 do begin
    seekbfile(c+5);
    read(bfile,b);
    seekbfile(c);
    write(bfile,b);
    end;
    seekbfile(numbuls-4);
    truncate(bfile);
    getlastreadnum;
    end;



  function wipe(amount:byte):string;
  var z:integer;
      gee:string[80];
   begin
   for z:=1 to amount do gee:=gee+' ';
   wipe:=gee;
   end;

  procedure postbul;
  var l:integer;
      m:message;
      b:bulrec;
      ds:longint;
  begin
    if ulvl<configset.postleve then begin
      reqlevel(configset.postleve);
      exit
    end;
    l:=editor(m,true,true,'0','0');
    if l>=0 then
      begin
        inc(urec.nbu);
        writeurec;
        b.Where:=Configset.Origin1;
        B.Where2:=Configset.Origin2;
        B.Version:=NetMailVer;
        B.Cnet:=False;
        B.FidoNet:=False;
        B.Flag3:=False;
        B.Flag4:=False;
        B.Flag5:=False;
        B.Flag6:=False;
        B.Flag7:=False;
        B.Flag8:=False;
        B.RealName:=Urec.RealName;
        b.anon:=m.anon;
        b.title:=m.title;
        b.when:=now;
        b.leftby:=unam;
        b.status:='[ ha ]';
        b.recieved:=false;
        b.leftto:=m.sendto;
        b.line:=l;
        b.plevel:=ulvl;
        addbul (b);
        inc(newposts);
        inc(gnup);
        with curboard do
          if autodel<=numbuls then autodelete
      end
  end;

  procedure readcurbul;
  var q:anystr;
      t:sstr;
      cnt,emusux,anarkyamerika:integer;
      oligarch:mstr;
  begin
    q:=wipe(80);
    if checkcurbul then begin
     getbrec;
     If (ansigraphics in urec.config) and (urec.msgheader=2) then begin
      clearscr;
      WriteLn(^O'???['^P'Msg'^O' -       ?????????????????????????????['^P'When:'^O'       ???????????????????');
      oligarch:=^S+strr(curbul)+' of '+strr(numbuls)+^O']';
      printxy(1,11,oligarch+^M);
      WriteLn(^O'?'^P' Title'^O':'^P'                               To'^O':                                  ?');
      if issysop or (not b.anon) then
      printxy(1,53,^S+datestr(b.when)+^R' at '^S+timestr(b.when)+^O']');
      printxy(2,10,^S+b.title);
      printxy(2,44,^S+b.leftto+^M);
      WriteLn(^O'?'^P' From'^O' :                                                                    '^O'?');
      q:='';
      if b.anon then
          begin
            q:=q+configset.anonymousst;
            if (issysop) or (ulvl>=configset.sysopleve) then q:=q+' ['+^A+b.leftby+^S+']'
          end
        else
          begin
            if b.plevel=-1
              then t:='unknown'
              else t:=strr(b.plevel);
           q:=q+b.leftby+' '^S'(Level '^P+t+^S') '+b.status;
          end;
      printxy(3,10,q+^M);
      WriteLn(^O'?????????????????????????????????????????????????????????????????????????????');
      EnD Else Begin
      clearscr;
      Writeln(^A'Sub-Board'^R': '^S,curboard.boardname);
      write   (^B^M^A'['^F'Message'^A']'^R': '^S);
      oligarch:=^S+strr(curbul)+' '^S' of '+strr(numbuls);
      writeln (oligarch);
      writeln (^A'['^F'When'^A'   ]'^R': '^S,datestr(b.when),' at ',timestr(b.when),^R);
      writeln (^A'['^F'Subject'^A']'^R': '^S,b.title);
      write   (^A'['^F'To'^A'     ]'^R': '^S,b.leftto);
      if (b.recieved) then begin
      for anarkyamerika:=1 to 25-(length(b.leftto)+3) do
      write (' ');
       write (^R'['^A'Received'^R']'^R);
       end;
       writeln;
      q:=^A'['^F'From'^A'   ]'^R': '^S;
      if b.anon then
      begin
      q:=q+configset.anonymousst;
      if (issysop) or (ulvl>=configset.sysopleve) then q:=q+' ['+^A+b.leftby+^S+']'
      end
      else
      begin
      if b.plevel=-1
      then t:='unknown'
      else t:=strr(b.plevel);
      q:=q+b.leftby;
           if urec.level>=b.plevel then q:=q+' '+^R+'['^S'Level '+^F+t+^R+'] '+^S else q:=q+' <Classified> ';
           q:=q+b.status;
           end;
           writeln (q);
      End;
      ansicolor(urec.regularcolor);
      if break then exit;
      printtext (b.line);
      If Curboard.Echo>0 then WriteLn(^P'['^A'Net Origin: '+B.Where+^P']'^M'['^A+B.Where2+^P']'^M);
      if match (b.leftto,unam) then begin
       b.recieved:=true;
       seekbfile (curbul);
       write (bfile,b);
      end;
      ansicolor (urec.regularcolor);
    end;
    begin
      if (urec.lastread[curboardnum+(50*(currentconference-1))]<=b.id) or (curbul>=lastreadnum) then
      urec.lastread[curboardnum+(50*(CurrentConference-1))]:=b.id;
      if lastreadnum<curbul then lastreadnum:=curbul;
    end
  end;

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

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

  procedure readnextbul;
  var t:integer;
  begin
    t:=curbul;
    inc(curbul);
    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 curboard.conference>0 then begin
       haveaccess:=false;
       if urec.confset[curboard.conference]>0 then haveaccess:=true;
     exit;
    end;
    if a=bylevel
      then haveaccess:=ulvl>=curboard.level
      else haveaccess:=a=letin
  end;

  procedure makeboard;
  begin
    formatbfile;
    If FileSize(BDfile)=51 then Begin
       WriteLn('You may not have more then 51 message areas per conference!');
       Exit;
    End;
    with curboard do begin
      shortname:=curboardname;
      WriteHdr('Creating Sub-Board: '+shortname);
      buflen:=30;
      writestr (^M^R'Board Name'^A': &');
      boardname:=input;
      buflen:=30;
      writestr (^R'Sponsor '^F'['^S'CR/'+unam+^F']'^A':');
      if input='' then input:=unam;
      sponsor:=input;
      writestr(^R'Area Flag '^F'('^S'1-30'^F') ['^S'CR/None'^F']'^A':');
      if input='' then input:='0';
      conference:=valu(input);
      writestr (^R'Minimum Level for entry'^A':');
      level:=valu(input);
      writestr (^R'Autodelete after '^F'['^S'CR/100'^F']'^A':');
      if length(input)<1 then input:='100';
      autodel:=valu(input);
      if autodel<10 then begin
        writeln ('Must be at least 10!');
        autodel:=10
      end;
      WriteStr(^R'Is this a Net-Mail Sub? '^F'['^S'N'^F']'^A':*');
        If yes then begin
      WriteStr(^R'EchoMail ID Number '^F'('^S'0=None'^F') ['^S'0'^F']'^A':');
      if Input='' then input:='0';
      echo:=Valu(Input);
        end else echo:=0;
      setallflags (curboardnum,bylevel);
      writecurboard;
      writeln (^M^U'Board created!');
      writelog (4,4,boardname+' ['+shortname+']')
    end
  end;

  Procedure Sdw;
  Begin
  ansicolor(8);
  WriteLn('?');
  end;

 procedure setactive (nn:sstr);

    procedure doswitch;
    begin
      openbfile;
      curbul:=lastreadnum;
      with curboard do
     begin
      curbul:=lastreadnum;
      with curboard do
      if not (ansigraphics in urec.config) then  writeln (^M'Sub-board: '^S,boardname,
                 ^M'Sponsor:   '^S,sponsor,
                 ^M'Bulletins: '^S,numbuls,
                 ^M'Last read: '^S,lastreadnum,^M)
           else begin
                clearscr;
writeln(^R'                      ???????????????????????????????????????');
write(^R'                      ?'^P' Sub:                              '^R'  ?');sdw;
write(^R'                      ???????????????????????????????????????');sdw;
write(^R'                      ???????????????????????????????????????');sdw;
write(^R'                      ?'^P' Messages'^A'....'^R'                        ?');sdw;
write(^R'                      ?'^P' Last Read'^A'...'^R'                        ?');sdw;
write(^R'                      ?'^P' Sponsor'^A'.....'^R'                        ?');sdw;
write(^R'                      ?'^P' Posts by You'^R'                        ?');sdw;
write(^R'                      ?'^P' Date/Time'^A'...'^R'                        ?');sdw;
write(^R'                      ???????????????????????????????????????');sdw;ANSiColoR(8);
WriteLn('                         ?????????????????????????????????????');ANsiColor(urec.regularcolor);
printxy(2,30,curboard.boardname);
printxy(5,38,strr(numbuls));
printxy(6,38,strr(lastreadnum));
printxy(7,38,Curboard.sponsor);
printxy(8,38,strr(urec.nbu));
PrintXy(9,38,DateStr(Now)+' - '+TimeStr(Now)+^M^M^M);
End;
end;
End;



    procedure tryswitch;
    var n,s:integer;

      procedure denyaccess;
      var b:bulrec;
      begin
        writeln(^M^P'Invalid Board!'^G);
        setfirstboard
      end;

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

  var b:bulrec;
  begin
    curbul:=0;
    close (bfile);
    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;
    clearscr;writehdr(' Message Areas ');
   writeln(^R'???????????????????????????????????????????????????????????????');
   writeln(^R'? '^P'Number      Sub-Board Name                 Level/Conference'^R' ?');
   writeln(^R'???????????????????????????????????????????????????????????????');
    if break then exit;
    for cnt:=0 to filesize(bdfile)-1 do
      if haveaccess(cnt) then
        with curboard do begin
        write(^R'? ');
          tab (^U+shortname,11); write('  ');
          tab (^A+boardname,31); write('  ');
          if (conference>0) then tab(^R'Conference '^S+strr(conference),18) else
          tab(^S+strr(level),17);
           writeln(^R'?');
          if break then exit
        end;
   writeln(^R'???????????????????????????????????????????????????????????????'^M);
    curboardnum:=oldcurboard;
    seekbdfile (curboardnum);
    read (bdfile,curboard)
  end;


  procedure activeboard;
  begin
    if length(input)>1
      then input:=copy(input,2,255)
      else begin
        listboards;
        repeat
          writestr (^M^M^P'Board Number '^S'['^F'?'^A'/'^F'List'^S']'^P':');
          if input='?' then listboards
        until (input<>'?') or hungupon;
      end;
    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 ('Sorry user cannot access first sub 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