Properly initialize parameters
[llpp.git] / wsi.ml
blobd85f5a7c8325dbd30576deb2075833c1aa8a2c19
1 open Utils;;
3 let (~>) = Bytes.unsafe_of_string;;
5 type cursor =
6 | CURSOR_INHERIT
7 | CURSOR_INFO
8 | CURSOR_CYCLE
9 | CURSOR_CROSSHAIR
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";;
31 let vlog fmt = Format.ksprintf ignore fmt;;
33 let onot = object
34 method display = ()
35 method map _ = ()
36 method expose = ()
37 method visible _ = ()
38 method reshape _ _ = ()
39 method mouse _ _ _ _ _ = ()
40 method motion _ _ = ()
41 method pmotion _ _ = ()
42 method key _ _ = ()
43 method enter _ _ = ()
44 method leave = ()
45 method winstate _ = ()
46 method quit = exit 0
47 end;;
49 class type t = object
50 method display : unit
51 method map : bool -> unit
52 method expose : unit
53 method visible : visiblestate -> unit
54 method reshape : int -> int -> unit
55 method mouse : int -> bool -> int -> int -> int -> unit
56 method motion : int -> int -> unit
57 method pmotion : int -> int -> unit
58 method key : int -> int -> unit
59 method enter : int -> int -> unit
60 method leave : unit
61 method winstate : winstate list -> unit
62 method quit : unit
63 end;;
65 type state =
66 { mutable mink : int
67 ; mutable maxk : int
68 ; mutable keymap : int array array
69 ; fifo : (bytes -> unit) Queue.t
70 ; mutable seq : int
71 ; mutable protoatom : atom
72 ; mutable deleatom : atom
73 ; mutable nwmsatom : atom
74 ; mutable maxvatom : atom
75 ; mutable maxhatom : atom
76 ; mutable fulsatom : atom
77 ; mutable idbase : int
78 ; mutable wid : int
79 ; mutable fid : int
80 ; mutable fullscreen : (int -> unit)
81 ; mutable setwmname : (bytes -> unit)
82 ; mutable actwin : (unit -> unit)
83 ; mutable stringatom : int
84 ; mutable t : t
85 ; mutable sock : Unix.file_descr
86 ; mutable x : int
87 ; mutable y : int
88 ; mutable w : int
89 ; mutable h : int
90 ; mutable fs : fs
91 ; mutable curcurs : cursor
92 ; mutable capslmask : int
93 ; mutable numlmask : int
94 ; mutable levl3mask : int
95 ; mutable levl5mask : int
96 ; mutable xkb : bool
98 and fs =
99 | NoFs
100 | Fs of (int * int * int * int)
103 let state =
104 { mink = max_int
105 ; maxk = min_int
106 ; keymap = E.a
107 ; fifo = Queue.create ()
108 ; seq = 0
109 ; protoatom = -1
110 ; deleatom = -1
111 ; nwmsatom = -1
112 ; maxvatom = -1
113 ; maxhatom = -1
114 ; fulsatom = -1
115 ; idbase = -1
116 ; wid = -1
117 ; fid = -1
118 ; fullscreen = (fun _ -> ())
119 ; setwmname = (fun _ -> ())
120 ; actwin = (fun _ -> ())
121 ; sock = Unix.stdin
122 ; t = onot
123 ; x = -1
124 ; y = -1
125 ; w = -1
126 ; h = -1
127 ; fs = NoFs
128 ; stringatom = 31
129 ; curcurs = CURSOR_INHERIT
130 ; capslmask = 0
131 ; numlmask = 0
132 ; levl3mask = 0
133 ; levl5mask = 0
134 ; xkb = false
138 include Bo;;
140 let makereq opcode len reqlen =
141 let s = Bytes.create len in
142 w8 s 0 opcode;
143 w16 s 2 reqlen;
147 let recv fd s pos len =
148 Unix.read fd s pos len;
151 let readstr sock n =
152 let s = Bytes.create n in
153 let rec loop pos n =
154 let m = tempfailureretry (recv sock s pos) n in
155 if m = 0
156 then state.t#quit;
157 if n != m
158 then (
159 ignore (tempfailureretry (Unix.select [sock] [] []) 0.01);
160 loop (pos + m) (n - m)
163 loop 0 n;
167 let sendstr1 s pos len sock =
168 let s = Bytes.unsafe_to_string s in
169 vlog "%d <= %S" state.seq s;
170 state.seq <- state.seq + 1;
171 let n = tempfailureretry (Unix.write_substring sock s pos) len in
172 if n != len
173 then error "send %d returned %d" len n;
176 let updkmap sock resp =
177 let syms = r8 resp 1 in
178 let len = r32 resp 4 in
179 let data =
180 if len > 0
181 then readstr sock (4*len)
182 else E.b
184 let m = len / syms in
185 state.keymap <- Array.make_matrix
186 (state.maxk - state.mink) syms 0xffffff;
187 let rec loop i = if i = m then () else
188 let k = i*4*syms in
189 let rec loop2 k l = if l = syms then () else
190 let v = r32 data k in
191 state.keymap.(i).(l) <- v;
192 loop2 (k+4) (l+1)
194 loop2 k 0;
195 loop (i+1);
197 loop 0;
200 let updmodmap sock resp =
201 let n = r8 resp 1 in
202 let len = r16 resp 4 in
203 let data =
204 if len > 0
205 then readstr sock (len*4)
206 else E.b
208 if len > 0 then (*???*)
209 let modmap = Array.make_matrix 8 n 0xffffff in
210 let rec loop l = if l = 8 then () else
211 let p = l*n in
212 let rec loop1 m = if m = n then () else
213 let p = p+m in
214 let code = r8 data p in
215 modmap.(l).(m) <- code;
216 if l = 1
217 then (
218 let ki = code - state.mink in
219 if ki >= 0
220 then
221 let a = state.keymap.(ki) in
222 let rec capsloop i = if i = Array.length a || i > 3 then () else
223 let s = a.(i) in
224 if s = 0xffe5
225 then state.capslmask <- 2
226 else capsloop (i+1)
228 capsloop 0;
230 else (
231 if l > 3
232 then (
233 let ki = code - state.mink in
234 if ki >= 0
235 then
236 let a = state.keymap.(ki) in
237 let rec lloop i = if i = Array.length a || i > 3 then () else
238 let s = a.(i) in
239 match s with
240 | 0xfe03 -> state.levl3mask <- 1 lsl l
241 | 0xfe11 -> state.levl5mask <- 1 lsl l
242 | 0xff7f -> state.numlmask <- 1 lsl l
243 | _ -> lloop (i+1)
245 lloop 0;
248 loop1 (m+1)
250 loop1 0;
251 loop (l+1)
253 loop 0;
256 let sendwithrep sock s f =
257 Queue.push f state.fifo;
258 sendstr1 s 0 (Bytes.length s) sock;
261 let padcatl =
262 let pad = "123" in
263 fun ss ->
264 let b = Buffer.create 16 in
265 List.iter (Buffer.add_bytes b) ss;
266 let bl = Buffer.length b in
267 let pl = bl land 3 in
268 if pl != 0
269 then (
270 Buffer.add_substring b pad 0 (4 - pl);
272 Buffer.to_bytes b;
275 let padcat s1 s2 = padcatl [s1; s2];;
277 let internreq name onlyifexists =
278 let s = makereq 16 8 8 in
279 let s = padcat s name in
280 w8 s 1 (if onlyifexists then 1 else 0);
281 w16 s 2 (Bytes.length s / 4);
282 w16 s 4 (Bytes.length name);
286 let sendintern sock s onlyifexists f =
287 let s = internreq s onlyifexists in
288 sendwithrep sock s f;
291 let createwindowreq wid parent x y w h bw eventmask vid depth mid =
292 let s = makereq 1 48 12 in
293 w8 s 1 depth;
294 w32 s 4 wid;
295 w32 s 8 parent;
296 w16 s 12 x;
297 w16 s 14 y;
298 w16 s 16 w;
299 w16 s 18 h;
300 w16 s 20 bw;
301 w16 s 22 0; (* copyfromparent *)
302 w32 s 24 vid; (* visual *)
303 w32 s 28 0x280a; (* valuemask =
304 | background pixel
305 | border pixel
306 | event mask
307 | colormap *)
308 w32 s 32 0; (* background pixel *)
309 w32 s 36 0; (* border pixel*)
310 w32 s 40 eventmask;
311 w32 s 44 mid;
315 let createcolormapreq mid wid vid =
316 let s = makereq 78 16 4 in
317 w8 s 1 0;
318 w32 s 4 mid;
319 w32 s 8 wid;
320 w32 s 12 vid;
324 let getgeometryreq wid =
325 let s = makereq 14 8 2 in
326 w32 s 4 wid;
330 let mapreq wid =
331 let s = makereq 8 8 2 in
332 w32 s 4 wid;
336 let getkeymapreq first count =
337 let s = makereq 101 8 2 in
338 w8 s 4 first;
339 w8 s 5 count;
343 let changepropreq wid prop typ format props =
344 let s = makereq 18 24 0 in
345 let s = padcat s props in
346 w8 s 1 0;
347 w16 s 2 (Bytes.length s / 4);
348 w32 s 4 wid;
349 w32 s 8 prop;
350 w32 s 12 typ;
351 w8 s 16 format;
352 let ful = Bytes.length props / (match format with
353 | 8 -> 1
354 | 16 -> 2
355 | 32 -> 4
356 | n -> error "no idea what %d means" n)
358 w32 s 20 ful;
362 let getpropreq delete wid prop typ =
363 let s = makereq 20 24 6 in
364 w8 s 1 (if delete then 1 else 0);
365 w32 s 4 wid;
366 w32 s 8 prop;
367 w32 s 12 typ;
368 w32 s 16 0;
369 w32 s 20 2;
373 let openfontreq fid name =
374 let s = makereq 45 12 0 in
375 let s = padcat s name in
376 w16 s 2 (Bytes.length s / 4);
377 w32 s 4 fid;
378 w16 s 8 (Bytes.length name);
382 let createglyphcursorreq fid cid cindex =
383 let s = makereq 94 32 8 in
384 w32 s 4 cid;
385 w32 s 8 fid;
386 w32 s 12 fid;
387 w16 s 16 cindex;
388 w16 s 18 (cindex+1);
389 w16 s 20 0;
390 w16 s 22 0;
391 w16 s 24 0;
392 w16 s 26 0xffff;
393 w16 s 28 0xffff;
394 w16 s 30 0xffff;
398 let changewindowattributesreq wid mask attrs =
399 let s = makereq 2 12 0 in
400 let s = padcat s attrs in
401 w16 s 2 (Bytes.length s / 4);
402 w32 s 4 wid;
403 w32 s 8 mask;
407 let configurewindowreq wid mask values =
408 let s = makereq 12 12 0 in
409 let s = padcat s values in
410 w16 s 2 (Bytes.length s / 4);
411 w32 s 4 wid;
412 w16 s 8 mask;
416 let s32 n =
417 let s = Bytes.create 4 in
418 w32 s 0 n;
422 let clientmessage format seq wid typ data =
423 let s = makereq 33 12 0 in
424 let s = padcat s data in
425 w8 s 1 format;
426 w16 s 2 seq;
427 w32 s 4 wid;
428 w32 s 8 typ;
432 let sendeventreq propagate destwid mask data =
433 let s = makereq 25 12 11 in
434 let s = padcat s data in
435 w8 s 1 propagate;
436 w16 s 2 11;
437 w32 s 4 destwid;
438 w32 s 8 mask;
442 let getmodifiermappingreq () =
443 makereq 119 4 1;
446 let queryextensionreq name =
447 let s = makereq 98 8 0 in
448 let s = padcat s name in
449 w16 s 2 (Bytes.length s / 4);
450 w16 s 4 (Bytes.length name);
454 let getkeysym pkpk code mask =
455 if (pkpk >= 0xff80 && pkpk <= 0xffbd)
456 || (pkpk >= 0x11000000 && pkpk <= 0x1100ffff)
457 then (
458 if mask land state.numlmask != 0
459 then
460 let keysym = state.keymap.(code-state.mink).(1) in
461 if keysym = 0 then pkpk else keysym
462 else pkpk
464 else (
465 let shift =
466 if pkpk land 0xf000 = 0xf000
467 then 0
468 else (mask land 1) lxor ((mask land state.capslmask) lsr 1)
470 let index =
471 if state.xkb && mask land 0x2000 != 0
472 then
473 shift + 2
474 else
475 let l3 = (mask land state.levl3mask) != 0 in
476 let l4 = (mask land state.levl5mask) != 0 in
477 shift +
478 if l3 then (if l4 then 8 else 4) else (if l4 then 6 else 0)
480 let keysym = state.keymap.(code-state.mink).(index) in
481 if index land 1 = 1 && keysym = 0
482 then state.keymap.(code-state.mink).(index - 1)
483 else keysym
487 let getkeysym code mask =
488 let pkpk = state.keymap.(code-state.mink).(0) in
489 if state.xkb && pkpk lsr 8 = 0xfe (* XKB *)
490 then 0
491 else getkeysym pkpk code mask
494 let readresp sock =
495 let resp = readstr sock 32 in
496 let opcode = r8 resp 0 in
497 match opcode land lnot 0x80 with
498 | 0 -> (* error *)
499 let s = resp in
500 let code = r8 s 1
501 and serial = r16 s 2
502 and resid = r32 resp 4
503 and min = r16 s 8
504 and maj = r8 s 10 in
505 error "code=%d serial=%d resid=%#x min=%d maj=%d\n%S"
506 code serial resid min maj (Bytes.unsafe_to_string resp);
508 | 1 -> (* response *)
509 let rep = Queue.pop state.fifo in
510 rep resp;
512 | 2 -> (* key press *)
513 if Array.length state.keymap > 0
514 then
515 let code = r8 resp 1 in
516 let mask = r16 resp 28 in
517 let keysym = getkeysym code mask in
518 vlog "keysym = %x %c mask %#x code %d"
519 keysym (Char.unsafe_chr keysym) mask code;
520 state.t#key keysym mask;
522 | 3 -> (* key release *)
523 if Array.length state.keymap > 0
524 then
525 let code = r8 resp 1 in
526 let mask = r16 resp 28 in
527 let keysym = getkeysym code mask in
528 vlog "release keysym = %x %c mask %#x code %#d"
529 keysym (Char.unsafe_chr keysym) mask code
531 | 4 -> (* buttonpress *)
532 let n = r8 resp 1
533 and x = r16s resp 24
534 and y = r16s resp 26
535 and m = r16 resp 28 in
536 state.t#mouse n true x y m;
537 vlog "press %d" n
539 | 5 -> (* buttonrelease *)
540 let n = r8 resp 1
541 and x = r16s resp 24
542 and y = r16s resp 26
543 and m = r16 resp 28 in
544 state.t#mouse n false x y m;
545 vlog "release %d %d %d" n x y
547 | 6 -> (* motion *)
548 let x = r16s resp 24 in
549 let y = r16s resp 26 in
550 let m = r16 resp 28 in
551 if m land 0x1f00 = 0
552 then state.t#pmotion x y
553 else state.t#motion x y;
554 vlog "move %dx%d => %d" x y m
556 | 7 -> (* enter *)
557 let x = r16s resp 24
558 and y = r16s resp 26 in
559 state.t#enter x y;
560 vlog "enter %d %d" x y
562 | 8 -> (* leave *)
563 state.t#leave
565 | 18 -> (* unmap *)
566 state.t#map false;
567 vlog "unmap";
569 | 19 -> (* map *)
570 state.t#map true;
571 vlog "map";
573 | 12 -> (* exposure *)
574 vlog "exposure";
575 state.t#expose
577 | 15 -> (* visibility *)
578 let v = r8 resp 8 in
579 let vis =
580 match v with
581 | 0 -> Unobscured
582 | 1 -> PartiallyObscured
583 | 2 -> FullyObscured
584 | _ ->
585 dolog "unknown visibility %d" v;
586 Unobscured
588 state.t#visible vis;
589 vlog "visibility %d" v;
591 | 34 -> (* mapping *)
592 state.keymap <- E.a;
593 let s = getkeymapreq state.mink (state.maxk-state.mink-1) in
594 sendwithrep sock s (updkmap sock);
595 state.capslmask <- 0;
596 state.levl3mask <- 0;
597 state.levl5mask <- 0;
598 state.numlmask <- 0;
599 let s = getmodifiermappingreq () in
600 sendwithrep sock s (updmodmap sock);
602 | 33 -> (* clientmessage *)
603 let atom = r32 resp 8 in
604 if atom = state.protoatom
605 then (
606 let atom = r32 resp 12 in
607 if atom = state.deleatom
608 then state.t#quit;
610 vlog "atom %#x" atom
612 | 21 -> (* reparent *)
613 vlog "reparent"
615 | 22 -> (* configure *)
616 let x = r16s resp 16
617 and y = r16s resp 18
618 and w = r16 resp 20
619 and h = r16 resp 22 in
620 vlog "configure cur [%d %d %d %d] conf [%d %d %d %d]"
621 state.x state.y state.w state.h
622 x y w h
624 if w != state.w || h != state.h
625 then (
626 state.t#reshape w h;
628 state.w <- w;
629 state.h <- h;
630 state.x <- x;
631 state.y <- y;
632 state.t#expose
634 | 28 ->
635 let atom = r32 resp 8 in
636 if atom = state.nwmsatom
637 then
638 let s = getpropreq false state.wid atom 4 in
639 sendwithrep sock s (fun resp ->
640 let len = r32 resp 4 in
641 let nitems = r32 resp 16 in
642 let wsl =
643 if len = 0
644 then []
645 else
646 let s = readstr sock (len*4) in
647 let rec loop wsl i = if i = nitems then wsl else
648 let atom = r32 s (i*4) in
649 let wsl =
650 if atom = state.maxhatom
651 then MaxHorz::wsl
652 else (
653 if atom = state.maxvatom
654 then MaxVert::wsl
655 else (
656 if atom = state.fulsatom
657 then (
658 state.fs <- Fs (state.x, state.y, state.w, state.h);
659 Fullscreen::wsl
661 else wsl
664 in loop wsl (i+1)
666 loop [] 0
668 state.t#winstate (List.sort compare wsl)
671 | n ->
672 dolog "event %d %S" n (Bytes.unsafe_to_string resp)
675 let readresp sock =
676 let rec loop () =
677 readresp sock;
678 if hasdata sock then loop ();
680 loop ();
683 let sendstr s ?(pos=0) ?(len=Bytes.length s) sock =
684 sendstr1 s pos len sock;
685 if hasdata sock then readresp sock;
688 let reshape w h =
689 if state.fs = NoFs
690 then
691 let s = Bytes.create 8 in
692 w32 s 0 w;
693 w32 s 4 h;
694 let s = configurewindowreq state.wid 0x000c s in
695 sendstr s state.sock;
696 else state.fullscreen state.wid
699 let activatewin () =
700 state.actwin ();
703 let syncsendwithrep sock secstowait s f =
704 let completed = ref false in
705 sendwithrep sock s (fun resp -> f resp; completed := true);
706 let now = Unix.gettimeofday in
707 let deadline = now () +. secstowait in
708 let rec readtillcompletion () =
709 let sf deadline =
710 let timeout = deadline -. now () in
711 if timeout <= 0.0
712 then [], [], []
713 else Unix.select [sock] [] [] timeout
715 let r, _, _ = tempfailureretry sf deadline in
716 match r with
717 | [] -> error "didn't get X response in %f seconds, aborting" secstowait
718 | _ ->
719 readresp sock;
720 if not !completed
721 then readtillcompletion ()
723 readtillcompletion ();
726 let mapwin () =
727 let s = mapreq state.wid in
728 sendstr s state.sock;
731 let syncsendintern sock secstowait s onlyifexists f =
732 let s = internreq s onlyifexists in
733 syncsendwithrep sock secstowait s f;
736 let setup disp sock rootwid screennum w h =
737 let s = readstr sock 2 in
738 let n = Bytes.length s in
739 if n != 2
740 then error "failed to read X connection setup response n=%d" n;
741 match Bytes.get s 0 with
742 | '\000' ->
743 let reasonlen = r8 s 1 in
744 let s = readstr sock 6 in
745 let maj = r16 s 0
746 and min = r16 s 2
747 and add = r16 s 4 in
748 let len = add*4 in
749 let data = readstr sock len in
750 let reason = Bytes.sub data 0 reasonlen in
751 error "X connection failed maj=%d min=%d reason=%S"
752 maj min (Bytes.unsafe_to_string reason)
754 | '\002' -> failwith "X connection setup failed: authentication required";
756 | '\001' ->
757 let s = readstr sock 38 in
758 let maj = r16 s 0
759 and min = r16 s 2
760 and add = r16 s 4
761 and idbase = r32 s 10
762 and idmask = r32 s 14
763 and vlen = r16 s 22
764 and screens = r8 s 26
765 and formats = r8 s 27
766 and minkk = r8 s 32
767 and maxkk = r8 s 33 in
768 let data = readstr sock (4*add-32) in
769 let vendor = Bytes.sub data 0 vlen in
770 let pos = ((vlen+3) land lnot 3) + formats*8 in
772 if screennum >= screens
773 then error "invalid screen %d, max %d" screennum (screens-1);
775 let pos =
776 let rec findscreen n pos = if n = screennum then pos else
777 let pos =
778 let ndepths = r8 data (pos+39) in
779 let rec skipdepths n pos = if n = ndepths then pos else
780 let pos =
781 let nvisiuals = r16 data (pos+2) in
782 pos + nvisiuals*24 + 8
784 skipdepths (n+1) pos
786 skipdepths n (pos+40)
788 findscreen (n+1) pos
790 findscreen 0 pos
792 let root = if rootwid = 0 then r32 data pos else rootwid in
793 let rootw = r16 data (pos+20)
794 and rooth = r16 data (pos+22)
795 and rootdepth = r8 data (pos+38)in
797 state.mink <- minkk;
798 state.maxk <- maxkk;
799 state.idbase <- idbase;
800 vlog "vendor = %S, maj=%d min=%d" (Bytes.unsafe_to_string vendor) maj min;
801 vlog "screens = %d formats = %d" screens formats;
802 vlog "minkk = %d maxkk = %d" minkk maxkk;
803 vlog "idbase = %#x idmask = %#x" idbase idmask;
804 vlog "root=%#x %dx%d" root rootw rooth;
805 vlog "wmm = %d, hmm = %d" (r16 data (pos+24)) (r16 data (pos+26));
806 vlog "visualid = %#x " (r32 data (pos+32));
807 vlog "root depth = %d" rootdepth;
809 let wid = state.idbase in
810 let mid = wid+1 in
811 let fid = mid+1 in
813 state.wid <- wid;
814 state.fid <- fid;
816 let vid = glxinit disp wid screennum in
817 let ndepths = r8 data (pos+39) in
818 let rec finddepth n' pos =
819 if n' = ndepths
820 then error "couldn't find depth for visual %#x" vid;
821 let depth = r8 data pos in
822 let nvisuals = r16 data (pos+2) in
823 let rec findvisual n pos =
824 if n = nvisuals
825 then finddepth (n'+1) pos
826 else
827 let id = r32 data pos in
828 if id = vid
829 then depth
830 else findvisual (n+1) (pos+24)
832 findvisual 0 (pos+8)
834 let depth = finddepth 0 (pos+40) in
836 let s = createcolormapreq mid root vid in
837 sendstr s sock;
839 let mask = 0
840 + 0x00000001 (* KeyPress *)
841 (* + 0x00000002 *) (* KeyRelease *)
842 + 0x00000004 (* ButtonPress *)
843 + 0x00000008 (* ButtonRelease *)
844 + 0x00000010 (* EnterWindow *)
845 + 0x00000020 (* LeaveWindow *)
846 + 0x00000040 (* PointerMotion *)
847 (* + 0x00000080 *) (* PointerMotionHint *)
848 (* + 0x00000100 *) (* Button1Motion *)
849 (* + 0x00000200 *) (* Button2Motion *)
850 (* + 0x00000400 *) (* Button3Motion *)
851 (* + 0x00000800 *) (* Button4Motion *)
852 (* + 0x00001000 *) (* Button5Motion *)
853 + 0x00002000 (* ButtonMotion *)
854 (* + 0x00004000 *) (* KeymapState *)
855 + 0x00008000 (* Exposure *)
856 + 0x00010000 (* VisibilityChange *)
857 + 0x00020000 (* StructureNotify *)
858 (* + 0x00040000 *) (* ResizeRedirect *)
859 (* + 0x00080000 *) (* SubstructureNotify *)
860 (* + 0x00100000 *) (* SubstructureRedirect *)
861 (* + 0x00200000 *) (* FocusChange *)
862 + 0x00400000 (* PropertyChange *)
863 (* + 0x00800000 *) (* ColormapChange *)
864 (* + 0x01000000 *) (* OwnerGrabButton *)
867 let s = createwindowreq wid root 0 0 w h 0 mask vid depth mid in
868 sendstr s sock;
870 sendintern sock (~> "WM_PROTOCOLS") false (fun resp ->
871 state.protoatom <- r32 resp 8;
872 sendintern
873 sock (~> "WM_DELETE_WINDOW") false (fun resp ->
874 state.deleatom <- r32 resp 8;
875 let s = s32 state.deleatom in
876 let s = changepropreq wid state.protoatom 4 32 s in
877 sendstr s sock;
881 sendintern sock (~> "WM_CLIENT_MACHINE") false (fun resp ->
882 let atom = r32 resp 8 in
883 let empty = E.s in
884 let hostname =
885 try Unix.gethostname ()
886 with exn ->
887 dolog "error getting host name: %s" (exntos exn);
888 empty
890 if hostname != empty
891 then
892 let s = changepropreq wid atom state.stringatom 8
893 (~> hostname) in
894 sendstr s sock;
895 sendintern sock (~> "_NET_WM_PID") false (fun resp ->
896 let atom = r32 resp 8 in
897 let pid = Unix.getpid () in
898 let s = s32 pid in
899 let s = changepropreq wid atom 6(*cardinal*) 32 s in
900 sendstr s sock;
904 state.actwin <- (fun () ->
905 let s = Bytes.create 4 in
906 let s = configurewindowreq wid 0x40 s in
907 sendstr s state.sock;
908 let s = mapreq wid in
909 sendstr s state.sock;
912 sendintern sock (~> "_NET_ACTIVE_WINDOW") true (fun resp ->
913 let atom = r32 resp 8 in
914 state.actwin <- (fun () ->
915 let data = Bytes.make 20 '\000' in
916 let cm = clientmessage 32 0 wid atom data in
917 let s = sendeventreq 0 root 0x180000 cm in
918 sendstr s state.sock;
922 syncsendintern sock 2.0 (~> "WM_CLASS") false (fun resp ->
923 let atom = r32 resp 8 in
924 let llpp = ~> "llpp\000llpp\000" in
925 let s = changepropreq wid atom 31 8 llpp in
926 sendstr s sock;
929 let s = getkeymapreq state.mink (state.maxk-state.mink) in
930 sendwithrep sock s (updkmap sock);
932 let s = getmodifiermappingreq () in
933 sendwithrep sock s (updmodmap sock);
935 let s = openfontreq fid (~> "cursor") in
936 sendstr s sock;
938 Array.iteri (fun i glyphindex ->
939 let s = createglyphcursorreq fid (fid+1+i) glyphindex in
940 sendstr s sock;
941 ) [|34;48;50;58;128;152|];
943 sendintern sock (~> "UTF8_STRING") true (fun resp ->
944 let atom = r32 resp 8 in
945 if atom != 0
946 then state.stringatom <- atom;
949 let setwmname s =
950 let s = changepropreq wid 39 state.stringatom 8 s in
951 sendstr s state.sock;
953 state.setwmname <- setwmname;
954 sendintern sock (~> "_NET_WM_NAME") true (fun resp ->
955 let atom = r32 resp 8 in
956 if atom != 0
957 then state.setwmname <- (fun s ->
958 setwmname s;
959 let s = changepropreq wid atom state.stringatom 8 s in
960 sendstr s state.sock;
964 state.fullscreen <- (fun wid ->
965 let s = Bytes.create 16 in
966 match state.fs with
967 | NoFs ->
968 w32 s 0 0;
969 w32 s 4 0;
970 w32 s 8 rootw;
971 w32 s 12 rooth;
972 let s = configurewindowreq wid 0x000f s in
973 sendstr s state.sock;
974 state.fs <- Fs (state.x, state.y, state.w, state.h);
976 | Fs (x, y, w, h) ->
977 w32 s 0 x;
978 w32 s 4 y;
979 w32 s 8 w;
980 w32 s 12 h;
981 let s = configurewindowreq wid 0x000f s in
982 sendstr s state.sock;
983 state.fs <- NoFs;
986 sendintern sock (~> "_NET_WM_STATE") true (fun resp ->
987 state.nwmsatom <- r32 resp 8;
988 if state.nwmsatom != 0
989 then (
990 sendintern sock (~> "_NET_WM_STATE_MAXIMIZED_VERT") true (fun resp ->
991 state.maxvatom <- r32 resp 8;
993 sendintern sock (~> "_NET_WM_STATE_MAXIMIZED_HORZ") true (fun resp ->
994 state.maxhatom <- r32 resp 8;
996 sendintern sock (~> "_NET_WM_STATE_FULLSCREEN") true (fun resp ->
997 state.fulsatom <- r32 resp 8;
998 if state.fulsatom != 0
999 then
1000 state.fullscreen <-
1001 (fun wid ->
1002 let data = Bytes.make 20 '\000' in
1003 let fs, f =
1004 match state.fs with
1005 | NoFs -> Fs (-1, -1, -1, -1), 1
1006 | Fs _ -> NoFs, 0
1008 w32 data 0 f;
1009 w32 data 4 state.fulsatom;
1011 let cm = clientmessage 32 0 wid state.nwmsatom data in
1012 let s = sendeventreq 0 root 0x180000 cm in
1013 sendstr s sock;
1014 state.fs <- fs;
1019 let s = queryextensionreq (~> "XKEYBOARD") in
1020 sendwithrep
1021 sock s (fun resp ->
1022 let present = r8 resp 8 in
1023 if present != 0
1024 then (
1025 let maj = r8 resp 9 in
1026 let s = Bytes.create 8 in
1027 w8 s 0 maj; (* XKB *)
1028 w8 s 1 0; (* XKBUseExtension *)
1029 w16 s 2 2; (* request-length *)
1030 w16 s 4 1; (* wantedMajor *)
1031 w16 s 6 0; (* watnedMinor *)
1032 sendwithrep
1033 sock s
1034 (fun resp ->
1035 let supported = r8 resp 1 in
1036 state.xkb <- supported != 0
1040 let s = getgeometryreq wid in
1041 syncsendwithrep sock 2.0 s (fun resp ->
1042 glxcompleteinit ();
1043 let w = r16 resp 16
1044 and h = r16 resp 18 in
1045 state.w <- w;
1046 state.h <- h;
1049 | c ->
1050 error "unknown conection setup response %d" (Char.code c)
1053 let getauth haddr dnum =
1054 let haddr =
1055 if haddr = "localhost" || String.length haddr = 0
1056 then
1057 try Unix.gethostname ()
1058 with exn ->
1059 dolog "failed to resolve `%S': %s" haddr (exntos exn);
1060 haddr
1061 else haddr
1063 let path =
1064 try Sys.getenv "XAUTHORITY"
1065 with Not_found ->
1066 try Filename.concat (Sys.getenv "HOME") ".Xauthority"
1067 with Not_found -> E.s
1069 let readauth ic =
1070 let r16be s =
1071 let rb pos = Char.code (Bytes.get s pos) in
1072 (rb 1) lor ((rb 0) lsl 8)
1074 let rec find () =
1075 let rs () =
1076 let s = really_input_string ic 2 in
1077 let n = r16be (~> s) in
1078 really_input_string ic n
1080 let family = really_input_string ic 2 in
1081 let addr = rs () in
1082 let nums = rs () in
1083 let optnum =
1084 try Some (int_of_string nums)
1085 with exn ->
1086 dolog
1087 "display number(%S) is not an integer (corrupt %S?): %s"
1088 nums path (exntos exn);
1089 None
1091 let name = rs () in
1092 let data = rs () in
1094 vlog "family %S addr %S(%S) num %S(%d) name %S data %S"
1095 family addr haddr nums dnum name data;
1096 match optnum with
1097 | Some num when addr = haddr && num = dnum ->
1098 name, data
1099 | _ -> find ()
1101 let name, data =
1102 try find ()
1103 with
1104 | End_of_file -> E.s, E.s
1105 | exn ->
1106 dolog "exception while reading X authority data (%S): %s"
1107 path (exntos exn);
1108 E.s, E.s
1110 close_in ic;
1111 name, data;
1113 if String.length path = 0
1114 then E.s, E.s
1115 else
1116 match open_in_bin path with
1117 | ic -> readauth ic
1118 | (exception exn) ->
1119 dolog "failed to open X authority file `%S' : %s" path (exntos exn);
1120 E.s, E.s
1123 let init t rootwid w h platform =
1124 let d =
1125 try Sys.getenv "DISPLAY"
1126 with exn ->
1127 error "could not get DISPLAY evironment variable: %s"
1128 (exntos exn)
1130 let getnum w b e =
1131 if b = e
1132 then error "invalid DISPLAY(%s) %S" w d
1133 else
1134 let s = String.sub d b (e - b) in
1135 try int_of_string s
1136 with exn ->
1137 error "invalid DISPLAY %S can not parse %s(%S): %s"
1138 d w s (exntos exn)
1140 let rec phost pos =
1141 if pos = String.length d
1142 then error "invalid DISPLAY %S no display number specified" d
1143 else (
1144 if d.[pos] = ':'
1145 then
1146 let rec pdispnum pos1 =
1147 if pos1 = String.length d
1148 then getnum "display number" (pos+1) pos1, 0
1149 else
1150 match d.[pos1] with
1151 | '.' ->
1152 let dispnum = getnum "display number" (pos+1) pos1 in
1153 let rec pscreennum pos2 =
1154 if pos2 = String.length d
1155 then getnum "screen number" (pos1+1) pos2
1156 else
1157 match d.[pos2] with
1158 | '0' .. '9' -> pscreennum (pos2+1)
1159 | _ ->
1160 error "invalid DISPLAY %S, cannot parse screen number" d
1162 dispnum, pscreennum (pos1+1)
1163 | '0' .. '9' -> pdispnum (pos1+1)
1164 | _ ->
1165 error "invalid DISPLAY %S, cannot parse display number" d
1167 String.sub d 0 pos, pdispnum (pos+1)
1168 else phost (pos+1)
1171 let host, (dispnum, screennum) = phost 0 in
1172 let aname, adata = getauth host dispnum in
1173 let fd =
1174 let fd, addr =
1175 if String.length host = 0 || host = "unix"
1176 then
1177 let addr =
1178 match platform with
1179 | Utils.Posx -> Unix.ADDR_UNIX d
1180 | Utils.Plinux ->
1181 Unix.ADDR_UNIX ("\000/tmp/.X11-unix/X" ^ string_of_int dispnum)
1182 | Utils.Punknown | Utils.Psun | Utils.Pbsd | Utils.Pcygwin ->
1183 Unix.ADDR_UNIX ("/tmp/.X11-unix/X" ^ string_of_int dispnum)
1185 Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0, addr
1186 else
1187 let h =
1188 try Unix.gethostbyname host
1189 with exn ->
1190 error "cannot resolve %S: %s" host (exntos exn)
1192 let addr = h.Unix.h_addr_list.(0) in
1193 let port = 6000 + dispnum in
1194 let fd = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
1195 fd, (Unix.ADDR_INET (addr, port))
1197 try Unix.connect fd addr; fd
1198 with exn ->
1199 error "failed to connect to X: %s" (exntos exn)
1201 cloexec fd;
1202 let s = Bytes.create 12 in
1203 let s = padcat s (~> aname) in
1204 let s = padcat s (~> adata) in
1205 Bytes.set s 0 ordermagic;
1206 w16 s 2 11;
1207 w16 s 4 0;
1208 w16 s 6 (String.length aname);
1209 w16 s 8 (String.length adata);
1210 sendstr1 s 0 (Bytes.length s) fd;
1211 state.sock <- fd;
1212 setup d fd rootwid screennum w h;
1213 state.t <- t;
1214 fd, state.w, state.h;
1217 let settitle s =
1218 state.setwmname (~> s);
1221 let setcursor cursor =
1222 if cursor != state.curcurs
1223 then
1224 let n =
1225 match cursor with
1226 | CURSOR_INHERIT -> -1
1227 | CURSOR_INFO -> 3
1228 | CURSOR_CYCLE -> 2
1229 | CURSOR_CROSSHAIR -> 0
1230 | CURSOR_TEXT -> 5
1232 let s = s32 (if n = -1 then 0 else state.fid+1+n) in
1233 let s = changewindowattributesreq state.wid 0x4000(*cursor*) s in
1234 sendstr s state.sock;
1235 state.curcurs <- cursor;
1238 let fullscreen () =
1239 state.fullscreen state.wid;
1242 let metamask = 0x40;;
1243 let altmask = 8;;
1244 let shiftmask = 1;;
1245 let ctrlmask = 4;;
1247 let withalt mask = mask land altmask != 0;;
1248 let withctrl mask = mask land ctrlmask != 0;;
1249 let withshift mask = mask land shiftmask != 0;;
1250 let withmeta mask = mask land metamask != 0;;
1251 let withnone mask = mask land (altmask + ctrlmask + shiftmask + metamask) = 0;;
1253 let xlatt, xlatf =
1254 let t = Hashtbl.create 20
1255 and f = Hashtbl.create 20 in
1256 let add n nl k =
1257 List.iter (fun s -> Hashtbl.add t s k) (n::nl);
1258 Hashtbl.add f k n
1260 let addc c =
1261 let s = String.make 1 c in
1262 add s [] (Char.code c)
1264 let addcr a b =
1265 let an = Char.code a and bn = Char.code b in
1266 for i = an to bn do addc (Char.chr i) done;
1268 addcr '0' '9';
1269 addcr 'a' 'z';
1270 addcr 'A' 'Z';
1271 String.iter addc "`~!@#$%^&*()-_=+\\|[{]};:,./<>?";
1272 for i = 0 to 29 do add ("f" ^ string_of_int (i+1)) [] (0xffbe + i) done;
1273 add "space" [] 0x20;
1274 add "ret" ["return"; "enter"] 0xff0d;
1275 add "tab" [] 0xff09;
1276 add "left" [] 0xff51;
1277 add "right" [] 0xff53;
1278 add "home" [] 0xff50;
1279 add "end" [] 0xff57;
1280 add "ins" ["insert"] 0xff63;
1281 add "del" ["delete"] 0xffff;
1282 add "esc" ["escape"] 0xff1b;
1283 add "pgup" ["pageup"] 0xff55;
1284 add "pgdown" ["pagedown"] 0xff56;
1285 add "backspace" [] 0xff08;
1286 add "up" [] 0xff52;
1287 add "down" [] 0xff54;
1288 add "menu" [] 0xff67;
1289 t, f;
1292 let keyname k =
1293 try Hashtbl.find xlatf k
1294 with Not_found -> Printf.sprintf "%#x" k;
1297 let namekey name =
1298 try Hashtbl.find xlatt name
1299 with Not_found ->
1300 if String.length name = 1
1301 then Char.code name.[0]
1302 else int_of_string name;