{----------------------------SNiPy, SNiPy-----------------------------------}


{
I don't remember where I got this unit. If anyone
is upset with me because I distribute it, just let me know.
Willem van de Vis, s0730076@let.rug.nl
}

unit pushkey;


interface

uses dos;

Procedure PushKbdBuffer;
Procedure PushKeys(Keys:String);

var kbd         : Text;
    PushKeyBusy : Boolean;

implementation

var Vector     : Array [0..$FF] of pointer absolute 0:0;
    SaveInt16  : Pointer;
    SaveInt1B  : Pointer;
    SaveBufPtr : Pointer;
    SaveBufPos : Word;
    KeyPopped  : Boolean;
 DirectPush : Boolean;
    DirectBuf  : String;
    PopPtr     : Word;

Procedure CLI; InLine($FA);
Procedure STI; InLine($FB);

{$F+}

Function KbdFlush(var F:TextRec):Integer;

begin
  with F do
    begin
      if BufPtr^[BufPos-1] = ^J then Dec(BufPos);
   if BufPos >= BufSize then
        begin
    Writeln('KbdBuffer overflow');
    Halt;
  end;
 end;
  KbdFlush:=0;
end;


Function Ignore(var F:TextRec):Integer;

begin
  Ignore:=0;
end;


Function KbdOpen(var F:TextRec):Integer;
begin
  with F do
 begin
   Mode:=fmOutput;
   FlushFunc:=@KbdFlush;
   InOutFunc:=@Ignore;
   CloseFunc:=@Ignore;
   BufPos:=0;
 end;
  KbdOpen:=0;
end;


Procedure UnHook;

begin
  with TextRec(kbd) do
 begin
   PushKeyBusy:=False;
   Vector[$16]:=SaveInt16;
   Vector[$1B]:=SaveInt1B;
   BufPos:=0;
   if DirectPush then
  begin
    BufPtr:=SaveBufPtr;
    BufPos:=SaveBufPos;
    DirectPush:=False;
  end;
 end;
end;


procedure BreakHandler(Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,BP: Word);
interrupt;
begin
  UnHook;
end;


Procedure BiosKbdFunctions(Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,BP: Word);
interrupt;

begin
  with TextRec(kbd) do
 begin
   case Hi(AX) of
  0, $10 : begin                        { read character function }
       Inc(PopPtr);
       KeyPopped:=True;
       AX:=Ord(BufPtr^[PopPtr-1]);
       case Lo(AX) of
      0   : if PopPtr < BufPos then
        begin
          AX:=Ord(BufPtr^[PopPtr]) shl 8;
          Inc(PopPtr);
        end;
      $0D : AX:=$1C0D;
       end;
     end;
  1, $11 : begin                            { keypressed function }
       AX:=Ord(BufPtr^[PopPtr]);
       case Lo(AX) of
      $00 : AX:=Ord(BufPtr^[PopPtr+1]) shl 8;
      $0D : AX:=$1C0D;
       end;
       if KeyPopped then Flags:=Flags or FZero
                                else Flags:=Flags and (not FZero);
                   KeyPopped:=False;
                 end;
        2, $12 : begin                          { get shiftflags function }
                   AX:=Mem[$40:$17];
                 end;
      end;
      if PopPtr >= BufPos then UnHook;
    end;
end;


Procedure PushKbdBuffer;

begin
  with TextRec(kbd) do
    if (BufPos > 0) and (not PushKeyBusy) then
      begin
        CLI;
        PopPtr:=0;
        KeyPopped:=False;
        SaveInt16:=Vector[$16];
        Vector[$16]:=@BiosKbdFunctions;
        SaveInt1B:=Vector[$1B];
        Vector[$1B]:=@BreakHandler;
        PushKeyBusy:=True;
        STI;
      end;
end;


Procedure PushKeys(Keys:String);

begin
  if (not PushKeyBusy) and (Keys <> '') then
    with TextRec(kbd) do
      begin
        DirectPush:=True;
        SaveBufPos:=BufPos;
        SaveBufPtr:=BufPtr;
        BufPos:=Length(Keys);
  BufPtr:=addr(DirectBuf[1]);
  DirectBuf:=Keys;
  PushKbdBuffer;
   end;
end;


begin
  with TextRec(kbd) do
    begin
      PushKeyBusy:=False;
      DirectPush:=False;
      Handle:=$FFFF;
      Mode:=fmClosed;
      BufSize:=SizeOf(Buffer);
      BufPtr:=@Buffer;
      OpenFunc:=@KbdOpen;
      Name[0]:=#0;
      ReWrite(kbd);
    end;
end.