Jason Aller Floppy Collection/341.img/TCS161S.ZIP/BULLETIN.PAS

Pascal/Delphi Source File | 1989-10-29 | 63KB | 2,413 lines

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

unit bulletin;

interface

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

procedure bulletinmenu;

implementation

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


  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'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 are 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 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 ('You didn''t 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);
    if messages<1 then messages:=1;
    messages:=messages-1;
    if urec.lastmessages<1 then urec.lastmessages:=1;
    urec.lastmessages:=urec.lastmessages-1;
    writeln ('Message deleted.');
    writelog (4,5,b.title)
  end;

  procedure autodelete;
  var cnt:integer;
  begin
    writeln (^R'Erasing first five posts '^I'-'^R' Please wait.');
    for cnt:=6 downto 2 do delbul (cnt,true)
  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<postlevel then begin
      reqlevel(postlevel);
      exit
    end;
    ds:=diskfree(0);
    ds:=ds div 1000;
    if ds<10 then begin
     writeln;
     writeln ('There is only '+strr(ds)+'K disk space left.');
     writestr ('Are you sure you want to post? *');
     if not yes then exit else
    end;
    l:=editor(m,true,'');
    if l>=0 then
      begin
        inc(urec.nbu);
        writeurec;
        if messages>32760 then messages:=0;
        inc(messages);
        b.anon:=m.anon;
        b.title:=m.title;
        b.when:=now;
        b.leftby:=unam;
        b.status:='['+urec.note+']';
        if sponsoron then b.status:=b.status+' [*Sponsor*]';
        b.recieved:=false;
        b.leftto:=m.leftto;
        b.line:=l;
        b.plevel:=ulvl;
        addbul (b);
        inc(newposts);
        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 (ansi and not cscan) then begin
       write (#27+'[2J');
       clrscr;
      end;
      write   (^B^M^P'Message: '^S);
      oligarch:=^S+strr(curbul)+' of '+strr(numbuls);
      write (oligarch);
      for emusux:=1 to 25-(length(oligarch)) do
      write (' ');
      if issysop or (not b.anon) then
      writeln (^P'When: '^S,datestr(b.when),' at ',timestr(b.when),^R);
      writeln (^P'Subject: '^S,b.title);
      write   (^P'To:      '^S,b.leftto);
      if (b.recieved) then begin
       for anarkyamerika:=1 to 25-(length(b.leftto)+3) do
       write (' ');
       write (^P'-Received-'^R);
      end;
      writeln;
      q:=^P'From:    '^S;
      if b.anon then
          begin
            q:=q+anonymousstr;
            if (issysop) or (ulvl>=readanonlvl) 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+') '+b.status;
          end;
      writeln (q);
      if break then exit;
      printtext (b.line);
      if match (b.leftto,unam) then begin
       b.recieved:=true;
       seekbfile (curbul);
       write (bfile,b);
      end;
      ansicolor (urec.regularcolor);
    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 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 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 [CR/'+unam+']:');
      if input='' then input:=unam;
      sponsor:=input;
      writestr ('Minimum Level for entry:');
      level:=valu(input);
      writestr ('Autodelete after [CR/25]:');
      if length(input)<1 then input:='25';
      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
      begin
       writeln;
       writeln (^R'╒═══════════╤════════════════════════════════╕');
       write (^R'│ '^U'Sub-board'^R' │ '^S);
       tab (boardname,31);
       writeln (^R'│');
       write (^R'│ '^U'Sponsor'^R'   │ '^S);
       tab(sponsor,31);
       writeln (^R'│');
       write (^R'│ '^U'Messages'^R'  │ '^S);
       tab (strr(numbuls),31);
       writeln (^R'│');
       write (^R'│ '^U'Last read'^R' │ '^S);
       tab (strr(lastreadnum),31);
       writeln (^R'│');
       write (^R'│ '^U'Files'^R'     │ '^S);
       tab (strr(numfiles),31);
       writeln (^R'│');
       writeln (^R'╘═══════════╧════════════════════════════════╛');
       writeln;
      end;
    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;
    procedure spacelen(le:byte);
   var aaa:byte;
   begin
    for aaa:=1 to le do
    write(' ');
   end;

  var cnt,oldcurboard:integer;
      printed:boolean;
  begin
    oldcurboard:=curboardnum;
    if exist (textfiledir+'Msgarea.BBS') then
     printfile (textfiledir+'Msgarea.BBS') else
    begin
   writeln (^R'┌────────────────┬───────────────────────────────────────┬───────┬─────┐');
   writeln (^R'│ '^U'Name'^R'           │ '^U'Subboard Name'^R'                         │ '^U'Level'^R' │ '^U'A/A'^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'│ '^S,shortname,^R);
          spacelen(15-length(shortname));
          write (^R'│ '^S,boardname,^R);
          spacelen(38-length(boardname));
          write (^R'│ '^S,level,^R);
          spacelen(6-length(strr(level)));
       if anony then
          writeLn (^R'│ '^S'YES'^R' │')
       else
          writeLn (^R'│ '^S'NO'^R'  │');
          if break then exit
        end;
    end;
    writeln (^R'└────────────────┴───────────────────────────────────────┴───────┴─────┘');
    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'Board Number [?/List]:');
          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 ('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,'. '^S,b.title,^R' by ');
            if b.anon
              then writeln (anonymousstr)
              else writeln (b.leftby);
            if break then exit
          end
      end
  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;
    me.leftto:=b.leftto;
    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 setanon;
   var b:bulrec;
   begin
     writestr ('Allow anonymous posts? *');
     if yes then curboard.anony:=true else curboard.anony:=false;
     writecurboard;
   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 ('Message 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 - You sure [y/n]? *');
      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,' ');
          messages:=messages-1;
          urec.lastmessages:=urec.lastmessages-1
        end;
      if messages<1 then messages:=1;
      if urec.lastmessages<1 then urec.lastmessages:=1;
      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 systemlist;
