First stab at remote interface
[llpp.git] / wsi.ml
blobf203b931d1b51d19b0db18558d4a4c06648857ae
1 type cursor =
2 | CURSOR_INHERIT
3 | CURSOR_INFO
4 | CURSOR_CYCLE
5 | CURSOR_CROSSHAIR
6 | CURSOR_TEXT
7 ;;
9 let tempfailureretry f a =
10 let rec g () =
11 try f a with Unix.Unix_error (Unix.EINTR, _, _) -> g ()
12 in g ()
15 external cloexec : Unix.file_descr -> unit = "ml_cloexec";;
16 external glx : int -> unit = "ml_glx";;
17 external glxsync : unit -> unit = "ml_glxsync";;
18 external swapb : unit -> unit = "ml_swapb";;
19 external hasdata : Unix.file_descr -> bool = "ml_hasdata";;
20 external toutf8 : int -> string = "ml_keysymtoutf8";;
22 let dolog fmt = Format.kprintf prerr_endline fmt;;
23 let vlog fmt = Format.kprintf ignore fmt;;
25 let onot = object
26 method display = ()
27 method expose = ()
28 method reshape _ _ = ()
29 method mouse _ _ _ _ _ = ()
30 method motion _ _ = ()
31 method pmotion _ _ = ()
32 method key _ _ = ()
33 method enter _ _ = ()
34 method leave = ()
35 method quit = exit 0
36 end;;
38 class type t = object
39 method display : unit
40 method expose : unit
41 method reshape : int -> int -> unit
42 method mouse : int -> bool -> int -> int -> int -> unit
43 method motion : int -> int -> unit
44 method pmotion : int -> int -> unit
45 method key : int -> int -> unit
46 method enter : int -> int -> unit
47 method leave : unit
48 method quit : unit
49 end;;
51 type state =
52 { mutable mink : int
53 ; mutable maxk : int
54 ; mutable keymap : int array array
55 ; fifo : (string -> unit) Queue.t
56 ; mutable seq : int
57 ; mutable protoatom : int
58 ; mutable deleatom : int
59 ; mutable idbase : int
60 ; mutable fullscreen : (int -> unit)
61 ; mutable setwmname : (string -> unit)
62 ; mutable stringatom : int
63 ; mutable t : t
64 ; mutable sock : Unix.file_descr
65 ; mutable x : int
66 ; mutable y : int
67 ; mutable w : int
68 ; mutable h : int
69 ; mutable fs : fs
70 ; mutable curcurs : cursor
71 ; mutable capslmask : int
72 ; mutable numlmask : int
73 ; mutable levl3mask : int
74 ; mutable levl5mask : int
76 and fs =
77 | NoFs
78 | Fs of (int * int * int * int)
81 let state =
82 { mink = max_int
83 ; maxk = min_int
84 ; keymap = [||]
85 ; fifo = Queue.create ()
86 ; seq = 0
87 ; protoatom = -1
88 ; deleatom = -1
89 ; idbase = -1
90 ; fullscreen = (fun _ -> ())
91 ; setwmname = (fun _ -> ())
92 ; sock = Unix.stdin
93 ; t = onot
94 ; x = -1
95 ; y = -1
96 ; w = -1
97 ; h = -1
98 ; fs = NoFs
99 ; stringatom = 31
100 ; curcurs = CURSOR_INHERIT
101 ; capslmask = 0
102 ; numlmask = 0
103 ; levl3mask = 0
104 ; levl5mask = 0
108 let w8 s pos i = String.set s pos (Char.chr (i land 0xff));;
110 let w16 s pos i =
111 w8 s pos i;
112 w8 s (pos+1) (i lsr 8);
115 let w32 s pos i =
116 w16 s pos i;
117 w16 s (pos+2) (i lsr 16);
120 let r16 s pos =
121 let rb pos1 = Char.code (String.get s (pos + pos1)) in
122 (rb 0) lor ((rb 1) lsl 8)
125 let r16s s pos =
126 let i = r16 s pos in
127 i - ((i land 0x8000) lsl 1);
130 let r8 s pos = Char.code (String.get s pos);;
132 let r32 s pos =
133 let rb pos1 = Char.code (String.get s (pos + pos1)) in
134 let l = (rb 0) lor ((rb 1) lsl 8)
135 and u = (rb 2) lor ((rb 3) lsl 8) in
136 (u lsl 16) lor l
139 let exntos = function
140 | Unix.Unix_error (e, s, a) -> Printf.sprintf "%s(%s):%s(%d)"
141 s a (Unix.error_message e) (Obj.magic e)
142 | exn -> Printexc.to_string exn;
145 let error fmt = Printf.kprintf failwith fmt;;
147 let readstr sock n =
148 let s = String.create n in
149 let rec loop pos n =
150 let m = tempfailureretry (Unix.read sock s pos) n in
151 if m = 0
152 then state.t#quit;
153 if n != m
154 then (
155 ignore (tempfailureretry (Unix.select [sock] [] []) 0.01);
156 loop (pos + m) (n - m)
159 loop 0 n;
163 let sendstr1 s pos len sock =
164 vlog "%d => %S" state.seq s;
165 state.seq <- state.seq + 1;
166 let n = tempfailureretry (Unix.send sock s pos len) [] in
167 if n != len
168 then error "send %d returned %d" len n;
171 let updkmap sock resp =
172 let syms = r8 resp 1 in
173 let len = r32 resp 4 in
174 let data =
175 if len > 0
176 then readstr sock (4*len)
177 else ""
179 let m = len / syms in
180 state.keymap <- Array.make_matrix
181 (state.maxk - state.mink) syms 0xffffff;
182 let rec loop i = if i = m then () else
183 let k = i*4*syms in
184 let rec loop2 k l = if l = syms then () else
185 let v = r32 data k in
186 state.keymap.(i).(l) <- v;
187 loop2 (k+4) (l+1)
189 loop2 k 0;
190 loop (i+1);
192 loop 0;
195 let updmodmap sock resp =
196 let n = r8 resp 1 in
197 let len = r16 resp 4 in
198 let data =
199 if len > 0
200 then readstr sock (len*4)
201 else ""
203 let modmap = Array.make_matrix 8 n 0xffffff in
204 let rec loop l = if l = 8 then () else
205 let p = l*n in
206 let rec loop1 m = if m = n then () else
207 let p = p+m in
208 let code = r8 data p in
209 modmap.(l).(m) <- code;
210 if l = 1
211 then (
212 let ki = code - state.mink in
213 if ki >= 0
214 then
215 let a = state.keymap.(ki) in
216 let rec capsloop i = if i = Array.length a || i > 3 then () else
217 let s = a.(i) in
218 if s = 0xffe5
219 then state.capslmask <- 2
220 else capsloop (i+1)
222 capsloop 0;
224 else (
225 if l > 3
226 then (
227 let ki = code - state.mink in
228 if ki >= 0
229 then
230 let a = state.keymap.(ki) in
231 let rec lloop i = if i = Array.length a || i > 3 then () else
232 let s = a.(i) in
233 match s with
234 | 0xfe03 -> state.levl3mask <- 1 lsl l
235 | 0xfe11 -> state.levl5mask <- 1 lsl l
236 | 0xff7f -> state.numlmask <- 1 lsl l
237 | _ -> lloop (i+1)
239 lloop 0;
242 loop1 (m+1)
244 loop1 0;
245 loop (l+1)
247 loop 0;
250 let sendwithrep sock s f =
251 Queue.push f state.fifo;
252 sendstr1 s 0 (String.length s) sock;
255 let padcatl ss =
256 let b = Buffer.create 16 in
257 List.iter (Buffer.add_string b) ss;
258 let bl = Buffer.length b in
259 let pl = bl land 3 in
260 if pl != 0
261 then (
262 let pad = "123" in
263 Buffer.add_substring b pad 0 (4 - pl);
265 Buffer.contents b;
268 let padcat s1 s2 = padcatl [s1; s2];;
270 let internreq name onlyifexists =
271 let s = "\016\000\000\000\000\000\000\000" in
272 let s = padcat s name in
273 if onlyifexists then w8 s 1 1;
274 w16 s 2 (String.length s / 4);
275 w16 s 4 (String.length name);
279 let sendintern sock s onlyifexists f =
280 let s = internreq s onlyifexists in
281 sendwithrep sock s f;
284 let createwindowreq wid parent x y w h bw mask =
285 let s = "\001\000\009\000wwwwppppxxyywwhhbwccvvvvmmmmeeee" in
286 w32 s 4 wid;
287 w32 s 8 parent;
288 w16 s 12 x;
289 w16 s 14 y;
290 w16 s 16 w;
291 w16 s 18 h;
292 w16 s 20 bw;
293 w16 s 22 1;
294 w32 s 24 0;
295 w32 s 28 0x800; (* eventmask *)
296 w32 s 32 mask;
300 let getgeometryreq wid =
301 let s = "\014u\002\000dddd" in
302 w32 s 4 wid;
306 let mapreq wid =
307 let s = "\008u\002\000wwww" in
308 w32 s 4 wid;
312 let getkeymapreq first count =
313 let s = "\101u\002\000fcuu" in
314 w8 s 4 first;
315 w8 s 5 count;
319 let changepropreq wid prop typ format props =
320 let s = "\018\000llwwwwppppttttfuuuLLLL" in
321 let s = padcat s props in
322 w16 s 2 (String.length s / 4);
323 w32 s 4 wid;
324 w32 s 8 prop;
325 w32 s 12 typ;
326 w8 s 16 format;
327 let ful = String.length props / (match format with
328 | 8 -> 1
329 | 16 -> 2
330 | 32 -> 4
331 | n -> error "no idea what %d means" n)
333 w32 s 20 ful;
337 let openfontreq fid name =
338 let s = "\045ullffffnnuu" in
339 let s = padcat s name in
340 w16 s 2 (String.length s / 4);
341 w32 s 4 fid;
342 w16 s 8 (String.length name);
346 let createglyphcursorreq fid cid cindex =
347 let s = "\094u\008\000ccccffffffffssmmrrggbbRRGGBB" in
348 w32 s 4 cid;
349 w32 s 8 fid;
350 w32 s 12 fid;
351 w16 s 16 cindex;
352 w16 s 18 (cindex+1);
353 w16 s 20 0;
354 w16 s 22 0;
355 w16 s 24 0;
356 w16 s 26 0xffff;
357 w16 s 28 0xffff;
358 w16 s 30 0xffff;
362 let changewindowattributesreq wid mask attrs =
363 let s = "\002ullwwwwmmmm" in
364 let s = padcat s attrs in
365 w16 s 2 (String.length s / 4);
366 w32 s 4 wid;
367 w32 s 8 mask;
371 let configurewindowreq wid mask values =
372 let s = "\012ullwwwwmmuu" in
373 let s = padcat s values in
374 w16 s 2 (String.length s / 4);
375 w32 s 4 wid;
376 w16 s 8 mask;
380 let s32 n =
381 let s = "1234" in
382 w32 s 0 n;
386 let clientmessage format seq wid typ data =
387 let s = "\033fsswwwwtttt" in
388 let s = padcat s data in
389 w8 s 1 format;
390 w16 s 2 seq;
391 w32 s 4 wid;
392 w32 s 8 typ;
396 let sendeventreq propagate destwid mask data =
397 let s = "\025p\011\000wwwwmmmm" in
398 let s = padcat s data in
399 w8 s 1 propagate;
400 w32 s 4 destwid;
401 w32 s 8 mask;
405 let getmodifiermappingreq () =
406 let s = "\119u\001\000" in
410 let getkeysym code mask =
411 let pkpk = state.keymap.(code-state.mink).(0) in
412 if (pkpk >= 0xff80 && pkpk <= 0xffbd)
413 || (pkpk >= 0x11000000 && pkpk <= 0x1100ffff)
414 then (
415 if mask land state.numlmask != 0
416 then
417 let keysym = state.keymap.(code-state.mink).(1) in
418 if keysym = 0 then pkpk else keysym
419 else pkpk
421 else (
422 let shift = (mask land 1) lxor ((mask land state.capslmask) lsr 1) in
423 let index =
424 let l3 = (mask land state.levl3mask) != 0 in
425 let l4 = (mask land state.levl5mask) != 0 in
426 shift +
427 if l3 then (if l4 then 8 else 4) else (if l4 then 6 else 0)
429 let keysym = state.keymap.(code-state.mink).(index) in
430 if index land 1 = 1 && keysym = 0
431 then state.keymap.(code-state.mink).(index - 1)
432 else keysym
436 let readresp sock =
437 let resp = readstr sock 32 in
438 let opcode = r8 resp 0 in
439 match opcode land lnot 0x80 with
440 | 0 -> (* error *)
441 let s = resp in
442 let code = r8 s 1
443 and serial = r16 s 2
444 and resid = r32 resp 4
445 and min = r16 s 8
446 and maj = r8 s 10 in
447 error "code=%d serial=%d resid=%#x min=%d maj=%d\n%S"
448 code serial resid min maj resp;
450 | 1 -> (* response *)
451 let rep = Queue.pop state.fifo in
452 rep resp;
454 | 2 -> (* key press *)
455 if Array.length state.keymap > 0
456 then
457 let code = r8 resp 1 in
458 let mask = r16 resp 28 in
459 let keysym = getkeysym code mask in
460 vlog "keysym = %x %c mask %#x code %d"
461 keysym (Char.unsafe_chr keysym) mask code;
462 state.t#key keysym mask;
464 | 3 -> (* key release *)
465 if Array.length state.keymap > 0
466 then
467 let code = r8 resp 1 in
468 let mask = r16 resp 28 in
469 let keysym = getkeysym code mask in
470 vlog "release keysym = %x %c mask %#x code %#d"
471 keysym (Char.unsafe_chr keysym) mask code
473 | 4 -> (* buttonpress *)
474 let n = r8 resp 1
475 and x = r16s resp 24
476 and y = r16s resp 26
477 and m = r16 resp 28 in
478 state.t#mouse n true x y m;
479 vlog "press %d" n
481 | 5 -> (* buttonrelease *)
482 let n = r8 resp 1
483 and x = r16s resp 24
484 and y = r16s resp 26
485 and m = r16 resp 28 in
486 state.t#mouse n false x y m;
487 vlog "release %d %d %d" n x y
489 | 6 -> (* motion *)
490 let x = r16s resp 24 in
491 let y = r16s resp 26 in
492 let m = r16 resp 28 in
493 if m land 0x1f00 = 0
494 then state.t#pmotion x y
495 else state.t#motion x y;
496 vlog "move %dx%d => %d" x y m
498 | 7 -> (* enter *)
499 let x = r16s resp 24
500 and y = r16s resp 26 in
501 state.t#enter x y;
502 vlog "enter %d %d" x y
504 | 8 -> (* leave *)
505 state.t#leave
507 | 18 -> vlog "unmap";
509 | 19 -> (* map *)
510 vlog "map";
512 | 12 -> (* exposure *)
513 vlog "exposure";
514 state.t#expose
516 | 15 -> (* visibility *)
517 let vis = r8 resp 8 in
518 if vis != 2 then state.t#expose;
519 vlog "visibility %d" vis;
521 | 34 -> (* mapping *)
522 state.keymap <- [||];
523 let s = getkeymapreq state.mink (state.maxk-state.mink-1) in
524 sendwithrep sock s (updkmap sock);
525 state.capslmask <- 0;
526 state.levl3mask <- 0;
527 state.levl5mask <- 0;
528 state.numlmask <- 0;
529 let s = getmodifiermappingreq () in
530 sendwithrep sock s (updmodmap sock);
533 | 33 -> (* clientmessage *)
534 let atom = r32 resp 8 in
535 if atom = state.protoatom
536 then (
537 let atom = r32 resp 12 in
538 if atom = state.deleatom
539 then state.t#quit;
541 vlog "atom %#x" atom
543 | 21 -> (* reparent *)
544 vlog "reparent"
546 | 22 -> (* configure *)
547 let x = r16s resp 16
548 and y = r16s resp 18
549 and w = r16 resp 20
550 and h = r16 resp 22 in
551 vlog "configure cur [%d %d %d %d] conf [%d %d %d %d]"
552 state.x state.y state.w state.h
553 x y w h
555 glxsync ();
556 if w != state.w || h != state.h
557 then (
558 state.t#reshape w h;
560 state.w <- w;
561 state.h <- h;
562 state.x <- x;
563 state.y <- y;
564 state.t#expose
566 | n ->
567 dolog "event %d %S" n resp
570 let readresp sock =
571 let rec loop () =
572 readresp sock;
573 if hasdata sock then loop ();
575 loop ();
578 let sendstr s ?(pos=0) ?(len=String.length s) sock =
579 sendstr1 s pos len sock;
580 if hasdata sock then readresp sock;
583 let reshape w h =
584 if state.fs = NoFs
585 then
586 let s = "wwuuhhuu" in
587 w32 s 0 w;
588 w32 s 4 h;
589 let s = configurewindowreq state.idbase 0x000c s in
590 sendstr s state.sock;
591 else state.fullscreen state.idbase
594 let syncsendwithrep sock secstowait s f =
595 let completed = ref false in
596 sendwithrep sock s (fun resp -> f resp; completed := true);
597 let now = Unix.gettimeofday in
598 let deadline = now () +. secstowait in
599 let rec readtillcompletion () =
600 let sf deadline =
601 let timeout = deadline -. now () in
602 if timeout <= 0.0
603 then [], [], []
604 else Unix.select [sock] [] [] timeout
606 let r, _, _ = tempfailureretry sf deadline in
607 match r with
608 | [] -> error "didn't get X response in %f seconds, aborting" secstowait
609 | _ ->
610 readresp sock;
611 if not !completed
612 then readtillcompletion ()
614 readtillcompletion ();
617 let syncsendintern sock secstowait s onlyifexists f =
618 let s = internreq s onlyifexists in
619 syncsendwithrep sock secstowait s f;
622 let setup sock screennum w h =
623 let s = readstr sock 2 in
624 let n = String.length s in
625 if n != 2
626 then error "failed to read X connection setup response n=%d" n;
627 match s.[0] with
628 | '\000' ->
629 let reasonlen = r8 s 1 in
630 let s = readstr sock 6 in
631 let maj = r16 s 0
632 and min = r16 s 2
633 and add = r16 s 4 in
634 let len = add*4 in
635 let data = readstr sock len in
636 let reason = String.sub data 0 reasonlen in
637 error "X connection failed maj=%d min=%d reason=%S"
638 maj min reason
640 | '\002' -> failwith "X connection setup failed: authentication required";
642 | '\001' ->
643 let s = readstr sock 38 in
644 let maj = r16 s 0
645 and min = r16 s 2
646 and add = r16 s 4
647 and idbase = r32 s 10
648 and idmask = r32 s 14
649 and vlen = r16 s 22
650 and screens = r8 s 26
651 and formats = r8 s 27
652 and minkk = r8 s 32
653 and maxkk = r8 s 33 in
654 let data = readstr sock (4*add-32) in
655 let vendor = String.sub data 0 vlen in
656 let pos = ((vlen+3) land lnot 3) + formats*8 in
658 if screennum >= screens
659 then error "invalid screen %d, max %d" screennum (screens-1);
661 let pos =
662 let s = data in
663 let rec findscreen n pos = if n = screennum then pos else
664 let pos =
665 let ndepths = r8 s (pos+39) in
666 let rec skipdepths n pos = if n = ndepths then pos else
667 let pos =
668 let nvisiuals = r16 s (pos+2) in
669 pos + nvisiuals*24 + 8
671 skipdepths (n+1) pos
673 skipdepths n (pos+40)
675 findscreen (n+1) pos
677 findscreen 0 pos
679 let root = r32 data pos in
680 let rootw = r16 data (pos+20)
681 and rooth = r16 data (pos+22) in
682 state.mink <- minkk;
683 state.maxk <- maxkk;
684 state.idbase <- idbase;
685 vlog "vendor = %S, maj=%d min=%d" vendor maj min;
686 vlog "screens = %d formats = %d" screens formats;
687 vlog "minkk = %d maxkk = %d" minkk maxkk;
688 vlog "idbase = %#x idmask = %#x" idbase idmask;
689 vlog "root=%#x %dx%d" root rootw rooth;
691 let mask = 0
692 + 0x00000001 (* KeyPress *)
693 (* + 0x00000002 *) (* KeyRelease *)
694 + 0x00000004 (* ButtonPress *)
695 + 0x00000008 (* ButtonRelease *)
696 + 0x00000010 (* EnterWindow *)
697 + 0x00000020 (* LeaveWindow *)
698 + 0x00000040 (* PointerMotion *)
699 (* + 0x00000080 *) (* PointerMotionHint *)
700 (* + 0x00000100 *) (* Button1Motion *)
701 (* + 0x00000200 *) (* Button2Motion *)
702 (* + 0x00000400 *) (* Button3Motion *)
703 (* + 0x00000800 *) (* Button4Motion *)
704 (* + 0x00001000 *) (* Button5Motion *)
705 + 0x00002000 (* ButtonMotion *)
706 (* + 0x00004000 *) (* KeymapState *)
707 + 0x00008000 (* Exposure *)
708 + 0x00010000 (* VisibilityChange *)
709 + 0x00020000 (* StructureNotify *)
710 (* + 0x00040000 *) (* ResizeRedirect *)
711 (* + 0x00080000 *) (* SubstructureNotify *)
712 (* + 0x00100000 *) (* SubstructureRedirect *)
713 (* + 0x00200000 *) (* FocusChange *)
714 (* + 0x00400000 *) (* PropertyChange *)
715 (* + 0x00800000 *) (* ColormapChange *)
716 (* + 0x01000000 *) (* OwnerGrabButton *)
718 let wid = state.idbase in
719 let s = createwindowreq wid root 0 0 w h 0 mask in
720 sendstr s sock;
722 sendintern sock "WM_PROTOCOLS" false (fun resp ->
723 state.protoatom <- r32 resp 8;
724 sendintern sock "WM_DELETE_WINDOW" false (fun resp ->
725 state.deleatom <- r32 resp 8;
726 let s = s32 state.deleatom in
727 let s = changepropreq wid state.protoatom 4 32 s in
728 sendstr s sock;
732 syncsendintern sock 2.0 "WM_CLASS" false (fun resp ->
733 let atom = r32 resp 8 in
734 let llpp = "llpp\000llpp\000" in
735 let s = changepropreq wid atom 31 8 llpp in
736 sendstr s sock;
739 let s = mapreq wid in
740 sendstr s sock;
742 let s = getkeymapreq state.mink (state.maxk-state.mink) in
743 sendwithrep sock s (updkmap sock);
745 let s = getmodifiermappingreq () in
746 sendwithrep sock s (updmodmap sock);
748 let s = openfontreq (wid+1) "cursor" in
749 sendstr s sock;
751 Array.iteri (fun i glyphindex ->
752 let s = createglyphcursorreq (wid+1) (wid+2+i) glyphindex in
753 sendstr s sock;
754 ) [|34;48;50;58;128;152|];
756 sendintern sock "UTF8_STRING" true (fun resp ->
757 let atom = r32 resp 8 in
758 if atom != 0
759 then state.stringatom <- atom;
762 let setwmname s =
763 let s = changepropreq state.idbase 39 state.stringatom 8 s in
764 sendstr s state.sock;
766 state.setwmname <- setwmname;
767 sendintern sock "_NET_WM_NAME" true (fun resp ->
768 let atom = r32 resp 8 in
769 if atom != 0
770 then state.setwmname <- (fun s ->
771 setwmname s;
772 let s = changepropreq state.idbase atom state.stringatom 8 s in
773 sendstr s state.sock;
777 state.fullscreen <- (fun wid ->
778 let s = "xxuuyyuuwwuuhhuu" in
779 match state.fs with
780 | NoFs ->
781 w32 s 0 0;
782 w32 s 4 0;
783 w32 s 8 rootw;
784 w32 s 12 rooth;
785 let s = configurewindowreq wid 0x000f s in
786 sendstr s state.sock;
787 state.fs <- Fs (state.x, state.y, state.w, state.h);
789 | Fs (x, y, w, h) ->
790 w32 s 0 x;
791 w32 s 4 y;
792 w32 s 8 w;
793 w32 s 12 h;
794 let s = configurewindowreq wid 0x000f s in
795 sendstr s state.sock;
796 state.fs <- NoFs;
799 sendintern sock "_NET_WM_STATE" true (fun resp ->
800 let nwmsatom = r32 resp 8 in
801 if nwmsatom != 0
802 then
803 sendintern sock "_NET_WM_STATE_FULLSCREEN" true (fun resp ->
804 let fsatom = r32 resp 8 in
805 if fsatom != 0
806 then
807 state.fullscreen <-
808 (fun wid ->
809 let data = String.make 20 '\000' in
810 let fs, f =
811 match state.fs with
812 | NoFs -> Fs (-1, -1, -1, -1), 1
813 | Fs _ -> NoFs, 0
815 w32 data 0 f;
816 w32 data 4 fsatom;
818 let cm = clientmessage 32 0 wid nwmsatom data in
819 let s = sendeventreq 0 root 0x180000 cm in
820 sendstr s sock;
821 state.fs <- fs;
825 let s = getgeometryreq wid in
826 syncsendwithrep sock 2.0 s (fun resp ->
827 glx wid;
828 let w = r16 resp 16
829 and h = r16 resp 18 in
830 state.w <- w;
831 state.h <- h;
834 | c ->
835 error "unknown conection setup response %d" (Char.code c)
838 let getauth haddr dnum =
839 let haddr =
840 if haddr = "localhost" || String.length haddr = 0
841 then
842 try Unix.gethostname ()
843 with exn ->
844 dolog "failed to resolve `%S': %s" haddr (exntos exn);
845 haddr
846 else haddr
848 let path =
849 try Sys.getenv "XAUTHORITY"
850 with Not_found ->
851 try Filename.concat (Sys.getenv "HOME") ".Xauthority"
852 with Not_found -> ""
854 let readauth ic =
855 let input_string ic len =
856 let s = String.create len in
857 really_input ic s 0 len;
860 let r16 s =
861 let rb pos = Char.code (String.get s pos) in
862 (rb 1) lor ((rb 0) lsl 8)
864 let rec find () =
865 let rs () =
866 let s = input_string ic 2 in
867 let n = r16 s in
868 input_string ic n
870 let family = input_string ic 2 in
871 let addr = rs () in
872 let nums = rs () in
873 let optnum =
874 try Some (int_of_string nums)
875 with exn ->
876 dolog
877 "display number(%S) is not an integer (corrupt %S?): %s"
878 nums path (exntos exn);
879 None
881 let name = rs () in
882 let data = rs () in
884 vlog "family %S addr %S(%S) num %S(%d) name %S data %S"
885 family addr haddr nums dnum name data;
886 match optnum with
887 | Some num when addr = haddr && num = dnum ->
888 name, data
889 | _ -> find ()
891 let name, data =
892 try find ()
893 with
894 | End_of_file -> "", ""
895 | exn ->
896 dolog "exception while reading X authority data (%S): %s"
897 path (exntos exn);
898 "", ""
900 close_in ic;
901 name, data;
903 let opt =
905 if String.length path = 0
906 then None
907 else Some (open_in_bin path)
908 with exn ->
909 if Sys.file_exists path
910 then
911 dolog "failed to open X authority file `%S' : %s"
912 path (exntos exn);
913 None
915 match opt with
916 | None -> "", ""
917 | Some ic -> readauth ic
920 let init t w h osx =
921 let d =
922 try Sys.getenv "DISPLAY"
923 with exn ->
924 error "could not get DISPLAY evironment variable: %s"
925 (exntos exn)
927 let getnum w b e =
928 if b = e
929 then error "invalid DISPLAY(%s) %S" w d
930 else
931 let s = String.sub d b (e - b) in
932 try int_of_string s
933 with exn ->
934 error "invalid DISPLAY %S can not parse %s(%S): %s"
935 d w s (exntos exn)
937 let rec phost pos =
938 if pos = String.length d
939 then error "invalid DISPLAY %S no display number specified" d
940 else (
941 if d.[pos] = ':'
942 then
943 let rec pdispnum pos1 =
944 if pos1 = String.length d
945 then getnum "display number" (pos+1) pos1, 0
946 else
947 match d.[pos1] with
948 | '.' ->
949 let dispnum = getnum "display number" (pos+1) pos1 in
950 let rec pscreennum pos2 =
951 if pos2 = String.length d
952 then getnum "screen number" (pos1+1) pos2
953 else
954 match d.[pos2] with
955 | '0' .. '9' -> pscreennum (pos2+1)
956 | _ ->
957 error "invalid DISPLAY %S, cannot parse screen number" d
959 dispnum, pscreennum (pos1+1)
960 | '0' .. '9' -> pdispnum (pos1+1)
961 | _ ->
962 error "invalid DISPLAY %S, cannot parse display number" d
964 String.sub d 0 pos, pdispnum (pos+1)
965 else phost (pos+1)
968 let host, (dispnum, screennum) = phost 0 in
969 let aname, adata = getauth host dispnum in
970 let fd =
971 let fd, addr =
972 if osx || String.length host = 0 || host = "unix"
973 then
974 let addr =
975 if osx
976 then Unix.ADDR_UNIX d
977 else Unix.ADDR_UNIX ("/tmp/.X11-unix/X" ^ string_of_int dispnum)
979 let fd = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
980 fd, addr
981 else
982 let h =
983 try Unix.gethostbyname host
984 with exn ->
985 error "cannot resolve %S: %s" host (exntos exn)
987 let addr = h.Unix.h_addr_list.(0) in
988 let port = 6000 + dispnum in
989 let fd = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
990 fd, (Unix.ADDR_INET (addr, port))
992 try Unix.connect fd addr; fd
993 with exn ->
994 error "failed to connect to X: %s" (exntos exn)
996 cloexec fd;
997 let s = "luMMmmnndduu" in
998 let s = padcat s aname in
999 let s = padcat s adata in
1000 w16 s 2 11;
1001 w16 s 4 0;
1002 w16 s 6 (String.length aname);
1003 w16 s 8 (String.length adata);
1004 sendstr1 s 0 (String.length s) fd;
1005 state.sock <- fd;
1006 setup fd screennum w h;
1007 state.t <- t;
1008 fd, state.w, state.h;
1011 let settitle s =
1012 state.setwmname s;
1015 let setcursor cursor =
1016 if cursor != state.curcurs
1017 then
1018 let n =
1019 match cursor with
1020 | CURSOR_INHERIT -> -1
1021 | CURSOR_INFO -> 3
1022 | CURSOR_CYCLE -> 2
1023 | CURSOR_CROSSHAIR -> 0
1024 | CURSOR_TEXT -> 5
1026 let s = s32 (if n = -1 then 0 else state.idbase+2+n) in
1027 let s = changewindowattributesreq state.idbase (*cursor*)0x4000 s in
1028 sendstr s state.sock;
1029 state.curcurs <- cursor;
1032 let fullscreen () =
1033 state.fullscreen state.idbase;
1036 let metamask = 0x40;;
1037 let altmask = 8;;
1038 let shiftmask = 1;;
1039 let ctrlmask = 4;;
1041 let withalt mask = mask land altmask != 0;;
1042 let withctrl mask = mask land ctrlmask != 0;;
1043 let withshift mask = mask land shiftmask != 0;;
1044 let withmeta mask = mask land metamask != 0;;
1045 let withnone mask = mask land (altmask + ctrlmask + shiftmask + metamask) = 0;;
1047 let xlatt, xlatf =
1048 let t = Hashtbl.create 20
1049 and f = Hashtbl.create 20 in
1050 let add n nl k =
1051 List.iter (fun s -> Hashtbl.add t s k) (n::nl);
1052 Hashtbl.add f k n
1054 let addc c =
1055 let s = String.create 1 in
1056 s.[0] <- c;
1057 add s [] (Char.code c)
1059 let addcr a b =
1060 let an = Char.code a and bn = Char.code b in
1061 for i = an to bn do addc (Char.chr i) done;
1063 addcr '0' '9';
1064 addcr 'a' 'z';
1065 addcr 'A' 'Z';
1066 String.iter addc "`~!@#$%^&*()-_=+\\|[{]};:,./<>?";
1067 for i = 0 to 29 do add ("f" ^ string_of_int (i+1)) [] (0xffbe + i) done;
1068 add "space" [] 0x20;
1069 add "ret" ["return"; "enter"] 0xff0d;
1070 add "tab" [] 0xff09;
1071 add "left" [] 0xff51;
1072 add "right" [] 0xff53;
1073 add "home" [] 0xff50;
1074 add "end" [] 0xff57;
1075 add "ins" ["insert"] 0xff63;
1076 add "del" ["delete"] 0xffff;
1077 add "esc" ["escape"] 0xff1b;
1078 add "pgup" ["pageup"] 0xff55;
1079 add "pgdown" ["pagedown"] 0xff56;
1080 add "backspace" [] 0xff08;
1081 add "up" [] 0xff52;
1082 add "down" [] 0xff54;
1083 t, f;
1086 let keyname k =
1087 try Hashtbl.find xlatf k
1088 with Not_found -> Printf.sprintf "%#x" k;
1091 let namekey name =
1092 try Hashtbl.find xlatt name
1093 with Not_found ->
1094 if String.length name = 1
1095 then Char.code name.[0]
1096 else int_of_string name;