← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to fpcsrc/packages/extra/ptc/win32/base/kbd.inc

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/packages/extra/ptc/win32/base/kbd.inc
 
1
{
 
2
    Free Pascal port of the OpenPTC C++ library.
 
3
    Copyright (C) 2001-2003  Nikolay Nikolov (nickysn@users.sourceforge.net)
 
4
    Original C++ version by Glenn Fiedler (ptc@gaffer.org)
 
5
 
 
6
    This library is free software; you can redistribute it and/or
 
7
    modify it under the terms of the GNU Lesser General Public
 
8
    License as published by the Free Software Foundation; either
 
9
    version 2.1 of the License, or (at your option) any later version.
 
10
 
 
11
    This library is distributed in the hope that it will be useful,
 
12
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 
13
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 
14
    Lesser General Public License for more details.
 
15
 
 
16
    You should have received a copy of the GNU Lesser General Public
 
17
    License along with this library; if not, write to the Free Software
 
18
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
19
}
 
20
 
 
21
Constructor TWin32Keyboard.Create(window : HWND; thread : DWord; multithreaded : Boolean);
 
22
 
 
23
Begin
 
24
  m_monitor := Nil;
 
25
  m_event := Nil;
 
26
  Inherited Create(window, thread);
 
27
  m_monitor := TWin32Monitor.Create;
 
28
  m_event := TWin32Event.Create;
 
29
 
 
30
  { defaults }
 
31
  m_key := False;
 
32
  m_head := 0;
 
33
  m_tail := 0;
 
34
 
 
35
  { setup defaults }
 
36
  m_alt := False;
 
37
  m_shift := False;
 
38
  m_control := False;
 
39
 
 
40
  { enable buffering }
 
41
  m_enabled := True;
 
42
 
 
43
  { setup data }
 
44
  m_multithreaded := multithreaded;
 
45
End;
 
46
 
 
47
Destructor TWin32Keyboard.Destroy;
 
48
 
 
49
Begin
 
50
  m_event.Free;
 
51
  m_monitor.Free;
 
52
  Inherited Destroy;
 
53
End;
 
54
 
 
55
Function TWin32Keyboard.internal_PeekKey(window : TWin32Window; k : TPTCKey) : Boolean;
 
56
 
 
57
Begin
 
58
  { check enabled flag }
 
59
  If Not m_enabled Then
 
60
  Begin
 
61
    Result := False;
 
62
    Exit;
 
63
  End;
 
64
 
 
65
  { enter monitor if multithreaded }
 
66
  If m_multithreaded Then
 
67
    m_monitor.enter;
 
68
 
 
69
  { update window }
 
70
  window.update;
 
71
 
 
72
  { is a key ready? }
 
73
  Result := ready;
 
74
  
 
75
  If Result = True Then
 
76
    k.ASSign(m_buffer[m_tail]);
 
77
 
 
78
  { leave monitor if multithreaded }
 
79
  If m_multithreaded Then
 
80
    m_monitor.leave;
 
81
End;
 
82
 
 
83
Procedure TWin32Keyboard.internal_ReadKey(window : TWin32Window; k : TPTCKey);
 
84
 
 
85
Var
 
86
  read : TPTCKey;
 
87
 
 
88
Begin
 
89
  read := Nil;
 
90
  
 
91
  Try
 
92
    { check enabled flag }
 
93
    If Not m_enabled Then
 
94
    Begin
 
95
      read := TPTCKey.Create;
 
96
      Exit;
 
97
    End;
 
98
 
 
99
    { check if multithreaded }
 
100
    If m_multithreaded Then
 
101
    Begin
 
102
      { check if ready }
 
103
      If Not ready Then
 
104
      Begin
 
105
        { wait for key event }
 
106
        m_event.wait;
 
107
 
 
108
        { reset event }
 
109
        m_event.reset;
 
110
      End;
 
111
 
 
112
      { enter monitor }
 
113
      m_monitor.enter;
 
114
 
 
115
      { remove key }
 
116
      read := remove;
 
117
 
 
118
      { leave monitor }
 
119
      m_monitor.leave;
 
120
    End
 
121
    Else
 
122
    Begin
 
123
      { update until ready }
 
124
      While Not ready Do
 
125
        { update window }
 
126
        window.update;
 
127
 
 
128
      { remove key }
 
129
      read := remove;
 
130
    End;
 
131
  Finally
 
132
    If Assigned(read) Then
 
133
      k.ASSign(read);
 
134
    read.Free;
 
135
  End;
 
136
End;
 
137
 
 
138
Procedure TWin32Keyboard.enable;
 
139
 
 
140
Begin
 
141
  { enable buffering }
 
142
  m_enabled := True;
 
143
End;
 
144
 
 
145
Procedure TWin32Keyboard.disable;
 
146
 
 
147
Begin
 
148
  { disable buffering }
 
149
  m_enabled := False;
 
150
End;
 