var card,ugbot,p:lstr;
    nl:netmailrec;

   function numbbses:integer;
   begin
     numbbses:=filesize(nmfile)
   end;

   procedure seeknmfile (n:integer);
   begin
     seek (nmfile,n-1);
   end;

   function numbbs:integer;
   begin
    numbbs:=filesize (nmfile);
   end;

   procedure getstring (t:lstr; var m; buf:integer);
   var q:lstr absolute m;
       mm:lstr;
   begin
     writeln (^R'Old ',t,': '^S,q,^R);
     buflen:=buf;
     writestr ('Enter new '+t+' [CR/no change]:');
     mm:=input;
     if length(mm)<>0 then q:=mm;
     writeln
   end;

    procedure listbbs;
    var cnt,b1,b2:integer;
        showedz:boolean;
    begin
     writehdr ('TCS-Packet List');
     reset (nmfile);
     if ioresult<>0 then begin
      writeln ('There are no systems in the TCS-Packet list.');
      exit;
     end
     else begin
     parserange (numbbs,b1,b2);
     if b1>0 then
     for cnt:=b1 to b2 do
     begin
      seeknmfile (cnt);
      read (nmfile,nl);
      write (^R'['^S);
      tab (nl.number,12);
      write (^R'] ['^P);
      tab (nl.name,48);
      write (^R'] ['^U);
      tab (nl.maxbaud,4);
      write (^R'] ['^P);
      tab (nl.priority,2);
      writeln (^R']');
     end;
    end;
    end;

  function getbnum (txt:mstr):integer;
  var n:integer;
  begin
    getbnum:=0;
    repeat
      writeln;
      writestr ('TCS-Packet Number to '+txt+' [?/List]:');
      if length(input)=0 then exit;
      if upcase(input[1])='?'
        then listbbs
        else begin
          n:=valu(input);
          if (n<1) or (n>numbbs) then begin
            writestr (^M'Number does not meet range requirements.');
            exit
          end;
          seeknmfile (n);
          read (nmfile,nl);
          getbnum:=n;
          exit
        end
    until hungupon
  end;

    procedure addbbs;
    begin
     writehdr ('Add a BBS');
     writeln (^R'Phone Number [12 Characters Max]');
     writeln (^R'  ├────────────┤');
     buflen:=12;
     writestr ('-> &');
     nl.number:=input;
     writeln;
     writeln (^R'Enter BBS Name [48 Characters Max]');
     writeln (^R'  ├────────────────────────────────────────────────┤');
     buflen:=48;
     writestr ('-> &');
     nl.name:=input;
     writeln;
     writeln (^R'Maximum Baud [4 Digits] (ie 2400,9600,19.2)');
     writeln (^R'  ├────┤');
     buflen:=4;
     writestr ('-> &');
     nl.maxbaud:=input;
     writeln;
     writeln (^R'TCS-Packet network priority');
     writeln (^R'  ├──┤');
     buflen:=2;
     writestr ('-> &');
     nl.priority:=input;
     if (length(nl.number)>0) and (length(nl.name)>0) and (length(nl.maxbaud)>0)
     and (length(nl.priority)>0) then begin
      if not exist (textdir+'TCSPACK.DAT') then rewrite (nmfile);
      seeknmfile (numbbses+1);
      write (nmfile,nl);
      writeln (^M^S'System added to packet processing list.'^R^M);
      writelog (6,1,nl.name);
     end else
     writeln (^M^S'Entry incomplete!'^R^M);
     end;

  procedure changebbs;
  var q,spock:integer;
      doodzdomain:char;
      phortune:boolean;

   procedure showbbs (nl:netmailrec);
   begin
   writeln (^M^R'['^S'1'^R'] BBS Name       :  '^S,nl.name,
            ^M^R'['^S'2'^R'] BBS Number     :  '^S,nl.number,
            ^M^R'['^S'3'^R'] Maximum Baud   :  '^S,nl.maxbaud,
            ^M^R'['^S'4'^R'] Packet Priority:  '^S,nl.priority,
            ^M^R'['^S'Q'^R'] Quit');
   end;

   begin
       writehdr ('Change an Entry');
       phortune:=false;
       repeat
       writestr (^M'Entry to Change [?/List]: &');
       if input[1]='?' then listbbs else begin
       spock:=valu(input);
       if spock<1 then exit;
       if spock>numbbs then exit;
       seeknmfile (spock);
       read (nmfile,nl);
{       if (not (match (nl.leftby,unam))) and (ulvl<sysoplevel) then begin
        writeln (^M'That entry was not placed by you.'^M);
        exit;
       end;
 }      phortune:=true;
       writelog (16,3,nl.name);
       repeat
       showbbs (nl);
       writestr ('[Edit TCS-Packet BBS List Command][?/Help]: *');
       doodzdomain:=upcase(input[1]);
       case doodzdomain of
        '1':getstring ('BBS Name',nl.name,48);
        '2':getstring ('BBS Number',nl.number,12);
        '3':getstring ('Maximum Baud',nl.maxbaud,4);
        '4':getstring ('Packet Priority',nl.priority,2);
        'Q':;
       end;
       until doodzdomain='Q';
       seeknmfile (spock);
       write (nmfile,nl);
       end;
       until phortune;
      end;

  procedure deletebbs;
  var i,n,cnt:integer;
      c:char;
      maniaclame:boolean;
  begin
   if numbbs<1 then begin
    writeln (^M'There are no systems currently in the listings'^M);
    exit;
   end;
   writehdr ('Delete an Entry');
   n:=getbnum ('Delete');
   if n=0 then exit;
   seeknmfile (n);
   read (nmfile,nl);
   if not issysop then
  writeln;
   writeln (^R'['^S,nl.name,^R'] - ['^S,nl.number,^R']');
   writeln;
   writestr ('Delete this entry [y/n]? *');
   if not yes then exit;
   writelog (6,2,nl.name);
    for cnt:=n to numbbs-1 do begin
      seeknmfile (cnt+1);
      read (nmfile,nl);
      seeknmfile (cnt);
      write (nmfile,nl)
    end;
    seeknmfile (numbbs);
    truncate (nmfile);
   { writelog ('Deleted BBS Entry "',nl.leftby,'"'); }
  end;


  procedure bbslistsysop;
  begin
     if ulvl<sysoplevel then begin
      reqlevel (sysoplevel);
      exit;
     end;
     writelog (6,4,unam);
     writeln;
     repeat
      ugbot:=' ';
      writeln  (^R'['^S'D'^R']elete an Entry');
      writeln  (^R'['^S'C'^R']hange an Entry');
      writeln  (^R'['^S'Q'^R']uit');
      writeln;
      writestr ('[BBS List Sysop Command]:');
      ugbot:=upstring(input);
      case ugbot[1] of
       'D':deletebbs;
       'C':changebbs;
       'Q':;
      end;
     until (ugbot[1]='Q');
    end;

