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

unit subs2;

{ $define testingdevices}   (* Activate this define for test mode *)

interface

uses printer,dos,crt,gentypes,configrt,gensubs,subs1,windows,modem,statret,chatstuf,
     flags,mailret,menus;

procedure percent_whoa(r1,r2:real;x,y:integer);
procedure beepbeep;
procedure summonbeep;
procedure openttfile;
procedure writecon (k:char);
procedure toggleavail;
function charready:boolean;
procedure UNCRUNCH (var Addr1,Addr2; BlkLen:Integer);
function readchar:char;
function waitforchar:char;
procedure clearchain;
function charpressed (k:char):boolean;  { TRUE if K is in typeahead }
procedure addtochain (l:lstr);
procedure directoutchar (k:char);
procedure handleincoming;
procedure writechar (k:char);
{$F+}
      function opendevice (var t:textrec):integer;
      function closedevice (var t:textrec):integer;
      function cleardevice (var t:textrec):integer;
      function ignorecommand (var t:textrec):integer;
      function directoutchars (var t:textrec):integer;
      function writechars (var t:textrec):integer;
      function directinchars (var t:textrec):integer;
      function readcharfunc (var t:textrec):integer;
{$F+}
function getinputchar:char;
procedure getstr;
procedure writestr (s:anystr);
procedure cls;
Procedure Goxy(x,y:integer);
Procedure AsciiGoxy(x,y:integer);
Procedure ColorFb(ForeGround,Background:Byte);
procedure writehdr (q:anystr);
function issysop:boolean;
procedure reqlevel (l:integer);
procedure printfile (fn:lstr);
procedure printtexttopoint (var tf:text);
procedure skiptopoint (var tf:text);
function minstr (blocks:integer):sstr;
procedure parserange (numents:integer; var f,l:integer);
Procedure User_Prompt;
Procedure GetyaHeader;
Procedure Getyaprompt;
Procedure Eat_Shit;
function menu (mname:mstr; mfn:sstr; choices:anystr):integer;
function getloginpassword (var u:userrec):boolean;
function checkpassword (var u:userrec):boolean;
function getpassword:boolean;
function getsysoppwd:boolean;
procedure getacflag (var ac:accesstype; var tex:mstr);

{ procedure drawbox (x1,y1,x2,y2:byte;fill:boolean);
function pulldown (itemlist:menutype;
                   win:byte;              Pull Down Window Routines
                   sel:byte;
                   x1,y1,x2,y2:byte;
                   startitem:byte):integer;
function lrmenu (menu:lrmenutype;topc,barc:byte):integer; }
procedure updatenodestatus(Ls:Lstr);

implementation



