← Back to branch summary

~ubuntu-branches/ubuntu/feisty/fpc/feisty

« back to all changes in this revision

Viewing changes to packages/base/graph/win32/wincrt.pp

  • Committer: Bazaar Package Importer
  • Author(s): Torsten Werner
  • Date: 2007-01-27 20:08:50 UTC
  • mfrom: (1.2.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20070127200850-9mrptaqqjsx9nwa7
Tags: 2.0.4-5
* Fixed Build-Depends.
* Add myself to Uploaders in debian/control.
* Make sure that the sources are really patched before building them.
* Build unit 'libc' on powerpc too.

Show diffs side-by-side

added added

removed removed

Lines of Context:
packages/base/graph/win32/wincrt.pp
 
1
{
 
2
    This file is part of the Free Pascal run time library.
 
3
    Copyright (c) 1999-2000 by Florian Klaempfl
 
4
    member of the Free Pascal development team
 
5
 
 
6
    This is unit implements some of the crt functionality
 
7
    for the gui win32 graph unit implementation
 
8
 
 
9
    See the file COPYING.FPC, included in this distribution,
 
10
    for details about the copyright.
 
11
 
 
12
    This program is distributed in the hope that it will be useful,
 
13
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 
14
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
15
 
 
16
 **********************************************************************}
 
17
unit wincrt;
 
18
 
 
19
  interface
 
20
 
 
21
    function readkey : char;
 
22
    function keypressed : boolean;
 
23
    procedure delay(ms : word);
 
24
 
 
25
    { dummy }
 
26
    procedure textmode(mode : integer);
 
27
 
 
28
    { plays the windows standard sound }
 
29
    { hz is ignored (at least on win95 }
 
30
    procedure sound(hz : word);
 
31
 
 
32
    { dummy }
 
33
    procedure nosound;
 
34
 
 
35
 
 
36
  var
 
37
     directvideo : boolean;
 
38
 
 
39
     { dummy }
 
40
     lastmode : word;
 
41
 
 
42
  implementation
 
43
 
 
44
    uses
 
45
       windows,graph;
 
46
 
 
47
    const
 
48
       keybuffersize = 32;
 
49
 
 
50
    var
 
51
       keyboardhandling : TCriticalSection;
 
52
       keybuffer : array[1..keybuffersize] of char;
 
53
       nextfree,nexttoread : longint;
 
54
 
 
55
    procedure inccyclic(var i : longint);
 
56
 
 
57
      begin
 
58
         inc(i);
 
59
         if i>keybuffersize then
 
60
           i:=1;
 
61
      end;
 
62
 
 
63
    procedure addchar(c : char);
 
64
 
 
65
      begin
 
66
         EnterCriticalSection(keyboardhandling);
 
67
         keybuffer[nextfree]:=c;
 
68
         inccyclic(nextfree);
 
69
         { skip old chars }
 
70
         if nexttoread=nextfree then
 
71
           begin
 
72
              // special keys are started by #0
 
73
              // so we've to remove two chars
 
74
              if keybuffer[nexttoread]=#0 then
 
75
                inccyclic(nexttoread);
 
76
              inccyclic(nexttoread);
 
77
           end;
 
78
         LeaveCriticalSection(keyboardhandling);
 
79
      end;
 
80
 
 
81
    function readkey : char;
 
82
 
 
83
      begin
 
84
         while true do
 
85
           begin
 
86
              EnterCriticalSection(keyboardhandling);
 
87
              if nexttoread<>nextfree then
 
88
                begin
 
89
                   readkey:=keybuffer[nexttoread];
 
90
                   inccyclic(nexttoread);
 
91
                   LeaveCriticalSection(keyboardhandling);
 
92
                   exit;
 
93
                end;
 
94
              LeaveCriticalSection(keyboardhandling);
 
95
              { give other threads a chance }
 
96
              Windows.Sleep(10);
 
97
           end;
 
98
      end;
 
99
 
 
100
    function keypressed : boolean;
 
101
 
 
102
      begin
 
103
         EnterCriticalSection(keyboardhandling);
 
104
         keypressed:=nexttoread<>nextfree;
 
105
         LeaveCriticalSection(keyboardhandling);
 
106
      end;
 
107
 
 
108
    procedure delay(ms : word);
 
109
 
 
110
      begin
 
111
         Sleep(ms);
 
112
      end;
 
113
 
 
114
    procedure textmode(mode : integer);
 
115
 
 
116
      begin
 
117
      end;
 
118
 
 
119
    procedure sound(hz : word);
 
120
 
 
121
      begin
 
122
         Windows.Beep(hz,500);
 
123
      end;
 
124
 
 
125
    procedure nosound;
 
126
 
 
127
      begin
 
128
      end;
 
129
 
 
130
    procedure addextchar(c : char);
 
131
 
 
132
      begin
 
133
         addchar(#0);
 
134
         addchar(c);
 
135
      end;
 
136
 
 
137
    const
 
138
       altkey : boolean = false;
 
139
       ctrlkey : boolean = false;
 
140
       shiftkey : boolean = false;
 
141
 
 
142
    function msghandler(Window: HWnd; AMessage:UInt; WParam : WParam; LParam: LParam): Longint; stdcall;
 
143
 
 
144
      begin
 
145
         case amessage of
 
146
           WM_CHAR:
 
147
             begin
 
148
                addchar(chr(wparam));
 
149
             end;
 
150
           WM_KEYDOWN:
 
151
             begin
 
152
                case wparam of
 
153
                   VK_LEFT:
 
154
                     addextchar(#75);
 
155
                   VK_RIGHT:
 
156
                     addextchar(#77);
 
157
                   VK_DOWN:
 
158
                     addextchar(#80);
 
159
                   VK_UP:
 
160
                     addextchar(#72);
 
161
                   VK_INSERT:
 
162
                     addextchar(#82);
 
163
                   VK_DELETE:
 
164
                     addextchar(#83);
 
165
                   VK_END:
 
166
                     addextchar(#79);
 
167
                   VK_HOME:
 
168
                     addextchar(#71);
 
169
                   VK_PRIOR:
 
170
                     addextchar(#73);
 
171
                   VK_NEXT:
 
172
                     addextchar(#81);
 
173
                   VK_F1..VK_F10:
 
174
                     begin
 
175
                        if ctrlkey then
 
176
                          addextchar(chr(wparam+24))
 
177
                        else if altkey then
 
178
                          addextchar(chr(wparam+34))
 
179
                        else
 
180
                          addextchar(chr(wparam-11));
 
181
                     end;
 
182
                   VK_CONTROL:
 
183
                     ctrlkey:=true;
 
184
                   VK_MENU:
 
185
                     altkey:=true;
 
186
                   VK_SHIFT:
 
187
                     shiftkey:=true;
 
188
                end;
 
189
             end;
 
190
           WM_KEYUP:
 
191
             begin
 
192
                case wparam of
 
193
                   VK_CONTROL:
 
194
                     ctrlkey:=false;
 
195
                   VK_MENU:
 
196
                     altkey:=false;
 
197
                   VK_SHIFT:
 
198
                     shiftkey:=false;
 
199
                end;
 
200
             end;
 
201
         end;
 
202
         msghandler:=0;
 
203
      end;
 
204
 
 
205
    var
 
206
       oldexitproc : pointer;
 
207
 
 
208
    procedure myexitproc;
 
209
 
 
210
      begin
 
211
         exitproc:=oldexitproc;
 
212
         charmessagehandler:=nil;
 
213
         DeleteCriticalSection(keyboardhandling);
 
214
      end;
 
215
 
 
216
begin
 
217
   charmessagehandler:=@msghandler;
 
218
   nextfree:=1;
 
219
   nexttoread:=1;
 
220
   InitializeCriticalSection(keyboardhandling);
 
221
   oldexitproc:=exitproc;
 
222
   exitproc:=@myexitproc;
 
223
   lastmode:=0;
 
224
end.