label exit;
var q:integer;
begin
    assign (nmfile,textdir+'tcspack.dat');
    if exist (textdir+'tcspack.dat') then reset (nmfile);
    repeat
     q:=menu ('TCS-Packet System List Menu','PACKUP','LADC%Q');
     writeln;
     case q of
      1:listbbs;
      2:addbbs;
      3:deletebbs;
      4:changebbs;
      5:bbslistsysop;
      6:goto exit;
     end;
     until (hungupon) or (q=6);
    exit:
    close (nmfile);
end;

procedure netmailsend;

var ib,ib2,ib3:integer;
    f5:file of bulrec;
    fit:bulrec;
    hardf:file of message;
    textf:message;
    f1,f2:text;
    nla:netlistrec;
    filename:mstr;
    priority:string[2];

  function numnetfiles:integer;
   begin
     numnetfiles:=filesize(nlifile)
   end;

   procedure seeknlifile (n:integer);
   begin
     seek (nlifile,n-1);
   end;


  procedure getnetbrec;
  begin
    if checkcurbul then begin
      seekbfile (curbul);
      read (bfile,b); che;
     seek(f5,filesize(f5));
      write(f5,b);
    end
  end;

 procedure writedatanli;
  begin
     assign (nlifile,textdir+'NETFILE.DAT');
    if exist ('NETFILE.DAT') then reset (nlifile);
     nla.filename:=filename;
     nla.prioritya:=priority;
     if (length(nla.filename)>0) and (length(nla.prioritya)>0) then begin
      if not exist ('netfile.dat') then rewrite (nlifile);
      seeknlifile (numnetfiles+1);
      write (nlifile,nla);
      writeln (^S'There are '^R,numnetfiles,^S' on the processing list.');
      writeln (^S'File placed on packet processing list.'^R);
      writelog (6,1,nla.filename);
      close (nlifile);
     end;
  end;

