freepascal.compiler/packages/extra/ptc/win32/base/kbd.inc

{
    Free Pascal port of the OpenPTC C++ library.
    Copyright (C) 2001-2003  Nikolay Nikolov ([email protected])
    Original C++ version by Glenn Fiedler ([email protected])

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License as published by the Free Software Foundation; either
    version 2.1 of the License, or (at your option) any later version.

    This library 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.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
}

Constructor TWin32Keyboard.Create(window : HWND; thread : DWord; multithreaded : Boolean; EventQueue : TEventQueue);

Begin
  m_monitor := Nil;
  m_event := Nil;
  Inherited Create(window, thread);
  m_monitor := TWin32Monitor.Create;
  m_event := TWin32Event.Create;

  { setup defaults }
  m_alt := False;
  m_shift := False;
  m_control := False;

  { setup data }
  FEventQueue := EventQueue;
  m_multithreaded := multithreaded;

  { enable buffering }
  m_enabled := True;
End;

Destructor TWin32Keyboard.Destroy;

Begin
  m_event.Free;
  m_monitor.Free;
  Inherited Destroy;
End;

(*Function TWin32Keyboard.internal_PeekKey(window : TWin32Window; k : TPTCKeyEvent) : Boolean;

Begin
  { check enabled flag }
  If Not m_enabled Then
  Begin
    Result := False;
    Exit;
  End;

  { enter monitor if multithreaded }
  If m_multithreaded Then
    m_monitor.enter;

  { update window }
  window.update;

  { is a key ready? }
  Result := ready;

  If Result = True Then
    k.Assign(m_buffer[m_tail]);

  { leave monitor if multithreaded }
  If m_multithreaded Then
    m_monitor.leave;
End;

Procedure TWin32Keyboard.internal_ReadKey(window : TWin32Window; k : TPTCKeyEvent);

Var
  read : TPTCKeyEvent;

Begin
  read := Nil;

  Try
    { check enabled flag }
    If Not m_enabled Then
    Begin
      read := TPTCKeyEvent.Create;
      Exit;
    End;

    { check if multithreaded }
    If m_multithreaded Then
    Begin
      { check if ready }
      If Not ready Then
      Begin
        { wait for key event }
        m_event.wait;

        { reset event }
        m_event.reset;
      End;

      { enter monitor }
      m_monitor.enter;

      { remove key }
      read := remove;

      { leave monitor }
      m_monitor.leave;
    End
    Else
    Begin
      { update until ready }
      While Not ready Do
        { update window }
        window.update;

      { remove key }
      read := remove;
    End;
  Finally
    If Assigned(read) Then
      k.Assign(read);
    read.Free;
  End;
End;*)

Procedure TWin32Keyboard.enable;

Begin
  { enable buffering }
  m_enabled := True;
End;

Procedure TWin32Keyboard.disable;

Begin
  { disable buffering }
  m_enabled := False;
End;

Function TWin32Keyboard.WndProc(hWnd : HWND; message : DWord; wParam : WPARAM; lParam : LPARAM) : LRESULT;

Var
  i : Integer;
  scancode : Integer;
  KeyStateArray : Array[0..255] Of Byte;
  AsciiBuf : Word;
  press : Boolean;
  uni : Integer;
  tmp : Integer;

Begin
  WndProc := 0;
  { check enabled flag }
  If Not m_enabled Then
    Exit;

  { process key message }
  If (message = WM_KEYDOWN) Or (message = WM_KEYUP) {Or ((message = WM_SYSKEYDOWN) And ((lParam And (1 Shl 29)) <> 0))} Then
  Begin
    If message = WM_KEYUP Then
      press := False
    Else
      press := True;

    { update modifiers }
    If wParam = VK_MENU Then
      { alt }
      m_alt := press
    Else
      If wParam = VK_SHIFT Then
        { shift }
        m_shift := press
      Else
        If wParam = VK_CONTROL Then
          { control }
          m_control := press;

    { enter monitor if multithreaded }
    If m_multithreaded Then
      m_monitor.enter;

    uni := -1;

    If GetKeyboardState(@KeyStateArray) Then
    Begin
      scancode := (lParam Shr 16) And $FF;
      {todo: ToUnicode (Windows NT)}
      tmp := ToAscii(wParam, scancode, @KeyStateArray, @AsciiBuf, 0);
      If (tmp = 1) Or (tmp = 2) Then
      Begin
        If tmp = 2 Then
        Begin
//          Writeln('[', AsciiBuf, ']'); {???? todo: dead keys ????}
        End
        Else
        Begin
//          Write(Chr(AsciiBuf));
          {todo: codepage -> unicode}
          If AsciiBuf <= 126 Then
            uni := AsciiBuf;
        End;

      End;
    End;

    { handle key repeat count }
    For i := 1 To lParam And $FFFF Do
      { create and insert key object }
      FEventQueue.AddEvent(TPTCKeyEvent.Create(wParam, uni, m_alt, m_shift, m_control, press));

    { check multithreaded flag }
    If m_multithreaded Then
    Begin
      { set event }
      m_event._set;

      { leave monitor }
      m_monitor.leave;
    End;
  End;
(*  Else
    If message = WM_KEYUP Then
      { update modifiers }
      If wParam = VK_MENU Then
        { alt up }
        m_alt := False
      Else
        If wParam = VK_SHIFT Then
          { shift up }
          m_shift := False
        Else
          If wParam = VK_CONTROL Then
            { control up }
            m_control := False;*)
End;

(*Procedure TWin32Keyboard.insert(_key : TPTCKeyEvent);

Begin
  { check for overflow }
  If (m_head <> (m_tail - 1)) And
    ((m_tail <> 0) Or (m_head <> High(m_buffer))) Then
  Begin
    { insert key at head }
    m_buffer[m_head] := _key;

    { increase head }
    Inc(m_head);

    { wrap head from end to start }
    If m_head > High(m_buffer) Then
      m_head := Low(m_buffer);
  End;
End;

Function TWin32Keyboard.remove : TPTCKeyEvent;

Begin
  { return key data from tail }
  remove := m_buffer[m_tail];

  { increase tail }
  Inc(m_tail);

  { wrap tail from end to start }
  If m_tail > High(m_buffer) Then
    m_tail := Low(m_buffer);
End;

Function TWin32Keyboard.ready : Boolean;

Begin
  ready := m_head <> m_tail;
End;
*)