9 external cloexec
: Unix.file_descr
-> unit = "ml_cloexec";;
10 external glx
: int -> unit = "ml_glx";;
11 external glxsync
: unit -> unit = "ml_glxsync";;
12 external swapb
: unit -> unit = "ml_swapb";;
13 external hasdata
: Unix.file_descr
-> bool = "ml_hasdata";;
14 external toutf8
: int -> string = "ml_keysymtoutf8";;
16 let dolog fmt
= Format.kprintf prerr_endline fmt
;;
17 let vlog fmt
= Format.kprintf ignore fmt
;;
22 method reshape _ _
= ()
23 method mouse _ _ _ _ _
= ()
24 method motion _ _
= ()
25 method pmotion _ _
= ()
35 method reshape
: int -> int -> unit
36 method mouse
: int -> bool -> int -> int -> int -> unit
37 method motion
: int -> int -> unit
38 method pmotion
: int -> int -> unit
39 method key
: int -> int -> unit
40 method enter
: int -> int -> unit
48 ; mutable keymap
: int array array
49 ; fifo
: (string -> unit) Queue.t
51 ; mutable protoatom
: int
52 ; mutable deleatom
: int
53 ; mutable idbase
: int
54 ; mutable fullscreen
: (int -> unit)
55 ; mutable setwmname
: (string -> unit)
56 ; mutable stringatom
: int
58 ; mutable sock
: Unix.file_descr
64 ; mutable curcurs
: cursor
69 | Fs
of (int * int * int * int)
76 ; fifo
= Queue.create
()
81 ; fullscreen
= (fun _
-> ())
82 ; setwmname
= (fun _
-> ())
91 ; curcurs
= CURSOR_INHERIT
96 let w8 s pos i
= String.set s pos
(Char.chr
(i
land 0xff));;
100 w8 s
(pos
+1) (i
lsr 8);
105 w16 s
(pos
+2) (i
lsr 16);
109 let rb pos1
= Char.code
(String.get s
(pos
+ pos1
)) in
110 (rb 0) lor ((rb 1) lsl 8)
115 i - ((i land 0x8000) lsl 1);
118 let r8 s pos
= Char.code
(String.get s pos
);;
121 let rb pos1
= Char.code
(String.get s
(pos
+ pos1
)) in
122 let l = (rb 0) lor ((rb 1) lsl 8)
123 and u
= (rb 2) lor ((rb 3) lsl 8) in
127 let exntos = function
128 | Unix.Unix_error
(e
, s
, a
) -> Printf.sprintf
"%s(%s):%s(%d)"
129 s a
(Unix.error_message e
) (Obj.magic e
)
130 | exn
-> Printexc.to_string exn
;
133 let error fmt
= Printf.kprintf failwith fmt
;;
136 let s = String.create n
in
138 let m = Unix.read sock
s pos n
in
143 ignore
(Unix.select
[sock
] [] [] 0.01);
144 loop (pos
+ m) (n
- m)
151 let sendstr1 s pos len sock
=
152 vlog "%d => %S" state.seq
s;
153 state.seq
<- state.seq
+ 1;
154 let n = Unix.send sock
s pos len
[] in
156 then error "send %d returned %d" len
n;
159 let updkmap sock resp
=
160 let syms = r8 resp
1 in
161 let len = r32 resp
4 in
164 then readstr sock
(4*len)
167 let m = len / syms in
168 state.keymap
<- Array.make_matrix
169 (state.maxk
- state.mink
) syms 0xffffff;
170 let rec loop i = if i = m then () else
172 let rec loop2 k l = if l = syms then () else
173 let v = r32 data k in
174 state.keymap
.(i).(l) <- v;
183 let sendwithrep sock
s f
=
184 Queue.push f
state.fifo
;
185 sendstr1 s 0 (String.length
s) sock
;
189 let b = Buffer.create
16 in
190 List.iter
(Buffer.add_string
b) ss
;
191 let bl = Buffer.length
b in
192 let pl = bl land 3 in
196 Buffer.add_substring
b pad 0 (4 - pl);
201 let padcat s1 s2
= padcatl [s1
; s2
];;
203 let internreq name onlyifexists
=
204 let s = "\016\000\000\000\000\000\000\000" in
205 let s = padcat s name
in
206 if onlyifexists
then w8 s 1 1;
207 w16 s 2 (String.length
s / 4);
208 w16 s 4 (String.length name
);
212 let sendintern sock
s onlyifexists f
=
213 let s = internreq s onlyifexists
in
214 sendwithrep sock
s f
;
217 let createwindowreq wid parent x y w h bw mask
=
218 let s = "\001\000\009\000wwwwppppxxyywwhhbwccvvvvmmmmeeee" in
228 w32 s 28 0x800; (* eventmask *)
233 let getgeometryreq wid
=
234 let s = "\014u\002\000dddd" in
240 let s = "\008u\002\000wwww" in
245 let getkeymapreq first count
=
246 let s = "\101u\002\000fcuu" in
252 let changepropreq wid prop typ format props
=
253 let s = "\018\000llwwwwppppttttfuuuLLLL" in
254 let s = padcat s props
in
255 w16 s 2 (String.length
s / 4);
260 let ful = String.length props
/ (match format
with
264 | n -> error "no idea what %d means" n)
270 let openfontreq fid name
=
271 let s = "\045ullffffnnuu" in
272 let s = padcat s name
in
273 w16 s 2 (String.length
s / 4);
275 w16 s 8 (String.length name
);
279 let createglyphcursorreq fid cid cindex
=
280 let s = "\094u\008\000ccccffffffffssmmrrggbbRRGGBB" in
295 let changewindowattributesreq wid mask attrs
=
296 let s = "\002ullwwwwmmmm" in
297 let s = padcat s attrs
in
298 w16 s 2 (String.length
s / 4);
304 let configurewindowreq wid mask values
=
305 let s = "\012ullwwwwmmuu" in
306 let s = padcat s values
in
307 w16 s 2 (String.length
s / 4);
319 let clientmessage format seq wid typ
data =
320 let s = "\033fsswwwwtttt" in
321 let s = padcat s data in
329 let sendeventreq propagate destwid mask
data =
330 let s = "\025p\011\000wwwwmmmm" in
331 let s = padcat s data in
338 let getkeysym code mask
=
339 let index = (mask
land 1) lxor ((mask
land 2) lsr 1) in
340 let keysym = state.keymap
.(code
-state.mink
).(index) in
343 state.il3s
<- state.il3s
lxor 4;
347 let index = index + state.il3s
in
348 let keysym = state.keymap
.(code
-state.mink
).(index) in
349 if index = 1 && keysym = 0
350 then state.keymap
.(code
-state.mink
).(0)
356 let resp = readstr sock
32 in
357 let opcode = r8 resp 0 in
358 match opcode land lnot
0x80 with
363 and resid
= r32 resp 4
366 error "code=%d serial=%d resid=%#x min=%d maj=%d\n%S"
367 code serial resid min maj
resp;
369 | 1 -> (* response *)
370 let rep = Queue.pop
state.fifo
in
373 | 2 -> (* key press *)
374 if Array.length
state.keymap
> 0
376 let code = r8 resp 1 in
377 let mask = r16 resp 28 in
378 let keysym = getkeysym code mask in
379 vlog "keysym = %x %c mask %#x code %d"
380 keysym (Char.unsafe_chr
keysym) mask code;
381 state.t#key
keysym mask;
383 | 3 -> (* key release *)
384 if Array.length
state.keymap
> 0
386 let code = r8 resp 1 in
387 let mask = r16 resp 28 in
388 let keysym = getkeysym code mask in
389 vlog "release keysym = %x %c mask %#x code %#d"
390 keysym (Char.unsafe_chr
keysym) mask code
392 | 4 -> (* buttonpress *)
396 and m = r16 resp 28 in
397 state.t#mouse
n true x y
m;
400 | 5 -> (* buttonrelease *)
404 and m = r16 resp 28 in
405 state.t#mouse
n false x y
m;
406 vlog "release %d %d %d" n x y
409 let x = r16s resp 24 in
410 let y = r16s resp 26 in
411 let m = r16 resp 28 in
413 then state.t#pmotion
x y
414 else state.t#motion
x y;
415 vlog "move %dx%d => %d" x y m
419 and y = r16s resp 26 in
421 vlog "enter %d %d" x y
426 | 18 -> vlog "unmap";
431 | 12 -> (* exposure *)
435 | 15 -> (* visibility *)
436 let vis = r8 resp 8 in
437 if vis != 2 then state.t#expose
;
438 vlog "visibility %d" vis;
440 | 34 -> (* mapping *)
441 state.keymap
<- [||];
442 let s = getkeymapreq state.mink
(state.maxk
-state.mink
-1) in
443 sendwithrep sock
s (updkmap sock
);
445 | 33 -> (* clientmessage *)
446 let atom = r32 resp 8 in
447 if atom = state.protoatom
449 let atom = r32 resp 12 in
450 if atom = state.deleatom
455 | 21 -> (* reparent *)
458 | 22 -> (* configure *)
462 and h
= r16 resp 22 in
463 vlog "configure cur [%d %d %d %d] conf [%d %d %d %d]"
464 state.x state.y state.w
state.h
468 if w
!= state.w
|| h
!= state.h
479 dolog "event %d %S" n resp
485 if hasdata sock
then loop ();
490 let sendstr s ?
(pos
=0) ?
(len=String.length
s) sock
=
491 sendstr1 s pos
len sock
;
492 if hasdata sock
then readresp sock
;
498 let s = "wwuuhhuu" in
501 let s = configurewindowreq state.idbase
0x000c s in
502 sendstr s state.sock
;
503 else state.fullscreen
state.idbase
506 let syncsendwithrep sock secstowait
s f
=
507 let completed = ref false in
508 sendwithrep sock
s (fun resp -> f
resp; completed := true);
509 let now = Unix.gettimeofday
in
510 let deadline = now () +. secstowait
in
511 let rec readtillcompletion () =
512 let r, _
, _
= Unix.select
[sock
] [] [] (deadline -. now ()) in
514 | [] -> error "didn't get X response in %f seconds, aborting" secstowait
518 then readtillcompletion ()
520 readtillcompletion ();
523 let syncsendintern sock secstowait
s onlyifexists f
=
524 let s = internreq s onlyifexists
in
525 syncsendwithrep sock secstowait
s f
;
528 let setup sock screennum w h
=
529 let s = readstr sock
2 in
530 let n = String.length
s in
532 then error "failed to read X connection setup response n=%d" n;
535 let reasonlen = r8 s 1 in
536 let s = readstr sock
6 in
541 let data = readstr sock
len in
542 let reason = String.sub
data 0 reasonlen in
543 error "X connection failed maj=%d min=%d reason=%S"
546 | '
\002'
-> failwith
"X connection setup failed: authentication required";
549 let s = readstr sock
38 in
553 and idbase
= r32 s 10
554 and idmask
= r32 s 14
556 and screens
= r8 s 26
557 and formats
= r8 s 27
559 and maxkk
= r8 s 33 in
560 let data = readstr sock
(4*add
-32) in
561 let vendor = String.sub
data 0 vlen
in
562 let pos = ((vlen
+3) land lnot
3) + formats
*8 in
564 if screennum
>= screens
565 then error "invalid screen %d, max %d" screennum
(screens
-1);
569 let rec findscreen n pos = if n = screennum
then pos else
571 let ndepths = r8 s (pos+39) in
572 let rec skipdepths n pos = if n = ndepths then pos else
574 let nvisiuals = r16 s (pos+2) in
575 pos + nvisiuals*24 + 8
579 skipdepths n (pos+40)
585 let root = r32 data pos in
586 let rootw = r16 data (pos+20)
587 and rooth
= r16 data (pos+22) in
590 state.idbase
<- idbase
;
591 vlog "vendor = %S, maj=%d min=%d" vendor maj min
;
592 vlog "screens = %d formats = %d" screens formats
;
593 vlog "minkk = %d maxkk = %d" minkk maxkk
;
594 vlog "idbase = %#x idmask = %#x" idbase idmask
;
595 vlog "root=%#x %dx%d" root rootw rooth
;
598 + 0x00000001 (* KeyPress *)
599 + 0x00000002 (* KeyRelease *)
600 + 0x00000004 (* ButtonPress *)
601 + 0x00000008 (* ButtonRelease *)
602 + 0x00000010 (* EnterWindow *)
603 + 0x00000020 (* LeaveWindow *)
604 + 0x00000040 (* PointerMotion *)
605 (* + 0x00000080 *) (* PointerMotionHint *)
606 (* + 0x00000100 *) (* Button1Motion *)
607 (* + 0x00000200 *) (* Button2Motion *)
608 (* + 0x00000400 *) (* Button3Motion *)
609 (* + 0x00000800 *) (* Button4Motion *)
610 (* + 0x00001000 *) (* Button5Motion *)
611 + 0x00002000 (* ButtonMotion *)
612 (* + 0x00004000 *) (* KeymapState *)
613 + 0x00008000 (* Exposure *)
614 + 0x00010000 (* VisibilityChange *)
615 + 0x00020000 (* StructureNotify *)
616 (* + 0x00040000 *) (* ResizeRedirect *)
617 (* + 0x00080000 *) (* SubstructureNotify *)
618 (* + 0x00100000 *) (* SubstructureRedirect *)
619 (* + 0x00200000 *) (* FocusChange *)
620 (* + 0x00400000 *) (* PropertyChange *)
621 (* + 0x00800000 *) (* ColormapChange *)
622 (* + 0x01000000 *) (* OwnerGrabButton *)
624 let wid = state.idbase
in
625 let s = createwindowreq wid root 0 0 w h
0 mask in
628 sendintern sock
"WM_PROTOCOLS" false (fun resp ->
629 state.protoatom
<- r32 resp 8;
630 sendintern sock
"WM_DELETE_WINDOW" false (fun resp ->
631 state.deleatom
<- r32 resp 8;
632 let s = s32 state.deleatom
in
633 let s = changepropreq wid state.protoatom
4 32 s in
638 syncsendintern sock
2.0 "WM_CLASS" false (fun resp ->
639 let atom = r32 resp 8 in
640 let llpp = "llpp\000llpp\000" in
641 let s = changepropreq wid atom 31 8 llpp in
645 let s = mapreq wid in
648 let s = getkeymapreq state.mink
(state.maxk
-state.mink
) in
649 sendwithrep sock
s (updkmap sock
);
651 let s = openfontreq (wid+1) "cursor" in
654 Array.iteri
(fun i glyphindex
->
655 let s = createglyphcursorreq (wid+1) (wid+2+i) glyphindex
in
657 ) [|34;48;50;58;128;152|];
659 sendintern sock
"UTF8_STRING" true (fun resp ->
660 let atom = r32 resp 8 in
662 then state.stringatom
<- atom;
666 let s = changepropreq state.idbase
39 state.stringatom
8 s in
667 sendstr s state.sock
;
669 state.setwmname <- setwmname;
670 sendintern sock
"_NET_WM_NAME" true (fun resp ->
671 let atom = r32 resp 8 in
673 then state.setwmname <- (fun s ->
675 let s = changepropreq state.idbase
atom state.stringatom
8 s in
676 sendstr s state.sock
;
680 state.fullscreen
<- (fun wid ->
681 let s = "xxuuyyuuwwuuhhuu" in
688 let s = configurewindowreq wid 0x000f s in
689 sendstr s state.sock
;
690 state.fs
<- Fs
(state.x, state.y, state.w
, state.h
);
697 let s = configurewindowreq wid 0x000f s in
698 sendstr s state.sock
;
702 sendintern sock
"_NET_WM_STATE" true (fun resp ->
703 let nwmsatom = r32 resp 8 in
706 sendintern sock
"_NET_WM_STATE_FULLSCREEN" true (fun resp ->
707 let fsatom = r32 resp 8 in
712 let data = String.make
20 '
\000'
in
715 | NoFs
-> Fs
(-1, -1, -1, -1), 1
721 let cm = clientmessage 32 0 wid nwmsatom data in
722 let s = sendeventreq 0 root 0x180000 cm in
728 let s = getgeometryreq wid in
729 syncsendwithrep sock
2.0 s (fun resp ->
732 and h
= r16 resp 18 in
738 error "unknown conection setup response %d" (Char.code c
)
741 let getauth haddr dnum
=
743 if haddr = "localhost" || String.length
haddr = 0
745 try Unix.gethostname
()
747 dolog "failed to resolve `%S': %s" haddr (exntos exn
);
752 try Sys.getenv
"XAUTHORITY"
754 try Filename.concat
(Sys.getenv
"HOME") ".Xauthority"
758 let input_string ic
len =
759 let s = String.create
len in
760 really_input ic
s 0 len;
764 let rb pos = Char.code (String.get
s pos) in
765 (rb 1) lor ((rb 0) lsl 8)
769 let s = input_string ic
2 in
773 let family = input_string ic
2 in
777 try Some
(int_of_string
nums)
780 "display number(%S) is not an integer (corrupt %S?): %s"
781 nums path (exntos exn
);
787 vlog "family %S addr %S(%S) num %S(%d) name %S data %S"
788 family addr haddr nums dnum
name data;
790 | Some num
when addr = haddr && num
= dnum
->
797 | End_of_file
-> "", ""
799 dolog "exception while reading X authority data (%S): %s"
808 if String.length
path = 0
810 else Some
(open_in_bin
path)
812 if Sys.file_exists
path
814 dolog "failed to open X authority file `%S' : %s"
820 | Some ic
-> readauth ic
825 try Sys.getenv
"DISPLAY"
827 error "could not get DISPLAY evironment variable: %s"
832 then error "invalid DISPLAY(%s) %S" w d
834 let s = String.sub
d b (e
- b) in
837 error "invalid DISPLAY %S can not parse %s(%S): %s"
841 if pos = String.length
d
842 then error "invalid DISPLAY %S no display number specified" d
846 let rec pdispnum pos1
=
847 if pos1
= String.length
d
848 then getnum "display number" (pos+1) pos1
, 0
852 let dispnum = getnum "display number" (pos+1) pos1
in
853 let rec pscreennum pos2
=
854 if pos2
= String.length
d
855 then getnum "screen number" (pos1
+1) pos2
858 | '
0'
.. '
9'
-> pscreennum (pos2
+1)
860 error "invalid DISPLAY %S, cannot parse screen number" d
862 dispnum, pscreennum (pos1
+1)
863 | '
0'
.. '
9'
-> pdispnum (pos1
+1)
865 error "invalid DISPLAY %S, cannot parse display number" d
867 String.sub
d 0 pos, pdispnum (pos+1)
871 let host, (dispnum, screennum
) = phost 0 in
872 let aname, adata
= getauth host dispnum in
875 if osx
|| String.length
host = 0 || host = "unix"
879 then Unix.ADDR_UNIX
d
880 else Unix.ADDR_UNIX
("/tmp/.X11-unix/X" ^ string_of_int
dispnum)
882 let fd = Unix.socket
Unix.PF_UNIX
Unix.SOCK_STREAM
0 in
886 try Unix.gethostbyname
host
888 error "cannot resolve %S: %s" host (exntos exn
)
890 let addr = h.Unix.h_addr_list
.(0) in
891 let port = 6000 + dispnum in
892 let fd = Unix.socket
Unix.PF_INET
Unix.SOCK_STREAM
0 in
893 fd, (Unix.ADDR_INET
(addr, port))
895 try Unix.connect
fd addr; fd
897 error "failed to connect to X: %s" (exntos exn
)
900 let s = "luMMmmnndduu" in
901 let s = padcat s aname in
902 let s = padcat s adata
in
905 w16 s 6 (String.length
aname);
906 w16 s 8 (String.length adata
);
907 sendstr1 s 0 (String.length
s) fd;
909 setup fd screennum
w h;
911 fd, state.w, state.h;
918 let setcursor cursor
=
919 if cursor
!= state.curcurs
923 | CURSOR_INHERIT
-> -1
926 | CURSOR_CROSSHAIR
-> 0
929 let s = s32 (if n = -1 then 0 else state.idbase
+2+n) in
930 let s = changewindowattributesreq state.idbase
(*cursor*)0x4000 s in
931 sendstr s state.sock
;
932 state.curcurs
<- cursor
;
936 state.fullscreen state.idbase
;
939 let metamask = 0x40;;
944 let withalt mask = mask land altmask != 0;;
945 let withctrl mask = mask land ctrlmask != 0;;
946 let withshift mask = mask land shiftmask != 0;;
947 let withmeta mask = mask land metamask != 0;;
948 let withnone mask = mask land (altmask + ctrlmask + shiftmask + metamask) = 0;;
951 let t = Hashtbl.create
20
952 and f
= Hashtbl.create
20 in
954 List.iter
(fun s -> Hashtbl.add t s k) (n::nl
);
958 let s = String.create
1 in
960 add s [] (Char.code c
)
963 let an = Char.code a
and bn
= Char.code b in
964 for i = an to bn
do addc (Char.chr
i) done;
969 String.iter
addc "`~!@#$%^&*()-_=+\\|[{]};:,./<>?";
970 for i = 0 to 29 do add ("f" ^ string_of_int
(i+1)) [] (0xffbe + i) done;
972 add "ret" ["return"; "enter"] 0xff0d;
974 add "left" [] 0xff51;
975 add "right" [] 0xff53;
976 add "home" [] 0xff50;
978 add "ins" ["insert"] 0xff63;
979 add "del" ["delete"] 0xffff;
980 add "esc" ["escape"] 0xff1b;
981 add "pgup" ["pageup"] 0xff55;
982 add "pgdown" ["pagedown"] 0xff56;
983 add "backspace" [] 0xff08;
985 add "down" [] 0xff54;
990 try Hashtbl.find xlatf
k
991 with Not_found
-> Printf.sprintf
"%#x" k;
995 try Hashtbl.find xlatt name
997 if String.length
name = 1
998 then Char.code name.[0]
999 else int_of_string
name;