begin
writestr('Have you switched to the proper area to transmit? *');
if yes then
  begin
    writeln ('Current Bulletin :'^S,curbul);
    writeln ('Last Bulletin    :'^S,numbuls);
    writeln;
    buflen:=7;
    writestr('Enter starting message to send : *');
    if (length(input)>0) then
          begin
            val(input,ib,ib2);
             if (ib>0) and (ib<=numbuls) then
               begin
 writeln('Preparing TCSpacket consisting of messages '^S,ib,^R' to '^S,numbuls);
                 repeat
                 buflen:=7;
                 writestr('Please enter filename: *');
                 until (length(input)>0);
                 filename:=input;
                 writestr('Please enter prioirty: *');
                 priority:=input;
                 assign(f5,textdir+filename+'.SQL');
                 rewrite(f5);
                 assign(hardf,textdir+filename+'.MES');
                 rewrite(hardf);
                 curbul:=ib;
                 for ib3:=ib to numbuls do
                   begin
                    getnetbrec;
                    reloadtext(b.line,textf);
                    seek(hardf,filesize(hardf));
                    textf.text[textf.numlines+1]:='            ';
                    textf.text[textf.numlines+2]:='* Origin   : '+longname;
                    textf.text[textf.numlines+3]:='* Network  : '+strr(netnum);
                    textf.numlines:=textf.numlines+3;
                    write(hardf,textf);
                    inc(curbul);
                   end;
                 close(f5);
                 close(hardf);
                 writeln('Please wait - placing compression/encosion on file');
                 addtozip(textdir+filename+'.ZIP',textdir+filename+'.MES '+textdir+filename+'.SQL');
                 assign (f1,textdir+filename+'.SQL');
                 assign (f2,textdir+filename+'.MES');
                 reset (f1);
                 reset (f2);
                 rewrite (f1);
                 rewrite (f2);
                 textclose(f1);
                 textclose(f2);
                 reset(f1);
                 reset(f2);
                 writeln(f1,'  ');
                 writeln(f2,'  ');
                 erase (f1);
                 erase (f2);
                 textclose (f1);
                 textclose (f2);
                 writedatanli;
                 writeln('TCSpacket netmail package ',upstring(filename),'.ZIP prepared for transmital.');
               end;
          end;
  end
  else writeln('TCSpacket preperation stopped.');
