The Devil's Doorknob BBS Capture (1996-2003)/devilsdoorknobbbscapture1996-2003.iso/Dloads/OTHERUTI/WWIV310S.ZIP/BBS.PAS

Pascal/Delphi Source File | 1986-04-02 | 32KB | 1,060 lines

PROGRAM BBS;

                      {*****************************}
                      {Copyright (c) 1986 Wayne Bell}
                      {*****************************}


{$V-} {$C-}
TYPE j=array[1..8] of string[14];

CONST strlen=160;
      comnum=1;
      maxbaud=1200;
      maxusers=300;
      dsaves : Integer = 0;
      buffer_Max    = 5120;
      comptyp:j=('IBM','APPLE','TRS-80','Z-80 CP/M','COMMODORE','ATARI',
                 'DUMB TERMINAL','OTHER');

TYPE str=string[strlen];
     restrictions=(rlogon,rchat,rvalidate,rbackspace,ramsg,rpostan,
                   rpost,remail,rvoting,rmsg);
     acrq='@'..'G';
     newtyp=(rp,lt,rm);
     deflts=(spcsr,onekey,wordwrap,pause);
     anontyp=(no,yes,forced,dearabby);
     ansttype=(postn,emailn,pana,sanm,cosysop,lcosysop);
     opts=(alert,smw,nomail);
     pnr=record name:string[40]; number:string[14]; hs:boolean; end;
     slr=record
           ttime:byte;
           mallowed:integer;
           emails,posts:byte;
           anst:set of ansttype;
         end;
     messages=record
                ltr:char;
                number:integer;
                ext:byte;
              end;
     smalrec=record
               name:string[25];
               number:integer;
             end;
     userrec=record
               name:string[25];
               realname:string[14];
               deleted:boolean;
               pw:string[8];
               ph:string[12];
               waiting:byte;
               laston:string[10];
               loggedon:integer;
               msgpost:integer;
               emailsent:integer;
               feedback:integer;
               linelen:byte;
               pagelen:byte;
               defaults:set of deflts;
               ontoday:byte;
               illegal:byte;
               cursor:string[10];
               sl:byte;
               ac:set of restrictions;
               ar:set of acrq;
               qscan:array[1..19] of messages;
               qscn:array[1..19] of boolean;
               macro:array[1..2] of string[79];
               comptype:byte;
               option:set of opts;
               vote:array[1..9] of byte;
               sbn:byte;
               dsl:byte;
               uploads,downloads:integer;
               uk,dk:integer;
             end;
      boardrec=record
                 name:string[25];
                 filename:string[12];
                 sl:byte;
                 maxmsgs:byte;
                 pw:string[10];
                 anonymous:anontyp;
                 ar:acrq;
                 key:char;
               end;
      msgstat=(validated,unvalidated,deleted);
      messagerec=record
                   title:string[30];
                   messagestat:msgstat;
                   message:messages;
                   owner:integer;
                   date:integer;
                   mage:byte;
                 end;
      systatrec=record
                  boardpw:string[8];
                  sysoppw:string[8];
                  hmsg:messages;
                  users:integer;
                  lastdate:string[8];
                  callernum:integer;
                  activetoday:integer;
                  callstoday:integer;
                  msgposttoday:integer;
                  emailtoday:integer;
                  fbacktoday:integer;
                  uptoday:integer;
                  closedsystem:boolean;
                end;
      blk=array[1..255] of byte;
      mailrec=record
                title:string[30];
                from,destin:integer;
                msg:messages;
                date:integer;
                mage:byte;
              end;
      gft=record
            num:integer;
            title:string[40];
            filen:string[12];
          end;
      charfil=text;
      smr=record
            msg:str;
            destin:integer;
          end;
      vdatar=record
               question:string[79];
               numa:integer;
               answ:array[0..9] of record
                      ans:string[25];
                      numres:integer;
                    end;
             end;
      regs=record ax,bx,cx,dx,bp,si,di,ds,es,flags:integer; end;
      ulrec=record
              name:string[25];
              filename:string[12];
              password:string[10];
              dsl:byte;
              maxfiles:integer;
            end;