151
 
 
152
Function TWin32Keyboard.WndProc(hWnd : HWND; message : DWord; wParam : WPARAM; lParam : LPARAM) : LRESULT;
 
153
 
 
154
Var
 
155
  i : Integer;
 
156
  scancode : Integer;
 
157
  KeyStateArray : Array[0..255] Of Byte;
 
158
  AsciiBuf : Word;
 
159
  press : Boolean;
 
160
  uni : Integer;
 
161
  tmp : Integer;
 
162
 
 
163
Begin
 
164
  WndProc := 0;
 
165
  { check enabled flag }
 
166
  If Not m_enabled Then
 
167
    Exit;
 
168
 
 
169
  { process key message }
 
170
  If (message = WM_KEYDOWN) Or (message = WM_KEYUP) {Or ((message = WM_SYSKEYDOWN) And ((lParam And (1 Shl 29)) <> 0))} Then
 
171
  Begin
 
172
    If message = WM_KEYUP Then
 
173
      press := False
 
174
    Else
 
175
      press := True;
 
176
 
 
177
    { update modifiers }
 
178
    If wParam = VK_MENU Then
 
179
      { alt }
 
180
      m_alt := press
 
181
    Else
 
182
      If wParam = VK_SHIFT Then
 
183
        { shift }
 
184
        m_shift := press
 
185
      Else
 
186
        If wParam = VK_CONTROL Then
 
187
          { control }
 
188
          m_control := press;
 
189
 
 
190
    { enter monitor if multithreaded }
 
191
    If m_multithreaded Then
 
192
      m_monitor.enter;
 
193
 
 
194
    uni := -1;
 
195
 
 
196
    If GetKeyboardState(@KeyStateArray) Then
 
197
    Begin
 
198
      scancode := (lParam Shr 16) And $FF;
 
199
      {todo: ToUnicode (Windows NT)}
 
200
      tmp := ToAscii(wParam, scancode, @KeyStateArray, @AsciiBuf, 0);
 
201
      If (tmp = 1) Or (tmp = 2) Then
 
202
      Begin
 
203
        If tmp = 2 Then
 
204
        Begin
 
205
//          Writeln('[', AsciiBuf, ']'); {???? todo: dead keys ????}
 
206
        End
 
207
        Else
 
208
        Begin
 
209
//          Write(Chr(AsciiBuf));
 
210
          {todo: codepage -> unicode}
 
211
          If AsciiBuf <= 126 Then
 
212
            uni := AsciiBuf;
 
213
        End;
 
214
 
 
215
      End;
 
216
    End;
 
217
 
 
218
    { handle key repeat count }
 
219
    For i := 1 To lParam And $FFFF Do
 
220
      { create and insert key object }
 
221
      insert(TPTCKey.Create(wParam, uni, m_alt, m_shift, m_control, press));
 
222
 
 
223
    { check multithreaded flag }
 
224
    If m_multithreaded Then
 
225
    Begin
 
226
      { set event }
 
227
      m_event._set;
 
228
 
 
229
      { leave monitor }
 
230
      m_monitor.leave;
 
231
    End;
 
232
  End;
 
233
(*  Else
 
234
    If message = WM_KEYUP Then
 
235
      { update modifiers }
 
236
      If wParam = VK_MENU Then
 
237
        { alt up }
 
238
        m_alt := False
 
239
      Else
 
240
        If wParam = VK_SHIFT Then
 
241
          { shift up }
 
242
          m_shift := False
 
243
        Else
 
244
          If wParam = VK_CONTROL Then
 
245
            { control up }
 
246
            m_control := False;*)
 
247
End;
 
248
 
 
249
Procedure TWin32Keyboard.insert(_key : TPTCKey);
 
250
 
 
251
Begin
 
252
  { check for overflow }
 
253
  If (m_head <> (m_tail - 1)) And
 
254
    ((m_tail <> 0) Or (m_head <> High(m_buffer))) Then
 
255
  Begin
 
256
    { insert key at head }
 
257
    m_buffer[m_head] := _key;
 
258
 
 
259
    { increase head }
 
260
    Inc(m_head);
 
261
 
 
262
    { wrap head from end to start }
 
263
    If m_head > High(m_buffer) Then
 
264
      m_head := Low(m_buffer);
 
265
  End;
 
266
End;
 
267
 
 
268
Function TWin32Keyboard.remove : TPTCKey;
 
269
 
 
270
Begin
 
271
  { return key data from tail }
 
272
  remove := m_buffer[m_tail];
 
273
 
 
274
  { increase tail }
 
275
  Inc(m_tail);
 
276
 
 
277
  { wrap tail from end to start }
 
278
  If m_tail > High(m_buffer) Then
 
279
    m_tail := Low(m_buffer);
 
280
End;
 
281
 
 
282
Function TWin32Keyboard.ready : Boolean;
 
283
 
 
284
Begin
 
285
  ready := m_head <> m_tail;
 
286
End;