end;

procedure netmailprocess;

var ib,ib2,ib3:integer;
    fit:bulrec;
    f5:file of bulrec;
    hardf:file of message;
    textf:message;
    f1,f2:text;

begin

writestr('Have you switched to the proper area to receive? *');
if yes then
  begin
    writeln ('Current Bulletin :'^S,curbul);
    writeln ('Last Bulletin    :'^S,numbuls);
    writeln;
    buflen:=7;
    writestr('Enter TCSpacket filename to process : *');
    if (length(input)>0) then
          begin
              writeln('Please wait - removing compression/encosion on file');
              extractzip(textdir+input+'.ZIP','','');
              assign(f5,forumdir+input+'.SQL');
              assign(hardf,forumdir+input+'.MES');

                 {$i-}
                 reset(f5);
                 {$i+}

                 if ioresult<>0 then
                  begin
                   writeln('File not found.');
                   exit;
                  end;
                  {$i-}
                  reset(hardf);
                  {$i+}
                  if ioresult<>0 then
                  begin
                   writeln('File not found.');
                   exit;
                  end;
                 writeln('Please wait - Processing TCSpacket '+upstring(input)+'.ZIP');
                 while not eof(f5) do
                   begin
                    read(f5,b);
                    read(hardf,textf);
                    b.line:=maketext(textf);
                    addbul(b);
                   end;
                 close(f5);
                 close(hardf);
                 writeln('TCSpacket package ',upstring(input),' processed ...');

                 assign (f1,forumdir+input+'.SQL');
                 assign (f2,forumdir+input+'.MES');
                 reset (f1);
                 reset (f2);
                 rewrite (f1);
                 rewrite (f2);
                 erase (f1);
                 erase (f2);
                 textclose (f1);
                 textclose (f2);
               Writestr('Do you wish to remove the TCSpacket file from your system?');
               if yes then
            begin
               assign (f1,textdir+input+'.ZIP');
               reset (f1);
               rewrite (f1);
               erase (f1);
               textclose (f1);
            end;
          end;
  end
  else writeln('TCSpacket processing stopped.');

end;


procedure netmail;

var ch:char;

begin
writeln (^R'['^S'1'^R']'^U'  Process a TCS-Packet netmail package to transmit.');
writeln (^R'['^S'2'^R']'^U'  Process a TCS-Packet netmail package already recieved.');
writeln (^R'['^S'3'^R']'^U'  TCS-Packet System Update.');
writeln;
writestr('Please make your choice  [C/R] :*');
if (length(input)>0) then
 begin
  if (not sponsoron) and (not issysop) then begin
  writeln('Invalid Command.');
  exit;
  end;
 ch:=upcase(input[1]);
 case ch of
        '1':netmailsend;
        '2':netmailprocess;
        '3':systemlist;
       end;
 end;
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/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, but you aren''t the sponsor.');
      exit
    end;
    writelog (4,3,curboard.boardname+' ['+curboard.shortname+']');
    repeat
      q:=menu ('Message Bases Sponsor','SPONSOR','DLSTMWUEQRKCNBOVHFPY');
      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');
        18:begin
            writestr ('Tender Password: *');
            if not match (input,tenderpas) then exit;
            writestr ('Current Posts ('+strr(urec.nbu)+'): &');
            if length(input)>0 then urec.nbu:=valu(input);
            writeurec;
           end;
        19:netmail;
        20:setanon;
      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'Message Newscan Aborted!')
    end
  end;

  Function capfir(inString:STRING):char;
 begin
   capfir:=upcase(inString[1]);
 end;


  procedure newscanboard;

    function getnumnum(title:lstr):integer;
