stdlib/ui/event.ajla

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