E.s
[llpp.git] / wsi.ml
blob68a09bd391a46be6ae693298644dbf40e03c62cd
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";;
32 let vlog fmt = Format.ksprintf ignore fmt;;
34 let onot = object
35 method display = ()
36 method map _ = ()
37 method expose = ()
38 method visible _ = ()
39 method reshape _ _ = ()
40 method mouse _ _ _ _ _ = ()
41 method motion _ _ = ()
42 method pmotion _ _ = ()
43 method key _ _ = ()
44 method enter _ _ = ()
45 method leave = ()
46 method winstate _ = ()
47 method quit = exit 0
48 end;;
50 class type t = object
51 method display : unit
52 method map : bool -> unit
53 method expose : unit
54 method visible : visiblestate -> unit
55 method reshape : int -> int -> unit
56 method mouse : int -> bool -> int -> int -> int -> unit
57 method motion : int -> int -> unit
58 method pmotion : int -> int -> unit
59 method key : int -> int -> unit
60 method enter : int -> int -> unit
61 method leave : unit
62 method winstate : winstate list -> unit
63 method quit : unit
64 end;;
66 type state =
67 { mutable mink : int
68 ; mutable maxk : int
69 ; mutable keymap : int array array
70 ; fifo : (bytes -> unit) Queue.t
71 ; mutable seq : int
72 ; mutable protoatom : atom
73 ; mutable deleatom : atom
74 ; mutable nwmsatom : atom
75 ; mutable maxvatom : atom
76 ; mutable maxhatom : atom
77 ; mutable fulsatom : atom
78 ; mutable idbase : int
79 ; mutable wid : int
80 ; mutable fid : int
81 ; mutable fullscreen : (int -> unit)
82 ; mutable setwmname : (bytes -> unit)
83 ; mutable actwin : (unit -> unit)
84 ; mutable stringatom : int
85 ; mutable t : t
86 ; mutable sock : Unix.file_descr
87 ; mutable x : int
88 ; mutable y : int
89 ; mutable w : int
90 ; mutable h : int
91 ; mutable fs : fs
92 ; mutable curcurs : cursor
93 ; mutable capslmask : int
94 ; mutable numlmask : int
95 ; mutable levl3mask : int
96 ; mutable levl5mask : int
97 ; mutable xkb : bool
99 and fs =
100 | NoFs
101 | Fs of (int * int * int * int)
104 let state =
105 { mink = max_int
106 ; maxk = min_int
107 ; keymap = E.a
108 ; fifo = Queue.create ()
109 ; seq = 0
110 ; protoatom = -1
111 ; deleatom = -1
112 ; nwmsatom = -1
113 ; maxvatom = -1
114 ; maxhatom = -1
115 ; fulsatom = -1
116 ; idbase = -1
117 ; wid = -1
118 ; fid = -1
119 ; fullscreen = (fun _ -> ())
120 ; setwmname = (fun _ -> ())
121 ; actwin = (fun _ -> ())
122 ; sock = Unix.stdin
123 ; t = onot
124 ; x = -1
125 ; y = -1
126 ; w = -1
127 ; h = -1
128 ; fs = NoFs
129 ; stringatom = 31
130 ; curcurs = CURSOR_TEXT
131 ; capslmask = 0
132 ; numlmask = 0
133 ; levl3mask = 0
134 ; levl5mask = 0
135 ; xkb = false
139 let w8 s pos i = Bytes.set s pos (Char.chr (i land 0xff));;
140 let r8 s pos = Char.code (Bytes.get s pos);;
142 let ordermagic = 'l';;
144 let w16 s pos i =
145 w8 s pos i;
146 w8 s (pos+1) (i lsr 8)
149 let w32 s pos i =
150 w16 s pos i;
151 w16 s (pos+2) (i lsr 16)
154 let r16 s pos =
155 let rb pos1 = Char.code (Bytes.get s (pos + pos1)) in
156 (rb 0) lor ((rb 1) lsl 8)
159 let r16s s pos =
160 let i = r16 s pos in
161 i - ((i land 0x8000) lsl 1)
164 let r32 s pos =
165 let rb pos1 = Char.code (Bytes.get s (pos + pos1)) in
166 let l = (rb 0) lor ((rb 1) lsl 8)
167 and u = (rb 2) lor ((rb 3) lsl 8) in
168 (u lsl 16) lor l
171 let makereq opcode len reqlen =
172 let s = Bytes.create len in
173 w8 s 0 opcode;
174 w16 s 2 reqlen;
178 let readstr sock n =
179 let s = Bytes.create n in
180 let rec loop pos n =
181 let m = tempfailureretry (Unix.read sock s pos) n in
182 if m = 0
183 then state.t#quit;
184 if n != m
185 then (
186 ignore (tempfailureretry (Unix.select [sock] [] []) 0.01);
187 loop (pos + m) (n - m)
190 loop 0 n;
194 let sendstr1 s pos len sock =
195 let s = Bytes.unsafe_to_string s in
196 vlog "%d <= %S" state.seq s;
197 state.seq <- state.seq + 1;
198 let n = tempfailureretry (Unix.write_substring sock s pos) len in
199 if n != len
200 then error "send %d returned %d" len n;
203 let updkmap sock resp =
204 let syms = r8 resp 1 in
205 let len = r32 resp 4 in
206 let data =
207 if len > 0
208 then readstr sock (4*len)
209 else E.b
211 let m = len / syms in
212 state.keymap <- Array.make_matrix
213 (state.maxk - state.mink) syms 0xffffff;
214 let rec loop i = if i = m then () else
215 let k = i*4*syms in
216 let rec loop2 k l = if l = syms then () else
217 let v = r32 data k in
218 state.keymap.(i).(l) <- v;
219 loop2 (k+4) (l+1)
221 loop2 k 0;
222 loop (i+1);
224 loop 0;
227 let updmodmap sock resp =
228 let n = r8 resp 1 in
229 let len = r16 resp 4 in
230 let data =
231 if len > 0
232 then readstr sock (len*4)
233 else E.b
235 if len > 0 then (*???*)
236 let modmap = Array.make_matrix 8 n 0xffffff in
237 let rec loop l = if l = 8 then () else
238 let p = l*n in
239 let rec loop1 m = if m = n then () else
240 let p = p+m in
241 let code = r8 data p in
242 modmap.(l).(m) <- code;
243 if l = 1
244 then (
245 let ki = code - state.mink in
246 if ki >= 0
247 then
248 let a = state.keymap.(ki) in
249 let rec capsloop i = if i = Array.length a || i > 3 then () else
250 let s = a.(i) in
251 if s = 0xffe5
252 then state.capslmask <- 2
253 else capsloop (i+1)
255 capsloop 0;
257 else (
258 if l > 3
259 then (
260 let ki = code - state.mink in
261 if ki >= 0
262 then
263 let a = state.keymap.(ki) in
264 let rec lloop i = if i = Array.length a || i > 3 then () else
265 let s = a.(i) in
266 match s with
267 | 0xfe03 -> state.levl3mask <- 1 lsl l
268 | 0xfe11 -> state.levl5mask <- 1 lsl l
269 | 0xff7f -> state.numlmask <- 1 lsl l
270 | _ -> lloop (i+1)
272 lloop 0;
275 loop1 (m+1)
277 loop1 0;
278 loop (l+1)
280 loop 0;
283 let sendwithrep sock s f =
284 Queue.push f state.fifo;
285 sendstr1 s 0 (Bytes.length s) sock;
288 let padcatl =
289 let pad = "123" in
290 fun ss ->
291 let b = Buffer.create 16 in
292 List.iter (Buffer.add_bytes b) ss;
293 let bl = Buffer.length b in
294 let pl = bl land 3 in
295 if pl != 0
296 then (
297 Buffer.add_substring b pad 0 (4 - pl);
299 Buffer.to_bytes b;
302 let padcat s1 s2 = padcatl [s1; s2];;
304 let internreq name onlyifexists =
305 let s = makereq 16 8 8 in
306 let s = padcat s name in
307 w8 s 1 (if onlyifexists then 1 else 0);
308 w16 s 2 (Bytes.length s / 4);
309 w16 s 4 (Bytes.length name);
313 let sendintern sock s onlyifexists f =
314 let s = internreq s onlyifexists in
315 sendwithrep sock s f;
318 let createwindowreq wid parent x y w h bw eventmask vid depth mid =
319 let s = makereq 1 48 12 in
320 w8 s 1 depth;
321 w32 s 4 wid;
322 w32 s 8 parent;
323 w16 s 12 x;
324 w16 s 14 y;
325 w16 s 16 w;
326 w16 s 18 h;
327 w16 s 20 bw;
328 w16 s 22 0; (* copyfromparent *)
329 w32 s 24 vid; (* visual *)
330 w32 s 28 0x280a; (* valuemask =
331 | background pixel
332 | border pixel
333 | event mask
334 | colormap *)
335 w32 s 32 0; (* background pixel *)
336 w32 s 36 0; (* border pixel*)
337 w32 s 40 eventmask;
338 w32 s 44 mid;
342 let createcolormapreq mid wid vid =
343 let s = makereq 78 16 4 in
344 w8 s 1 0;
345 w32 s 4 mid;
346 w32 s 8 wid;
347 w32 s 12 vid;
351 let getgeometryreq wid =
352 let s = makereq 14 8 2 in
353 w32 s 4 wid;
357 let mapreq wid =
358 let s = makereq 8 8 2 in
359 w32 s 4 wid;
363 let getkeymapreq first count =
364 let s = makereq 101 8 2 in
365 w8 s 4 first;
366 w8 s 5 count;
370 let changepropreq wid prop typ format props =
371 let s = makereq 18 24 0 in
372 let s = padcat s props in
373 w8 s 1 0;
374 w16 s 2 (Bytes.length s / 4);
375 w32 s 4 wid;
376 w32 s 8 prop;
377 w32 s 12 typ;
378 w8 s 16 format;
379 let ful = Bytes.length props / (match format with
380 | 8 -> 1
381 | 16 -> 2
382 | 32 -> 4
383 | n -> error "no idea what %d means" n)
385 w32 s 20 ful;
389 let getpropreq delete wid prop typ =
390 let s = makereq 20 24 6 in
391 w8 s 1 (if delete then 1 else 0);
392 w32 s 4 wid;
393 w32 s 8 prop;
394 w32 s 12 typ;
395 w32 s 16 0;
396 w32 s 20 2;
400 let configurewindowreq wid mask values =
401 let s = makereq 12 12 0 in
402 let s = padcat s values in
403 w16 s 2 (Bytes.length s / 4);
404 w32 s 4 wid;
405 w16 s 8 mask;
409 let s32 n =
410 let s = Bytes.create 4 in
411 w32 s 0 n;
415 let clientmessage format seq wid typ data =
416 let s = makereq 33 12 0 in
417 let s = padcat s data in
418 w8 s 1 format;
419 w16 s 2 seq;
420 w32 s 4 wid;
421 w32 s 8 typ;
425 let sendeventreq propagate destwid mask data =
426 let s = makereq 25 12 11 in
427 let s = padcat s data in
428 w8 s 1 propagate;
429 w16 s 2 11;
430 w32 s 4 destwid;
431 w32 s 8 mask;
435 let getmodifiermappingreq () =
436 makereq 119 4 1;
439 let queryextensionreq name =
440 let s = makereq 98 8 0 in
441 let s = padcat s name in
442 w16 s 2 (Bytes.length s / 4);
443 w16 s 4 (Bytes.length name);
447 let getkeysym pkpk code mask =
448 if (pkpk >= 0xff80 && pkpk <= 0xffbd)
449 || (pkpk >= 0x11000000 && pkpk <= 0x1100ffff)
450 then (
451 if mask land state.numlmask != 0
452 then
453 let keysym = state.keymap.(code-state.mink).(1) in
454 if keysym = 0 then pkpk else keysym
455 else pkpk
457 else (
458 let shift =
459 if pkpk land 0xf000 = 0xf000
460 then 0
461 else (mask land 1) lxor ((mask land state.capslmask) lsr 1)
463 let index =
464 if state.xkb && mask land 0x2000 != 0
465 then
466 shift + 2
467 else
468 let l3 = (mask land state.levl3mask) != 0 in
469 let l4 = (mask land state.levl5mask) != 0 in
470 shift +
471 if l3 then (if l4 then 8 else 4) else (if l4 then 6 else 0)
473 let keysym = state.keymap.(code-state.mink).(index) in
474 if index land 1 = 1 && keysym = 0
475 then state.keymap.(code-state.mink).(index - 1)
476 else keysym
480 let getkeysym code mask =
481 let pkpk = state.keymap.(code-state.mink).(0) in
482 if state.xkb && pkpk lsr 8 = 0xfe (* XKB *)
483 then 0
484 else getkeysym pkpk code mask
487 let readresp sock =
488 let resp = readstr sock 32 in
489 let opcode = r8 resp 0 in
490 match opcode land lnot 0x80 with
491 | 0 -> (* error *)
492 let s = resp in
493 let code = r8 s 1
494 and serial = r16 s 2
495 and resid = r32 resp 4
496 and min = r16 s 8
497 and maj = r8 s 10 in
498 error "code=%d serial=%d resid=%#x min=%d maj=%d\n%S"
499 code serial resid min maj (Bytes.unsafe_to_string resp);
501 | 1 -> (* response *)
502 let rep = Queue.pop state.fifo in
503 rep resp;
505 | 2 -> (* key press *)
506 if Array.length state.keymap > 0
507 then
508 let code = r8 resp 1 in
509 let mask = r16 resp 28 in
510 let keysym = getkeysym code mask in
511 vlog "keysym = %x %c mask %#x code %d"
512 keysym (Char.unsafe_chr keysym) mask code;
513 state.t#key keysym mask;
515 | 3 -> (* key release *)
516 if Array.length state.keymap > 0
517 then
518 let code = r8 resp 1 in
519 let mask = r16 resp 28 in
520 let keysym = getkeysym code mask in
521 vlog "release keysym = %x %c mask %#x code %#d"
522 keysym (Char.unsafe_chr keysym) mask code
524 | 4 -> (* buttonpress *)
525 let n = r8 resp 1
526 and x = r16s resp 24
527 and y = r16s resp 26
528 and m = r16 resp 28 in
529 state.t#mouse n true x y m;
530 vlog "press %d" n
532 | 5 -> (* buttonrelease *)
533 let n = r8 resp 1
534 and x = r16s resp 24
535 and y = r16s resp 26
536 and m = r16 resp 28 in
537 state.t#mouse n false x y m;
538 vlog "release %d %d %d" n x y
540 | 6 -> (* motion *)
541 let x = r16s resp 24 in
542 let y = r16s resp 26 in
543 let m = r16 resp 28 in
544 if m land 0x1f00 = 0
545 then state.t#pmotion x y
546 else state.t#motion x y;
547 vlog "move %dx%d => %d" x y m
549 | 7 -> (* enter *)
550 let x = r16s resp 24
551 and y = r16s resp 26 in
552 state.t#enter x y;
553 vlog "enter %d %d" x y
555 | 8 -> (* leave *)
556 state.t#leave
558 | 18 -> (* unmap *)
559 state.t#map false;
560 vlog "unmap";
562 | 19 -> (* map *)
563 state.t#map true;
564 vlog "map";
566 | 12 -> (* exposure *)
567 vlog "exposure";
568 state.t#expose
570 | 15 -> (* visibility *)
571 let v = r8 resp 8 in
572 let vis =
573 match v with
574 | 0 -> Unobscured
575 | 1 -> PartiallyObscured
576 | 2 -> FullyObscured
577 | _ ->
578 dolog "unknown visibility %d" v;
579 Unobscured
581 state.t#visible vis;
582 vlog "visibility %d" v;
584 | 34 -> (* mapping *)
585 state.keymap <- E.a;
586 let s = getkeymapreq state.mink (state.maxk-state.mink-1) in
587 sendwithrep sock s (updkmap sock);
588 state.capslmask <- 0;
589 state.levl3mask <- 0;
590 state.levl5mask <- 0;
591 state.numlmask <- 0;
592 let s = getmodifiermappingreq () in
593 sendwithrep sock s (updmodmap sock);
595 | 33 -> (* clientmessage *)
596 let atom = r32 resp 8 in
597 if atom = state.protoatom
598 then (
599 let atom = r32 resp 12 in
600 if atom = state.deleatom
601 then state.t#quit;
603 vlog "atom %#x" atom
605 | 21 -> (* reparent *)
606 vlog "reparent"
608 | 22 -> (* configure *)
609 let x = r16s resp 16
610 and y = r16s resp 18
611 and w = r16 resp 20
612 and h = r16 resp 22 in
613 vlog "configure cur [%d %d %d %d] conf [%d %d %d %d]"
614 state.x state.y state.w state.h
615 x y w h
617 if w != state.w || h != state.h
618 then (
619 state.t#reshape w h;
621 state.w <- w;
622 state.h <- h;
623 state.x <- x;
624 state.y <- y;
625 state.t#expose
627 | 28 ->
628 let atom = r32 resp 8 in
629 if atom = state.nwmsatom
630 then
631 let s = getpropreq false state.wid atom 4 in
632 sendwithrep sock s (fun resp ->
633 let len = r32 resp 4 in
634 let nitems = r32 resp 16 in
635 let wsl =
636 if len = 0
637 then []
638 else
639 let s = readstr sock (len*4) in
640 let rec loop wsl i = if i = nitems then wsl else
641 let atom = r32 s (i*4) in
642 let wsl =
643 if atom = state.maxhatom
644 then MaxHorz::wsl
645 else (
646 if atom = state.maxvatom
647 then MaxVert::wsl
648 else (
649 if atom = state.fulsatom
650 then (
651 state.fs <- Fs (state.x, state.y, state.w, state.h);
652 Fullscreen::wsl
654 else wsl
657 in loop wsl (i+1)
659 loop [] 0
661 state.t#winstate (List.sort compare wsl)
664 | n ->
665 dolog "event %d %S" n (Bytes.unsafe_to_string resp)
668 let readresp sock =
669 let rec loop () =
670 readresp sock;
671 if hasdata sock then loop ();
673 loop ();
676 let sendstr s ?(pos=0) ?(len=Bytes.length s) sock =
677 sendstr1 s pos len sock;
678 if hasdata sock then readresp sock;
681 let reshape w h =
682 if state.fs = NoFs
683 then
684 let s = Bytes.create 8 in
685 w32 s 0 w;
686 w32 s 4 h;
687 let s = configurewindowreq state.wid 0x000c s in
688 sendstr s state.sock;
689 else state.fullscreen state.wid
692 let activatewin () =
693 state.actwin ();
696 let syncsendwithrep sock secstowait s f =
697 let completed = ref false in
698 sendwithrep sock s (fun resp -> f resp; completed := true);
699 let now = Unix.gettimeofday in
700 let deadline = now () +. secstowait in
701 let rec readtillcompletion () =
702 let sf deadline =
703 let timeout = deadline -. now () in
704 if timeout <= 0.0
705 then [], [], []
706 else Unix.select [sock] [] [] timeout
708 let r, _, _ = tempfailureretry sf deadline in
709 match r with
710 | [] -> error "didn't get X response in %f seconds, aborting" secstowait
711 | _ ->
712 readresp sock;
713 if not !completed
714 then readtillcompletion ()
716 readtillcompletion ();
719 let mapwin () =
720 let s = mapreq state.wid in
721 sendstr s state.sock;
724 let syncsendintern sock secstowait s onlyifexists f =
725 let s = internreq s onlyifexists in
726 syncsendwithrep sock secstowait s f;
729 let setup disp sock rootwid screennum w h =
730 let s = readstr sock 2 in
731 let n = Bytes.length s in
732 if n != 2
733 then error "failed to read X connection setup response n=%d" n;
734 match Bytes.get s 0 with
735 | '\000' ->
736 let reasonlen = r8 s 1 in
737 let s = readstr sock 6 in
738 let maj = r16 s 0
739 and min = r16 s 2
740 and add = r16 s 4 in
741 let len = add*4 in
742 let data = readstr sock len in
743 let reason = Bytes.sub data 0 reasonlen in
744 error "X connection failed maj=%d min=%d reason=%S"
745 maj min (Bytes.unsafe_to_string reason)
747 | '\002' -> failwith "X connection setup failed: authentication required";
749 | '\001' ->
750 let s = readstr sock 38 in
751 let maj = r16 s 0
752 and min = r16 s 2
753 and add = r16 s 4
754 and idbase = r32 s 10
755 and idmask = r32 s 14
756 and vlen = r16 s 22
757 and screens = r8 s 26
758 and formats = r8 s 27
759 and minkk = r8 s 32
760 and maxkk = r8 s 33 in
761 let data = readstr sock (4*add-32) in
762 let vendor = Bytes.sub data 0 vlen in
763 let pos = ((vlen+3) land lnot 3) + formats*8 in
765 if screennum >= screens
766 then error "invalid screen %d, max %d" screennum (screens-1);
768 let pos =
769 let rec findscreen n pos = if n = screennum then pos else
770 let pos =
771 let ndepths = r8 data (pos+39) in
772 let rec skipdepths n pos = if n = ndepths then pos else
773 let pos =
774 let nvisiuals = r16 data (pos+2) in
775 pos + nvisiuals*24 + 8
777 skipdepths (n+1) pos
779 skipdepths n (pos+40)
781 findscreen (n+1) pos
783 findscreen 0 pos
785 let root = if rootwid = 0 then r32 data pos else rootwid in
786 let rootw = r16 data (pos+20)
787 and rooth = r16 data (pos+22)
788 and rootdepth = r8 data (pos+38)in
790 state.mink <- minkk;
791 state.maxk <- maxkk;
792 state.idbase <- idbase;
793 vlog "vendor = %S, maj=%d min=%d" (Bytes.unsafe_to_string vendor) maj min;
794 vlog "screens = %d formats = %d" screens formats;
795 vlog "minkk = %d maxkk = %d" minkk maxkk;
796 vlog "idbase = %#x idmask = %#x" idbase idmask;
797 vlog "root=%#x %dx%d" root rootw rooth;
798 vlog "wmm = %d, hmm = %d" (r16 data (pos+24)) (r16 data (pos+26));
799 vlog "visualid = %#x " (r32 data (pos+32));
800 vlog "root depth = %d" rootdepth;
802 let wid = state.idbase in
803 let mid = wid+1 in
804 let fid = mid+1 in
806 state.wid <- wid;
807 state.fid <- fid;
809 let vid = glxinit disp wid screennum in
810 let ndepths = r8 data (pos+39) in
811 let rec finddepth n' pos =
812 if n' = ndepths
813 then error "cannot find depth for visual %#x" vid;
814 let depth = r8 data pos in
815 let nvisuals = r16 data (pos+2) in
816 let rec findvisual n pos =
817 if n = nvisuals
818 then finddepth (n'+1) pos
819 else
820 let id = r32 data pos in
821 if id = vid
822 then depth
823 else findvisual (n+1) (pos+24)
825 findvisual 0 (pos+8)
827 let depth = finddepth 0 (pos+40) in
829 let s = createcolormapreq mid root vid in
830 sendstr s sock;
832 let mask = 0
833 + 0x00000001 (* KeyPress *)
834 (* + 0x00000002 *) (* KeyRelease *)
835 + 0x00000004 (* ButtonPress *)
836 + 0x00000008 (* ButtonRelease *)
837 + 0x00000010 (* EnterWindow *)
838 + 0x00000020 (* LeaveWindow *)
839 + 0x00000040 (* PointerMotion *)
840 (* + 0x00000080 *) (* PointerMotionHint *)
841 (* + 0x00000100 *) (* Button1Motion *)
842 (* + 0x00000200 *) (* Button2Motion *)
843 (* + 0x00000400 *) (* Button3Motion *)
844 (* + 0x00000800 *) (* Button4Motion *)
845 (* + 0x00001000 *) (* Button5Motion *)
846 + 0x00002000 (* ButtonMotion *)
847 (* + 0x00004000 *) (* KeymapState *)
848 + 0x00008000 (* Exposure *)
849 + 0x00010000 (* VisibilityChange *)
850 + 0x00020000 (* StructureNotify *)
851 (* + 0x00040000 *) (* ResizeRedirect *)
852 (* + 0x00080000 *) (* SubstructureNotify *)
853 (* + 0x00100000 *) (* SubstructureRedirect *)
854 (* + 0x00200000 *) (* FocusChange *)
855 + 0x00400000 (* PropertyChange *)
856 (* + 0x00800000 *) (* ColormapChange *)
857 (* + 0x01000000 *) (* OwnerGrabButton *)
860 let s = createwindowreq wid root 0 0 w h 0 mask vid depth mid in
861 sendstr s sock;
863 sendintern sock (~> "WM_PROTOCOLS") false (fun resp ->
864 state.protoatom <- r32 resp 8;
865 sendintern
866 sock (~> "WM_DELETE_WINDOW") false (fun resp ->
867 state.deleatom <- r32 resp 8;
868 let s = s32 state.deleatom in
869 let s = changepropreq wid state.protoatom 4 32 s in
870 sendstr s sock;
874 sendintern sock (~> "WM_CLIENT_MACHINE") false (fun resp ->
875 let atom = r32 resp 8 in
876 let empty = E.s in
877 let hostname =
878 try Unix.gethostname ()
879 with exn ->
880 dolog "error getting host name: %s" @@ exntos exn;
881 empty
883 if hostname != empty
884 then
885 let s = changepropreq wid atom state.stringatom 8
886 (~> hostname) in
887 sendstr s sock;
888 sendintern sock (~> "_NET_WM_PID") false (fun resp ->
889 let atom = r32 resp 8 in
890 let pid = Unix.getpid () in
891 let s = s32 pid in
892 let s = changepropreq wid atom 6(*cardinal*) 32 s in
893 sendstr s sock;
897 state.actwin <- (fun () ->
898 let s = Bytes.create 4 in
899 let s = configurewindowreq wid 0x40 s in
900 sendstr s state.sock;
901 let s = mapreq wid in
902 sendstr s state.sock;
905 sendintern sock (~> "_NET_ACTIVE_WINDOW") true (fun resp ->
906 let atom = r32 resp 8 in
907 state.actwin <- (fun () ->
908 let data = Bytes.make 20 '\000' in
909 let cm = clientmessage 32 0 wid atom data in
910 let s = sendeventreq 0 root 0x180000 cm in
911 sendstr s state.sock;
915 syncsendintern sock 2.0 (~> "WM_CLASS") false (fun resp ->
916 let atom = r32 resp 8 in
917 let llpp = ~> "llpp\000llpp\000" in
918 let s = changepropreq wid atom 31 8 llpp in
919 sendstr s sock;
922 let s = getkeymapreq state.mink (state.maxk-state.mink) in
923 sendwithrep sock s (updkmap sock);
925 let s = getmodifiermappingreq () in
926 sendwithrep sock s (updmodmap sock);
928 sendintern sock (~> "UTF8_STRING") true (fun resp ->
929 let atom = r32 resp 8 in
930 if atom != 0
931 then state.stringatom <- atom;
934 let setwmname s =
935 let s = changepropreq wid 39 state.stringatom 8 s in
936 sendstr s state.sock;
938 state.setwmname <- setwmname;
939 sendintern sock (~> "_NET_WM_NAME") true (fun resp ->
940 let atom = r32 resp 8 in
941 if atom != 0
942 then state.setwmname <- (fun s ->
943 setwmname s;
944 let s = changepropreq wid atom state.stringatom 8 s in
945 sendstr s state.sock;
949 state.fullscreen <- (fun wid ->
950 let s = Bytes.create 16 in
951 match state.fs with
952 | NoFs ->
953 w32 s 0 0;
954 w32 s 4 0;
955 w32 s 8 rootw;
956 w32 s 12 rooth;
957 let s = configurewindowreq wid 0x000f s in
958 sendstr s state.sock;
959 state.fs <- Fs (state.x, state.y, state.w, state.h);
961 | Fs (x, y, w, h) ->
962 w32 s 0 x;
963 w32 s 4 y;
964 w32 s 8 w;
965 w32 s 12 h;
966 let s = configurewindowreq wid 0x000f s in
967 sendstr s state.sock;
968 state.fs <- NoFs;
971 sendintern sock (~> "_NET_WM_STATE") true (fun resp ->
972 state.nwmsatom <- r32 resp 8;
973 if state.nwmsatom != 0
974 then (
975 sendintern sock (~> "_NET_WM_STATE_MAXIMIZED_VERT") true (fun resp ->
976 state.maxvatom <- r32 resp 8;
978 sendintern sock (~> "_NET_WM_STATE_MAXIMIZED_HORZ") true (fun resp ->
979 state.maxhatom <- r32 resp 8;
981 sendintern sock (~> "_NET_WM_STATE_FULLSCREEN") true (fun resp ->
982 state.fulsatom <- r32 resp 8;
983 if state.fulsatom != 0
984 then
985 state.fullscreen <-
986 (fun wid ->
987 let data = Bytes.make 20 '\000' in
988 let fs, f =
989 match state.fs with
990 | NoFs -> Fs (-1, -1, -1, -1), 1
991 | Fs _ -> NoFs, 0
993 w32 data 0 f;
994 w32 data 4 state.fulsatom;
996 let cm = clientmessage 32 0 wid state.nwmsatom data in
997 let s = sendeventreq 0 root 0x180000 cm in
998 sendstr s sock;
999 state.fs <- fs;
1004 let s = queryextensionreq (~> "XKEYBOARD") in
1005 sendwithrep
1006 sock s (fun resp ->
1007 let present = r8 resp 8 in
1008 if present != 0
1009 then (
1010 let maj = r8 resp 9 in
1011 let s = Bytes.create 8 in
1012 w8 s 0 maj; (* XKB *)
1013 w8 s 1 0; (* XKBUseExtension *)
1014 w16 s 2 2; (* request-length *)
1015 w16 s 4 1; (* wantedMajor *)
1016 w16 s 6 0; (* watnedMinor *)
1017 sendwithrep
1018 sock s
1019 (fun resp ->
1020 let supported = r8 resp 1 in
1021 state.xkb <- supported != 0
1025 let s = getgeometryreq wid in
1026 syncsendwithrep sock 2.0 s (fun resp ->
1027 glxcompleteinit ();
1028 let w = r16 resp 16
1029 and h = r16 resp 18 in
1030 state.w <- w;
1031 state.h <- h;
1034 | c ->
1035 error "unknown conection setup response %d" (Char.code c)
1038 let getauth haddr dnum =
1039 let haddr =
1040 if emptystr haddr || haddr = "localhost"
1041 then
1042 try Unix.gethostname ()
1043 with exn ->
1044 dolog "failed to resolve `%S': %s" haddr @@ exntos exn;
1045 haddr
1046 else haddr
1048 let path =
1049 try Sys.getenv "XAUTHORITY"
1050 with Not_found ->
1051 try Filename.concat (Sys.getenv "HOME") ".Xauthority"
1052 with Not_found -> E.s
1054 let readauth ic =
1055 let r16be s =
1056 let rb pos = Char.code (Bytes.get s pos) in
1057 (rb 1) lor ((rb 0) lsl 8)
1059 let rec find () =
1060 let rs () =
1061 let s = really_input_string ic 2 in
1062 let n = r16be (~> s) in
1063 really_input_string ic n
1065 let family = really_input_string ic 2 in
1066 let addr = rs () in
1067 let nums = rs () in
1068 let optnum =
1069 try Some (int_of_string nums)
1070 with exn ->
1071 dolog
1072 "display number(%S) is not an integer (corrupt %S?): %s"
1073 nums path @@ exntos exn;
1074 None
1076 let name = rs () in
1077 let data = rs () in
1079 vlog "family %S addr %S(%S) num %S(%d) name %S data %S"
1080 family addr haddr nums dnum name data;
1081 match optnum with
1082 | Some num when addr = haddr && num = dnum ->
1083 name, data
1084 | _ -> find ()
1086 let name, data =
1087 try find ()
1088 with
1089 | End_of_file -> E.s, E.s
1090 | exn ->
1091 dolog "exception while reading X authority data (%S): %s"
1092 path @@ exntos exn;
1093 E.s, E.s
1095 close_in ic;
1096 name, data;
1098 if emptystr path
1099 then E.s, E.s
1100 else
1101 match open_in_bin path with
1102 | ic -> readauth ic
1103 | (exception exn) ->
1104 dolog "failed to open X authority file `%S' : %s" path @@ exntos exn;
1105 E.s, E.s
1108 let init t rootwid w h platform =
1109 let d =
1110 try Sys.getenv "DISPLAY"
1111 with exn ->
1112 error "cannot get DISPLAY evironment variable: %s" @@ exntos exn
1114 let getnum w b e =
1115 if b = e
1116 then error "invalid DISPLAY(%s) %S" w d
1117 else
1118 let s = String.sub d b (e - b) in
1119 try int_of_string s
1120 with exn ->
1121 error "invalid DISPLAY %S can not parse %s(%S): %s"
1122 d w s @@ exntos exn
1124 let rec phost pos =
1125 if pos = String.length d
1126 then error "invalid DISPLAY %S no display number specified" d
1127 else (
1128 if d.[pos] = ':'
1129 then
1130 let rec pdispnum pos1 =
1131 if pos1 = String.length d
1132 then getnum "display number" (pos+1) pos1, 0
1133 else
1134 match d.[pos1] with
1135 | '.' ->
1136 let dispnum = getnum "display number" (pos+1) pos1 in
1137 let rec pscreennum pos2 =
1138 if pos2 = String.length d
1139 then getnum "screen number" (pos1+1) pos2
1140 else
1141 match d.[pos2] with
1142 | '0' .. '9' -> pscreennum (pos2+1)
1143 | _ ->
1144 error "invalid DISPLAY %S, cannot parse screen number" d
1146 dispnum, pscreennum (pos1+1)
1147 | '0' .. '9' -> pdispnum (pos1+1)
1148 | _ ->
1149 error "invalid DISPLAY %S, cannot parse display number" d
1151 String.sub d 0 pos, pdispnum (pos+1)
1152 else phost (pos+1)
1155 let host, (dispnum, screennum) = phost 0 in
1156 let aname, adata = getauth host dispnum in
1157 let fd =
1158 let fd, addr =
1159 if emptystr host || host = "unix"
1160 then
1161 let addr =
1162 match platform with
1163 | Utils.Posx -> Unix.ADDR_UNIX d
1164 | Utils.Plinux ->
1165 Unix.ADDR_UNIX ("\000/tmp/.X11-unix/X" ^ string_of_int dispnum)
1166 | Utils.Punknown | Utils.Psun | Utils.Pbsd | Utils.Pcygwin ->
1167 Unix.ADDR_UNIX ("/tmp/.X11-unix/X" ^ string_of_int dispnum)
1169 Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0, addr
1170 else
1171 let h =
1172 try Unix.gethostbyname host
1173 with exn -> error "cannot resolve %S: %s" host @@ exntos exn
1175 let addr = h.Unix.h_addr_list.(0) in
1176 let port = 6000 + dispnum in
1177 let fd = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
1178 fd, (Unix.ADDR_INET (addr, port))
1180 try Unix.connect fd addr; fd
1181 with exn -> error "failed to connect to X: %s" @@ exntos exn
1183 cloexec fd;
1184 let s = Bytes.create 12 in
1185 let s = padcat s (~> aname) in
1186 let s = padcat s (~> adata) in
1187 Bytes.set s 0 ordermagic;
1188 w16 s 2 11;
1189 w16 s 4 0;
1190 w16 s 6 (String.length aname);
1191 w16 s 8 (String.length adata);
1192 sendstr1 s 0 (Bytes.length s) fd;
1193 state.sock <- fd;
1194 setup d fd rootwid screennum w h;
1195 state.t <- t;
1196 fd, state.w, state.h;
1199 let settitle s =
1200 state.setwmname (~> s);
1203 let setcursor cursor =
1204 if cursor != state.curcurs
1205 then (
1206 setcursor cursor;
1207 state.curcurs <- cursor;
1211 let fullscreen () =
1212 state.fullscreen state.wid;
1215 let metamask = 0x40;;
1216 let altmask = 8;;
1217 let shiftmask = 1;;
1218 let ctrlmask = 4;;
1220 let withalt mask = mask land altmask != 0;;
1221 let withctrl mask = mask land ctrlmask != 0;;
1222 let withshift mask = mask land shiftmask != 0;;
1223 let withmeta mask = mask land metamask != 0;;
1224 let withnone mask = mask land (altmask + ctrlmask + shiftmask + metamask) = 0;;
1226 let xlatt, xlatf =
1227 let t = Hashtbl.create 20
1228 and f = Hashtbl.create 20 in
1229 let add n nl k =
1230 List.iter (fun s -> Hashtbl.add t s k) (n::nl);
1231 Hashtbl.add f k n
1233 let addc c =
1234 let s = String.make 1 c in
1235 add s [] (Char.code c)
1237 let addcr a b =
1238 let an = Char.code a and bn = Char.code b in
1239 for i = an to bn do addc (Char.chr i) done;
1241 addcr '0' '9';
1242 addcr 'a' 'z';
1243 addcr 'A' 'Z';
1244 String.iter addc "`~!@#$%^&*()-_=+\\|[{]};:,./<>?";
1245 for i = 0 to 29 do add ("f" ^ string_of_int (i+1)) [] (0xffbe + i) done;
1246 add "space" [] 0x20;
1247 add "ret" ["return"; "enter"] 0xff0d;
1248 add "tab" [] 0xff09;
1249 add "left" [] 0xff51;
1250 add "right" [] 0xff53;
1251 add "home" [] 0xff50;
1252 add "end" [] 0xff57;
1253 add "ins" ["insert"] 0xff63;
1254 add "del" ["delete"] 0xffff;
1255 add "esc" ["escape"] 0xff1b;
1256 add "pgup" ["pageup"] 0xff55;
1257 add "pgdown" ["pagedown"] 0xff56;
1258 add "backspace" [] 0xff08;
1259 add "up" [] 0xff52;
1260 add "down" [] 0xff54;
1261 add "menu" [] 0xff67;
1262 t, f;
1265 let keyname k =
1266 try Hashtbl.find xlatf k
1267 with Not_found -> Printf.sprintf "%#x" k;
1270 let namekey name =
1271 try Hashtbl.find xlatt name
1272 with Not_found ->
1273 if String.length name = 1
1274 then Char.code name.[0]
1275 else int_of_string name;