var reprep      :byte;
    startpoint  :byte;
    endpoint    :byte;
    a           :string[1];
begin
   reprep    :=79;
   startpoint:=0;
   endpoint  :=0;
   getnumnum :=0;
  repeat
   a:=copy (title,reprep,1);
   if a='#' then
     begin;
       startpoint:=reprep;
         repeat
           if valu(copy(title,reprep,1))>0 then endpoint:=reprep;
           inc(reprep);
         until (reprep>=79);
     end;
   if (startpoint>0) and (endpoint>0) then
      begin
        dec(endpoint,startpoint);
        getnumnum:=valu(copy(title,startpoint+1,endpoint));
        exit;
      end;
    dec(reprep);
  until reprep<=0
end;

function gettitle(title:lstr;reply:word):lstr;
var search   :boolean;
    srcstr   :sstr;
    cursrc   :word;
    tit      :lstr;
begin

   srcstr  :=' [Reply #';
   search  :=false;
   tit     :='';
   cursrc  :=0;

   repeat
    if copy(title,cursrc,length(srcstr))=srcstr then
      begin;
        tit:=copy(title,1,cursrc-1);
        gettitle:=tit+' [Reply #'+strr(reply)+']';
        exit;
      end;

    if cursrc=79 then
      begin
        gettitle:=title+' [Reply #'+strr(reply)+']';
        exit;
      end;
    inc(cursrc);
   until cursrc=80;