var sf:file of smalrec;
    uf:file of userrec;
    bf:file of boardrec;
    mf:file of messagerec;
    mailfile:file of mailrec;
    sysopf:charfil;
    slf:file of slr;
    seclev:array[0..255] of slr;
    systatf:file of systatrec;
    systat:systatrec;
    sr:smalrec;
    thisline,chatr,buf,spd,irt,lastname,ll,cursor,i:str;
    thisuser,user:userrec;
    boards:array[1..19] of boardrec;
    fw,extramsgs,mread,board,numboards,t,usernum:integer;
    pap,lil,realsl,ftoday,ptoday,etoday:integer;
    c,ID:char;
    hungup,useron,next,chatcall,expert,doneday,echo,hangup,incom,outcom:boolean;
    extratime,timeon:real;
    macok,lan,enddayf,ch,quit:boolean;
    buffer:Array[0..buffer_Max] of Char;
    comport,base:Integer;
    Async_Irq:Integer;
    buffer_Head,buffer_tail,buffer_newtail:Integer;
    smf:file of smr;
    srl:array[0..maxusers] of smalrec;
    vqu:array[1..9] of boolean;
    ret:byte absolute cseg:$0080;
    ldate:integer;
    maxspd:integer;
    cmd:char;
    help:array[1..25000] of char;
    helpi:array['0'..'^'] of integer;
    helpl:char;
    ihelp:boolean;
    cf:text; cfo,okt:boolean;
    elevel:byte;

label reent,reent1;

{$I COMMON.PAS}
{$I PART1.PAS}

procedure dos(c:char);
var f:file;
begin
  cmd:=upcase(c);
  assign(f,'dos.chn');
  {$I-} reset(f); {$I+}
  if ioresult=0 then begin
    print('Loading.');
    close(f);
    remove_port;
    chain(f);
  end else print('Dos system not present.');
end;

function greater(mrec:messages):boolean;
begin
 if mrec.ext>thisuser.qscan[board].ext then greater:=true else
  if mrec.ltr>thisuser.qscan[board].ltr then greater:=true else
    if (mrec.ltr=thisuser.qscan[board].ltr) and (mrec.number>thisuser.qscan[board].number) then
      greater:=true
    else greater:=false;
end;

procedure mcursor;
var i:integer;
begin
  cursor:='';
  for i:=1 to length(thisuser.cursor) do
    cursor:=cursor+thisuser.cursor[i]+chr(8);
end;

function maxage(x:integer):integer;
begin
  maxage:=255;
  if x<20 then
    maxage:=5
  else if x<30 then
    maxage:=14
  else if x<40 then
    maxage:=90
  else if x<60 then
    maxage:=120;
end;

function boardac(nb:integer):boolean;
var i:str;
begin
  boardac:=false;
  if cs then boardac:=true else
    if (thisuser.sl>=boards[nb].sl) and
    ((boards[nb].ar='@') or (boards[nb].ar in thisuser.ar)) then
    if boards[nb].pw='' then boardac:=true else begin
      prompt('Password? '); input(i,10);
      if i=boards[nb].pw then boardac:=true else print('Wrong.');
    end;
end;

function mln(i:str; l:integer):str;
begin
  while length(i)<l do i:=i+' ';
  mln:=i;
end;

function mn(i,l:integer):str;
begin
  mn:=mln(cstr(i),l);
end;

procedure inu(var i:integer);
var s:str;
begin
  input(s,3); i:=value(s);
end;

procedure ini(var i:byte);
var s:str;
begin
  input(s,3); i:=value(s);
end;

function rmail(n:integer):str;
var tu,cn,c:integer; f:file; mr,mr1:mailrec; u:userrec; dm:boolean;
begin
  dm:=true;
  seek(mailfile,n); read(mailfile,mr); tu:=mr.destin;
  if mr.msg.ext>128 then begin
    for c:=0 to filesize(mailfile)-1 do begin
      seek(mailfile,c); read(mailfile,mr1);
      if (mr1.msg.ltr=mr.msg.ltr) and (mr1.msg.number=mr1.msg.number)
      and (mr.msg.ext=mr1.msg.ext) and (c<>n) and (mr1.destin<>-1) then
        dm:=false;
    end;
  end;
  if dm then begin
    assign(f,filename(mr.msg)); {$I-} erase(f); {$I+} cn:=ioresult;
  end;
  mr.destin:=-1; mr.from:=0; mr.mage:=0;
  seek(mailfile,n); write(mailfile,mr);
  reset(uf);
  if (tu>0) and (tu<filesize(uf)) then begin
    seek(uf,tu); read(uf,u); u.waiting:=u.waiting-1;
    seek(uf,tu); write(uf,u);if tu=1 then fw:=fw-1;
  end;
  close(uf);
  rmail:=u.name+' #'+cstr(tu);
end;

procedure isr(uname:str;usernum:integer);
var t,i,ii:integer; sr:smalrec;
begin
 ii:=systat.users; i:=0;
 while (ii-i)>1 do begin
   t:=(ii+i) div 2;
   if uname<srl[t].name then
     ii:=t
   else
     i:=t;
 end;
 if srl[ii].name<uname then i:=ii;
 for ii:=systat.users downto i+1 do
   srl[ii+1]:=srl[ii];
 sr.name:=uname; sr.number:=usernum;
 srl[i+1]:=sr;
 systat.users:=systat.users+1; reset(systatf);write(systatf,systat);
 close(systatf);
 rewrite(sf); for ii:=0 to systat.users do write(sf,srl[ii]); close(sf);