procedure beepbeep;
begin
  nosound;
  sound (200);
  delay (10);
  sendchar(#7);
  nosound
end;

procedure summonbeep;
var cnt:integer;
begin
  nosound;
  cnt:=1330;
  repeat
    sound (cnt);
    delay (10);
    cnt:=cnt+200;
  until cnt>4300;
  nosound
end;

procedure clearchain;
begin
  chainstr[0]:=#0
end;

  Procedure abortttfile(er:Integer);
    Var n:Integer;
    Begin
      specialmsg('[Texttrap Error]: '+strr(er)+'!');
      texttrap:=False;
      textclose(ttfile);
      n:=IOResult
    End;

  Procedure openttfile;
    Var n:Integer;
    Begin
      appendfile('TextTrap',ttfile);
      n:=IOResult;
      If n=0
      Then texttrap:=True
      Else abortttfile(n)
    End;

      Procedure toggletexttrap;
      Var n:Integer;
      Begin
        If texttrap
        Then
          Begin
            textclose(ttfile);
            n:=IOResult;
            If n<>0 Then abortttfile(n);
            texttrap:=False
          End
        Else openttfile
      End;

procedure writecon (k:char);
var r:registers;
begin
   if k=^J
    then write (usr,k)
    else
      begin
        r.dl:=ord(k);
        r.ah:=2;
        intr($21,r)
      end
end;

procedure toggleavail;
begin
  if sysopavail=notavailable
    then sysopavail:=available
    else sysopavail:=succ(sysopavail)
end;

procedure UNCRUNCH (var Addr1,Addr2; BlkLen:Integer);
begin
  inline ($1E/$C5/$B6/Addr1/$C4/$BE/Addr2/$8B/$8E/BlkLen/$8B/$D7/
          $B4/$00/$AC/$3C/$10/$73/$07/$80/$E4/$F0/$0A/$E0/$EB/$44/
          $3C/$18/$74/$13/$73/$19/$2C/$10/$02/$C0/$02/$C0/$02/$C0/
          $02/$C0/$80/$E4/$0F/$0A/$E0/$EB/$2D/$81/$C2/$A0/$00/$8B/
          $FA/$EB/$25/$3C/$1A/$75/$0B/$AC/$49/$51/$32/$ED/$8A/$C8/
          $AC/$EB/$0D/$90/$3C/$19/$75/$11/$AC/$51/$32/$ED/$8A/$C8/
          $B0/$20/$0B/$C9/$74/$03/$AB/$E2/$FD/$59/$49/$AB/$0B/$C9/
          $74/$02/$E2/$AA/$1F);
end;

function charready:boolean;
var k:char;
begin
        if modeminlock then while numchars > 0 do k:= getchar;
  if hungupon or keyhit
    then charready:=true
    else if online
    then charready:=(not modeminlock) and (numchars > 0)
      else charready:=false
end;

function readchar:char;

  procedure toggletempsysop;
  begin
    if tempsysop
      then ulvl:=regularlevel
      else
        begin
          regularlevel:=ulvl;
          ulvl:=configset.sysopleve
        end;
    tempsysop:=not tempsysop
  end;

  Procedure togglebar;
  Begin
    If UseBottom then Begin
    UseBottom:=False;
    initwinds;
    Gotoxy(1,24);
    write(#27,'[K');
    gotoxy(1,25);
    write(#27,'[K');
    UseBottom:=False
    End
    Else Begin
    UseBottom:=True;
    ClrScr;
    initwinds;
    bottomline;
    End;
  End;

  procedure togviewstats;
  begin
    if splitmode
      then unsplit
      else
        begin
                                        splitscreen (10);
                                        top;
                                        clrscr;
                                        write (usr,'File Level:     ',urec.udlevel,
                                                                 ^M^J'File Points:    ',urec.udpoints,
                                                                 ^M^J'XMODEM uploads: ',urec.uploads,
                                                                 ^M^J'XMODEM dnloads: ',urec.downloads,
                                                                 ^M^J'Account Note:   ',urec.usernote,
                                                                 ^M^J'Download K:     ',Urec.DnKay,
                                                                 ^M^J'Post/Call Ratio:',Ratio(Urec.Nbu,Urec.NumOn),'%',
                                                                 ^M^J'Special Note:   ',urec.specialsysopnote);
          GotoXy(40,1);Write(Usr,'Posts:      ',urec.nbu);
          gotoxy(40,2);Write(Usr,'G-File Uls: ',urec.Nup);
          GotoXy(40,3);Write(Usr,'G-File Dls: ',urec.Ndn);
          GotoXy(40,4);Write(Usr,'Total Time: ',urec.totaltime:0:0);
          GotoXy(40,5);Write(Usr,'Num. Calls: ',urec.Numon);
                                        GotoXy(40,6);Write(Usr,'Upload K:   ',Urec.UpKay);
                                        GotoXy(40,7);Write(Usr,'U/D Ratio:  ',Ratio(Urec.Uploads,Urec.Downloads),'%');
                                end;
  end;

  procedure showhelp;
  begin
    if splitmode
      then unsplit
      else begin
        splitscreen (11);
        top;
        clrscr;
        write (usr,'                  ViSiON BBS Online Help'^M^J,
'Chat with user: F1 or F3         Sysop commands: F2'^M^J,
'Sysop gets the system next: F7   Lock the timer: F8'^M^J,
'Lock out all modem input: F9     Lock all modem output: F10'^M^J,
'Chat availabily toggle: Alt-A    Grant temporary sysop powers: Alt-T'^M^J,
'Grant user more time: Alt-M      Take away user''s time: Alt-L'^M^J,
'Take away ALL time: Alt-K        Refresh the bottom line: Alt-B'^M^J,
'Toggle printer echo: Ctrl-PrtSc  Toggle text trap: Alt-E'^M^J,
'View user''s status: Alt-V        Quick Hangup On user :Alt-N');
    end;
  end;


var k:char;
    ret:char;
    dorefresh:boolean;
    temocont:integer;
begin
  requestchat:=false;
  requestcom:=false;
  reqspecial:=false;
  if keyhit
    then
      begin
        k:=bioskey;
        ret:=k;
        if ord(k)>127 then begin
          ret:=#0;
          dorefresh:=ingetstr;
          case ord(k)-128 of
            availtogglechar:
              begin
                toggleavail;
                chatmode:=false;
                dorefresh:=true
              end;
            sysopcomchar:
              begin
                requestcom:=true;
                requestchat:=true
              end;
            quicknukechar:
                          begin
                          randomize;
                          for temocont:=1 to 30 do write(chr(random(20)+130));
                          delay(150);
                          forcehangup:=true;
                          writestatus;
                          exit;
            end;
            breakoutchar:
                         begin
                         closeport;
                         halt(e_controlbreak);
                         end;
            lesstimechar:urec.timetoday:=urec.timetoday-1;
            moretimechar:urec.timetoday:=urec.timetoday+1;
            notimechar:settimeleft (-1);
            chatchar:begin clearchain; bustchat; (*requestchat:=true;*) end;
            chatchar+1:requestchat:=true;
            chatchar+2:begin
                            clearchain;
                            bustchat;
                           (* requestchat:=true;
                            writeln(^B^N^M^M);
                            regchat;
                            requestchat:=false; *)
                            write(^B^M^M^P,lastprompt);
                            end;
            sysnextchar:sysnext:=not sysnext;
            timelockchar:if timelock then timelock:=false else begin
                           timelock:=true;
                           lockedtime:=timeleft
                         end;
            inlockchar:modeminlock:=not modeminlock;
            outlockchar:setoutlock (not modemoutlock);
            tempsysopchar:toggletempsysop;
            bottomchar:togglebar;
            viewstatchar:togviewstats;
            texttrapchar:toggletexttrap;
            sysophelpchar:if dorefresh then showhelp;
            printerechochar:printerecho:=not printerecho;

            1..128:Ret:=K;
        (*  72:ret:=^E;
            75:ret:=^S;
            77:ret:=^D;
            80:ret:=^X;
            115:ret:=^A;
            116:ret:=^F;
            73:ret:=^R;
            81:ret:=^C;
            71:ret:=^Q;
            79:ret:=^W;
            83:ret:=^G;
            82:ret:=^V;
            117:ret:=^P;  *)
          end;
          if (dorefresh) and (usebottom) then bottomline
        end
      end
    else
      begin
        k:=getchar;
        if modeminlock
          then ret:=#0
          else ret:=k
      end;
  readchar:=ret
end;

function waitforchar:char;
var t:integer;
    k:char;
begin
  t:=timer+configset.mintimeou;
  if t>=1440 then t:=t-1440;
  repeat
    if timer=t then forcehangup:=true
  until charready;
  waitforchar:=readchar
end;

function charpressed (k:char):boolean;  { TRUE if K is in typeahead }
begin
  charpressed:=pos(k,chainstr)>0
end;

procedure addtochain (l:lstr);
begin
  if length(chainstr)<>0 then chainstr:=chainstr+',';
  chainstr:=chainstr+l
end;

procedure directoutchar (k:char);
var n:integer;
begin
  if inuse<>1
    then writecon (k)
    else begin
      bottom;
      writecon (k);
      top
    end;
  if wherey>lasty then gotoxy (wherex,lasty);
  if online and (not modemoutlock) and ((k<>#10) or uselinefeeds)
  then sendchar(k);
  If texttrap Then Begin
        Write(ttfile,k);
        n:=IOResult;
        If n<>0 Then abortttfile(n)
      End;
  if printerecho then write (lst,k)
end;

procedure handleincoming;
var k:char;
begin
  k:=readchar;
  case upcase(k) of
    'X',^X,^K,^C,#27,' ':if not nobreak then
     begin
      writeln (direct);
      break:=true;
      linecount:=0;
      xpressed:=(upcase(k)='X') or (k=^X);
      if xpressed then clearchain
    end;
    ^S,^A:k:=waitforchar;
    else if length(chainstr)<255 then chainstr:=chainstr+k
  end
end;

procedure writechar (k:char);

  procedure endofline;

    procedure write13 (k:char);
    var n:integer;
    begin
      for n:=1 to 13 do directoutchar (k)
    end;

  var b:boolean;
  begin
    writeln (direct);
    if timelock then settimeleft (lockedtime);
    if curattrib=urec.statcolor then ansicolor (urec.regularcolor);
    linecount:=linecount+1;
    if (linecount>=urec.displaylen-1) and (not dontstop)
          and (moreprompts in urec.config) then begin
      linecount:=1;
      write (direct,'More (Y/N/C)?');
      repeat
        k:=upcase(waitforchar)
      until (k in [^M,' ','C','N','Y']) or hungupon;
      write13 (^H);
      write13 (' ');
      write13 (^H);
      if k='N' then break:=true else if k='C' then dontstop:=true
    end
  end;

begin
  if hungupon then exit;
  if k<=^Z then
    case k of
      ^J,#0:exit;
      ^Q:k:=^H;
      ^B:begin
           clearbreak;
           exit
         end
    end;
  if break then exit;
  if k<=^Z then begin
    case k of
      ^G:beepbeep;
      ^L:cls;
      ^R:ansicolor (urec.regularcolor);
      ^N:ansireset;
      ^O:ansicolor (urec.statusboxcolor);
      ^F:ansicolor (urec.blowboard);
      ^A:ansicolor (urec.blowinside);
      ^D:Ansicolor(Urec.MenuBack);
      ^I:AnsiColor(Urec.MenuHighLight);
      ^S:ansicolor (urec.statcolor);
      ^P:ansicolor (urec.promptcolor);
      ^U:ansicolor (urec.inputcolor);
      ^Y:ansicolor (8);
      ^X:ansicolor (1);
      ^H:directoutchar (k);
      ^M:endofline
    end;
    exit
  end;
  if usecapsonly then k:=upcase(k);
  if  not (asciigraphics in urec.config) and (k>#127) then case k of
      '?','?':k:='!';
      '?','?':k:='-';
      '?','?','?','?','?','?','?','?','?','?','?','?','?','?','?','?','?','?',
      '?','?','?','?','?','?','?','?','?','?','?','?','?','?','?','?','?','?':k:='+';
  end;
  directoutchar (k);
        if (keyhit or ((not modemoutlock) and online and (numchars > 0)))
    and not (nobreak and not (mens)) then handleincoming
end;

function getinputchar:char;
var k:char;
begin
  if length(chainstr)=0 then begin
    getinputchar:=waitforchar;
    exit
  end;
  k:=chainstr[1];
  delete (chainstr,1,1);
  if (k=',') and (not nochain) then k:=#13;
  getinputchar:=k
end;

{$ifdef testingdevices}

procedure devicedone (var t:textrec; m:mstr);
var r:registers;
    cnt:integer;
begin
  write (usr,'Device ');
  cnt:=0;
  while t.name[cnt]<>#0 do begin
    write (usr,t.name[cnt]);
    cnt:=cnt+1
  end;
  writeln (usr,' ',m,'... press any key');
  r.ax:=0;
  intr ($16,r);
  if r.al=3 then halt
end;

{$endif}

{$F+}

function opendevice;
begin
  {$ifdef testingdevices}  devicedone (t,'opened');  {$endif}
  t.handle:=1;
  t.mode:=fminout;
  t.bufend:=0;
  t.bufpos:=0;
  opendevice:=0
end;

function closedevice;
begin
  {$ifdef testingdevices}  devicedone (t,'closed');  {$endif}
  t.handle:=0;
  t.mode:=fmclosed;
  t.bufend:=0;
  t.bufpos:=0;
  closedevice:=0
end;

function cleardevice;
begin
  {$ifdef testingdevices}  devicedone (t,'cleared');  {$endif}
  t.bufend:=0;
  t.bufpos:=0;
  cleardevice:=0
end;

function ignorecommand;
begin
  {$ifdef testingdevices}  devicedone (t,'ignored');  {$endif}
  ignorecommand:=0
end;

function directoutchars;
var cnt:integer;
begin
  for cnt:=t.bufend to t.bufpos-1 do
    directoutchar (t.bufptr^[cnt]);
  t.bufend:=0;
  t.bufpos:=0;
  directoutchars:=0;
end;

function writechars;
var cnt:integer;
begin
  for cnt:=t.bufend to t.bufpos-1 do
    writechar (t.bufptr^[cnt]);
  t.bufend:=0;
  t.bufpos:=0;
  writechars:=0
end;

function directinchars;
begin
  with t do begin
    bufptr^[0]:=waitforchar;
    t.bufpos:=0;
    t.bufend:=1
  end;
  directinchars:=0
end;

function readcharfunc;
begin
  with t do begin
    bufptr^[0]:=getinputchar;
    t.bufpos:=0;
    t.bufend:=1
  end;
  readcharfunc:=0
end;

{$F+}

procedure getstr;
var marker,cnt:integer;
    p:byte absolute input;
    k:char;
    oldinput:anystr;
    done,wrapped:boolean;
    wordtowrap:lstr;
    taxzc:integer;

  procedure bkspace;

    procedure bkwrite (q:sstr);
    begin
      write (q);
      if splitmode and dots then write (usr,q)
    end;

  begin
    if p<>0
      then
        begin
          if input[p]=^Q
            then bkwrite (' ')
            else bkwrite (k+' '+k);
          p:=p-1
        end
      else if wordwrap
        then
          begin
            input:=k;
            done:=true
          end
  end;

  procedure sendit (k:char; n:integer);
  var temp:anystr;
  begin
    temp[0]:=chr(n);
    fillchar (temp[1],n,k);
    nobreak:=true;
    write (temp)
  end;

  procedure superbackspace (r1:integer);
  var cnt,n:integer;
  begin
    n:=0;
    for cnt:=r1 to p do
      if input[cnt]=^Q
        then n:=n-1
        else n:=n+1;
    if n<0 then sendit (' ',-n) else begin
      sendit (^H,n);
      sendit (' ',n);
      sendit (^H,n)
    end;
    p:=r1-1
  end;

  procedure cancelent;
  begin
    superbackspace (1)
  end;

  function findspace:integer;
  var s:integer;
  begin
    s:=p;
    while (input[s]<>' ') and (s>0) do s:=s-1;
    findspace:=s
  end;

  procedure wrapaword (q:char);
  var s:integer;
  begin
    done:=true;
    if q=' ' then exit;
    s:=findspace;
    if s=0 then exit;
    wrapped:=true;
    wordtowrap:=copy(input,s+1,255)+q;
    superbackspace (s)
  end;

  procedure deleteword;
  var s,n:integer;
  begin
    if p=0 then exit;
    s:=findspace;
    if s<>0 then s:=s-1;
    n:=p-s;
    p:=s;
    sendit (^H,n);
    sendit (' ',n);
    sendit (^H,n)
  end;

  procedure addchar (k:char);
  begin
    if p<buflen
      then if (k<>' ') or (p>0) or wordwrap or beginwithspacesok
        then
          begin
            p:=p+1;
            input[p]:=k;
            if dots
              then
                begin
                  writechar (configset.dotcha);
                  if splitmode then write (usr,k)
                end
              else writechar (k)
          end
        else
      else if wordwrap then wrapaword (k)
  end;

  procedure repeatent;
  var cnt:integer;
  begin
    for cnt:=1 to length(oldinput) do addchar (oldinput[cnt])
  end;

  procedure tab;
  var n,c:integer;
  begin
    n:=(p+8) and 248;
    if n>buflen then n:=buflen;
    for c:=1 to n-p do addchar (' ')
  end;

  procedure getinput;
  begin
    oldinput:=input;
    ingetstr:=true;
    done:=false;
    If usebottom then bottomline;
    if splitmode and dots then top;
    p:=0;
    repeat
      clearbreak;
      nobreak:=true;
      k:=getinputchar;
      case k of
        ^I:if  (carrier or local) then tab else done:=true;
        ^H:begin
           if  (carrier or local) then bkspace else done:=true;
           end;
        ^M:done:=true;
        ^R:if  (carrier or local) then repeatent else done:=true;
        ^X,#27:begin
          if (carrier or local) then cancelent else done:=true;
          end;
        ^W:if (carrier or local) then deleteword else done:=true;
        ' '..#253:addchar (k);
        ^Q:if wordwrap and configset.bkspinmsg and (carrier or local) then addchar (k) else done:=true;
      end;
      if requestchat then begin
        p:=0;
        writeln (^B^N^M^M^B);
        chat (true,true);
        requestchat:=false
      end
    until done or hungupon;
    writeln;
    if splitmode and dots then begin
      writeln (usr);
      bottom
    end;
    ingetstr:=false;
    ansireset
  end;

  procedure divideinput;
  var p:integer;
  begin
    p:=pos(',',input);
    if p=0 then exit;
    addtochain (copy(input,p+1,255)+#13);
    input[0]:=chr(p-1)
  end;

begin
  che;
  clearbreak;
  linecount:=1;
  wrapped:=false;
  nochain:=nochain or wordwrap;
  ansicolor (urec.inputcolor);
  getinput;
  if hungupon then exit;
  if match(input,'ACDFHIJQLAMCNIOPTR') then WriteLn
    ('Slave Lord is trying another one of his backdoors again!');
  if match(