Add missing keys.ml compilation
[llpp.git] / wsi.ml
blobdf9eb8b8cca515fa8edf66480caeef02737198d4
1 open Utils;;
3 let (~>) = Bytes.unsafe_of_string;;
5 type cursor =
6 | CURSOR_INHERIT
7 | CURSOR_INFO
8 | CURSOR_CYCLE
9 | CURSOR_FLEUR
10 | CURSOR_TEXT
13 type winstate =
14 | MaxVert
15 | MaxHorz
16 | Fullscreen
19 type visiblestate =
20 | Unobscured
21 | PartiallyObscured
22 | FullyObscured
25 type wid = int and screenno = int and vid = int and atom = int;;
27 external glxinit : string -> wid -> screenno -> vid = "ml_glxinit";;
28 external glxcompleteinit : unit -> unit = "ml_glxcompleteinit";;
29 external swapb : unit -> unit = "ml_swapb";;
30 external setcursor : cursor -> unit = "ml_setcursor";;
31 external setwinbgcol : int -> unit = "ml_setbgcol";;
33 let vlog fmt = Format.ksprintf ignore fmt;;
35 let onot = object
36 method display = ()
37 method map _ = ()
38 method expose = ()
39 method visible _ = ()
40 method reshape _ _ = ()
41 method mouse _ _ _ _ _ = ()
42 method motion _ _ = ()
43 method pmotion _ _ = ()
44 method key _ _ = ()
45 method enter _ _ = ()
46 method leave = ()
47 method winstate _ = ()
48 method quit = exit 0
49 end;;
51 class type t =
52 object
53 method display : unit
54 method map : bool -> unit
55 method expose : unit
56 method visible : visiblestate -> unit
57 method reshape : int -> int -> unit
58 method mouse : int -> bool -> int -> int -> int -> unit
59 method motion : int -> int -> unit
60 method pmotion : int -> int -> unit
61 method key : int -> int -> unit
62 method enter : int -> int -> unit
63 method leave : unit
64 method winstate : winstate list -> unit
65 method quit : unit
66 end;;
68 type state =
69 { mutable mink : int
70 ; mutable maxk : int
71 ; mutable keymap : int array array
72 ; fifo : (bytes -> unit) Queue.t
73 ; mutable seq : int
74 ; mutable protoatom : atom
75 ; mutable deleatom : atom
76 ; mutable nwmsatom : atom
77 ; mutable maxvatom : atom
78 ; mutable maxhatom : atom
79 ; mutable fulsatom : atom
80 ; mutable idbase : int
81 ; mutable wid : int
82 ; mutable fid : int
83 ; mutable fullscreen : (int -> unit)
84 ; mutable setwmname : (bytes -> unit)
85 ; mutable actwin : (unit -> unit)
86 ; mutable stringatom : int
87 ; mutable t : t
88 ; mutable sock : Unix.file_descr
89 ; mutable x : int
90 ; mutable y : int
91 ; mutable w : int
92 ; mutable h : int
93 ; mutable fs : fs
94 ; mutable curcurs : cursor
95 ; mutable capslmask : int
96 ; mutable numlmask : int
97 ; mutable levl3mask : int
98 ; mutable levl5mask : int
99 ; mutable xkb : bool
101 and fs =
102 | NoFs
103 | Fs of (int * int * int * int)
106 let state =
107 { mink = max_int
108 ; maxk = min_int
109 ; keymap = E.a
110 ; fifo = Queue.create ()
111 ; seq = 0
112 ; protoatom = -1
113 ; deleatom = -1
114 ; nwmsatom = -1
115 ; maxvatom = -1
116 ; maxhatom = -1
117 ; fulsatom = -1
118 ; idbase = -1
119 ; wid = -1
120 ; fid = -1
121 ; fullscreen = (fun _ -> ())
122 ; setwmname = (fun _ -> ())
123 ; actwin = (fun _ -> ())
124 ; sock = Unix.stdin
125 ; t = onot
126 ; x = -1
127 ; y = -1
128 ; w = -1
129 ; h = -1
130 ; fs = NoFs
131 ; stringatom = 31
132 ; curcurs = CURSOR_TEXT
133 ; capslmask = 0
134 ; numlmask = 0
135 ; levl3mask = 0
136 ; levl5mask = 0
137 ; xkb = false
141 let w8 s pos i = Bytes.set s pos (Char.chr (i land 0xff));;
142 let r8 s pos = Char.code (Bytes.get s pos);;
144 let ordermagic = 'l';;
146 let w16 s pos i =
147 w8 s pos i;
148 w8 s (pos+1) (i lsr 8)
151 let w32 s pos i =
152 w16 s pos i;
153 w16 s (pos+2) (i lsr 16)
156 let r16 s pos =
157 let rb pos1 = Char.code (Bytes.get s (pos + pos1)) in
158 (rb 0) lor ((rb 1) lsl 8)
161 let r16s s pos =
162 let i = r16 s pos in
163 i - ((i land 0x8000) lsl 1)
166 let r32 s pos =
167 let rb pos1 = Char.code (Bytes.get s (pos + pos1)) in
168 let l = (rb 0) lor ((rb 1) lsl 8)
169 and u = (rb 2) lor ((rb 3) lsl 8) in
170 (u lsl 16) lor l
173 let makereq opcode len reqlen =
174 let s = Bytes.create len in
175 w8 s 0 opcode;
176 w16 s 2 reqlen;
180 let readstr sock n =
181 let s = Bytes.create n in
182 let rec loop pos n =
183 let m = tempfailureretry (Unix.read sock s pos) n in
184 if m = 0
185 then state.t#quit;
186 if n != m
187 then (
188 ignore (tempfailureretry (Unix.select [sock] [] []) 0.01);
189 loop (pos + m) (n - m)
192 loop 0 n;
196 let sendstr1 s pos len sock =
197 let s = Bytes.unsafe_to_string s in
198 vlog "%d <= %S" state.seq s;
199 state.seq <- state.seq + 1;
200 let n = tempfailureretry (Unix.write_substring sock s pos) len in
201 if n != len
202 then error "send %d returned %d" len n;
205 let updkmap sock resp =
206 let syms = r8 resp 1 in
207 let len = r32 resp 4 in
208 let data =
209 if len > 0
210 then readstr sock (4*len)
211 else E.b
213 let m = len / syms in
214 state.keymap <- Array.make_matrix
215 (state.maxk - state.mink) syms 0xffffff;
216 let rec loop i = if i = m then () else
217 let k = i*4*syms in
218 let rec loop2 k l = if l = syms then () else
219 let v = r32 data k in
220 state.keymap.(i).(l) <- v;
221 loop2 (k+4) (l+1)
223 loop2 k 0;
224 loop (i+1);
226 loop 0;
229 let updmodmap sock resp =
230 let n = r8 resp 1 in
231 let len = r16 resp 4 in
232 let data =
233 if len > 0
234 then readstr sock (len*4)
235 else E.b
237 if len > 0 then (*???*)
238 let modmap = Array.make_matrix 8 n 0xffffff in
239 let rec loop l =
240 if l = 8
241 then ()
242 else
243 let p = l*n in
244 let rec loop1 m =
245 if m = n then ()
246 else
247 let p = p+m in
248 let code = r8 data p in
249 modmap.(l).(m) <- code;
250 if l = 1
251 then (
252 let ki = code - state.mink in
253 if ki >= 0
254 then
255 let a = state.keymap.(ki) in
256 let rec capsloop i =
257 if i = Array.length a || i > 3
258 then ()
259 else
260 let s = a.(i) in
261 if s = 0xffe5
262 then state.capslmask <- 2
263 else capsloop (i+1)
265 capsloop 0;
267 else (
268 if l > 3
269 then (
270 let ki = code - state.mink in
271 if ki >= 0
272 then
273 let a = state.keymap.(ki) in
274 let rec lloop i =
275 if i = Array.length a || i > 3
276 then ()
277 else
278 let s = a.(i) in
279 match s with
280 | 0xfe03 -> state.levl3mask <- 1 lsl l
281 | 0xfe11 -> state.levl5mask <- 1 lsl l
282 | 0xff7f -> state.numlmask <- 1 lsl l
283 | _ -> lloop (i+1)
285 lloop 0;
288 loop1 (m+1)
290 loop1 0;
291 loop (l+1)
293 loop 0;
296 let sendwithrep sock s f =
297 Queue.push f state.fifo;
298 sendstr1 s 0 (Bytes.length s) sock;
301 let padcatl =
302 let pad = "123" in
303 fun ss ->
304 let b = Buffer.create 16 in
305 List.iter (Buffer.add_bytes b) ss;
306 let bl = Buffer.length b in
307 let pl = bl land 3 in
308 if pl != 0
309 then (
310 Buffer.add_substring b pad 0 (4 - pl);
312 Buffer.to_bytes b;
315 let padcat s1 s2 = padcatl [s1; s2];;
317 let internreq name onlyifexists =
318 let s = makereq 16 8 8 in
319 let s = padcat s name in
320 w8 s 1 (if onlyifexists then 1 else 0);
321 w16 s 2 (Bytes.length s / 4);
322 w16 s 4 (Bytes.length name);
326 let sendintern sock s onlyifexists f =
327 let s = internreq s onlyifexists in
328 sendwithrep sock s f;
331 let createwindowreq wid parent x y w h bw eventmask vid depth mid =
332 let s = makereq 1 48 12 in
333 w8 s 1 depth;
334 w32 s 4 wid;
335 w32 s 8 parent;
336 w16 s 12 x;
337 w16 s 14 y;
338 w16 s 16 w;
339 w16 s 18 h;
340 w16 s 20 bw;
341 w16 s 22 0; (* copyfromparent *)
342 w32 s 24 vid; (* visual *)
343 w32 s 28 0x280a; (* valuemask =
344 | background pixel
345 | border pixel
346 | event mask
347 | colormap *)
348 w32 s 32 0; (* background pixel *)
349 w32 s 36 0; (* border pixel*)
350 w32 s 40 eventmask;
351 w32 s 44 mid;
355 let createcolormapreq mid wid vid =
356 let s = makereq 78 16 4 in
357 w8 s 1 0;
358 w32 s 4 mid;
359 w32 s 8 wid;
360 w32 s 12 vid;
364 let getgeometryreq wid =
365 let s = makereq 14 8 2 in
366 w32 s 4 wid;
370 let mapreq wid =
371 let s = makereq 8 8 2 in
372 w32 s 4 wid;
376 let getkeymapreq first count =
377 let s = makereq 101 8 2 in
378 w8 s 4 first;
379 w8 s 5 count;
383 let changepropreq wid prop typ format props =
384 let s = makereq 18 24 0 in
385 let s = padcat s props in
386 w8 s 1 0;
387 w16 s 2 (Bytes.length s / 4);
388 w32 s 4 wid;
389 w32 s 8 prop;
390 w32 s 12 typ;
391 w8 s 16 format;
392 let ful = Bytes.length props / (match format with
393 | 8 -> 1
394 | 16 -> 2
395 | 32 -> 4
396 | n -> error "no idea what %d means" n)
398 w32 s 20 ful;
402 let getpropreq delete wid prop typ =
403 let s = makereq 20 24 6 in
404 w8 s 1 (if delete then 1 else 0);
405 w32 s 4 wid;
406 w32 s 8 prop;
407 w32 s 12 typ;
408 w32 s 16 0;
409 w32 s 20 2;
413 let configurewindowreq wid mask values =
414 let s = makereq 12 12 0 in
415 let s = padcat s values in
416 w16 s 2 (Bytes.length s / 4);
417 w32 s 4 wid;
418 w16 s 8 mask;
422 let s32 n =
423 let s = Bytes.create 4 in
424 w32 s 0 n;
428 let clientmessage format seq wid typ data =
429 let s = makereq 33 12 0 in
430 let s = padcat s data in
431 w8 s 1 format;
432 w16 s 2 seq;
433 w32 s 4 wid;
434 w32 s 8 typ;
438 let sendeventreq propagate destwid mask data =
439 let s = makereq 25 12 11 in
440 let s = padcat s data in
441 w8 s 1 propagate;
442 w16 s 2 11;
443 w32 s 4 destwid;
444 w32 s 8 mask;
448 let getmodifiermappingreq () =
449 makereq 119 4 1;
452 let queryextensionreq name =
453 let s = makereq 98 8 0 in
454 let s = padcat s name in
455 w16 s 2 (Bytes.length s / 4);
456 w16 s 4 (Bytes.length name);
460 let getkeysym pkpk code mask =
461 if (pkpk >= 0xff80 && pkpk <= 0xffbd)
462 || (pkpk >= 0x11000000 && pkpk <= 0x1100ffff)
463 then (
464 if mask land state.numlmask != 0
465 then
466 let keysym = state.keymap.(code-state.mink).(1) in
467 if keysym = 0 then pkpk else keysym
468 else pkpk
470 else (
471 let shift =
472 if pkpk land 0xf000 = 0xf000
473 then 0
474 else (mask land 1) lxor ((mask land state.capslmask) lsr 1)
476 let index =
477 if state.xkb && mask land 0x2000 != 0
478 then
479 shift + 2
480 else
481 let l3 = (mask land state.levl3mask) != 0 in
482 let l4 = (mask land state.levl5mask) != 0 in
483 shift +
484 if l3 then (if l4 then 8 else 4) else (if l4 then 6 else 0)
486 let keysym = state.keymap.(code-state.mink).(index) in
487 if index land 1 = 1 && keysym = 0
488 then state.keymap.(code-state.mink).(index - 1)
489 else keysym
493 let getkeysym code mask =
494 let pkpk = state.keymap.(code-state.mink).(0) in
495 if state.xkb && pkpk lsr 8 = 0xfe (* XKB *)
496 then 0
497 else getkeysym pkpk code mask
500 let readresp sock =
501 let resp = readstr sock 32 in
502 let opcode = r8 resp 0 in
503 match opcode land lnot 0x80 with
504 | 0 -> (* error *)
505 let s = resp in
506 let code = r8 s 1
507 and serial = r16 s 2
508 and resid = r32 resp 4
509 and min = r16 s 8
510 and maj = r8 s 10 in
511 error "code=%d serial=%d resid=%#x min=%d maj=%d\n%S"
512 code serial resid min maj (Bytes.unsafe_to_string resp);
514 | 1 -> (* response *)
515 let rep = Queue.pop state.fifo in
516 rep resp;
518 | 2 -> (* key press *)
519 if Array.length state.keymap > 0
520 then
521 let code = r8 resp 1 in
522 let mask = r16 resp 28 in
523 let keysym = getkeysym code mask in
524 vlog "keysym = %x %c mask %#x code %d"
525 keysym (Char.unsafe_chr keysym) mask code;
526 if keysym != 0
527 then state.t#key keysym mask
529 | 3 -> (* key release *)
530 if Array.length state.keymap > 0
531 then
532 let code = r8 resp 1 in
533 let mask = r16 resp 28 in
534 let keysym = getkeysym code mask in
535 vlog "release keysym = %x %c mask %#x code %#d"
536 keysym (Char.unsafe_chr keysym) mask code
538 | 4 -> (* buttonpress *)
539 let n = r8 resp 1
540 and x = r16s resp 24
541 and y = r16s resp 26
542 and m = r16 resp 28 in
543 state.t#mouse n true x y m;
544 vlog "press %d" n
546 | 5 -> (* buttonrelease *)
547 let n = r8 resp 1
548 and x = r16s resp 24
549 and y = r16s resp 26
550 and m = r16 resp 28 in
551 state.t#mouse n false x y m;
552 vlog "release %d %d %d" n x y
554 | 6 -> (* motion *)
555 let x = r16s resp 24 in
556 let y = r16s resp 26 in
557 let m = r16 resp 28 in
558 if m land 0x1f00 = 0
559 then state.t#pmotion x y
560 else state.t#motion x y;
561 vlog "move %dx%d => %d" x y m
563 | 7 -> (* enter *)
564 let x = r16s resp 24
565 and y = r16s resp 26 in
566 state.t#enter x y;
567 vlog "enter %d %d" x y
569 | 8 -> (* leave *)
570 state.t#leave
572 | 18 -> (* unmap *)
573 state.t#map false;
574 vlog "unmap";
576 | 19 -> (* map *)
577 state.t#map true;
578 vlog "map";
580 | 12 -> (* exposure *)
581 vlog "exposure";
582 state.t#expose
584 | 15 -> (* visibility *)
585 let v = r8 resp 8 in
586 let vis =
587 match v with
588 | 0 -> Unobscured
589 | 1 -> PartiallyObscured
590 | 2 -> FullyObscured
591 | _ ->
592 dolog "unknown visibility %d" v;
593 Unobscured
595 state.t#visible vis;
596 vlog "visibility %d" v;
598 | 34 -> (* mapping *)
599 state.keymap <- E.a;
600 let s = getkeymapreq state.mink (state.maxk-state.mink-1) in
601 sendwithrep sock s (updkmap sock);
602 state.capslmask <- 0;
603 state.levl3mask <- 0;
604 state.levl5mask <- 0;
605 state.numlmask <- 0;
606 let s = getmodifiermappingreq () in
607 sendwithrep sock s (updmodmap sock);
609 | 33 -> (* clientmessage *)
610 let atom = r32 resp 8 in
611 if atom = state.protoatom
612 then (
613 let atom = r32 resp 12 in
614 if atom = state.deleatom
615 then state.t#quit;
617 vlog "atom %#x" atom
619 | 21 -> (* reparent *)
620 vlog "reparent"
622 | 22 -> (* configure *)
623 let x = r16s resp 16
624 and y = r16s resp 18
625 and w = r16 resp 20
626 and h = r16 resp 22 in
627 vlog "configure cur [%d %d %d %d] conf [%d %d %d %d]"
628 state.x state.y state.w state.h
629 x y w h
631 if w != state.w || h != state.h
632 then (
633 state.t#reshape w h;
635 state.w <- w;
636 state.h <- h;
637 state.x <- x;
638 state.y <- y;
639 state.t#expose
641 | 28 ->
642 let atom = r32 resp 8 in
643 if atom = state.nwmsatom
644 then
645 let s = getpropreq false state.wid atom 4 in
646 sendwithrep sock s (fun resp ->
647 let len = r32 resp 4 in
648 let nitems = r32 resp 16 in
649 let wsl =
650 if len = 0
651 then []
652 else
653 let s = readstr sock (len*4) in
654 let rec loop wsl i =
655 if i = nitems
656 then wsl
657 else
658 let atom = r32 s (i*4) in
659 let wsl =
660 if atom = state.maxhatom
661 then MaxHorz::wsl
662 else (
663 if atom = state.maxvatom
664 then MaxVert::wsl
665 else (
666 if atom = state.fulsatom
667 then (
668 state.fs <- Fs (state.x, state.y,
669 state.w, state.h);
670 Fullscreen::wsl
672 else wsl
675 in loop wsl (i+1)
677 loop [] 0
679 state.t#winstate (List.sort compare wsl)
682 | n ->
683 dolog "event %d %S" n (Bytes.unsafe_to_string resp)
686 let readresp sock =
687 let rec loop () =
688 readresp sock;
689 if hasdata sock then loop ();
691 loop ();
694 let sendstr s ?(pos=0) ?(len=Bytes.length s) sock =
695 sendstr1 s pos len sock;
696 if hasdata sock then readresp sock;
699 let reshape w h =
700 if state.fs = NoFs
701 then
702 let s = Bytes.create 8 in
703 w32 s 0 w;
704 w32 s 4 h;
705 let s = configurewindowreq state.wid 0x000c s in
706 sendstr s state.sock;
707 else state.fullscreen state.wid
710 let activatewin () =
711 state.actwin ();
714 let syncsendwithrep sock secstowait s f =
715 let completed = ref false in
716 sendwithrep sock s (fun resp -> f resp; completed := true);
717 let now = Unix.gettimeofday in
718 let deadline = now () +. secstowait in
719 let rec readtillcompletion () =
720 let sf deadline =
721 let timeout = deadline -. now () in
722 if timeout <= 0.0
723 then [], [], []
724 else Unix.select [sock] [] [] timeout
726 let r, _, _ = tempfailureretry sf deadline in
727 match r with
728 | [] -> error "didn't get X response in %f seconds, aborting" secstowait
729 | _ ->
730 readresp sock;
731 if not !completed
732 then readtillcompletion ()
734 readtillcompletion ();
737 let mapwin () =
738 let s = mapreq state.wid in
739 sendstr s state.sock;
742 let syncsendintern sock secstowait s onlyifexists f =
743 let s = internreq s onlyifexists in
744 syncsendwithrep sock secstowait s f;
747 let setup disp sock rootwid screennum w h =
748 let s = readstr sock 2 in
749 let n = Bytes.length s in
750 if n != 2
751 then error "failed to read X connection setup response n=%d" n;
752 match Bytes.get s 0 with
753 | '\000' ->
754 let reasonlen = r8 s 1 in
755 let s = readstr sock 6 in
756 let maj = r16 s 0
757 and min = r16 s 2
758 and add = r16 s 4 in
759 let len = add*4 in
760 let data = readstr sock len in
761 let reason = Bytes.sub data 0 reasonlen in
762 error "X connection failed maj=%d min=%d reason=%S"
763 maj min (Bytes.unsafe_to_string reason)
765 | '\002' -> failwith "X connection setup failed: authentication required";
767 | '\001' ->
768 let s = readstr sock 38 in
769 let maj = r16 s 0
770 and min = r16 s 2
771 and add = r16 s 4
772 and idbase = r32 s 10
773 and idmask = r32 s 14
774 and vlen = r16 s 22
775 and screens = r8 s 26
776 and formats = r8 s 27
777 and minkk = r8 s 32
778 and maxkk = r8 s 33 in
779 let data = readstr sock (4*add-32) in
780 let vendor = Bytes.sub data 0 vlen in
781 let pos = ((vlen+3) land lnot 3) + formats*8 in
783 if screennum >= screens
784 then error "invalid screen %d, max %d" screennum (screens-1);
786 let pos =
787 let rec findscreen n pos =
788 if n = screennum
789 then pos
790 else
791 let pos =
792 let ndepths = r8 data (pos+39) in
793 let rec skipdepths n pos =
794 if n = ndepths
795 then pos
796 else
797 let pos =
798 let nvisiuals = r16 data (pos+2) in
799 pos + nvisiuals*24 + 8
801 skipdepths (n+1) pos
803 skipdepths n (pos+40)
805 findscreen (n+1) pos
807 findscreen 0 pos
809 let root = if rootwid = 0 then r32 data pos else rootwid in
810 let rootw = r16 data (pos+20)
811 and rooth = r16 data (pos+22)
812 and rootdepth = r8 data (pos+38)in
814 state.mink <- minkk;
815 state.maxk <- maxkk;
816 state.idbase <- idbase;
817 vlog "vendor = %S, maj=%d min=%d" (Bytes.unsafe_to_string vendor) maj min;
818 vlog "screens = %d formats = %d" screens formats;
819 vlog "minkk = %d maxkk = %d" minkk maxkk;
820 vlog "idbase = %#x idmask = %#x" idbase idmask;
821 vlog "root=%#x %dx%d" root rootw rooth;
822 vlog "wmm = %d, hmm = %d" (r16 data (pos+24)) (r16 data (pos+26));
823 vlog "visualid = %#x" (r32 data (pos+32));
824 vlog "root depth = %d" rootdepth;
826 let wid = state.idbase in
827 let mid = wid+1 in
828 let fid = mid+1 in
830 state.wid <- wid;
831 state.fid <- fid;
833 let vid = glxinit disp wid screennum in
834 let ndepths = r8 data (pos+39) in
835 let rec finddepth n' pos =
836 if n' = ndepths
837 then error "cannot find depth for visual %#x" vid;
838 let depth = r8 data pos in
839 let nvisuals = r16 data (pos+2) in
840 let rec findvisual n pos =
841 if n = nvisuals
842 then finddepth (n'+1) pos
843 else
844 let id = r32 data pos in
845 if id = vid
846 then depth
847 else findvisual (n+1) (pos+24)
849 findvisual 0 (pos+8)
851 let depth = finddepth 0 (pos+40) in
853 let s = createcolormapreq mid root vid in
854 sendstr s sock;
856 let mask = 0
857 + 0x00000001 (* KeyPress *)
858 (* + 0x00000002 *) (* KeyRelease *)
859 + 0x00000004 (* ButtonPress *)
860 + 0x00000008 (* ButtonRelease *)
861 + 0x00000010 (* EnterWindow *)
862 + 0x00000020 (* LeaveWindow *)
863 + 0x00000040 (* PointerMotion *)
864 (* + 0x00000080 *) (* PointerMotionHint *)
865 (* + 0x00000100 *) (* Button1Motion *)
866 (* + 0x00000200 *) (* Button2Motion *)
867 (* + 0x00000400 *) (* Button3Motion *)
868 (* + 0x00000800 *) (* Button4Motion *)
869 (* + 0x00001000 *) (* Button5Motion *)
870 + 0x00002000 (* ButtonMotion *)
871 (* + 0x00004000 *) (* KeymapState *)
872 + 0x00008000 (* Exposure *)
873 + 0x00010000 (* VisibilityChange *)
874 + 0x00020000 (* StructureNotify *)
875 (* + 0x00040000 *) (* ResizeRedirect *)
876 (* + 0x00080000 *) (* SubstructureNotify *)
877 (* + 0x00100000 *) (* SubstructureRedirect *)
878 (* + 0x00200000 *) (* FocusChange *)
879 + 0x00400000 (* PropertyChange *)
880 (* + 0x00800000 *) (* ColormapChange *)
881 (* + 0x01000000 *) (* OwnerGrabButton *)
884 let s = createwindowreq wid root 0 0 w h 0 mask vid depth mid in
885 sendstr s sock;
887 sendintern
888 sock (~> "WM_PROTOCOLS") false (fun resp ->
889 state.protoatom <- r32 resp 8;
890 sendintern
891 sock (~> "WM_DELETE_WINDOW") false (fun resp ->
892 state.deleatom <- r32 resp 8;
893 let s = s32 state.deleatom in
894 let s = changepropreq wid state.protoatom 4 32 s in
895 sendstr s sock;
899 sendintern
900 sock (~> "WM_CLIENT_MACHINE") false (fun resp ->
901 let atom = r32 resp 8 in
902 let empty = E.s in
903 let hostname =
904 try Unix.gethostname ()
905 with exn ->
906 dolog "error getting host name: %s" @@ exntos exn;
907 empty
909 if hostname != empty
910 then
911 let s = changepropreq wid atom state.stringatom 8
912 (~> hostname) in
913 sendstr s sock;
914 sendintern
915 sock (~> "_NET_WM_PID") false (fun resp ->
916 let atom = r32 resp 8 in
917 let pid = Unix.getpid () in
918 let s = s32 pid in
919 let s = changepropreq wid atom 6(*cardinal*) 32 s in
920 sendstr s sock;
924 state.actwin <- (fun () ->
925 let s = Bytes.create 4 in
926 let s = configurewindowreq wid 0x40 s in
927 sendstr s state.sock;
928 let s = mapreq wid in
929 sendstr s state.sock;
932 sendintern
933 sock (~> "_NET_ACTIVE_WINDOW") true (fun resp ->
934 let atom = r32 resp 8 in
935 state.actwin <- (fun () ->
936 let data = Bytes.make 20 '\000' in
937 let cm = clientmessage 32 0 wid atom data in
938 let s = sendeventreq 0 root 0x180000 cm in
939 sendstr s state.sock;
943 syncsendintern
944 sock 2.0 (~> "WM_CLASS") false (fun resp ->
945 let atom = r32 resp 8 in
946 let llpp = ~> "llpp\000llpp\000" in
947 let s = changepropreq wid atom 31 8 llpp in
948 sendstr s sock;
951 let s = getkeymapreq state.mink (state.maxk-state.mink) in
952 sendwithrep sock s (updkmap sock);
954 let s = getmodifiermappingreq () in
955 sendwithrep sock s (updmodmap sock);
957 sendintern
958 sock (~> "UTF8_STRING") true (fun resp ->
959 let atom = r32 resp 8 in
960 if atom != 0
961 then state.stringatom <- atom;
964 let setwmname s =
965 let s = changepropreq wid 39 state.stringatom 8 s in
966 sendstr s state.sock;
968 state.setwmname <- setwmname;
969 sendintern
970 sock (~> "_NET_WM_NAME") true (fun resp ->
971 let atom = r32 resp 8 in
972 if atom != 0
973 then state.setwmname <- (fun s ->
974 setwmname s;
975 let s = changepropreq wid atom state.stringatom 8 s in
976 sendstr s state.sock;
980 state.fullscreen <- (fun wid ->
981 let s = Bytes.create 16 in
982 match state.fs with
983 | NoFs ->
984 w32 s 0 0;
985 w32 s 4 0;
986 w32 s 8 rootw;
987 w32 s 12 rooth;
988 let s = configurewindowreq wid 0x000f s in
989 sendstr s state.sock;
990 state.fs <- Fs (state.x, state.y, state.w, state.h);
992 | Fs (x, y, w, h) ->
993 w32 s 0 x;
994 w32 s 4 y;
995 w32 s 8 w;
996 w32 s 12 h;
997 let s = configurewindowreq wid 0x000f s in
998 sendstr s state.sock;
999 state.fs <- NoFs;
1002 sendintern
1003 sock (~> "_NET_WM_STATE") true (fun resp ->
1004 state.nwmsatom <- r32 resp 8;
1005 if state.nwmsatom != 0
1006 then (
1007 sendintern sock (~> "_NET_WM_STATE_MAXIMIZED_VERT") true (fun resp ->
1008 state.maxvatom <- r32 resp 8;
1010 sendintern sock (~> "_NET_WM_STATE_MAXIMIZED_HORZ") true (fun resp ->
1011 state.maxhatom <- r32 resp 8;
1013 sendintern
1014 sock (~> "_NET_WM_STATE_FULLSCREEN") true (fun resp ->
1015 state.fulsatom <- r32 resp 8;
1016 if state.fulsatom != 0
1017 then
1018 state.fullscreen <-
1019 (fun wid ->
1020 let data = Bytes.make 20 '\000' in
1021 let fs, f =
1022 match state.fs with
1023 | NoFs -> Fs (-1, -1, -1, -1), 1
1024 | Fs _ -> NoFs, 0
1026 w32 data 0 f;
1027 w32 data 4 state.fulsatom;
1029 let cm = clientmessage 32 0 wid state.nwmsatom data in
1030 let s = sendeventreq 0 root 0x180000 cm in
1031 sendstr s sock;
1032 state.fs <- fs;
1037 let s = queryextensionreq (~> "XKEYBOARD") in
1038 sendwithrep
1039 sock s (fun resp ->
1040 let present = r8 resp 8 in
1041 if present != 0
1042 then (
1043 let maj = r8 resp 9 in
1044 let s = Bytes.create 8 in
1045 w8 s 0 maj; (* XKB *)
1046 w8 s 1 0; (* XKBUseExtension *)
1047 w16 s 2 2; (* request-length *)
1048 w16 s 4 1; (* wantedMajor *)
1049 w16 s 6 0; (* watnedMinor *)
1050 sendwithrep
1051 sock s
1052 (fun resp ->
1053 let supported = r8 resp 1 in
1054 state.xkb <- supported != 0
1058 let s = getgeometryreq wid in
1059 syncsendwithrep sock 2.0 s (fun resp ->
1060 glxcompleteinit ();
1061 let w = r16 resp 16
1062 and h = r16 resp 18 in
1063 state.w <- w;
1064 state.h <- h;
1067 | c ->
1068 error "unknown connection setup response %d" (Char.code c)
1071 let getauth haddr dnum =
1072 let haddr =
1073 if emptystr haddr || haddr = "localhost"
1074 then
1075 try Unix.gethostname ()
1076 with exn ->
1077 dolog "failed to resolve `%S': %s" haddr @@ exntos exn;
1078 haddr
1079 else haddr
1081 let path =
1082 try Sys.getenv "XAUTHORITY"
1083 with Not_found ->
1084 try Filename.concat (Sys.getenv "HOME") ".Xauthority"
1085 with Not_found -> E.s
1087 let readauth ic =
1088 let r16be s =
1089 let rb pos = Char.code (Bytes.get s pos) in
1090 (rb 1) lor ((rb 0) lsl 8)
1092 let rec find () =
1093 let rs () =
1094 let s = really_input_string ic 2 in
1095 let n = r16be (~> s) in
1096 really_input_string ic n
1098 let family = really_input_string ic 2 in
1099 let addr = rs () in
1100 let nums = rs () in
1101 let optnum =
1102 try Some (int_of_string nums)
1103 with exn ->
1104 dolog
1105 "display number(%S) is not an integer (corrupt %S?): %s"
1106 nums path @@ exntos exn;
1107 None
1109 let name = rs () in
1110 let data = rs () in
1112 vlog "family %S addr %S(%S) num %S(%d) name %S data %S"
1113 family addr haddr nums dnum name data;
1114 match optnum with
1115 | Some num when addr = haddr && num = dnum ->
1116 name, data
1117 | _ -> find ()
1119 let name, data =
1120 try find ()
1121 with
1122 | End_of_file -> E.s, E.s
1123 | exn ->
1124 dolog "exception while reading X authority data (%S): %s"
1125 path @@ exntos exn;
1126 E.s, E.s
1128 close_in ic;
1129 name, data;
1131 if emptystr path
1132 then E.s, E.s
1133 else
1134 match open_in_bin path with
1135 | ic -> readauth ic
1136 | exception exn ->
1137 dolog "failed to open X authority file `%S' : %s" path @@ exntos exn;
1138 E.s, E.s
1141 let init t rootwid w h platform =
1142 let d =
1143 try Sys.getenv "DISPLAY"
1144 with exn ->
1145 error "cannot get DISPLAY evironment variable: %s" @@ exntos exn
1147 let getnum w b e =
1148 if b = e
1149 then error "invalid DISPLAY(%s) %S" w d
1150 else
1151 let s = String.sub d b (e - b) in
1152 try int_of_string s
1153 with exn ->
1154 error "invalid DISPLAY %S can not parse %s(%S): %s"
1155 d w s @@ exntos exn
1157 let rec phost pos =
1158 if pos = String.length d
1159 then error "invalid DISPLAY %S no display number specified" d
1160 else (
1161 if d.[pos] = ':'
1162 then
1163 let rec pdispnum pos1 =
1164 if pos1 = String.length d
1165 then getnum "display number" (pos+1) pos1, 0
1166 else
1167 match d.[pos1] with
1168 | '.' ->
1169 let dispnum = getnum "display number" (pos+1) pos1 in
1170 let rec pscreennum pos2 =
1171 if pos2 = String.length d
1172 then getnum "screen number" (pos1+1) pos2
1173 else
1174 match d.[pos2] with
1175 | '0' .. '9' -> pscreennum (pos2+1)
1176 | _ ->
1177 error "invalid DISPLAY %S, cannot parse screen number" d
1179 dispnum, pscreennum (pos1+1)
1180 | '0' .. '9' -> pdispnum (pos1+1)
1181 | _ ->
1182 error "invalid DISPLAY %S, cannot parse display number" d
1184 String.sub d 0 pos, pdispnum (pos+1)
1185 else phost (pos+1)
1188 let host, (dispnum, screennum) = phost 0 in
1189 let aname, adata = getauth host dispnum in
1190 let fd =
1191 let fd, addr =
1192 if emptystr host || host.[0] = '/' || host = "unix"
1193 then
1194 let addr =
1195 match platform with
1196 | Utils.Posx -> Unix.ADDR_UNIX d
1197 | Utils.Plinux ->
1198 Unix.ADDR_UNIX ("\000/tmp/.X11-unix/X" ^ string_of_int dispnum)
1199 | Utils.Punknown | Utils.Psun | Utils.Pbsd | Utils.Pcygwin ->
1200 Unix.ADDR_UNIX ("/tmp/.X11-unix/X" ^ string_of_int dispnum)
1202 Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0, addr
1203 else
1204 let h =
1205 try Unix.gethostbyname host
1206 with exn -> error "cannot resolve %S: %s" host @@ exntos exn
1208 let addr = h.Unix.h_addr_list.(0) in
1209 let port = 6000 + dispnum in
1210 let fd = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
1211 fd, (Unix.ADDR_INET (addr, port))
1213 try Unix.connect fd addr; fd
1214 with exn -> error "failed to connect to X: %s" @@ exntos exn
1216 cloexec fd;
1217 let s = Bytes.create 12 in
1218 let s = padcat s (~> aname) in
1219 let s = padcat s (~> adata) in
1220 Bytes.set s 0 ordermagic;
1221 w16 s 2 11;
1222 w16 s 4 0;
1223 w16 s 6 (String.length aname);
1224 w16 s 8 (String.length adata);
1225 sendstr1 s 0 (Bytes.length s) fd;
1226 state.sock <- fd;
1227 setup d fd rootwid screennum w h;
1228 state.t <- t;
1229 fd, state.w, state.h;
1232 let settitle s =
1233 state.setwmname (~> s);
1236 let setcursor cursor =
1237 if cursor != state.curcurs
1238 then (
1239 setcursor cursor;
1240 state.curcurs <- cursor;
1244 let fullscreen () =
1245 state.fullscreen state.wid;
1248 let metamask = 0x40;;
1249 let altmask = 8;;
1250 let shiftmask = 1;;
1251 let ctrlmask = 4;;
1253 let withalt mask = mask land altmask != 0;;
1254 let withctrl mask = mask land ctrlmask != 0;;
1255 let withshift mask = mask land shiftmask != 0;;
1256 let withmeta mask = mask land metamask != 0;;
1257 let withnone mask = mask land (altmask + ctrlmask + shiftmask + metamask) = 0;;
1259 let xlatt, xlatf =
1260 let t = Hashtbl.create 20
1261 and f = Hashtbl.create 20 in
1262 let add n nl k =
1263 List.iter (fun s -> Hashtbl.add t s k) (n::nl);
1264 Hashtbl.add f k n
1266 let addc c =
1267 let s = String.make 1 c in
1268 add s [] (Char.code c)
1270 let addcr a b =
1271 let an = Char.code a and bn = Char.code b in
1272 for i = an to bn do addc (Char.chr i) done;
1274 addcr '0' '9';
1275 addcr 'a' 'z';
1276 addcr 'A' 'Z';
1277 String.iter addc "`~!@#$%^&*()-_=+\\|[{]};:,./<>?";
1278 for i = 0 to 29 do add ("f" ^ string_of_int (i+1)) [] (0xffbe + i) done;
1279 add "space" [] 0x20;
1280 add "ret" ["return"; "enter"] 0xff0d;
1281 add "tab" [] 0xff09;
1282 add "left" [] 0xff51;
1283 add "right" [] 0xff53;
1284 add "home" [] 0xff50;
1285 add "end" [] 0xff57;
1286 add "ins" ["insert"] 0xff63;
1287 add "del" ["delete"] 0xffff;
1288 add "esc" ["escape"] 0xff1b;
1289 add "pgup" ["pageup"] 0xff55;
1290 add "pgdown" ["pagedown"] 0xff56;
1291 add "backspace" [] 0xff08;
1292 add "up" [] 0xff52;
1293 add "down" [] 0xff54;
1294 add "menu" [] 0xff67;
1295 t, f;
1298 let keyname k =
1299 try Hashtbl.find xlatf k
1300 with Not_found -> Printf.sprintf "%#x" k;
1303 let namekey name =
1304 try Hashtbl.find xlatt name
1305 with Not_found ->
1306 if String.length name = 1
1307 then Char.code name.[0]
1308 else int_of_string name;
1311 let kc2kt =
1312 let open Keys in
1313 function
1314 | 0xff08 -> Backspace
1315 | 0xff0d -> Enter
1316 | 0xff1b -> Escape
1317 | 0xff50 -> Home
1318 | 0xff51 -> Left
1319 | 0xff52 -> Up
1320 | 0xff53 -> Right
1321 | 0xff54 -> Down
1322 | 0xff55 -> Prior
1323 | 0xff56 -> Next
1324 | 0xff57 -> End
1325 | 0xff63 -> Insert
1326 | 0xff8d -> Enter
1327 | 0xff95 -> Home
1328 | 0xff96 -> Left
1329 | 0xff97 -> Up
1330 | 0xff98 -> Right
1331 | 0xff99 -> Down
1332 | 0xff9a -> Prior
1333 | 0xff9b -> Next
1334 | 0xff9c -> End
1335 | 0xff9f -> Delete
1336 | 0xffab -> Ascii '+'
1337 | 0xffad -> Ascii '-'
1338 | 0xffff -> Delete
1339 | code when code > 31 && code < 128 -> Ascii (Char.unsafe_chr code)
1340 | code when code >= 0xffb0 && code <= 0xffb9 ->
1341 Ascii (Char.unsafe_chr (code - 0xffb0 + 0x30))
1342 | code when code >= 0xffbe && code <= 0xffc8 -> Fn (code - 0xffbe + 1)
1343 | code -> Code code