Consistency
[llpp.git] / wsi.ml
blob3154ffca0adb2514f14401476f381d4900ad6102
1 open Utils;;
3 type cursor =
4 | CURSOR_INHERIT
5 | CURSOR_INFO
6 | CURSOR_CYCLE
7 | CURSOR_CROSSHAIR
8 | CURSOR_TEXT
9 ;;
11 type winstate =
12 | MaxVert
13 | MaxHorz
14 | Fullscreen
17 external glx : int -> unit = "ml_glx";;
18 external glxsync : unit -> unit = "ml_glxsync";;
19 external swapb : unit -> unit = "ml_swapb";;
21 let vlog fmt = Format.kprintf ignore fmt;;
23 let onot = object
24 method display = ()
25 method expose = ()
26 method visible = ()
27 method reshape _ _ = ()
28 method mouse _ _ _ _ _ = ()
29 method motion _ _ = ()
30 method pmotion _ _ = ()
31 method key _ _ = ()
32 method enter _ _ = ()
33 method leave = ()
34 method winstate _ = ()
35 method quit = exit 0
36 end;;
38 class type t = object
39 method display : unit
40 method expose : unit
41 method visible : unit
42 method reshape : int -> int -> unit
43 method mouse : int -> bool -> int -> int -> int -> unit
44 method motion : int -> int -> unit
45 method pmotion : int -> int -> unit
46 method key : int -> int -> unit
47 method enter : int -> int -> unit
48 method leave : unit
49 method winstate : winstate list -> unit
50 method quit : unit
51 end;;
53 type state =
54 { mutable mink : int
55 ; mutable maxk : int
56 ; mutable keymap : int array array
57 ; fifo : (string -> unit) Queue.t
58 ; mutable seq : int
59 ; mutable protoatom : int
60 ; mutable deleatom : int
61 ; mutable nwmsatom : int
62 ; mutable maxvatom : int
63 ; mutable maxhatom : int
64 ; mutable fulsatom : int
65 ; mutable idbase : int
66 ; mutable fullscreen : (int -> unit)
67 ; mutable setwmname : (string -> unit)
68 ; mutable actwin : (unit -> unit)
69 ; mutable stringatom : int
70 ; mutable t : t
71 ; mutable sock : Unix.file_descr
72 ; mutable x : int
73 ; mutable y : int
74 ; mutable w : int
75 ; mutable h : int
76 ; mutable fs : fs
77 ; mutable curcurs : cursor
78 ; mutable capslmask : int
79 ; mutable numlmask : int
80 ; mutable levl3mask : int
81 ; mutable levl5mask : int
83 and fs =
84 | NoFs
85 | Fs of (int * int * int * int)
88 let state =
89 { mink = max_int
90 ; maxk = min_int
91 ; keymap = [||]
92 ; fifo = Queue.create ()
93 ; seq = 0
94 ; protoatom = -1
95 ; deleatom = -1
96 ; nwmsatom = -1
97 ; maxvatom = -1
98 ; maxhatom = -1
99 ; fulsatom = -1
100 ; idbase = -1
101 ; fullscreen = (fun _ -> ())
102 ; setwmname = (fun _ -> ())
103 ; actwin = (fun _ -> ())
104 ; sock = Unix.stdin
105 ; t = onot
106 ; x = -1
107 ; y = -1
108 ; w = -1
109 ; h = -1
110 ; fs = NoFs
111 ; stringatom = 31
112 ; curcurs = CURSOR_INHERIT
113 ; capslmask = 0
114 ; numlmask = 0
115 ; levl3mask = 0
116 ; levl5mask = 0
120 let w8 s pos i = String.set s pos (Char.chr (i land 0xff));;
122 let w16 s pos i =
123 w8 s pos i;
124 w8 s (pos+1) (i lsr 8);
127 let w32 s pos i =
128 w16 s pos i;
129 w16 s (pos+2) (i lsr 16);
132 let r16 s pos =
133 let rb pos1 = Char.code (String.get s (pos + pos1)) in
134 (rb 0) lor ((rb 1) lsl 8)
137 let r16s s pos =
138 let i = r16 s pos in
139 i - ((i land 0x8000) lsl 1);
142 let r8 s pos = Char.code (String.get s pos);;
144 let r32 s pos =
145 let rb pos1 = Char.code (String.get s (pos + pos1)) in
146 let l = (rb 0) lor ((rb 1) lsl 8)
147 and u = (rb 2) lor ((rb 3) lsl 8) in
148 (u lsl 16) lor l
151 let readstr sock n =
152 let s = String.create n in
153 let rec loop pos n =
154 let m = tempfailureretry (Unix.read 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 vlog "%d => %S" state.seq s;
169 state.seq <- state.seq + 1;
170 let n = tempfailureretry (Unix.send sock s pos len) [] in
171 if n != len
172 then error "send %d returned %d" len n;
175 let updkmap sock resp =
176 let syms = r8 resp 1 in
177 let len = r32 resp 4 in
178 let data =
179 if len > 0
180 then readstr sock (4*len)
181 else ""
183 let m = len / syms in
184 state.keymap <- Array.make_matrix
185 (state.maxk - state.mink) syms 0xffffff;
186 let rec loop i = if i = m then () else
187 let k = i*4*syms in
188 let rec loop2 k l = if l = syms then () else
189 let v = r32 data k in
190 state.keymap.(i).(l) <- v;
191 loop2 (k+4) (l+1)
193 loop2 k 0;
194 loop (i+1);
196 loop 0;
199 let updmodmap sock resp =
200 let n = r8 resp 1 in
201 let len = r16 resp 4 in
202 let data =
203 if len > 0
204 then readstr sock (len*4)
205 else ""
207 let modmap = Array.make_matrix 8 n 0xffffff in
208 let rec loop l = if l = 8 then () else
209 let p = l*n in
210 let rec loop1 m = if m = n then () else
211 let p = p+m in
212 let code = r8 data p in
213 modmap.(l).(m) <- code;
214 if l = 1
215 then (
216 let ki = code - state.mink in
217 if ki >= 0
218 then
219 let a = state.keymap.(ki) in
220 let rec capsloop i = if i = Array.length a || i > 3 then () else
221 let s = a.(i) in
222 if s = 0xffe5
223 then state.capslmask <- 2
224 else capsloop (i+1)
226 capsloop 0;
228 else (
229 if l > 3
230 then (
231 let ki = code - state.mink in
232 if ki >= 0
233 then
234 let a = state.keymap.(ki) in
235 let rec lloop i = if i = Array.length a || i > 3 then () else
236 let s = a.(i) in
237 match s with
238 | 0xfe03 -> state.levl3mask <- 1 lsl l
239 | 0xfe11 -> state.levl5mask <- 1 lsl l
240 | 0xff7f -> state.numlmask <- 1 lsl l
241 | _ -> lloop (i+1)
243 lloop 0;
246 loop1 (m+1)
248 loop1 0;
249 loop (l+1)
251 loop 0;
254 let sendwithrep sock s f =
255 Queue.push f state.fifo;
256 sendstr1 s 0 (String.length s) sock;
259 let padcatl ss =
260 let b = Buffer.create 16 in
261 List.iter (Buffer.add_string b) ss;
262 let bl = Buffer.length b in
263 let pl = bl land 3 in
264 if pl != 0
265 then (
266 let pad = "123" in
267 Buffer.add_substring b pad 0 (4 - pl);
269 Buffer.contents b;
272 let padcat s1 s2 = padcatl [s1; s2];;
274 let internreq name onlyifexists =
275 let s = "\016\000\000\000\000\000\000\000" in
276 let s = padcat s name in
277 if onlyifexists then w8 s 1 1;
278 w16 s 2 (String.length s / 4);
279 w16 s 4 (String.length name);
283 let sendintern sock s onlyifexists f =
284 let s = internreq s onlyifexists in
285 sendwithrep sock s f;
288 let createwindowreq wid parent x y w h bw mask =
289 let s = "\001\000\009\000wwwwppppxxyywwhhbwccvvvvmmmmeeee" in
290 w32 s 4 wid;
291 w32 s 8 parent;
292 w16 s 12 x;
293 w16 s 14 y;
294 w16 s 16 w;
295 w16 s 18 h;
296 w16 s 20 bw;
297 w16 s 22 1;
298 w32 s 24 0;
299 w32 s 28 0x800; (* eventmask *)
300 w32 s 32 mask;
304 let getgeometryreq wid =
305 let s = "\014u\002\000dddd" in
306 w32 s 4 wid;
310 let mapreq wid =
311 let s = "\008u\002\000wwww" in
312 w32 s 4 wid;
316 let getkeymapreq first count =
317 let s = "\101u\002\000fcuu" in
318 w8 s 4 first;
319 w8 s 5 count;
323 let changepropreq wid prop typ format props =
324 let s = "\018\000llwwwwppppttttfuuuLLLL" in
325 let s = padcat s props in
326 w16 s 2 (String.length s / 4);
327 w32 s 4 wid;
328 w32 s 8 prop;
329 w32 s 12 typ;
330 w8 s 16 format;
331 let ful = String.length props / (match format with
332 | 8 -> 1
333 | 16 -> 2
334 | 32 -> 4
335 | n -> error "no idea what %d means" n)
337 w32 s 20 ful;
341 let getpropreq delete wid prop typ =
342 let s = "\020\000\006\000wwwwppppttttooooLLLL" in
343 if delete then w8 s 1 1;
344 w32 s 4 wid;
345 w32 s 8 prop;
346 w32 s 12 typ;
347 w32 s 16 0;
348 w32 s 20 2;
352 let openfontreq fid name =
353 let s = "\045ullffffnnuu" in
354 let s = padcat s name in
355 w16 s 2 (String.length s / 4);
356 w32 s 4 fid;
357 w16 s 8 (String.length name);
361 let createglyphcursorreq fid cid cindex =
362 let s = "\094u\008\000ccccffffffffssmmrrggbbRRGGBB" in
363 w32 s 4 cid;
364 w32 s 8 fid;
365 w32 s 12 fid;
366 w16 s 16 cindex;
367 w16 s 18 (cindex+1);
368 w16 s 20 0;
369 w16 s 22 0;
370 w16 s 24 0;
371 w16 s 26 0xffff;
372 w16 s 28 0xffff;
373 w16 s 30 0xffff;
377 let changewindowattributesreq wid mask attrs =
378 let s = "\002ullwwwwmmmm" in
379 let s = padcat s attrs in
380 w16 s 2 (String.length s / 4);
381 w32 s 4 wid;
382 w32 s 8 mask;
386 let configurewindowreq wid mask values =
387 let s = "\012ullwwwwmmuu" in
388 let s = padcat s values in
389 w16 s 2 (String.length s / 4);
390 w32 s 4 wid;
391 w16 s 8 mask;
395 let s32 n =
396 let s = "1234" in
397 w32 s 0 n;
401 let clientmessage format seq wid typ data =
402 let s = "\033fsswwwwtttt" in
403 let s = padcat s data in
404 w8 s 1 format;
405 w16 s 2 seq;
406 w32 s 4 wid;
407 w32 s 8 typ;
411 let sendeventreq propagate destwid mask data =
412 let s = "\025p\011\000wwwwmmmm" in
413 let s = padcat s data in
414 w8 s 1 propagate;
415 w32 s 4 destwid;
416 w32 s 8 mask;
420 let getmodifiermappingreq () =
421 let s = "\119u\001\000" in
425 let getkeysym code mask =
426 let pkpk = state.keymap.(code-state.mink).(0) in
427 if (pkpk >= 0xff80 && pkpk <= 0xffbd)
428 || (pkpk >= 0x11000000 && pkpk <= 0x1100ffff)
429 then (
430 if mask land state.numlmask != 0
431 then
432 let keysym = state.keymap.(code-state.mink).(1) in
433 if keysym = 0 then pkpk else keysym
434 else pkpk
436 else (
437 let shift = (mask land 1) lxor ((mask land state.capslmask) lsr 1) in
438 let index =
439 let l3 = (mask land state.levl3mask) != 0 in
440 let l4 = (mask land state.levl5mask) != 0 in
441 shift +
442 if l3 then (if l4 then 8 else 4) else (if l4 then 6 else 0)
444 let keysym = state.keymap.(code-state.mink).(index) in
445 if index land 1 = 1 && keysym = 0
446 then state.keymap.(code-state.mink).(index - 1)
447 else keysym
451 let readresp sock =
452 let resp = readstr sock 32 in
453 let opcode = r8 resp 0 in
454 match opcode land lnot 0x80 with
455 | 0 -> (* error *)
456 let s = resp in
457 let code = r8 s 1
458 and serial = r16 s 2
459 and resid = r32 resp 4
460 and min = r16 s 8
461 and maj = r8 s 10 in
462 error "code=%d serial=%d resid=%#x min=%d maj=%d\n%S"
463 code serial resid min maj resp;
465 | 1 -> (* response *)
466 let rep = Queue.pop state.fifo in
467 rep resp;
469 | 2 -> (* key press *)
470 if Array.length state.keymap > 0
471 then
472 let code = r8 resp 1 in
473 let mask = r16 resp 28 in
474 let keysym = getkeysym code mask in
475 vlog "keysym = %x %c mask %#x code %d"
476 keysym (Char.unsafe_chr keysym) mask code;
477 state.t#key keysym mask;
479 | 3 -> (* key release *)
480 if Array.length state.keymap > 0
481 then
482 let code = r8 resp 1 in
483 let mask = r16 resp 28 in
484 let keysym = getkeysym code mask in
485 vlog "release keysym = %x %c mask %#x code %#d"
486 keysym (Char.unsafe_chr keysym) mask code
488 | 4 -> (* buttonpress *)
489 let n = r8 resp 1
490 and x = r16s resp 24
491 and y = r16s resp 26
492 and m = r16 resp 28 in
493 state.t#mouse n true x y m;
494 vlog "press %d" n
496 | 5 -> (* buttonrelease *)
497 let n = r8 resp 1
498 and x = r16s resp 24
499 and y = r16s resp 26
500 and m = r16 resp 28 in
501 state.t#mouse n false x y m;
502 vlog "release %d %d %d" n x y
504 | 6 -> (* motion *)
505 let x = r16s resp 24 in
506 let y = r16s resp 26 in
507 let m = r16 resp 28 in
508 if m land 0x1f00 = 0
509 then state.t#pmotion x y
510 else state.t#motion x y;
511 vlog "move %dx%d => %d" x y m
513 | 7 -> (* enter *)
514 let x = r16s resp 24
515 and y = r16s resp 26 in
516 state.t#enter x y;
517 vlog "enter %d %d" x y
519 | 8 -> (* leave *)
520 state.t#leave
522 | 18 -> vlog "unmap";
524 | 19 -> (* map *)
525 vlog "map";
527 | 12 -> (* exposure *)
528 vlog "exposure";
529 state.t#expose
531 | 15 -> (* visibility *)
532 let vis = r8 resp 8 in
533 if vis != 2 then state.t#visible;
534 vlog "visibility %d" vis;
536 | 34 -> (* mapping *)
537 state.keymap <- [||];
538 let s = getkeymapreq state.mink (state.maxk-state.mink-1) in
539 sendwithrep sock s (updkmap sock);
540 state.capslmask <- 0;
541 state.levl3mask <- 0;
542 state.levl5mask <- 0;
543 state.numlmask <- 0;
544 let s = getmodifiermappingreq () in
545 sendwithrep sock s (updmodmap sock);
548 | 33 -> (* clientmessage *)
549 let atom = r32 resp 8 in
550 if atom = state.protoatom
551 then (
552 let atom = r32 resp 12 in
553 if atom = state.deleatom
554 then state.t#quit;
556 vlog "atom %#x" atom
558 | 21 -> (* reparent *)
559 vlog "reparent"
561 | 22 -> (* configure *)
562 let x = r16s resp 16
563 and y = r16s resp 18
564 and w = r16 resp 20
565 and h = r16 resp 22 in
566 vlog "configure cur [%d %d %d %d] conf [%d %d %d %d]"
567 state.x state.y state.w state.h
568 x y w h
570 glxsync ();
571 if w != state.w || h != state.h
572 then (
573 state.t#reshape w h;
575 state.w <- w;
576 state.h <- h;
577 state.x <- x;
578 state.y <- y;
579 state.t#expose
581 | 28 ->
582 let atom = r32 resp 8 in
583 if atom = state.nwmsatom
584 then
585 let s = getpropreq false state.idbase atom 4 in
586 sendwithrep sock s (fun resp ->
587 let len = r32 resp 4 in
588 let nitems = r32 resp 16 in
589 let wsl =
590 if len = 0
591 then []
592 else
593 let s = readstr sock (len*4) in
594 let rec loop wsl i = if i = nitems then wsl else
595 let atom = r32 s (i*4) in
596 let wsl =
597 if atom = state.maxhatom
598 then MaxHorz::wsl
599 else (
600 if atom = state.maxvatom
601 then MaxVert::wsl
602 else (
603 if atom = state.fulsatom
604 then (
605 state.fs <- Fs (state.x, state.y, state.w, state.h);
606 Fullscreen::wsl
608 else wsl
611 in loop wsl (i+1)
613 loop [] 0
615 state.t#winstate (List.sort compare wsl)
618 | n ->
619 dolog "event %d %S" n resp
622 let readresp sock =
623 let rec loop () =
624 readresp sock;
625 if hasdata sock then loop ();
627 loop ();
630 let sendstr s ?(pos=0) ?(len=String.length s) sock =
631 sendstr1 s pos len sock;
632 if hasdata sock then readresp sock;
635 let reshape w h =
636 if state.fs = NoFs
637 then
638 let s = "wwuuhhuu" in
639 w32 s 0 w;
640 w32 s 4 h;
641 let s = configurewindowreq state.idbase 0x000c s in
642 sendstr s state.sock;
643 else state.fullscreen state.idbase
646 let activatewin () =
647 state.actwin ();
650 let syncsendwithrep sock secstowait s f =
651 let completed = ref false in
652 sendwithrep sock s (fun resp -> f resp; completed := true);
653 let now = Unix.gettimeofday in
654 let deadline = now () +. secstowait in
655 let rec readtillcompletion () =
656 let sf deadline =
657 let timeout = deadline -. now () in
658 if timeout <= 0.0
659 then [], [], []
660 else Unix.select [sock] [] [] timeout
662 let r, _, _ = tempfailureretry sf deadline in
663 match r with
664 | [] -> error "didn't get X response in %f seconds, aborting" secstowait
665 | _ ->
666 readresp sock;
667 if not !completed
668 then readtillcompletion ()
670 readtillcompletion ();
673 let mapwin () =
674 let s = mapreq state.idbase in
675 sendstr s state.sock;
678 let syncsendintern sock secstowait s onlyifexists f =
679 let s = internreq s onlyifexists in
680 syncsendwithrep sock secstowait s f;
683 let setup sock screennum w h =
684 let s = readstr sock 2 in
685 let n = String.length s in
686 if n != 2
687 then error "failed to read X connection setup response n=%d" n;
688 match s.[0] with
689 | '\000' ->
690 let reasonlen = r8 s 1 in
691 let s = readstr sock 6 in
692 let maj = r16 s 0
693 and min = r16 s 2
694 and add = r16 s 4 in
695 let len = add*4 in
696 let data = readstr sock len in
697 let reason = String.sub data 0 reasonlen in
698 error "X connection failed maj=%d min=%d reason=%S"
699 maj min reason
701 | '\002' -> failwith "X connection setup failed: authentication required";
703 | '\001' ->
704 let s = readstr sock 38 in
705 let maj = r16 s 0
706 and min = r16 s 2
707 and add = r16 s 4
708 and idbase = r32 s 10
709 and idmask = r32 s 14
710 and vlen = r16 s 22
711 and screens = r8 s 26
712 and formats = r8 s 27
713 and minkk = r8 s 32
714 and maxkk = r8 s 33 in
715 let data = readstr sock (4*add-32) in
716 let vendor = String.sub data 0 vlen in
717 let pos = ((vlen+3) land lnot 3) + formats*8 in
719 if screennum >= screens
720 then error "invalid screen %d, max %d" screennum (screens-1);
722 let pos =
723 let s = data in
724 let rec findscreen n pos = if n = screennum then pos else
725 let pos =
726 let ndepths = r8 s (pos+39) in
727 let rec skipdepths n pos = if n = ndepths then pos else
728 let pos =
729 let nvisiuals = r16 s (pos+2) in
730 pos + nvisiuals*24 + 8
732 skipdepths (n+1) pos
734 skipdepths n (pos+40)
736 findscreen (n+1) pos
738 findscreen 0 pos
740 let root = r32 data pos in
741 let rootw = r16 data (pos+20)
742 and rooth = r16 data (pos+22) in
743 state.mink <- minkk;
744 state.maxk <- maxkk;
745 state.idbase <- idbase;
746 vlog "vendor = %S, maj=%d min=%d" vendor maj min;
747 vlog "screens = %d formats = %d" screens formats;
748 vlog "minkk = %d maxkk = %d" minkk maxkk;
749 vlog "idbase = %#x idmask = %#x" idbase idmask;
750 vlog "root=%#x %dx%d" root rootw rooth;
752 let mask = 0
753 + 0x00000001 (* KeyPress *)
754 (* + 0x00000002 *) (* KeyRelease *)
755 + 0x00000004 (* ButtonPress *)
756 + 0x00000008 (* ButtonRelease *)
757 + 0x00000010 (* EnterWindow *)
758 + 0x00000020 (* LeaveWindow *)
759 + 0x00000040 (* PointerMotion *)
760 (* + 0x00000080 *) (* PointerMotionHint *)
761 (* + 0x00000100 *) (* Button1Motion *)
762 (* + 0x00000200 *) (* Button2Motion *)
763 (* + 0x00000400 *) (* Button3Motion *)
764 (* + 0x00000800 *) (* Button4Motion *)
765 (* + 0x00001000 *) (* Button5Motion *)
766 + 0x00002000 (* ButtonMotion *)
767 (* + 0x00004000 *) (* KeymapState *)
768 + 0x00008000 (* Exposure *)
769 + 0x00010000 (* VisibilityChange *)
770 + 0x00020000 (* StructureNotify *)
771 (* + 0x00040000 *) (* ResizeRedirect *)
772 (* + 0x00080000 *) (* SubstructureNotify *)
773 (* + 0x00100000 *) (* SubstructureRedirect *)
774 (* + 0x00200000 *) (* FocusChange *)
775 + 0x00400000 (* PropertyChange *)
776 (* + 0x00800000 *) (* ColormapChange *)
777 (* + 0x01000000 *) (* OwnerGrabButton *)
779 let wid = state.idbase in
780 let s = createwindowreq wid root 0 0 w h 0 mask in
781 sendstr s sock;
783 sendintern sock "WM_PROTOCOLS" false (fun resp ->
784 state.protoatom <- r32 resp 8;
785 sendintern sock "WM_DELETE_WINDOW" false (fun resp ->
786 state.deleatom <- r32 resp 8;
787 let s = s32 state.deleatom in
788 let s = changepropreq wid state.protoatom 4 32 s in
789 sendstr s sock;
793 sendintern sock "WM_CLIENT_MACHINE" false (fun resp ->
794 let atom = r32 resp 8 in
795 let empty = "" in
796 let hostname =
797 try Unix.gethostname ()
798 with exn ->
799 dolog "error getting host name: %s" (exntos exn);
800 empty
802 if hostname != empty
803 then
804 let s = changepropreq wid atom state.stringatom 8 hostname in
805 sendstr s sock;
806 sendintern sock "_NET_WM_PID" false (fun resp ->
807 let atom = r32 resp 8 in
808 let pid = Unix.getpid () in
809 let s = s32 pid in
810 let s = changepropreq wid atom (* cardinal *)6 32 s in
811 sendstr s sock;
815 state.actwin <- (fun () ->
816 let s = "\000uuu" in
817 let s = configurewindowreq state.idbase 0x40 s in
818 sendstr s state.sock;
819 let s = mapreq state.idbase in
820 sendstr s state.sock;
823 sendintern sock "_NET_ACTIVE_WINDOW" true (fun resp ->
824 let atom = r32 resp 8 in
825 state.actwin <- (fun () ->
826 let data = String.make 20 '\000' in
827 let cm = clientmessage 32 0 wid atom data in
828 let s = sendeventreq 0 root 0x180000 cm in
829 sendstr s state.sock;
833 syncsendintern sock 2.0 "WM_CLASS" false (fun resp ->
834 let atom = r32 resp 8 in
835 let llpp = "llpp\000llpp\000" in
836 let s = changepropreq wid atom 31 8 llpp in
837 sendstr s sock;
840 let s = getkeymapreq state.mink (state.maxk-state.mink) in
841 sendwithrep sock s (updkmap sock);
843 let s = getmodifiermappingreq () in
844 sendwithrep sock s (updmodmap sock);
846 let s = openfontreq (wid+1) "cursor" in
847 sendstr s sock;
849 Array.iteri (fun i glyphindex ->
850 let s = createglyphcursorreq (wid+1) (wid+2+i) glyphindex in
851 sendstr s sock;
852 ) [|34;48;50;58;128;152|];
854 sendintern sock "UTF8_STRING" true (fun resp ->
855 let atom = r32 resp 8 in
856 if atom != 0
857 then state.stringatom <- atom;
860 let setwmname s =
861 let s = changepropreq state.idbase 39 state.stringatom 8 s in
862 sendstr s state.sock;
864 state.setwmname <- setwmname;
865 sendintern sock "_NET_WM_NAME" true (fun resp ->
866 let atom = r32 resp 8 in
867 if atom != 0
868 then state.setwmname <- (fun s ->
869 setwmname s;
870 let s = changepropreq state.idbase atom state.stringatom 8 s in
871 sendstr s state.sock;
875 state.fullscreen <- (fun wid ->
876 let s = "xxuuyyuuwwuuhhuu" in
877 match state.fs with
878 | NoFs ->
879 w32 s 0 0;
880 w32 s 4 0;
881 w32 s 8 rootw;
882 w32 s 12 rooth;
883 let s = configurewindowreq wid 0x000f s in
884 sendstr s state.sock;
885 state.fs <- Fs (state.x, state.y, state.w, state.h);
887 | Fs (x, y, w, h) ->
888 w32 s 0 x;
889 w32 s 4 y;
890 w32 s 8 w;
891 w32 s 12 h;
892 let s = configurewindowreq wid 0x000f s in
893 sendstr s state.sock;
894 state.fs <- NoFs;
897 sendintern sock "_NET_WM_STATE" true (fun resp ->
898 state.nwmsatom <- r32 resp 8;
899 if state.nwmsatom != 0
900 then (
901 sendintern sock "_NET_WM_STATE_MAXIMIZED_VERT" true (fun resp ->
902 state.maxvatom <- r32 resp 8;
904 sendintern sock "_NET_WM_STATE_MAXIMIZED_HORZ" true (fun resp ->
905 state.maxhatom <- r32 resp 8;
907 sendintern sock "_NET_WM_STATE_FULLSCREEN" true (fun resp ->
908 state.fulsatom <- r32 resp 8;
909 if state.fulsatom != 0
910 then
911 state.fullscreen <-
912 (fun wid ->
913 let data = String.make 20 '\000' in
914 let fs, f =
915 match state.fs with
916 | NoFs -> Fs (-1, -1, -1, -1), 1
917 | Fs _ -> NoFs, 0
919 w32 data 0 f;
920 w32 data 4 state.fulsatom;
922 let cm = clientmessage 32 0 wid state.nwmsatom data in
923 let s = sendeventreq 0 root 0x180000 cm in
924 sendstr s sock;
925 state.fs <- fs;
930 let s = getgeometryreq wid in
931 syncsendwithrep sock 2.0 s (fun resp ->
932 glx wid;
933 let w = r16 resp 16
934 and h = r16 resp 18 in
935 state.w <- w;
936 state.h <- h;
939 | c ->
940 error "unknown conection setup response %d" (Char.code c)
943 let getauth haddr dnum =
944 let haddr =
945 if haddr = "localhost" || String.length haddr = 0
946 then
947 try Unix.gethostname ()
948 with exn ->
949 dolog "failed to resolve `%S': %s" haddr (exntos exn);
950 haddr
951 else haddr
953 let path =
954 try Sys.getenv "XAUTHORITY"
955 with Not_found ->
956 try Filename.concat (Sys.getenv "HOME") ".Xauthority"
957 with Not_found -> ""
959 let readauth ic =
960 let input_string ic len =
961 let s = String.create len in
962 really_input ic s 0 len;
965 let r16 s =
966 let rb pos = Char.code (String.get s pos) in
967 (rb 1) lor ((rb 0) lsl 8)
969 let rec find () =
970 let rs () =
971 let s = input_string ic 2 in
972 let n = r16 s in
973 input_string ic n
975 let family = input_string ic 2 in
976 let addr = rs () in
977 let nums = rs () in
978 let optnum =
979 try Some (int_of_string nums)
980 with exn ->
981 dolog
982 "display number(%S) is not an integer (corrupt %S?): %s"
983 nums path (exntos exn);
984 None
986 let name = rs () in
987 let data = rs () in
989 vlog "family %S addr %S(%S) num %S(%d) name %S data %S"
990 family addr haddr nums dnum name data;
991 match optnum with
992 | Some num when addr = haddr && num = dnum ->
993 name, data
994 | _ -> find ()
996 let name, data =
997 try find ()
998 with
999 | End_of_file -> "", ""
1000 | exn ->
1001 dolog "exception while reading X authority data (%S): %s"
1002 path (exntos exn);
1003 "", ""
1005 close_in ic;
1006 name, data;
1008 let opt =
1010 if String.length path = 0
1011 then None
1012 else Some (open_in_bin path)
1013 with exn ->
1014 if Sys.file_exists path
1015 then
1016 dolog "failed to open X authority file `%S' : %s"
1017 path (exntos exn);
1018 None
1020 match opt with
1021 | None -> "", ""
1022 | Some ic -> readauth ic
1025 let init t w h osx =
1026 let d =
1027 try Sys.getenv "DISPLAY"
1028 with exn ->
1029 error "could not get DISPLAY evironment variable: %s"
1030 (exntos exn)
1032 let getnum w b e =
1033 if b = e
1034 then error "invalid DISPLAY(%s) %S" w d
1035 else
1036 let s = String.sub d b (e - b) in
1037 try int_of_string s
1038 with exn ->
1039 error "invalid DISPLAY %S can not parse %s(%S): %s"
1040 d w s (exntos exn)
1042 let rec phost pos =
1043 if pos = String.length d
1044 then error "invalid DISPLAY %S no display number specified" d
1045 else (
1046 if d.[pos] = ':'
1047 then
1048 let rec pdispnum pos1 =
1049 if pos1 = String.length d
1050 then getnum "display number" (pos+1) pos1, 0
1051 else
1052 match d.[pos1] with
1053 | '.' ->
1054 let dispnum = getnum "display number" (pos+1) pos1 in
1055 let rec pscreennum pos2 =
1056 if pos2 = String.length d
1057 then getnum "screen number" (pos1+1) pos2
1058 else
1059 match d.[pos2] with
1060 | '0' .. '9' -> pscreennum (pos2+1)
1061 | _ ->
1062 error "invalid DISPLAY %S, cannot parse screen number" d
1064 dispnum, pscreennum (pos1+1)
1065 | '0' .. '9' -> pdispnum (pos1+1)
1066 | _ ->
1067 error "invalid DISPLAY %S, cannot parse display number" d
1069 String.sub d 0 pos, pdispnum (pos+1)
1070 else phost (pos+1)
1073 let host, (dispnum, screennum) = phost 0 in
1074 let aname, adata = getauth host dispnum in
1075 let fd =
1076 let fd, addr =
1077 if osx || String.length host = 0 || host = "unix"
1078 then
1079 let addr =
1080 if osx
1081 then Unix.ADDR_UNIX d
1082 else Unix.ADDR_UNIX ("/tmp/.X11-unix/X" ^ string_of_int dispnum)
1084 let fd = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
1085 fd, addr
1086 else
1087 let h =
1088 try Unix.gethostbyname host
1089 with exn ->
1090 error "cannot resolve %S: %s" host (exntos exn)
1092 let addr = h.Unix.h_addr_list.(0) in
1093 let port = 6000 + dispnum in
1094 let fd = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
1095 fd, (Unix.ADDR_INET (addr, port))
1097 try Unix.connect fd addr; fd
1098 with exn ->
1099 error "failed to connect to X: %s" (exntos exn)
1101 cloexec fd;
1102 let s = "luMMmmnndduu" in
1103 let s = padcat s aname in
1104 let s = padcat s adata in
1105 w16 s 2 11;
1106 w16 s 4 0;
1107 w16 s 6 (String.length aname);
1108 w16 s 8 (String.length adata);
1109 sendstr1 s 0 (String.length s) fd;
1110 state.sock <- fd;
1111 setup fd screennum w h;
1112 state.t <- t;
1113 fd, state.w, state.h;
1116 let settitle s =
1117 state.setwmname s;
1120 let setcursor cursor =
1121 if cursor != state.curcurs
1122 then
1123 let n =
1124 match cursor with
1125 | CURSOR_INHERIT -> -1
1126 | CURSOR_INFO -> 3
1127 | CURSOR_CYCLE -> 2
1128 | CURSOR_CROSSHAIR -> 0
1129 | CURSOR_TEXT -> 5
1131 let s = s32 (if n = -1 then 0 else state.idbase+2+n) in
1132 let s = changewindowattributesreq state.idbase (*cursor*)0x4000 s in
1133 sendstr s state.sock;
1134 state.curcurs <- cursor;
1137 let fullscreen () =
1138 state.fullscreen state.idbase;
1141 let metamask = 0x40;;
1142 let altmask = 8;;
1143 let shiftmask = 1;;
1144 let ctrlmask = 4;;
1146 let withalt mask = mask land altmask != 0;;
1147 let withctrl mask = mask land ctrlmask != 0;;
1148 let withshift mask = mask land shiftmask != 0;;
1149 let withmeta mask = mask land metamask != 0;;
1150 let withnone mask = mask land (altmask + ctrlmask + shiftmask + metamask) = 0;;
1152 let xlatt, xlatf =
1153 let t = Hashtbl.create 20
1154 and f = Hashtbl.create 20 in
1155 let add n nl k =
1156 List.iter (fun s -> Hashtbl.add t s k) (n::nl);
1157 Hashtbl.add f k n
1159 let addc c =
1160 let s = String.create 1 in
1161 s.[0] <- c;
1162 add s [] (Char.code c)
1164 let addcr a b =
1165 let an = Char.code a and bn = Char.code b in
1166 for i = an to bn do addc (Char.chr i) done;
1168 addcr '0' '9';
1169 addcr 'a' 'z';
1170 addcr 'A' 'Z';
1171 String.iter addc "`~!@#$%^&*()-_=+\\|[{]};:,./<>?";
1172 for i = 0 to 29 do add ("f" ^ string_of_int (i+1)) [] (0xffbe + i) done;
1173 add "space" [] 0x20;
1174 add "ret" ["return"; "enter"] 0xff0d;
1175 add "tab" [] 0xff09;
1176 add "left" [] 0xff51;
1177 add "right" [] 0xff53;
1178 add "home" [] 0xff50;
1179 add "end" [] 0xff57;
1180 add "ins" ["insert"] 0xff63;
1181 add "del" ["delete"] 0xffff;
1182 add "esc" ["escape"] 0xff1b;
1183 add "pgup" ["pageup"] 0xff55;
1184 add "pgdown" ["pagedown"] 0xff56;
1185 add "backspace" [] 0xff08;
1186 add "up" [] 0xff52;
1187 add "down" [] 0xff54;
1188 t, f;
1191 let keyname k =
1192 try Hashtbl.find xlatf k
1193 with Not_found -> Printf.sprintf "%#x" k;
1196 let namekey name =
1197 try Hashtbl.find xlatt name
1198 with Not_found ->
1199 if String.length name = 1
1200 then Char.code name.[0]
1201 else int_of_string name;