+ initial implementation of a win16 keyboard unit

git-svn-id: trunk@31866 -

.gitattributes

@@ -6808,6 +6808,7 @@ packages/rtl-console/src/win/mouse.pp svneol=native#text/plain
 packages/rtl-console/src/win/video.pp svneol=native#text/plain
 packages/rtl-console/src/win/winevent.pp svneol=native#text/plain
 packages/rtl-console/src/win16/crt.pp svneol=native#text/plain
+packages/rtl-console/src/win16/keyboard.pp svneol=native#text/plain
 packages/rtl-console/src/win16/video.pp svneol=native#text/plain
 packages/rtl-extra/Makefile svneol=native#text/plain
 packages/rtl-extra/Makefile.fpc svneol=native#text/plain

packages/rtl-console/fpmake.pp

@@ -17,7 +17,7 @@ Const
   
   // all full KVMers have crt too, except Amigalikes
   CrtOSes      = KVMALL+[msdos,WatCom,win16]-[aros,morphos];
-  KbdOSes      = KVMALL+[msdos];
+  KbdOSes      = KVMALL+[msdos,win16];
   VideoOSes    = KVMALL+[win16];
   MouseOSes    = KVMALL;
   TerminfoOSes = UnixLikes-[beos,haiku];
@@ -73,6 +73,7 @@ begin
         AddInclude('keyscan.inc',AllUnixOSes);
         AddUnit   ('winevent',[win32,win64]);
         AddInclude('nwsys.inc',[netware]);
+        AddUnit   ('video',[win16]);
       end;
 
     T:=P.Targets.AddUnit('mouse.pp',MouseOSes);

packages/rtl-console/src/win16/keyboard.pp

@@ -0,0 +1,168 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2015 by Nikolay Nikolov
+    member of the Free Pascal development team
+
+    Keyboard unit for Win16
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit Keyboard;
+interface
+
+{$i keybrdh.inc}
+
+implementation
+
+uses
+  WinProcs, WinTypes, video;
+
+{$i keyboard.inc}
+
+
+var
+  KbdBuf: array [0..15] of TKeyEvent;
+  KbdBufHead, KbdBufTail: SmallInt;
+  KbdShiftState: Byte;
+  KbdState: TKeyboardState;
+
+
+function KbdBufEmpty: Boolean; inline;
+begin
+  KbdBufEmpty:=KbdBufHead=KbdBufTail;
+end;
+
+
+procedure KbdBufEnqueue(k: TKeyEvent);
+var
+  nk: SmallInt;
+begin
+  nk:=(KbdBufHead+1) and 15;
+  if nk<>KbdBufTail then
+  begin
+    KbdBuf[KbdBufHead]:=k;
+    KbdBufHead:=nk;
+  end;
+end;
+
+
+function KbdBufDequeue: TKeyEvent;
+begin
+  KbdBufDequeue:=KbdBuf[KbdBufTail];
+  KbdBufTail:=(KbdBufTail+1) and 15;
+end;
+
+
+function KeyWndProc(hwnd: HWND; msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
+var
+  k: TKeyEvent;
+  charbuf: array [0..3] of Byte;
+  charcount, i: SmallInt;
+begin
+  case msg of
+    WM_KEYDOWN,
+    WM_SYSKEYDOWN:
+      begin
+        case wParam of
+          VK_SHIFT:
+            if Byte(lParam shr 16)=$36 then
+              KbdShiftState:=KbdShiftState or %0001
+            else
+              KbdShiftState:=KbdShiftState or %0010;
+          VK_CONTROL:
+            KbdShiftState:=KbdShiftState or %0100;
+          VK_MENU:
+            KbdShiftState:=KbdShiftState or %1000;
+        end;
+        GetKeyboardState(@KbdState);
+        charcount:=ToAscii(wParam,Byte(lParam shr 16),@KbdState,@charbuf,0);
+        if charcount>0 then
+          for i:=0 to charcount-1 do
+            KbdBufEnqueue((kbPhys shl 24) or charbuf[i] or (KbdShiftState shl 16));
+      end;
+    WM_KEYUP,
+    WM_SYSKEYUP:
+      begin
+        case wParam of
+          VK_SHIFT:
+            if Byte(lParam shr 16)=$36 then
+              KbdShiftState:=KbdShiftState and %11111110
+            else
+              KbdShiftState:=KbdShiftState and %11111101;
+          VK_CONTROL:
+            KbdShiftState:=KbdShiftState and %11111011;
+          VK_MENU:
+            KbdShiftState:=KbdShiftState and %11110111;
+        end;
+      end;
+  end;
+  KeyWndProc:=DefWindowProc(hwnd,msg,wParam,lParam);
+end;
+
+
+procedure SysInitKeyboard;
+begin
+  video.KeyEventWndProc:=@KeyWndProc;
+  KbdBufHead:=0;
+  KbdBufTail:=0;
+end;
+
+
+function SysGetKeyEvent: TKeyEvent;
+var
+  m: MSG;
+begin
+  while KbdBufEmpty and GetMessage(@m,0,0,0) do
+  begin
+    TranslateMessage(@m);
+    DispatchMessage(@m);
+  end;
+  if KbdBufEmpty then
+    SysGetKeyEvent:=0
+  else
+    SysGetKeyEvent:=KbdBufDequeue;
+end;
+
+
+function SysPollKeyEvent: TKeyEvent;
+var
+  m: MSG;
+begin
+  while PeekMessage(@m,0,0,0,1) do
+  begin
+    TranslateMessage(@m);
+    DispatchMessage(@m);
+  end;
+  if KbdBufEmpty then
+    SysPollKeyEvent:=0
+  else
+    SysPollKeyEvent:=KbdBufDequeue;
+end;
+
+
+function SysGetShiftState: Byte;
+begin
+  SysGetShiftState:=KbdShiftState;
+end;
+
+
+Const
+  SysKeyboardDriver : TKeyboardDriver = (
+    InitDriver : @SysInitKeyboard;
+    DoneDriver : Nil;
+    GetKeyevent : @SysGetKeyEvent;
+    PollKeyEvent : @SysPollKeyEvent;
+    GetShiftState : @SysGetShiftState;
+    TranslateKeyEvent : Nil;
+    TranslateKeyEventUnicode : Nil;
+  );
+
+begin
+  SetKeyBoardDriver(SysKeyBoardDriver);
+end.

packages/rtl-console/src/win16/video.pp

@@ -17,12 +17,18 @@ unit video;
 
 interface
 
+uses
+  WinTypes;
+
 {$I videoh.inc}
 
+var
+  KeyEventWndProc: WNDPROC;
+
 implementation
 
 uses
-  WinTypes, WinProcs;
+  WinProcs;
 
 {$I video.inc}
 
@@ -81,6 +87,11 @@ end;
 function MainWndProc(hwnd: HWND; msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; export;
 begin
   case msg of
+    WM_KEYDOWN,
+    WM_KEYUP,
+    WM_SYSKEYDOWN,
+    WM_SYSKEYUP:
+      MainWndProc:=KeyEventWndProc(hwnd,msg,wParam,lParam);
     WM_PAINT:
       WindowPaint(hwnd);
     WM_DESTROY:
@@ -234,5 +245,6 @@ const
   );
 
 begin
+  KeyEventWndProc:=@DefWindowProc;
   SetVideoDriver(SysVideoDriver);
 end.