end;

procedure dsr(uname:str);
var i,rn:integer; sr:smalrec;
begin
  rn:=0;
  for i:=1 to systat.users do
    if srl[i].name=uname then
      rn:=i;
  if rn<>0 then begin
    for i:=rn to systat.users-1 do srl[i]:=srl[i+1];
    reset(systatf); systat.users:=systat.users-1;
    write(systatf,systat); close(systatf);
    rewrite(sf); for i:=0 to systat.users do write(sf,srl[i]); close(sf);
  end else sl1('*** Couldn''t delete "'+uname+'"');
end;

procedure ssm(dest:integer; s:str);
var x:smr; e,cp,t:integer; u:userrec;
begin
  {$I-} reset(smf);{$I+}
  if ioresult<>0 then rewrite(smf);
  e:=filesize(smf);
  if e=0 then cp:=0 else begin
    t:=e-1;
    seek(smf,t); read(smf,x);
    while (T>0) and (x.destin=-1) do begin
      t:=t-1; seek(smf,t); read(smf,x);
    end;
    cp:=t+1;
  end;
  seek(smf,cp); x.msg:=s; x.destin:=dest;
  write(smf,x);
  close(smf);
  reset(uf); seek(uf,dest); read(uf,u);
  if not (smw in u.option) then
    begin u.option:=u.option+[smw]; seek(uf,dest); write(uf,u); end;
  close(uf);
  if (dest=usernum) then thisuser.option:=thisuser.option+[smw];
end;

procedure rsm;
var x:smr; i:integer;
begin
  {$I-} reset(smf); {$I+}
  if ioresult=0 then begin
    i:=0;
    repeat
      if i<=filesize(smf)-1 then begin seek(smf,i); read(smf,x); end;
      while (i<filesize(smf)-1) and (x.destin<>usernum) do begin
        i:=i+1; seek(smf,i); read(smf,x);
      end;
      if (x.destin=usernum) and (i<=filesize(smf)-1) then begin
        print(x.msg);
        seek(smf,i); x.destin:=-1; write(smf,x);
      end;
      i:=i+1;
    until (i>filesize(smf)-1) or hangup;
    close(smf);
  end;
end;

procedure email(touser:integer);
var mr:mailrec; t,e,cp:integer; f:messages; a:anontyp; i:str; us:userrec;
begin
  if (remail in thisuser.ac) or ((touser<>1) and (etoday>=seclev[thisuser.sl].emails) and  (thisuser.sl<55))
  or hangup or ((touser=1) and (ftoday>=5))
  then print('Too much mail sent today.') else
   if (touser=usernum) and (realsl<>255) then
     print('Can''t E-mail yourself.') else begin
    a:=no; if sanm in seclev[thisuser.sl].anst then a:=yes;
    reset(uf); seek(uf,touser); read(uf,user); close(uf);
    if ((touser=1) and (user.waiting>50)) or ((touser<>1) and
    (user.waiting>15)) or ((nomail in user.option) and not cs)
    then print('Can''t send him mail.') else
     if user.deleted then print('That user is deleted.') else begin
      inmsg(f,a,i,false,false);
      if f.ext<>0 then begin
        {$I-} reset(mailfile); {$I+}
        if (ioresult<>0) then
          rewrite(mailfile);
        e:=filesize(mailfile);
        if e=0 then cp:=0 else begin
          cp:=-1; t:=e-1;
          seek(mailfile,t); read(mailfile,mr);
          while (t>0) and (mr.destin=-1) do begin
            t:=t-1; seek(mailfile,t); read(mailfile,mr);
          end;
          cp:=t+1;
        end;
        seek(mailfile,cp);
        mr.msg:=f; if lan then mr.from:=-usernum else mr.from:=usernum;
        mr.destin:=touser;
        mr.title:=i; mr.date:=daynum(date);
        mr.mage:=maxage(thisuser.sl);
        write(mailfile,mr);
        if touser=1 then begin thisuser.feedback:=thisuser.feedback+1;
          ftoday:=ftoday+1; fw:=fw+1; end else begin thisuser.emailsent:=
          thisuser.emailsent+1; etoday:=etoday+1; end;
        close(mailfile); reset(uf); seek(uf,touser); read(uf,user);
        user.waiting:=user.waiting+1; seek(uf,touser); write(uf,user);
        if touser=usernum then thisuser.waiting:=thisuser.waiting+1;
        i:=user.name+' #'+cstr(touser);
        close(uf); topscr;
        sysoplog('Mail sent to '+i);
        print('Mail sent to '+i);
      end;
    end;
  end;
end;