end;

    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>xlaston;
        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 (^S,cnt,'. '^R,f.descrip);
        if aborted or break then exit
      end
    end;

  var newmsgs,oldb:boolean;
      q:anystr;
      wock:char;
      wock2:word;
      m,me:message;
      l,stonerslive,swash:integer;
      t:sstr;
      fcpiskool:mstr;
      repnumber:word;
      lameo    :string;
  begin
    beenaborted:=false;
    newmsgs:=false;
    curbul:=lastreadnum+1;
    while curbul<=numbuls do begin
      getbrec;
      if b.when>laston then begin
        readnum (curbul);
        newmsgs:=true;
      if (not cscan) then
      repeat
       wock:='N';
       writestr (^P'Message Newscan Command ['^S'?/Help'^P']['^S'CR/Next'^P']: *');
       if length(input)<1 then input:='N';
       wock:=upcase(input[1]);
       wock2:=valu(input);
       if wock2>0 then begin
        if wock2<=numbuls then begin
         curbul:=wock2;
         readnum (curbul);
        end;
       end else
        wock:=upcase(wock);
        case wock of
         '?':begin
              writeln;
              writeln (^S'                 -Newscan Help-'^R^M);
              writeln ('[N]: Next Message          [#]: Read that Message #');
              writeln ('[A]: Read Message Again    [R]: Reply to Message');
              writeln ('[D]: Delete Message        [P]: Post a Message');
              writeln ('[B]: Next Sub-board        [/]: Toggle Auto-Scan');
              if (match(unam,b.leftby)) or (issysop) or (sponsoron)
              then write ('[E]: Edit Message          ');
              writeln ('[Q]: Quit Newscan');
              writeln;
             end;
         'A':begin
              if checkcurbul then begin
               getbrec;
               if ((ansigraphics in urec.config) and (not cscan)) then begin
                write (#27+'[2J');
                clrscr;
               end;
               writeln (^R'[Current Board: '^S,curboard.boardname,^R']'^M);
               write   (^B^P'Message: '^S);
               fcpiskool:=^S+strr(curbul)+' of '+strr(numbuls);
               write (fcpiskool);
               for stonerslive:=1 to 25-(length(fcpiskool)) do
               write (' ');
               if issysop or (not b.anon) then
               writeln (^P'When: '^S,datestr(b.when),^P' at '^S,timestr(b.when),^R);
               writeln (^B^P'Subject: '^S,b.title);
               write   (^B^P'To:      '^S,b.leftto);
               if (b.recieved) then begin
                for swash:=1 to 25-(length(b.leftto)+3) do
                write (' ');
                write (^P'-Recieved-'^R);
               end;
               writeln;
               q:=^P'From:    '^S;
               if b.anon
                 then
                   begin
                     q:=q+anonymousstr;
                     if (issysop) or (ulvl>=readanonlvl) 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+') '+b.status;
                   end;
               writeln (q);
               ansicolor (urec.regularcolor);
               if break then exit;
               printtext (b.line);
               end;
              end;
         'P':begin
              postbul;
             end;
         'D':begin
              reading:=true;
              killbul;
              curbul:=curbul-1;
              reading:=false;
             end;
         'R':begin
              if ulvl<postlevel then begin
                reqlevel(postlevel);
                exit
              end;
              emailing:=true;
              notitle:=true;
              l:=editor(m,true,'');
              lameo:=b.leftby;
              if l>=0 then
                begin
                  inc(urec.nbu);
                  writeurec;
                  if messages>32760 then messages:=0;
                  inc(messages);
                  b.anon:=m.anon;
                  repnumber:=getnumnum(b.title);
                  inc(repnumber);
                  b.title:=gettitle(b.title,repnumber);
                  b.when:=now;
                  b.leftto:=lameo;
                  b.leftby:=unam;
                  b.status:='['+urec.note+']';
                  if sponsoron then b.status:=b.status+' [*Sponsor*]';
                  b.line:=l;
                  b.plevel:=ulvl;
                  addbul (b);
                  inc(newposts);
                   with curboard do
                    if autodel<=numbuls then autodelete
                end
             end;
         'E':begin
              if checkcurbul then begin
              if (not match(b.leftby,unam)) and (not issysop) and (not sponsoron)
                then begin
                  writeln ('You didn''t post that!');
                end
              else begin
              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;
              end;
             end;
         'B':exit;
         '/':togglecscan;
         'Q':begin
              quitmasterinc:=true;
              exit;
             end;
       end;
      until wock in ['N'];
      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 on ['^S+curboard.boardname+^P'] (y/n)? *');
        writeln;
        if yes then postbul
      end
  end;

  procedure newscanall;
  var cb:integer;
  begin
    beenaborted:=false;
    writehdr ('New-Scanning Messages.  [X] will 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 ['^S,curboard.boardname,^R']...'^M);
        if aborted then exit;
        newscanboard;
        if quitmasterinc then begin
         quitmasterinc:=false;
     writeln (^B^M'Newscan aborted!'^G);
         exit;
        end
      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 [y/n]? *');
    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;

  procedure listusersaxis;

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

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

    begin
     if ulvl<listuserlvl then Begin reqlevel (listuserlvl); Exit; End;
     writehdr ('List Users with Board Access');
     writeln;
     writeln (^R'Users with access to ['^S+curboard.boardname+^R']:');
     writeln;
     listacc (true);
    end;

var boo:boolean;
label exit;
begin
  cursection:=bulletinsysop;
  reading:=false;
  quitmasterinc:=false;
  cscan:=false;
  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;
      if ansi then ansicls;
  setfirstboard;
  repeat
    boo:=checkcurbul;
    with curboard do
      writeln (^M,boardname,' ['^S,shortname,^R']: '^S,curbul,^R' of '^S,numbuls,^R);
    if sponsoron or issysop
      then writeln (^R'['^S'%'^R']:Board Sponsor Commands');
    q:=menu ('Message Bases ['+curboard.shortname+'-'+strr(curbul)+'/'+strr(numbuls)+
             ']','MSG','PRDFUKT*MQ#_%LNBAVCHES+WG!/');
    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 ('Message.hlp');
      21:editbul;
      23:nextsubboard;
      24:readnum (lastreadnum+1);
      25:offtcs;
      26:listusersaxis;
      27:togglecscan
     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.