| blob | 48af20ff3133241232dfe2985b46a4de29e8f1b8 |
1 {*
2 * Copyright (C) 2024 Mikulas Patocka
3 *
4 * This file is part of Ajla.
5 *
6 * Ajla is free software: you can redistribute it and/or modify it under the
7 * terms of the GNU General Public License as published by the Free Software
8 * Foundation, either version 3 of the License, or (at your option) any later
9 * version.
10 *
11 * Ajla is distributed in the hope that it will be useful, but WITHOUT ANY
12 * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
13 * A PARTICULAR PURPOSE. See the GNU General Public License for more details.
14 *
15 * You should have received a copy of the GNU General Public License along with
16 * Ajla. If not, see <https://www.gnu.org/licenses/>.
17 *}
19 unit ui.event;
21 uses io;
22 uses msgqueue;
23 uses treemap;
24 uses charset;
25 uses ui.termcap;
27 const ev_tag_key : int := 1;
28 const ev_tag_mouse_move : int := 2;
29 const ev_tag_mouse_button : int := 3;
30 const ev_tag_redraw : int := 4;
31 const ev_tag_resize : int := 5;
33 record event_keyboard [
34 key : char;
35 flags : int;
36 rep : int;
37 ]
39 record event_resize [
40 x y : int;
41 ]
43 record event_redraw [
44 x1 y1 x2 y2 : int;
45 ]
47 record event_mouse [
48 x y prev_buttons buttons double_buttons wx wy : int;
49 soft_cursor : bool;
50 ]
52 option event [
53 keyboard : event_keyboard;
54 resize : event_resize;
55 redraw : event_redraw;
56 mouse : event_mouse;
57 altmq;
58 ]
60 // the f* keys must be contiguous
61 const key_f1 : char := -1;
62 const key_f2 : char := -2;
63 const key_f3 : char := -3;
64 const key_f4 : char := -4;
65 const key_f5 : char := -5;
66 const key_f6 : char := -6;
67 const key_f7 : char := -7;
68 const key_f8 : char := -8;
69 const key_f9 : char := -9;
70 const key_f10 : char := -10;
71 const key_f11 : char := -11;
72 const key_f12 : char := -12;
73 const key_left : char := -13;
74 const key_right : char := -14;
75 const key_up : char := -15;
76 const key_down : char := -16;
77 const key_insert : char := -17;
78 const key_delete : char := -18;
79 const key_home : char := -19;
80 const key_end : char := -20;
81 const key_page_up : char := -21;
82 const key_page_down : char := -22;
83 const key_backspace : char := -23;
84 const key_enter : char := -24;
85 const key_num_5 : char := -25;
86 const key_tab : char := -26;
87 const key_esc : char := -27;
89 const key_flag_shift : int := 1;
90 const key_flag_ctrl : int := 2;
91 const key_flag_alt : int := 4;
93 const key_to_termcap : list(int) := [
94 0,
95 tc_s_key_f1,
96 tc_s_key_f2,
97 tc_s_key_f3,
98 tc_s_key_f4,
99 tc_s_key_f5,
100 tc_s_key_f6,
101 tc_s_key_f7,
102 tc_s_key_f8,
103 tc_s_key_f9,
104 tc_s_key_f10,
105 tc_s_key_f11,
106 tc_s_key_f12,
107 tc_s_key_left,
108 tc_s_key_right,
109 tc_s_key_up,
110 tc_s_key_down,
111 tc_s_key_ic,
112 tc_s_key_dc,
113 tc_s_key_home,
114 tc_s_key_end,
115 tc_s_key_ppage,
116 tc_s_key_npage,
117 tc_s_key_backspace,
118 tc_s_key_enter,
119 tc_s_key_b2,
120 ];
122 fn event_get_keyboard~spark(w : world, h : handle, tc : termcap, loc : locale, q : msgqueue(event)) : bottom_type;
123 fn event_get_resize~spark(w : world, h : handle, q : msgqueue(event)) : bottom_type;
124 fn event_get_mouse~spark(w : world, h : handle, q : msgqueue(event)) : bottom_type;
125 fn event_wait_for_any_key(w : world, h : handle) : world;
126 fn event_reset_handle(w : world, h : handle) : world;
128 implementation
130 uses socket;
131 uses pcode;
132 uses exception;
134 const terminal_read_timeout : int64 := 100000;
136 fn os2_vkmap : list(char)
137 [
138 var a := fill(char, 0, #100);
139 a[1] := key_esc;
140 a[14] := key_backspace;
141 a[15] := key_tab;
142 a[28] := key_enter;
143 a[59] := key_f1;
144 a[60] := key_f2;
145 a[61] := key_f3;
146 a[62] := key_f4;
147 a[63] := key_f5;
148 a[64] := key_f6;
149 a[65] := key_f7;
150 a[66] := key_f8;
151 a[67] := key_f9;
152 a[68] := key_f10;
153 a[71] := key_home;
154 a[72] := key_up;
155 a[73] := key_page_up;
156 a[75] := key_left;
157 a[76] := key_num_5;
158 a[77] := key_right;
159 a[79] := key_end;
160 a[80] := key_down;
161 a[81] := key_page_down;
162 a[82] := key_insert;
163 a[83] := key_delete;
164 a[84] := key_f1;
165 a[85] := key_f2;
166 a[86] := key_f3;
167 a[87] := key_f4;
168 a[88] := key_f5;
169 a[89] := key_f6;
170 a[90] := key_f7;
171 a[91] := key_f8;
172 a[92] := key_f9;
173 a[93] := key_f10;
174 a[94] := key_f1;
175 a[95] := key_f2;
176 a[96] := key_f3;
177 a[97] := key_f4;
178 a[98] := key_f5;
179 a[99] := key_f6;
180 a[100] := key_f7;
181 a[101] := key_f8;
182 a[102] := key_f9;
183 a[103] := key_f10;
184 a[104] := key_f1;
185 a[105] := key_f2;
186 a[106] := key_f3;
187 a[107] := key_f4;
188 a[108] := key_f5;
189 a[109] := key_f6;
190 a[110] := key_f7;
191 a[111] := key_f8;
192 a[112] := key_f9;
193 a[113] := key_f10;
194 a[115] := key_left;
195 a[116] := key_right;
196 a[117] := key_end;
197 a[118] := key_page_down;
198 a[119] := key_home;
199 a[132] := key_page_up;
200 a[133] := key_f11;
201 a[134] := key_f12;
202 a[135] := key_f11;
203 a[136] := key_f12;
204 a[137] := key_f11;
205 a[138] := key_f12;
206 a[139] := key_f11;
207 a[140] := key_f12;
208 a[141] := key_up;
209 a[143] := key_num_5;
210 a[145] := key_down;
211 a[146] := key_insert;
212 a[147] := key_delete;
213 a[151] := key_home;
214 a[152] := key_up;
215 a[153] := key_page_up;
216 a[155] := key_left;
217 a[157] := key_right;
218 a[159] := key_end;
219 a[160] := key_down;
220 a[161] := key_page_down;
221 a[162] := key_insert;
222 a[163] := key_delete;
223 return a;
224 ]
226 fn os2_ctrlmap(p : list(int32)) : int
227 [
228 var result := 0;
229 var p3 := p[3];
230 if p3 bt 0 or p3 bt 1 then
231 result or= key_flag_shift;
232 if p3 bt 2 then
233 result or= key_flag_ctrl;
234 if p3 bt 3 then
235 result or= key_flag_alt;
236 return result;
237 ]
239 fn dos_vkmap : list(char)
240 [
241 var a := os2_vkmap;
242 a[2] := ' ';
243 a[16] := 'Q';
244 a[17] := 'W';
245 a[18] := 'E';
246 a[19] := 'R';
247 a[20] := 'T';
248 a[21] := 'Y';
249 a[22] := 'U';
250 a[23] := 'I';
251 a[24] := 'O';
252 a[25] := 'P';
253 a[26] := '[';
254 a[27] := ']';
255 a[30] := 'A';
256 a[31] := 'S';
257 a[32] := 'D';
258 a[33] := 'F';
259 a[34] := 'G';
260 a[35] := 'H';
261 a[36] := 'J';
262 a[37] := 'K';
263 a[38] := 'L';
264 a[39] := ';';
265 a[40] := '''';
266 a[41] := '`';
267 a[43] := '\';
268 a[44] := 'Z';
269 a[45] := 'X';
270 a[46] := 'C';
271 a[47] := 'V';
272 a[48] := 'B';
273 a[49] := 'N';
274 a[50] := 'M';
275 a[51] := ',';
276 a[52] := '.';
277 a[53] := '/';
278 a[55] := '*';
279 a[57] := ' ';
280 a[74] := '-';
281 a[78] := '+';
282 a[120] := '1';
283 a[121] := '2';
284 a[122] := '3';
285 a[123] := '4';
286 a[124] := '5';
287 a[125] := '6';
288 a[126] := '7';
289 a[127] := '8';
290 a[128] := '9';
291 a[129] := '0';
292 a[130] := '-';
293 a[131] := '=';
294 return a;
295 ]
297 fn dos_ctrlmap(p : list(int32)) : int
298 [
299 var result := 0;
300 if p[2] = #00 or p[2] = #e0 then [
301 var p1 := p[1];
302 if p1 = #0f or
303 p1 >= #54 and p1 <= #5d or
304 p1 >= #87 and p1 <= #88 then
305 result or= key_flag_shift;
306 if p1 >= #5e and p1 <= #67 or
307 p1 >= #73 and p1 <= #78 or
308 p1 = #84 or
309 p1 >= #89 and p1 <= #8a or
310 p1 >= #8e and p1 <= #94 then
311 result or= key_flag_ctrl;
312 if p1 = #0e or
313 p1 >= #10 and p1 <= #1c or
314 p1 >= #1e and p1 <= #29 or
315 p1 >= #2b and p1 <= #35 or
316 p1 = #37 or
317 p1 = #39 or
318 p1 = #4a or
319 p1 = #4e or
320 p1 >= #68 and p1 <= #71 or
321 p1 >= #78 and p1 <= #83 or
322 p1 >= #8b and p1 <= #8c or
323 p1 >= #97 and p1 <= #99 or
324 p1 = #9b or
325 p1 = #9d or
326 p1 >= #9f and p1 <= #a3 or
327 p1 >= #a5 and p1 <= #a6 then
328 result or= key_flag_alt;
329 ]
330 return result;
331 ]
333 fn win32_vkmap : list(char)
334 [
335 var a := fill(char, 0, #80);
336 a[#08] := key_backspace;
337 a[#09] := key_tab;
338 a[#0c] := key_num_5;
339 a[#0d] := key_enter;
340 a[#1b] := key_esc;
341 a[#21] := key_page_up;
342 a[#22] := key_page_down;
343 a[#23] := key_end;
344 a[#24] := key_home;
345 a[#25] := key_left;
346 a[#26] := key_up;
347 a[#27] := key_right;
348 a[#28] := key_down;
349 a[#2d] := key_insert;
350 a[#2e] := key_delete;
351 a[#70] := key_f1;
352 a[#71] := key_f2;
353 a[#72] := key_f3;
354 a[#73] := key_f4;
355 a[#74] := key_f5;
356 a[#75] := key_f6;
357 a[#76] := key_f7;
358 a[#77] := key_f8;
359 a[#78] := key_f9;
360 a[#79] := key_f10;
361 a[#7a] := key_f11;
362 a[#7b] := key_f12;
363 return a;
364 ]
366 fn win32_ctrlmap(p : list(int32)) : int
367 [
368 var result := 0;
369 var p3 := p[3];
370 if p3 bt 0 or p3 bt 1 then
371 result or= key_flag_alt;
372 if p3 bt 2 or p3 bt 3 then
373 result or= key_flag_ctrl;
374 if p3 bt 4 then
375 result or= key_flag_shift;
376 return result;
377 ]
379 type mouse_context := list(int64);
381 fn new_mouse_context := infinite_uninitialized(int64);
383 fn send_mouse_event(implicit w : world, implicit mouse : mouse_context, q : msgqueue(event), ev : event_mouse) : (world, mouse_context)
384 [
385 var xtag, xev := msgqueue_receive_tag_nonblock(q, ev_tag_mouse_move);
386 if not is_exception xtag then [
387 ev.wx += xev.mouse.wx;
388 ev.wy += xev.mouse.wy;
389 ]
390 ev.double_buttons := 0;
391 var button_down_mask := ev.buttons and not ev.prev_buttons;
392 if button_down_mask <> 0 then [
393 var time := get_monotonic_time();
394 while button_down_mask <> 0 do [
395 var b := bsr button_down_mask;
396 button_down_mask btr= b;
397 if not is_uninitialized(mouse[b]), time - mouse[b] <= 300000 then
398 ev.double_buttons bts= b;
399 mouse[b] := time;
400 ]
401 ]
402 msgqueue_send(q, select(ev.prev_buttons = ev.buttons, ev_tag_mouse_button, ev_tag_mouse_move), event.mouse.(ev));
403 ]
405 record kbd_context [
406 q : msgqueue(event);
407 tc : termcap;
408 loc : locale;
409 key_map : treemap(bytes, event_keyboard);
410 partial_map : treeset(bytes);
411 has_mouse : bool;
412 last_mouse_buttons : int;
413 mouse : mouse_context;
414 ]
416 fn kbd_is_partial_locale_character(ctx : kbd_context, b : bytes) : bool
417 [
418 return not locale_validate(ctx.loc, b);
419 ]
421 fn kbd_test_input(ctx : kbd_context, b : bytes) : int
422 [
423 var i := 1;
424 while true do [
425 var test := treeset_test(ctx.partial_map, b[ .. i]) or kbd_is_partial_locale_character(ctx, b[ .. i]);
426 if i > 1 then [
427 var timer := sleep~lazy(unit_value, terminal_read_timeout);
428 if any(test, timer) then [
429 //eval debug("timeout " + ntos(i));
430 i -= 1;
431 break;
432 ]
433 ]
434 if test then
435 i += 1;
436 else
437 break;
438 ]
439 return i;
440 ]
442 fn event_get_xterm_mouse(implicit w : world, ctx : kbd_context, mb mx my mm : int) : (world, kbd_context)
443 [
444 var xm := event_mouse.[
445 x : mx - 1,
446 y : my - 1,
447 prev_buttons : 0,
448 buttons : 0,
449 wx : 0,
450 wy : 0,
451 soft_cursor : false,
452 ];
453 //eval debug("x: " + ntos(mx) + ", y: " + ntos(my) + ", b: " + ntos(mb));
454 mb btr= 5;
455 var buttons := 0;
456 if mb = 0 then buttons := 1;
457 if mb = 1 then buttons := 4;
458 if mb = 2 then buttons := 2;
459 if mb = 64 then xm.wy := -1;
460 if mb = 65 then xm.wy := 1;
461 if mb = 66 then xm.wx := -1;
462 if mb = 67 then xm.wx := 1;
463 if mb = 128 then buttons := 8;
464 if mb = 129 then buttons := 16;
465 if mb = 130 then buttons := 32;
467 if xm.wx <> 0 and mm = 0 then
468 return ctx;
470 if mm = -1 then
471 xm.buttons := buttons;
472 else if mm = 0 then
473 xm.buttons := ctx.last_mouse_buttons and not buttons;
474 else
475 xm.buttons := ctx.last_mouse_buttons or buttons;
477 xm.prev_buttons := ctx.last_mouse_buttons;
479 ctx.last_mouse_buttons := xm.buttons;
481 ctx.mouse := send_mouse_event(ctx.mouse, ctx.q, xm);
483 return ctx;
484 ]
486 fn event_get_keyboard_loop(implicit w : world, ctx : kbd_context, b : bytes) : bottom_type
487 [
488 while true do [
489 if not len_greater_than(b, 0) then
490 abort;
491 var i := kbd_test_input(ctx, b);
492 while i >= 1 do [
493 if ctx.has_mouse, i >= 3 then [
494 var xm : list(event);
495 var timer := sleep~lazy(unit_value, terminal_read_timeout);
496 if b[ .. 3] = bytes.[ 27, 91, 77 ] then [
497 var mb := b[3] - ' ';
498 var mx := b[4] - ' ';
499 var my := b[5] - ' ';
500 if any(my, timer) then [
501 b := b[3 .. ];
502 goto cont;
503 ]
504 ctx := event_get_xterm_mouse(ctx, mb, mx, my, -1);
505 //return xm + event_get_keyboard_lazy(ctx, b[6 .. ]);
506 b := b[6 .. ];
507 goto cont;
508 ]
509 if b[ .. 3] = bytes.[ 27, 91, 60 ] then [
510 fn mM(b : byte) : bool := b = 'm' or b = 'M';
511 var end := list_search_fn(b, mM);
512 if any(end, timer) then [
513 b := b[3 .. ];
514 goto cont;
515 ]
516 //eval debug(b[3 .. end + 1]);
517 var mbs := list_break(b[3 .. end], ';');
518 var mb := ston(mbs[0]);
519 var mx := ston(mbs[1]);
520 var my := ston(mbs[2]);
521 if is_exception mb or is_exception mx or is_exception my then [
522 b := b[end + 1 .. ];
523 goto cont;
524 ]
525 ctx := event_get_xterm_mouse(ctx, mb, mx, my, select(b[end] = 'M', 0, 1));
526 //return xm + event_get_keyboard_lazy(ctx, b[end + 1 .. ]);
527 b := b[end + 1 .. ];
528 goto cont;
529 ]
530 ]
531 var xk := treemap_search(ctx.key_map, b[ .. i]);
532 if xk is j then [
533 //return [ event.keyboard.(xk.j) ] + event_get_keyboard_lazy(ctx, b[i .. ]);
534 msgqueue_send(ctx.q, ev_tag_key, event.keyboard.(xk.j));
535 b := b[i .. ];
536 goto cont;
537 ]
538 var start := select(b[0] = 27, 0, 1);
539 if start = 1, i = 2 then [
540 xk := treemap_search(ctx.key_map, b[start .. i]);
541 if xk is j then [
542 if xk.j.key <> key_esc then
543 xk.j.flags or= key_flag_alt;
544 //return [ event.keyboard.(xk.j) ] + event_get_keyboard_lazy(ctx, b[i .. ]);
545 msgqueue_send(ctx.q, ev_tag_key, event.keyboard.(xk.j));
546 b := b[i .. ];
547 goto cont;
548 ]
549 ]
550 if locale_validate(ctx.loc, b[start .. i]) then [
551 var uc := locale_to_string(ctx.loc, b[start .. i]);
552 if len_at_least(uc, 1) and classify_character(uc[0]) >= class_one then [
553 xk := maybe(event_keyboard).j.(event_keyboard.[ key : uc[0], flags : 0, rep : 1 ]);
554 if start = 1 then
555 xk.j.flags or= key_flag_alt;
556 msgqueue_send(ctx.q, ev_tag_key, event.keyboard.(xk.j));
557 b := b[i .. ];
558 goto cont;
559 ]
560 ]
561 if i = 1 then
562 b := b[i .. ];
563 i -= 1;
564 ]
565 cont:
566 xeval w;
567 ]
568 abort;
569 ]
571 fn kbd_add_mapping(ctx : kbd_context, str : bytes, ev : event_keyboard) : kbd_context
572 [
573 if treemap_test(ctx.key_map, str) then
574 return ctx;
575 for i := 0 to len(str) do
576 ctx.partial_map := treeset_set(ctx.partial_map, str[ .. i]);
577 if not is_uninitialized(ev) then
578 ctx.key_map := treemap_insert(ctx.key_map, str, ev);
579 return ctx;
580 ]
582 fn do_packet_console(implicit w : world, h : handle, q : msgqueue(event), os : int, vkmap : list(char), ctrlmap : fn (list(int32)) : int) : bottom_type
583 [
584 var mouse := new_mouse_context;
585 var cached_cp := -1;
586 var cached_locale := exception_make(locale, ec_sync, error_invalid_operation, 0, false);
587 while true do [
588 var packet := read_console_packet(h);
589 //xeval debug("got packet: " + ntos(packet[0]) + ", " + ntos(packet[1]) + ", " + ntos(packet[2]) + ", " + ntos(packet[3]) + ", " + ntos(packet[4]));
590 if packet[0] = 1 then [
591 var key : char;
592 var flags : int := ctrlmap(packet);
593 if os = SystemProperty_OS_DOS or os = SystemProperty_OS_OS2 then [
594 if packet[1] = 224 and packet[2] = 13 then [
595 key := key_enter;
596 goto have_key;
597 ]
598 if packet[2] >= 32 and packet[2] <> 224 then [
599 goto prefer_char;
600 ]
601 ]
602 if packet[1] >= 0, packet[1] < len(vkmap), vkmap[packet[1]] <> 0 then [
603 key := vkmap[packet[1]];
604 if key > 0 and flags = 0 then
605 goto prefer_char;
606 ] else [
607 prefer_char:
608 key := packet[2];
609 if key = 0 then
610 continue;
611 if key >= 1 and key < 32 then [
612 key += #40;
613 flags or= key_flag_ctrl;
614 ]
615 flags and= not key_flag_shift;
616 if key >= #7f, packet[4] <> 0 then [
617 if packet[4] <> cached_cp then [
618 cached_cp := packet[4];
619 cached_locale := locale_get(".cp" + ntos(packet[4]));
620 //eval debug("cached locale: " + select(is_exception(cached_locale), "ex", "op"));
621 ]
622 if is_exception cached_locale then
623 continue;
624 var str := locale_to_string(cached_locale, bytes.[ key ]);
625 if len(str) <> 1 then
626 continue;
627 key := str[0];
628 ]
629 ]
630 //eval debug("key=" + ntos(key) + ",flags=" + ntos(flags));
631 have_key:
632 var ev := event.keyboard.(event_keyboard.[ key : key, flags : flags, rep : 1 ] );
633 msgqueue_send(q, ev_tag_key, ev);
634 ] else if packet[0] = 2 then [
635 var ev := event_mouse.[ x : packet[1], y : packet[2], prev_buttons : packet[3], buttons : packet[4], wx : packet[5], wy : packet[6], soft_cursor : select(packet[7] <> 0, false, true) ];
636 mouse := send_mouse_event(mouse, q, ev);
637 ]
638 xeval w;
639 ]
640 abort;
641 ]
643 fn event_get_keyboard_internal(implicit w : world, h : handle, tc : termcap, loc : locale, q : msgqueue(event)) : bottom_type
644 [
645 var os := sysprop(SystemProperty_OS);
646 if os = SystemProperty_OS_DOS then [
647 var vkmap := dos_vkmap;
648 var ctrlmap := dos_ctrlmap;
649 return do_packet_console(h, q, os, vkmap, ctrlmap);
650 ]
651 if os = SystemProperty_OS_OS2 then [
652 var vkmap := os2_vkmap;
653 var ctrlmap := os2_ctrlmap;
654 return do_packet_console(h, q, os, vkmap, ctrlmap);
655 ]
656 if os = SystemProperty_OS_Windows then [
657 var vkmap := win32_vkmap;
658 var ctrlmap := win32_ctrlmap;
659 return do_packet_console(h, q, os, vkmap, ctrlmap);
660 ]
661 stty(h, stty_flag_raw or stty_flag_noecho);
662 var ctx := kbd_context.[
663 q : q,
664 tc : tc,
665 loc : loc,
666 key_map : treemap_init(bytes, event_keyboard),
667 partial_map : treeset_init(bytes),
668 has_mouse : termcap_has_mouse(tc),
669 last_mouse_buttons : 0,
670 mouse : new_mouse_context,
671 ];
672 for i := 1 to len(key_to_termcap) do [
673 var str := termcap_query_string(tc, key_to_termcap[i]);
674 if str = "" then
675 continue;
676 ctx := kbd_add_mapping(ctx, str, event_keyboard.[
677 key : -i,
678 flags : 0,
679 rep : 1,
680 ]);
681 ]
682 for i := tc_s_key_f13 to tc_s_key_f49 do [
683 var flags : int;
684 var str := termcap_query_string(tc, i);
685 if str = "" then
686 continue;
687 if i < tc_s_key_f25 then
688 flags := key_flag_shift;
689 else if i < tc_s_key_f37 then
690 flags := key_flag_ctrl;
691 else if i < tc_s_key_f49 then
692 flags := key_flag_shift or key_flag_ctrl;
693 else
694 flags := 0;
695 ctx := kbd_add_mapping(ctx, str, event_keyboard.[
696 key : key_f1 - (i - tc_s_key_f13) mod 12,
697 flags : flags,
698 rep : 1,
699 ]);
700 ]
701 ctx := kbd_add_mapping(ctx, bytes.[ 0 ], event_keyboard.[ key : ' ', flags : key_flag_ctrl, rep : 1 ]);
702 ctx := kbd_add_mapping(ctx, bytes.[ 9 ], event_keyboard.[ key : key_tab, flags : 0, rep : 1 ]);
703 ctx := kbd_add_mapping(ctx, bytes.[ 13 ], event_keyboard.[ key : key_enter, flags : 0, rep : 1 ]);
704 ctx := kbd_add_mapping(ctx, bytes.[ 27 ], event_keyboard.[ key : key_esc, flags : 0, rep : 1 ]);
705 for i := 1 to 32 do [
706 ctx := kbd_add_mapping(ctx, bytes.[ i ], event_keyboard.[
707 key : i + '@',
708 flags : key_flag_ctrl,
709 rep : 1,
710 ]);
711 ]
712 if ctx.has_mouse then [
713 ctx := kbd_add_mapping(ctx, bytes.[ 27, 91, 77 ], uninitialized(event_keyboard));
714 ctx := kbd_add_mapping(ctx, bytes.[ 27, 91, 60 ], uninitialized(event_keyboard));
715 ]
716 var b := read_lazy(h);
717 return event_get_keyboard_loop(ctx, b);
718 ]
720 fn event_get_keyboard~spark(implicit w : world, h : handle, tc : termcap, loc : locale, q : msgqueue(event)) : bottom_type
721 [
722 var err := event_get_keyboard_internal(h, tc, loc, q);
723 eval err;
724 var err_event := exception_copy(event, err);
725 msgqueue_send(q, ev_tag_key, err_event);
726 xeval w;
727 return err;
728 ]
730 fn event_get_resize~spark(implicit w : world, h : handle, q : msgqueue(event)) : bottom_type
731 [
732 var x, y := -1, -1;
733 while true do [
734 x, y := tty_size(h, x, y);
735 var ev : event := event.resize.(event_resize.[ x : x, y : y ]);
736 var xev : event;
737 var xtag : int;
738 xtag, xev := msgqueue_receive_tag_nonblock(q, ev_tag_redraw);
739 xtag, xev := msgqueue_receive_tag_nonblock(q, ev_tag_resize);
740 msgqueue_send(q, ev_tag_resize, ev);
741 xeval w;
742 ]
743 abort;
744 ]
747 fn event_get_mouse~spark(implicit w : world, h : handle, q : msgqueue(event)) : bottom_type
748 [
749 var mouse := new_mouse_context;
751 var s := socket(pf_unix, sock_stream, 0);
752 connect(s, bytes.[ pf_unix, 0 ] + "/dev/gpmctl");
754 xeval w;
756 //eval debug("connected");
758 var procname := readlink(dnone(), "/proc/self");
759 var ttylink := readlink(dnone(), "/proc/self/fd/1");
761 xeval w;
763 var cdata := empty(byte);
764 cdata += int_to_native(native.short, not 0);
765 cdata += int_to_native(native.short, 0);
766 cdata += int_to_native(native.short, 0);
767 cdata += int_to_native(native.short, 0);
768 cdata += int_to_native(native.integer, ston(procname));
769 var vc : int;
770 if list_begins_with(ttylink, "/dev/tty") then
771 vc := ston(ttylink[8 .. ]);
772 else if list_begins_with(ttylink, "/dev/vc/") then
773 vc := ston(ttylink[8 .. ]);
774 else
775 abort;
776 cdata += int_to_native(native.integer, vc);
777 write(s, cdata);
779 xeval w;
781 var b := read_lazy(s);
783 var button_state := 0;
785 while true do [
786 xeval b[ .. 28];
787 var x := native_to_int(native.short, b[8 .. 10]) - 1;
788 var y := native_to_int(native.short, b[10 .. 12]) - 1;
789 var etype := native_to_int(native.integer, b[12 .. 16]);
790 var buttons := 0;
791 var gpmb := b[0];
792 if gpmb bt 0 then buttons bts= 1;
793 if gpmb bt 1 then buttons bts= 2;
794 if gpmb bt 2 then buttons bts= 0;
795 if gpmb bt 3 then buttons bts= 3;
796 if gpmb bt 4 then buttons bts= 4;
797 var new_button_state := button_state;
798 if etype bt 2 then
799 new_button_state or= buttons;
800 if etype bt 3 then
801 new_button_state and= not buttons;
802 var wx := -native_to_int(native.short, b[24 .. 26]);
803 var wy := -native_to_int(native.short, b[26 .. 28]);
804 var ev := event_mouse.[ x : x, y : y, prev_buttons : button_state, buttons : new_button_state, wx : wx, wy : wy, soft_cursor : true ];
806 mouse := send_mouse_event(mouse, q, ev);
807 xeval w;
809 b := b[28 .. ];
810 button_state := new_button_state;
811 ]
813 abort;
814 ]
816 fn event_wait_for_any_key(implicit w : world, h : handle) : world
817 [
818 var os := sysprop(SystemProperty_OS);
819 if os = SystemProperty_OS_DOS or
820 os = SystemProperty_OS_OS2 or
821 os = SystemProperty_OS_Windows then [
822 read_another:
823 var k := read_console_packet(h);
824 if k[0] <> 1 then
825 goto read_another;
826 xeval k;
827 ] else [
828 stty(h, stty_flag_raw or stty_flag_noecho);
829 var k := read_partial(h, 10);
830 xeval k;
831 event_reset_handle(h);
832 ]
833 ]
835 fn event_reset_handle(implicit w : world, h : handle) : world
836 [
837 stty(h, 0);
838 ]