function ctp(t,b:integer):str;
var i,i1:str; n:real;
begin
  i:=cstr((t*100) div b); if length(i)=1 then i:=' '+i; i:=i+'.';
  if length(i)=3 then i:=' '+i;
  n:=t/b+0.0005;
  i1:=cstr(trunc(n*1000) mod 10);
  ctp:=i+i1+'%';
end;

procedure finduser(var usernum:integer);
var t,i,i1:integer;
    nn:str;
begin
  input(nn,25);
  usernum:=value(nn); if usernum>0 then begin
    reset(uf);
    if usernum>filesize(uf)-1 then begin
      print('Unknown User.');
      usernum:=0; end
    else begin
      seek(uf,usernum);
      read(uf,user);
      if user.deleted then begin
        print('Unknown User.');
        usernum:=0; end;
      end;
    close(uf); end
  else begin
    i:=1; i1:=systat.users; t:=(i1+i) div 2;
    while ((i1-i)>1) and (srl[t].name<>nn) do begin
      if srl[t].name<nn then
        i:=t
      else
        i1:=t;
      t:=(i1+i) div 2;
    end;
    usernum:=0;
    if srl[i].name=nn then usernum:=srl[i].number;
    if srl[i1].name=nn then usernum:=srl[i1].number;
    if srl[t].name=nn then usernum:=srl[t].number;
    if nn='NEW' then usernum:=-1;
    if usernum=0 then print('Unknown User.');
   end;
 end;

procedure imail(i:integer);
begin
  reset(uf); seek(uf,i); read(uf,user); close(uf);
  if user.deleted then begin
    print('That user is deleted.');
  end else begin
    prompt('E-mail '+user.name+' #'+cstr(i)+'? ');
    if yn then email(i);
  end;
end;

procedure readamsg;
var filv:text; i,n:str; ii:integer;
begin
  nl;nl;assign(filv,'gfiles\auto.msg');
  {$I-} reset(filv); {$I+}
  if ioresult<>0 then print('No Auto-message') else begin
    readln(filv,n); if n[1]='@' then
      if postn in seclev[thisuser.sl].anst then n:='<<< '+copy(n,2,length(n))+' >>>'
      else n:='>UNKNOWN<';
    print('Auto message by: '+n); nl;
    for ii:=1 to 3 do begin
      readln(filv,i); print(i); end;
    close(filv);
  end;
  nl;nl;
end;

procedure autoreply;
var i:integer; c:char;
begin
  if lastname='' then print('Can''t Auto-reply now.') else begin
    i:=length(lastname);
    while (lastname[i]<>'#') and (i>1) do i:=i-1;
    i:=value(copy(lastname,i+1,5));
    if i=0 then print('It seems I can''t do that now.') else imail(i);
  end;
end;

procedure vali(un:integer);
var i:integer; c:char; ii:str; r:restrictions;
begin
  reset(uf); seek(uf,un); read(uf,user);
  print('Name: '+user.name+' #'+cstr(un));
  print('RN  : '+user.realname);
  print('PH  : '+user.ph);
  print('SL  : '+cstr(user.sl));
  if user.sl=99 then print('SBN : '+cstr(user.sbn));
  prompt('Enter new sl : '); input(ii,3);
  if ii<>'' then begin
    i:=value(ii); if i<>255 then user.sl:=i;
  end;
  if user.sl=99 then begin
    prompt('Which board #? '); input(ii,2);
    user.sbn:=value(ii);
  end;
  print('      LCVBA*PEKM');
  repeat
    prompt('AC  : ');
    for r:=rlogon to rmsg do
    if r in user.ac then prompt(copy('LCVBA*PEKM',ORD(R)+1,1)) else prompt(' '); nl;
    prompt('Which? ');
    getkey(c); c:=upcase(c); print(c);acch(c,user);
  until (c=chr(13)) or hangup;
  print('DSL : '+cstr(user.dsl));
  prompt('Enter new dsl : '); input(ii,3);
  if ii<>'' then user.dsl:=value(ii);
  seek(uf,un); write(uf,user); close(uf);
end;

procedure vallastuser;
var i:integer;
begin
  if lastname='' then print('Can''t validate anyone.') else begin
    i:=length(lastname);
    while (lastname[i]<>'#') and (i>1) do i:=i-1;
    i:=value(copy(lastname,i+1,5));
    if i=0 then print('Oops, there''s a problem.') else vali(i);
  end;
end;

