Add fallback for fullscreen if _NET_WM atoms are not available
[llpp.git] / wsi.ml
blob5cad78cdac4b848a38d3656514fc45789ca72990
1 type cursor =
2 | CURSOR_INHERIT
3 | CURSOR_INFO
4 | CURSOR_CYCLE
5 | CURSOR_CROSSHAIR
6 | CURSOR_TEXT
7 ;;
9 external cloexec : Unix.file_descr -> unit = "ml_cloexec";;
10 external glx : int -> unit = "ml_glx";;
11 external swapb : unit -> unit = "ml_swapb";;
12 external hasdata : Unix.file_descr -> bool = "ml_hasdata";;
13 external toutf8 : int -> string = "ml_keysymtoutf8";;
15 let dolog fmt = Format.kprintf prerr_endline fmt;;
16 let vlog fmt = Format.kprintf ignore fmt;;
18 let onot = object
19 method display = ()
20 method expose = ()
21 method reshape _ _ = ()
22 method mouse _ _ _ _ _ = ()
23 method motion _ _ = ()
24 method pmotion _ _ = ()
25 method key _ _ = ()
26 method enter _ _ = ()
27 method leave = ()
28 method quit = exit 0
29 end;;
31 class type t = object
32 method display : unit
33 method expose : unit
34 method reshape : int -> int -> unit
35 method mouse : int -> bool -> int -> int -> int -> unit
36 method motion : int -> int -> unit
37 method pmotion : int -> int -> unit
38 method key : int -> int -> unit
39 method enter : int -> int -> unit
40 method leave : unit
41 method quit : unit
42 end;;
44 type state =
45 { mutable mink : int
46 ; mutable maxk : int
47 ; mutable keymap : int array array
48 ; fifo : (string -> unit) Queue.t
49 ; mutable seq : int
50 ; mutable protoatom : int
51 ; mutable deleatom : int
52 ; mutable idbase : int
53 ; mutable fullscreen : (int -> unit)
54 ; mutable setwmname : (string -> unit)
55 ; mutable stringatom : int
56 ; mutable t : t
57 ; mutable sock : Unix.file_descr
58 ; mutable w : int
59 ; mutable h : int
60 ; mutable fs : bool
64 let state =
65 { mink = max_int
66 ; maxk = min_int
67 ; keymap = [||]
68 ; fifo = Queue.create ()
69 ; seq = 0
70 ; protoatom = -1
71 ; deleatom = -1
72 ; idbase = -1
73 ; fullscreen = (fun _ -> ())
74 ; setwmname = (fun _ -> ())
75 ; sock = Unix.stdin
76 ; t = onot
77 ; w = -1
78 ; h = -1
79 ; fs = false
80 ; stringatom = 31
84 let w8 s pos i = String.set s pos (Char.chr (i land 0xff));;
86 let w16 s pos i =
87 w8 s pos i;
88 w8 s (pos+1) (i lsr 8);
91 let w32 s pos i =
92 w16 s pos i;
93 w16 s (pos+2) (i lsr 16);
96 let r16 s pos =
97 let rb pos1 = Char.code (String.get s (pos + pos1)) in
98 (rb 0) lor ((rb 1) lsl 8)
101 let r16s s pos =
102 let i = r16 s pos in
103 i - ((i land 0x8000) lsl 1);
106 let r8 s pos = Char.code (String.get s pos);;
108 let r32 s pos =
109 let rb pos1 = Char.code (String.get s (pos + pos1)) in
110 let l = (rb 0) lor ((rb 1) lsl 8)
111 and u = (rb 2) lor ((rb 3) lsl 8) in
112 (u lsl 16) lor l
115 let error fmt = Printf.kprintf failwith fmt;;
117 let readstr sock n =
118 let s = String.create n in
119 let rec loop pos n =
120 let m = Unix.read sock s pos n in
121 if n != m
122 then (
123 ignore (Unix.select [sock] [] [] 0.01);
124 loop (pos + m) (n - m)
127 loop 0 n;
131 let sendstr1 s pos len sock =
132 vlog "%d => %S" state.seq s;
133 state.seq <- state.seq + 1;
134 let n = Unix.send sock s pos len [] in
135 if n != len
136 then error "send %d returned %d" len n;
139 let updkmap sock resp =
140 let syms = r8 resp 1 in
141 let len = r32 resp 4 in
142 let data =
143 if len > 0
144 then readstr sock (4*len)
145 else ""
147 let m = len / syms in
148 state.keymap <- Array.make_matrix
149 (state.maxk - state.mink) syms 0xffffff;
150 let rec loop i = if i = m then () else
151 let k = i*4*syms in
152 let rec loop2 k l = if l = syms then () else
153 let v = r32 data k in
154 state.keymap.(i).(l) <- v;
155 loop2 (k+4) (l+1)
157 loop2 k 0;
158 loop (i+1);
160 loop 0;
163 let sendwithrep sock s f =
164 Queue.push f state.fifo;
165 sendstr1 s 0 (String.length s) sock;
168 let padcatl ss =
169 let b = Buffer.create 16 in
170 List.iter (Buffer.add_string b) ss;
171 let bl = Buffer.length b in
172 let pl = bl land 3 in
173 if pl != 0
174 then (
175 let pad = "123" in
176 Buffer.add_substring b pad 0 (4 - pl);
178 Buffer.contents b;
181 let padcat s1 s2 = padcatl [s1; s2];;
183 let internreq name onlyifexists =
184 let s = "\016\000\000\000\000\000\000\000" in
185 let s = padcat s name in
186 w8 s 1 (if onlyifexists then 1 else 0);
187 w16 s 2 (String.length s / 4);
188 w16 s 4 (String.length name);
192 let sendintern sock s onlyifexists f =
193 let s = internreq s onlyifexists in
194 sendwithrep sock s f;
197 let createwindowreq wid parent x y w h bw mask =
198 let s = "\001\000\009\000wwwwppppxxyywwhhbwccvvvvmmmmeeee" in
199 w32 s 4 wid;
200 w32 s 8 parent;
201 w16 s 12 x;
202 w16 s 14 y;
203 w16 s 16 w;
204 w16 s 18 h;
205 w16 s 20 bw;
206 w16 s 22 1;
207 w32 s 24 0;
208 w32 s 28 0x800; (* eventmask *)
209 w32 s 32 mask;
213 let getgeometryreq wid =
214 let s = "\014u\002\000dddd" in
215 w32 s 4 wid;
219 let mapreq wid =
220 let s = "\008u\002\000wwww" in
221 w32 s 4 wid;
225 let getkeymapreq first count =
226 let s = "\101u\002\000fcuu" in
227 w8 s 4 first;
228 w8 s 5 count;
232 let changepropreq wid prop typ format props =
233 let s = "\018\000llwwwwppppttttfuuuLLLL" in
234 let s = padcat s props in
235 w16 s 2 (String.length s / 4);
236 w32 s 4 wid;
237 w32 s 8 prop;
238 w32 s 12 typ;
239 w8 s 16 format;
240 let ful = String.length props / (match format with
241 | 8 -> 1
242 | 16 -> 2
243 | 32 -> 4
244 | n -> error "no idea what %d means" n)
246 w32 s 20 ful;
250 let openfontreq fid name =
251 let s = "\045ullffffnnuu" in
252 let s = padcat s name in
253 w16 s 2 (String.length s / 4);
254 w32 s 4 fid;
255 w16 s 8 (String.length name);
259 let createglyphcursorreq fid cid cindex =
260 let s = "\094u\008\000ccccffffffffssmmrrggbbRRGGBB" in
261 w32 s 4 cid;
262 w32 s 8 fid;
263 w32 s 12 fid;
264 w16 s 16 cindex;
265 w16 s 18 (cindex+1);
266 w16 s 20 0;
267 w16 s 22 0;
268 w16 s 24 0;
269 w16 s 26 0xffff;
270 w16 s 28 0xffff;
271 w16 s 30 0xffff;
275 let mapwindowreq wid =
276 let s = "\008u\002\000wwww" in
277 w32 s 4 wid;
281 let changewindowattributesreq wid mask attrs =
282 let s = "\002ullwwwwmmmm" in
283 let s = padcat s attrs in
284 w16 s 2 (String.length s / 4);
285 w32 s 4 wid;
286 w32 s 8 mask;
290 let configurewindowreq wid mask values =
291 let s = "\012ullwwwwmmuu" in
292 let s = padcat s values in
293 w16 s 2 (String.length s / 4);
294 w32 s 4 wid;
295 w16 s 8 mask;
299 let s32 n =
300 let s = "1234" in
301 w32 s 0 n;
305 let clientmessage format seq wid typ data =
306 let s = "\033fsswwwwtttt" in
307 let s = padcat s data in
308 w8 s 1 format;
309 w16 s 2 seq;
310 w32 s 4 wid;
311 w32 s 8 typ;
315 let sendeventreq propagate destwid mask data =
316 let s = "\025p\011\000wwwwmmmm" in
317 let s = padcat s data in
318 w8 s 1 propagate;
319 w32 s 4 destwid;
320 w32 s 8 mask;
324 let getkeysym code mask =
325 let index = (mask land 1) lxor ((mask land 2) lsr 1) in
326 let keysym = state.keymap.(code-state.mink).(index) in
327 if index = 1 && keysym = 0
328 then state.keymap.(code-state.mink).(0)
329 else keysym
332 let rec readresp sock =
333 let resp = readstr sock 32 in
334 let opcode = r8 resp 0 in
335 match opcode land lnot 0x80 with
336 | 0 -> (* error *)
337 let s = resp in
338 let code = r8 s 1
339 and serial = r16 s 2
340 and resid = r32 resp 4
341 and min = r16 s 8
342 and maj = r8 s 10 in
343 error "code=%d serial=%d resid=%#x min=%d maj=%d\n%S"
344 code serial resid min maj resp;
346 | 1 -> (* response *)
347 let rep = Queue.pop state.fifo in
348 rep resp;
350 | 2 -> (* key press *)
351 if Array.length state.keymap > 0
352 then
353 let code = r8 resp 1 in
354 let mask = r16 resp 28 in
355 let keysym = getkeysym code mask in
356 vlog "keysym = %x %c" keysym (Char.unsafe_chr keysym);
357 state.t#key keysym mask;
359 | 3 -> (* key release *)
360 if Array.length state.keymap > 0
361 then
362 let code = r8 resp 1 in
363 let mask = r16 resp 28 in
364 let keysym = getkeysym code mask in
365 vlog "release keysym = %x %c mask %#x"
366 keysym (Char.unsafe_chr keysym) mask
368 | 4 -> (* buttonpress *)
369 let n = r8 resp 1
370 and x = r16s resp 24
371 and y = r16s resp 26
372 and m = r16 resp 28 in
373 state.t#mouse n true x y m;
374 vlog "press %d" n
376 | 5 -> (* buttonrelease *)
377 let n = r8 resp 1
378 and x = r16s resp 24
379 and y = r16s resp 26
380 and m = r16 resp 28 in
381 state.t#mouse n false x y m;
382 vlog "release %d %d %d" n x y
384 | 6 -> (* motion *)
385 let x = r16s resp 24 in
386 let y = r16s resp 26 in
387 let m = r16 resp 28 in
388 if m land 0x1f00 = 0
389 then state.t#pmotion x y
390 else state.t#motion x y;
391 vlog "move %dx%d => %d" x y m
393 | 7 -> (* enter *)
394 let x = r16s resp 24
395 and y = r16s resp 26 in
396 state.t#enter x y;
397 vlog "enter %d %d" x y
399 | 8 -> (* leave *)
400 state.t#leave
402 | 18 -> vlog "unmap";
404 | 19 -> (* map *)
405 vlog "map";
407 | 12 -> (* exposure *)
408 vlog "exposure";
409 state.t#expose
411 | 15 -> (* visibility *)
412 let vis = r8 resp 8 in
413 if vis != 2 then state.t#display;
414 vlog "visibility %d" vis;
416 | 34 -> (* mapping *)
417 state.keymap <- [||];
418 let s = getkeymapreq state.mink (state.maxk-state.mink-1) in
419 sendwithrep sock s (updkmap sock);
421 | 33 -> (* clientmessage *)
422 let atom = r32 resp 8 in
423 if atom = state.protoatom
424 then (
425 let atom = r32 resp 12 in
426 if atom = state.deleatom
427 then state.t#quit;
429 vlog "atom %#x" atom
431 | 21 -> (* reparent *)
432 vlog "reparent"
434 | 22 -> (* configure *)
435 let w = r16 resp 20
436 and h = r16 resp 22 in
437 vlog "configure %d %d %d %d" state.w state.h w h;
438 if w != state.w || h != state.h
439 then (
440 state.w <- w;
441 state.h <- h;
442 state.t#reshape w h;
444 state.t#display
446 | n ->
447 dolog "event %d %S" n resp
450 let readresp sock =
451 let rec loop () =
452 readresp sock;
453 if hasdata sock then loop ();
455 loop ();
458 let sendstr s ?(pos=0) ?(len=String.length s) sock =
459 sendstr1 s pos len sock;
460 if hasdata sock then readresp sock;
463 let hexstr s =
464 let b = Buffer.create 16 in
465 String.iter (fun c ->
466 Buffer.add_string b (Printf.sprintf "%02x" (Char.code c))) s;
467 Buffer.contents b;
470 let reshape w h =
471 if state.fs
472 then
473 state.fullscreen state.idbase
475 let s = "wwuuhhuu" in
476 w32 s 0 w;
477 w32 s 4 h;
478 let s = configurewindowreq state.idbase 0x000c s in
479 vlog "reshape %d %s %d" state.seq (hexstr s) (String.length s);
480 sendstr s state.sock;
483 let setup sock screennum w h =
484 let s = readstr sock 2 in
485 let n = String.length s in
486 if n != 2
487 then error "failed to read X connection setup response n=%d" n;
488 match s.[0] with
489 | '\000' ->
490 let reasonlen = r8 s 1 in
491 let s = readstr sock 6 in
492 let maj = r16 s 0
493 and min = r16 s 2
494 and add = r16 s 4 in
495 let len = add*4 in
496 let data = readstr sock len in
497 let reason = String.sub data 0 reasonlen in
498 error "X connection failed maj=%d min=%d reason=%S"
499 maj min reason
501 | '\002' -> failwith "X connection setup failed: authentication required";
503 | '\001' ->
504 let s = readstr sock 38 in
505 let maj = r16 s 0
506 and min = r16 s 2
507 and add = r16 s 4
508 and idbase = r32 s 10
509 and idmask = r32 s 14
510 and vlen = r16 s 22
511 and screens = r8 s 26
512 and formats = r8 s 27
513 and minkk = r8 s 32
514 and maxkk = r8 s 33 in
515 let data = readstr sock (4*add-32) in
516 let vendor = String.sub data 0 vlen in
517 let pos = ((vlen+3) land lnot 3) + formats*8 in
519 if screennum >= screens
520 then error "invalid screen %d, max %d" screennum (screens-1);
522 let pos =
523 let s = data in
524 let rec findscreen n pos = if n = screennum then pos else
525 let pos =
526 let ndepths = r8 s (pos+39) in
527 let rec skipdepths n pos = if n = ndepths then pos else
528 let pos =
529 let nvisiuals = r16 s (pos+2) in
530 pos + nvisiuals*24 + 8
532 skipdepths (n+1) pos
534 skipdepths n (pos+40)
536 findscreen (n+1) pos
538 findscreen 0 pos
540 let root = r32 data pos in
541 let rootw = r16 data (pos+20)
542 and rooth = r16 data (pos+22) in
543 state.mink <- minkk;
544 state.maxk <- maxkk;
545 state.idbase <- idbase;
546 vlog "vendor = %S, maj=%d min=%d" vendor maj min;
547 vlog "screens = %d formats = %d" screens formats;
548 vlog "minkk = %d maxkk = %d" minkk maxkk;
549 vlog "idbase = %#x idmask = %#x" idbase idmask;
550 vlog "root=%#x %dx%d" root rootw rooth;
552 let mask = 0
553 + 0x00000001 (* KeyPress *)
554 (* + 0x00000002 *) (* KeyRelease *)
555 + 0x00000004 (* ButtonPress *)
556 + 0x00000008 (* ButtonRelease *)
557 + 0x00000010 (* EnterWindow *)
558 + 0x00000020 (* LeaveWindow *)
559 + 0x00000040 (* PointerMotion *)
560 (* + 0x00000080 *) (* PointerMotionHint *)
561 (* + 0x00000100 *) (* Button1Motion *)
562 (* + 0x00000200 *) (* Button2Motion *)
563 (* + 0x00000400 *) (* Button3Motion *)
564 (* + 0x00000800 *) (* Button4Motion *)
565 (* + 0x00001000 *) (* Button5Motion *)
566 + 0x00002000 (* ButtonMotion *)
567 (* + 0x00004000 *) (* KeymapState *)
568 + 0x00008000 (* Exposure *)
569 + 0x00010000 (* VisibilityChange *)
570 + 0x00020000 (* StructureNotify *)
571 (* + 0x00040000 *) (* ResizeRedirect *)
572 (* + 0x00080000 *) (* SubstructureNotify *)
573 (* + 0x00100000 *) (* SubstructureRedirect *)
574 (* + 0x00200000 *) (* FocusChange *)
575 (* + 0x00400000 *) (* PropertyChange *)
576 (* + 0x00800000 *) (* ColormapChange *)
577 (* + 0x01000000 *) (* OwnerGrabButton *)
579 let wid = state.idbase in
580 let s = createwindowreq wid root 0 0 w h 0 mask in
581 sendstr s sock;
583 let s = mapreq wid in
584 sendstr s sock;
586 let s = getkeymapreq state.mink (state.maxk-state.mink) in
587 sendwithrep sock s (updkmap sock);
589 sendintern sock "WM_PROTOCOLS" false (fun resp ->
590 state.protoatom <- r32 resp 8;
591 sendintern sock "WM_DELETE_WINDOW" false (fun resp ->
592 state.deleatom <- r32 resp 8;
593 let s = s32 state.deleatom in
594 let s = changepropreq wid state.protoatom 4 32 s in
595 sendstr s sock;
599 sendintern sock "WM_CLASS" false (fun resp ->
600 let atom = r32 resp 8 in
601 let llpp = "llpp\000llpp\000" in
602 let s = changepropreq wid atom 31 8 llpp in
603 sendstr s sock;
606 let s = openfontreq (wid+1) "cursor" in
607 sendstr s sock;
609 Array.iteri (fun i glyphindex ->
610 let s = createglyphcursorreq (wid+1) (wid+2+i) glyphindex in
611 sendstr s sock;
612 ) [|34;48;50;58;128;152|];
614 sendintern sock "UTF8_STRING" true (fun resp ->
615 let atom = r32 resp 8 in
616 if atom != 0
617 then state.stringatom <- atom;
620 let setwmname s =
621 let s = changepropreq state.idbase 39 state.stringatom 8 s in
622 sendstr s state.sock;
624 state.setwmname <- setwmname;
625 sendintern sock "_NET_WM_NAME" true (fun resp ->
626 let atom = r32 resp 8 in
627 if atom != 0
628 then state.setwmname <- (fun s ->
629 setwmname s;
630 let s = changepropreq state.idbase atom state.stringatom 8 s in
631 sendstr s state.sock;
635 state.fullscreen <- (fun _ ->
636 let s = "xxuuyyuuwwuuhhuu" in
637 w32 s 0 0;
638 w32 s 4 0;
639 w32 s 8 rootw;
640 w32 s 12 rooth;
641 let s = configurewindowreq state.idbase 0x000f s in
642 sendstr s state.sock;
644 sendintern sock "_NET_WM_STATE" true (fun resp ->
645 let nwmsatom = r32 resp 8 in
646 if nwmsatom != 0
647 then
648 sendintern sock "_NET_WM_STATE_FULLSCREEN" true (fun resp ->
649 let fsatom = r32 resp 8 in
650 if fsatom != 0
651 then
652 state.fullscreen <-
653 (fun wid ->
654 let data = String.make 20 '\000' in
655 state.fs <- not state.fs;
656 w32 data 0 (if state.fs then 1 else 0);
657 w32 data 4 fsatom;
659 let cm = clientmessage 32 0 wid nwmsatom data in
660 let s = sendeventreq 0 root 0x180000 cm in
661 sendstr s sock;
665 let s = getgeometryreq wid in
666 let completed = ref false in
667 sendwithrep sock s (fun resp ->
668 glx wid;
669 let w = r16 resp 16
670 and h = r16 resp 18 in
671 state.w <- w;
672 state.h <- h;
673 completed := true;
675 let now = Unix.gettimeofday in
676 let deadline = now () +. 2.0 in
677 let rec readtillcompletion () =
678 let r, _, _ = Unix.select [sock] [] [] (deadline -. now ()) in
679 match r with
680 | [] -> readtillcompletion ()
681 | _ ->
682 readresp sock;
683 if not !completed
684 then readtillcompletion ()
686 readtillcompletion ();
688 | c ->
689 error "unknown conection setup response %d" (Char.code c)
692 let getauth haddr dnum =
693 let haddr =
694 if haddr = "localhost" || String.length haddr = 0
695 then
696 try Unix.gethostname ()
697 with exn ->
698 dolog "failed to resolve `%S': %s" haddr (Printexc.to_string exn);
699 haddr
700 else haddr
702 let readauth ic =
703 let input_string ic len =
704 let s = String.create len in
705 really_input ic s 0 len;
708 let r16 s =
709 let rb pos = Char.code (String.get s pos) in
710 (rb 1) lor ((rb 0) lsl 8)
712 let rec find () =
713 let rs () =
714 let s = input_string ic 2 in
715 let n = r16 s in
716 input_string ic n
718 let family = input_string ic 2 in
719 let addr = rs () in
720 let nums = rs () in
721 let num = int_of_string nums in
722 let name = rs () in
723 let data = rs () in
725 vlog "family %S addr %S(%S) num %d(%d) name %S data %S"
726 family addr haddr num dnum name data;
727 if addr = haddr && num = dnum
728 then name, data
729 else find ()
731 let name, data =
732 try find () with _ -> "", ""
734 close_in ic;
735 name, data;
737 let path =
738 try Sys.getenv "XAUTHORITY"
739 with Not_found ->
740 try Filename.concat (Sys.getenv "HOME") ".Xauthority"
741 with Not_found -> ""
743 let opt =
745 if String.length path = 0
746 then None
747 else Some (open_in_bin path)
748 with exn ->
749 dolog "failed to open X authority file `%S' : %s"
750 path
751 (Printexc.to_string exn);
752 None
754 match opt with
755 | None -> "", ""
756 | Some ic -> readauth ic
759 let init t w h =
760 let d =
761 try Sys.getenv "DISPLAY"
762 with exn ->
763 error "Could not get DISPLAY evironment variable: %s"
764 (Printexc.to_string exn)
766 let colonpos = String.index d ':' in
767 let host = String.sub d 0 colonpos in
768 let dispnum, screennum =
770 let dotpos = String.index_from d (colonpos + 1) '.' in
771 let disp = String.sub d (colonpos + 1) (dotpos - colonpos - 1) in
772 let screen = String.sub d (dotpos + 1) (String.length d - dotpos - 1) in
773 int_of_string disp, int_of_string screen
774 with Not_found ->
775 let disp = String.sub d (colonpos + 1) (String.length d - colonpos - 1) in
776 int_of_string disp, 0
778 let aname, adata = getauth host dispnum in
779 let fd =
780 if String.length host = 0 || host = "unix"
781 then
782 let addr = Unix.ADDR_UNIX ("/tmp/.X11-unix/X" ^ string_of_int dispnum) in
783 let fd = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
784 Unix.connect fd addr;
786 else
787 let h = Unix.gethostbyname host in
788 let addr = h.Unix.h_addr_list.(0) in
789 let port = 6000 + dispnum in
790 let fd = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
791 Unix.connect fd (Unix.ADDR_INET (addr, port));
794 cloexec fd;
795 let s = "luMMmmnndduu" in
796 let s = padcat s aname in
797 let s = padcat s adata in
798 w16 s 2 11;
799 w16 s 4 0;
800 w16 s 6 (String.length aname);
801 w16 s 8 (String.length adata);
802 sendstr1 s 0 (String.length s) fd;
803 state.sock <- fd;
804 setup fd screennum w h;
805 state.t <- t;
806 fd, state.w, state.h;
809 let settitle s =
810 state.setwmname s;
813 let setcursor cursor =
814 let n =
815 match cursor with
816 | CURSOR_INHERIT -> -1
817 | CURSOR_INFO -> 3
818 | CURSOR_CYCLE -> 2
819 | CURSOR_CROSSHAIR -> 0
820 | CURSOR_TEXT -> 5
822 let s = s32 (if n = -1 then 0 else state.idbase+2+n) in
823 let s = changewindowattributesreq state.idbase (*cursor*)0x4000 s in
824 sendstr s state.sock;
827 let fullscreen () =
828 state.fullscreen state.idbase;
831 let metamask = 0x40;;
832 let altmask = 8;;
833 let shiftmask = 1;;
834 let ctrlmask = 4;;
836 let withalt mask = mask land altmask != 0;;
837 let withctrl mask = mask land ctrlmask != 0;;
838 let withshift mask = mask land shiftmask != 0;;
839 let withmeta mask = mask land metamask != 0;;
840 let withnone mask = mask land (altmask + ctrlmask + shiftmask + metamask) = 0;;
842 let xlatt, xlatf =
843 let t = Hashtbl.create 20
844 and f = Hashtbl.create 20 in
845 let add n nl k =
846 List.iter (fun s -> Hashtbl.add t s k) (n::nl);
847 Hashtbl.add f k n
849 let addc c =
850 let s = String.create 1 in
851 s.[0] <- c;
852 add s [] (Char.code c)
854 let addcr a b =
855 let an = Char.code a and bn = Char.code b in
856 for i = an to bn do addc (Char.chr i) done;
858 addcr '0' '9';
859 addcr 'a' 'z';
860 addcr 'A' 'Z';
861 String.iter addc "`~!@#$%^&*()-_=+\\|[{]};:,./<>?";
862 for i = 0 to 29 do add ("f" ^ string_of_int (i+1)) [] (0xffbe + i) done;
863 add "space" [] 0x20;
864 add "return" ["ret"; "enter"] 0xff0d;
865 add "tab" [] 0xff09;
866 add "left" [] 0xff51;
867 add "right" [] 0xff53;
868 add "home" [] 0xff50;
869 add "end" [] 0xff57;
870 add "insert" ["ins"] 0xff63;
871 add "delete" ["del"] 0xffff;
872 add "escape" ["esc"] 0xff1b;
873 add "pgup" ["pageup"] 0xff55;
874 add "pgdown" ["pagedown"] 0xff56;
875 add "backspace" [] 0xff08;
876 add "up" [] 0xff52;
877 add "down" [] 0xff54;
878 t, f;
881 let keyname k =
882 try Hashtbl.find xlatf k
883 with Not_found -> Printf.sprintf "%#x" k;
886 let namekey name =
887 try Hashtbl.find xlatt name
888 with Not_found ->
889 if String.length name = 1
890 then Char.code name.[0]
891 else int_of_string name;