procedure iscan(var pl:integer);
var b:messagerec;
begin
  assign(mf,'gfiles\'+boards[board].filename);
  {$I-} reset(mf); {$I+}
  if (ioresult=0) then begin
    read(mf,b);
    pl:=b.message.number;
  end else begin
    rewrite(mf);
    b.message.number:=0;
    write(mf,b);
    pl:=0;
    close(mf);
    reset(mf);
    read(mf,b);
  end;
end;

procedure deletem(var pl:integer; ntd:integer);
var b:messagerec; filvar:file; t:integer;
begin
  seek(mf,ntd); read(mf,b);  assign(filvar,filename(b.message));
  {$I-} erase(filvar); {$I+} t:=ioresult; pl:=pl-1;
  for t:=ntd+1 to pl+1 do begin
    seek(mf,t);read(mf,b); seek(mf,t-1); write(mf,b);
  end;
  seek(mf,0); b.message.number:=pl; write(mf,b);
end;

procedure readm(cn:integer; var next:boolean; var unvali:boolean; pl:integer);
var i:str; b:messagerec; ratall,rname:boolean;
begin
  nl;nl;
  ratall:=true; next:=false;unvali:=false;
  seek(mf,cn); read(mf,b);
  if b.messagestat<>validated then begin  unvali:=true;
    print(cstr(cn)+'/'+cstr(pl)+': <<< NOT VALIDATED YET >>>');
    lastname:='';
    if not lcs then ratall:=false;
  end;
  if ratall then begin
    print(cstr(cn)+'/'+cstr(pl)+': '+b.title); irt:=b.title;
    if postn in seclev[thisuser.sl].anst then rname:=true else rname:=false;
    if (thisuser.sl=255) then writeln('Days left: '+
      cstr(b.date-daynum(date)+b.mage));
    readmsg(b.message,rname,next); tleft;
    if greater(b.message) then thisuser.qscan[board]:=b.message;
  end;
end;


{$I PART2.PAS}
{$I PART3.PAS}

procedure dloads;
var f:file; ok:boolean;
begin
  ok:=true;
  if (thisuser.sl<=10) or (thisuser.dsl=0) then ok:=false;
  if cs then ok:=true;
  if not ok then print('You can''t access the file system.') else
  begin
    assign(f,'dloads.chn');
    {$I-} reset(f); {$I+}
    if ioresult=0 then begin
      print('Loading file system...');
      close(f);
      remove_port;
      chain(f);
    end else print('File system not present.');
  end;
end;

procedure getcaller;
var c:char; x:smr; chkcom:boolean; rl,rl1:real; i:str;

  procedure init1;
  begin
    set_baud(maxbaud);
    if maxbaud=300 then pr('ATS0=0Q0V0E0M0S2=1');
    if maxbaud=1200 then pr('ATS0=0Q0V0E0M0S2=1X1');
    if maxbaud=2400 then pr('ATS0=0Q0V0E0M0S2=1X1');
    dump;
  end;

  procedure i1;
  begin
    init1; c:=#0; write('Waiting...'); rl:=timer;
    repeat
      c:=cinkey;if abs(timer-rl)>4.0 then begin init1; rl:=timer; end;
    until c=#13; delay(50);
  end;

begin
  buf:=''; enddayf:=false; delay(50);
  dump;
  window(1,1,80,25); clrscr; chatr:='';
  outcom:=false; useron:=false; ll:='';
  hangup:=false; usernum:=0; chatcall:=false; hungup:=false;
  term_ready(true); i1; clrscr; thisline:=''; okt:=false;
  if systat.users>0 then
    begin reset(uf); seek(uf,1); read(uf,thisuser); close(uf); mcursor; usernum:=1; end;
  repeat
    if daynum(date)<>ldate then
      if (daynum(date)-ldate)=1 then
        ldate:=ldate+1
      else begin
        writeln('Date corrupted.');
        halt(1);
      end;
    randomize; incom:=false; outcom:=false; ihelp:=false; helpl:=#0; ret:=201;
    hangup:=false; hungup:=false; irt:=''; lastname:=''; macok:=true; cfo:=false;
    spd:='KB'; c:=#0; chkcom:=false; c:=inkey; if c<>chr(0) then begin
      c:=upcase(c);
      case c of
        'V':uedit(1);
        ' ':begin
              write('Log on? '); read(kbd,c); c:=upcase(c); writeln(c);
              if c='Y' then c:=' ' else c:='@';
            end;
        'Q':begin elevel:=0; hangup:=true; doneday:=true; end;
        'L':begin printfile('gfiles\sysop.log');getkey(c); c:='@';end;
        'Y':begin printfile('gfiles\ysysop.log');getkey(c); c:='@';end;
        'A':chkcom:=true;
        'S':pstat;
        'M':mailr;
        'B':boardedit;
        'T':dos('T');
        'E':dos('E');
        'G':dos('G');
        'P':changestuff;
        'D':dlboardedit;
        'R':if systat.users>0 then begin print('Feedback: '); nl; nl;
              macok:=true; readmail; macok:=false;
              reset(uf); seek(uf,1); write(uf,thisuser); close(uf);
            end;
        'F':dos('D');
      end;
      clrscr; dump;
    end;
    if c<>' ' then c:=#0;
    if commpressed then c:=cinkey;
    if c='2' then begin
      chkcom:=true; rl:=timer; write('* ');
      while (c<>#13) and (abs(rl-timer)<0.2) do c:=cinkey;
    end;
    if chkcom then begin
      pr('ATA'); writeln('Answering phone, "H" to abort');
      delay(50); dump; rl1:=timer; i:=''; rl:=0.0;
      repeat
        chkcom:=false;
        if keypressed then begin read(kbd,c);
          if upcase(c)='H' then begin chkcom:=true; pr('A');end;
        end;
        c:=cinkey;
        if (rl<>0.0) and (abs(rl-timer)>2.0) and (c=#0) then c:=#13;
        if c<>#0 then
          if c<>#13 then begin i:=i+c; rl:=timer; end else begin
            if i='1' then begin spd:='300'; chkcom:=true; end;
            if i='5' then begin spd:='1200'; chkcom:=true; end;
            if i='10' then begin spd:='2400'; chkcom:=true; end;
            if i='3' then chkcom:=true;
            rl:=0.0;
          end;
        if c=#13 then i:='';
        if abs(timer-rl1)>45.0 then chkcom:=true;
      until chkcom;
      if abs(timer-rl1)>45.0 then i1;
      clrscr;
    end;
    if spd<>'KB' then incom:=true;
  until incom or (c=' ') or doneday;
  etoday:=0; ptoday:=0; ftoday:=0; if not doneday then writeln('Logging on...');
  if incom then begin
    outcom:=true;
    set_baud(value(spd));
    delay(1000);
  end else begin term_ready(false); incom:=false; outcom:=false; end;
  timeon:=timer; ftoday:=0;
  dump;
  window(1,5,80,25); lil:=0; okt:=true;
end;

procedure post;
var b:messagerec; pl:integer; i:str; mesag:messages; a:anontyp; c:char;
begin
 irt:='';
 if ((ptoday>=seclev[thisuser.sl].posts) and (thisuser.sl<55)) or (rpost in
 thisuser.ac) or (thisuser.sl<boards[board].sl) then
   print('Too many messages posted today.') else begin
  iscan(pl);
  if pl>=boards[board].maxmsgs then deletem(pl,1);
  a:=boards[board].anonymous;
  if (a=no) and (pana in seclev[thisuser.sl].anst) then
    a:=yes;
  if rpostan in thisuser.ac then a:=no;
  inmsg(mesag,a,i,true,false);
    if mesag.ext<>0 then begin
      b.message:=mesag;
      b.title:=i;
      b.owner:=usernum;
      b.date:=daynum(date);
      b.mage:=maxage(thisuser.sl);
      if rvalidate in thisuser.ac then
        b.messagestat:=unvalidated else b.messagestat:=validated;
      if rmsg in thisuser.ac then b.messagestat:=deleted;
      pl:=pl+1; seek(mf,pl); write(mf,b);
      seek(mf,0); b.message.number:=pl; write(mf,b);
      thisuser.msgpost:=thisuser.msgpost+1; ptoday:=ptoday+1;
      systat.msgposttoday:=systat.msgposttoday+1;
      sysoplog('+'+i+' posted on '+boards[board].name); topscr;
      print('Message posted on '+boards[board].name+'.');
    end;
  close(mf);
 end;
end;

procedure titles(var cn:integer; pl:integer);
var abort,next:boolean; nl:integer; b:messagerec; i:str;
begin
  nl:=0;
  abort:=false;
  while (not abort) and (nl<10) and (cn<=pl) do begin
    seek(mf,cn); read(mf,b);
    if b.owner=usernum then i:='['+cstr(cn)+']' else i:='('+cstr(cn)+')';
    while length(i)<8 do i:=' '+i; i:=i+' '+b.title;
    if greater(b.message) then i[1]:='*';
    if b.messagestat<>validated then if lcs
      then begin
        i[1]:='N'; i[2]:='V';
      end else
        i:=copy(i,1,9)+'<<< NOT VALIDATED YET >>>';
    printacr(i,abort,next);
    nl:=nl+1;cn:=cn+1;
  end;
  cn:=cn-1;
end;

procedure scan2(pl:integer; var cn:integer; iread:newtyp; var quit:boolean);
var unvali,uv,pq,donescan,abort,next:boolean; i:str; t:integer;
 b:messagerec;
begin
  quit:=false;pq:=false; unvali:=false; helpl:='S';
  donescan:=false;
  repeat
    if iread=lt then begin cn:=cn+1; titles(cn,pl); iread:=rp; end;
    if iread=rp then begin
      tleft; prompt('Read:(1-'+cstr(pl)+',^'+cstr(cn)+'),T,R,Q,P,A,? :');
      input(i,4); t:=value(i);
      if i='R' then begin t:=cn; i:=cstr(t); end;
      if (i<>'') and (t=0) then case i[1] of
        'P':begin close(mf);post; iscan(pl); end;
        'T':iread:=lt;
        'Q':begin quit:=true; donescan:=true; end;
        'B':donescan:=true;
        'D':if lcs and (cn>0) and (cn<=pl) then begin
              deletem(pl,cn); cn:=cn-1;
            end;
        'A':autoreply;
        'V':if cs then vallastuser;
        'M':if cs then movemsg(pl,cn);
        '?':begin
              print('Read:number');
              print('<CR>=next');
              print('T:itles     Q:uit');
              print('P:ost       A:uto-reply');
              print('R:e-read    B:next board in N-scan');
            end;
      end else begin
        if (t>0) and (t<=pl) then begin
          cn:=t;
          iread:=rm;
        end else if i='' then begin
          t:=cn+1;
          if t<=pl then begin
            cn:=t;
            iread:=rm;
          end else begin donescan:=true; pq:=true; end;
        end;
      end;
    end;
    if (iread=rm) and (cn>0) and (cn<=pl) then begin
      readm(cn,next,uv,pl); if uv then unvali:=true;
      if next then cn:=cn+1 else iread:=rp;
      mread:=mread+1; tleft;
      if (mread>=extramsgs+seclev[thisuser.sl].mallowed)
      and (thisuser.sl<>255) and (thisuser.ontoday<>1) then begin
        print('You have read all your messages.');
        hangup:=true;
      end;
      if (mread+5=extramsgs+seclev[thisuser.sl].mallowed) and (thisuser.ontoday<>1) then
        print('5 messages left until forced logoff');
    end else if iread=rm then iread:=rp;
    if (iread=rm) and (cn=pl+1) then begin donescan:=true; pq:=true; end;
  until donescan or hangup;
  if unvali and lcs then begin
    prompt(chr(7)+'Validate messages here? ');
    if yn then for t:=1 to pl do begin
      seek(mf,t); read(mf,b); if b.messagestat<>validated then begin
        b.messagestat:=validated; seek(mf,t); write(mf,b);
      end;
    end;
  end;
  if pq then begin
    nl;prompt('Post on '+boards[board].name+'? ');
    if yn then begin close(mf); post; iscan(pl); end;
  end;
  nl;
end;

procedure scan1;
var pl,cn:integer; i:str; quit:boolean;
begin
  iscan(pl); helpl:='N';
  print(cstr(pl)+' msgs on '+boards[board].name);
  if pl<>0 then begin
    prompt('Start listing at? ');
    input(i,4);
    cn:=value(i); if cn<=0 then cn:=0 else  if cn>pl then cn:=pl else cn:=cn-1;
    if i='S' then scan2(pl,cn,rp,quit) else
      if (i<>'Q') then
        scan2(pl,cn,lt,quit);
  end;
  close(mf);
end;


procedure qscan(var quit:boolean);
var b:messagerec; pl,cn:integer; i:str;
begin
  iscan(pl);
  if boards[board].key=' ' then i:='#'+cstr(board) else i:=boards[board].key;
  cn:=1; nl; print('< Q-scan '+boards[board].name+' '+i+' - '+cstr(pl)+' msgs >');
  if pl<>0 then begin
    seek(mf,1); read(mf,b);
    while (not greater(b.message)) and (cn<pl) do begin
      cn:=cn+1; seek(mf,cn); read(mf,b);
    end;
    if greater(b.message) then scan2(pl,cn,rm,quit) else quit:=false;
  end;
  print('< '+boards[board].name+' Q-scan done >');
  close(mf);
end;

procedure nscan;
var quit:boolean;
begin
  nl;nl;print('<< Q-scan all >>');
  board:=1; quit:=false;
  while (board<=numboards) and (not quit) and (not hangup) do begin
   if thisuser.qscn[board] then
     if boardac(board) then qscan(quit);
   board:=board+1;
  end;
  nl;print('<<Global Q-scan done>>');nl;
  board:=1;
end;

procedure mmkey(var i:str);
var c:char;
begin
  repeat
    repeat
      getkey(c);
      if c=#26 then phelp;
      skey(c);
    until (((c>=' ') and (c<chr(127))) or (c=chr(13))) or hangup;
    c:=upcase(c);
    outkey(c);
    thisline:=thisline+c;
    if (c='/') or (c='1') then begin
      i:=c;
      repeat
        getkey(c);
        if c=#26 then phelp;
        skey(c);
      until ((c>=' ')and(c<=chr(127))) or (c=chr(13)) or (c=chr(8)) or hangup;
      c:=upcase(c);
      if c<>chr(13) then begin outkey(c); thisline:=thisline+c; end;
      if (c=chr(8)) or (c=chr(127)) then prompt(' '+c);
      if c='/' then input(i,20) else if c<>chr(13) then i:=i+c;
    end else i:=c;
  until (c<>chr(8)) and (c<>chr(127)) or hangup;
  nl;
end;

procedure mainmenu;
var nb,inte:integer; abort,next:boolean; ii:str; rl:real; mr:mailrec;
begin
  dump;tleft;nl;nl; macok:=true;
  if not expert then printfile('gfiles\mainmenu.msg');
  rl:=(seclev[thisuser.sl].ttime*60.0+extratime+timeon-timer);
  if rl>32767.0 then rl:=32000; if rl<0.0 then rl:=0;
  inte:=trunc(rl);
  i:=cstr(inte div 3600)+':'; ii:=cstr((inte mod 3600) div 60);
  if length(ii)=1 then ii:='0'+ii; i:='T - '+i+ii+':';
  ii:=cstr(inte mod 60); if length(ii)=1 then ii:='0'+ii;
  i:=i+ii; print(i);
  if boards[board].key=' ' then i:='['+cstr(board)+'] ' else
    i:='['+boards[board].key+'] ';
  i:=i+'['+boards[board].name+'] :';
  prompt(i); helpl:='@';
  if onekey in thisuser.defaults then mmkey(i) else input(i,20);
  helpl:=#0;
  if length(i)=1 then case i[1] of
    '?':if expert then begin nl;nl; printfile('gfiles\mainmenu.msg'); end;
    'O':begin
          helpl:='O';nl;nl;prompt('Hangup?  Sure? ');
          if yn then begin
            cls;
            printfile('gfiles\logoff.msg');
            hangup:=true;
            hungup:=false;
          end;
        end;
    '*':boardlist;
    'X':expert:=not expert;
    'D':default;
    'Y':yourinfo;
    'I':begin printfile('gfiles\logon.msg'); printfile('gfiles\system.msg'); end;
    'C':reqchat;
    '$':chpw;
    'R':removem;
    'U':ulist;
    'E':smail(false);
    'F':begin irt:='Feedback'; imail(1); end;
    'S':scan1;
    'P':post;
    'T':dloads;
    'M':readmail;
    'Q':qscan(next);
    'G':gfiles;
    'N':nscan;
    'W':wamsg;
    'V':vote;
    'L':printfile('gfiles\user.log');
    'A':abbs;
    'H':mmacro;
    'K':delmail;
    'J':prg(false);
    'Z':prg(true);
    'B':printfile('gfiles\bbslist.msg');
    '!':if cs then begin
          print('Enter name or number of person.'); prompt(':');
          finduser(inte); if inte>0 then vali(inte);
        end;
 end else
  begin
    if copy(i,1,2)='//' then i:=copy(i,3,length(i)-2);
    if i='/O' then hangup:=true;
    if i='/E' then smail(true);
    if i='/K' then if onekey in thisuser.defaults then thisuser.defaults:=
      thisuser.defaults-[onekey] else thisuser.defaults:=thisuser.defaults+[onekey];
    if (i='UEDIT') and cs then uedit(usernum);
    if (i='STATUS') and cs THEN PSTAT;
    if (i='IVOTES') AND cs then initvotes;
    if (i='LOG') and cs then printfile('gfiles\sysop.log');
    if (i='YLOG') and cs then printfile('gfiles\ysysop.log');
    if (i='BOARDEDIT') and so then boardedit;
    if (i='DLBOARDEDIT') and so then dlboardedit;
    if (i='MAILR') and so then mailr;
    if (i='/?') and cs then printfile('gfiles\sysopmnu.msg');
    if (i='QUIT') and so then begin doneday:=true; hangup:=true; elevel:=1; end;
    if (i='DOS') and cs then begin ret:=200; dos('D'); end;
  end;
  nb:=value(i);
  if nb>0 then
    if nb<=numboards then
      if (boards[nb].key=' ') and boardac(nb) then board:=nb
      else
    else
  else begin
    nb:=0;
    for inte:=1 to numboards do if boards[inte].key=i then nb:=inte;
    if (nb<>0) and (i<>' ') then if boardac(nb) then board:=nb;
  end;
end;

begin
  getdir(0,i); ovrpath(i);
  if ret>127 then begin
    iport;
    if ret=200 then
      goto reent;
    if ret=201 then
      goto reent1;
  end;
  ret:=ret+128;
  init;
  repeat
    reent1: getcaller;
    if getuser then newuser;
    macok:=true;
    if not hangup then logon;
    while not hangup do
      reent: mainmenu;
    term_ready(false); delay(500);
    if useron then logoff;
    if enddayf then endday;
    enddayf:=false;
  until doneday;
  term_ready(true); delay(100); pr('ATZ');
  remove_port;
  halt(elevel);
end.