9 external cloexec
: Unix.file_descr
-> unit = "ml_cloexec";;
10 external glx
: int -> unit = "ml_glx";;
11 external swapb
: unit -> unit = "ml_swapb";;
12 external hasdata
: Unix.file_descr
-> bool = "ml_hasdata";;
13 external toutf8
: int -> string = "ml_keysymtoutf8";;
15 let dolog fmt
= Format.kprintf prerr_endline fmt
;;
16 let vlog fmt
= Format.kprintf ignore fmt
;;
22 method reshape _ _
= ()
23 method mouse _ _ _ _ _
= ()
24 method motion _ _
= ()
25 method pmotion _ _
= ()
31 method reshape
: int -> int -> unit
32 method mouse
: int -> bool -> int -> int -> int -> unit
33 method motion
: int -> int -> unit
34 method pmotion
: int -> int -> unit
35 method key
: int -> int -> unit
41 ; mutable keymap
: int array array
42 ; fifo
: (string -> unit) Queue.t
44 ; mutable protoatom
: int
45 ; mutable deleatom
: int
46 ; mutable idbase
: int
47 ; mutable fullscreen
: (int -> unit)
48 ; mutable stringatom
: int
50 ; mutable sock
: Unix.file_descr
61 ; fifo
= Queue.create
()
66 ; fullscreen
= (fun _
-> ())
76 let w8 s pos i
= String.set s pos
(Char.chr
(i
land 0xff));;
80 w8 s
(pos
+1) (i
lsr 8);
85 w16 s
(pos
+2) (i
lsr 16);
89 let rb pos1
= Char.code
(String.get s
(pos
+ pos1
)) in
90 (rb 0) lor ((rb 1) lsl 8)
95 i - ((i land 0x8000) lsl 1);
98 let r8 s pos
= Char.code
(String.get s pos
);;
101 let rb pos1
= Char.code
(String.get s
(pos
+ pos1
)) in
102 let l = (rb 0) lor ((rb 1) lsl 8)
103 and u
= (rb 2) lor ((rb 3) lsl 8) in
107 let error fmt
= Printf.kprintf failwith fmt
;;
110 let s = String.create n
in
112 let m = Unix.read sock
s pos n
in
115 ignore
(Unix.select
[sock
] [] [] 0.01);
116 loop (pos
+ m) (n
- m)
118 (* error "read %d returned %d" n m; *)
124 let sendstr s ?
(pos
=0) ?
(len
=String.length
s) sock
=
125 vlog "%d => %S" state.seq
s;
126 state.seq
<- state.seq
+ 1;
127 let n = Unix.send sock
s pos len
[] in
129 then error "send %d returned %d" len
n;
132 let updkmap sock resp
=
133 let syms = r8 resp
1 in
134 let len = r32 resp
4 in
137 then readstr sock
(4*len)
140 let m = len / syms in
141 state.keymap
<- Array.make_matrix
142 (state.maxk
- state.mink
) syms 0xffffff;
143 let rec loop i = if i = m then () else
145 let rec loop2 k l = if l = syms then () else
146 let v = r32 data k in
147 state.keymap
.(i).(l) <- v;
156 let sendwithrep sock
s f
=
157 Queue.push f
state.fifo
;
162 let b = Buffer.create
16 in
163 List.iter
(Buffer.add_string
b) ss
;
164 let bl = Buffer.length
b in
165 let pl = bl land 3 in
169 Buffer.add_substring
b pad 0 (4 - pl);
174 let padcat s1 s2
= padcatl [s1
; s2
];;
176 let internreq name onlyifexists
=
177 let s = "\016\000\000\000\000\000\000\000" in
178 let s = padcat s name
in
179 w8 s 1 (if onlyifexists
then 1 else 0);
180 w16 s 2 (String.length
s / 4);
181 w16 s 4 (String.length name
);
185 let sendintern sock
s onlyifexists f
=
186 let s = internreq s onlyifexists
in
187 sendwithrep sock
s f
;
190 let createwindowreq wid parent x y w h bw mask
=
191 let s = "\001\000\009\000wwwwppppxxyywwhhbwccvvvvmmmmeeee" in
201 w32 s 28 0x800; (* eventmask *)
207 let s = "\008u\002\000wwww" in
212 let getkeymapreq first count
=
213 let s = "\101u\002\000fcuu" in
219 let changepropreq wid prop typ format props
=
220 let s = "\018\000llwwwwppppttttfuuuLLLL" in
221 let s = padcat s props
in
222 w16 s 2 (String.length
s / 4);
227 let ful = String.length props
/ (match format
with
231 | n -> error "no idea what %d means" n)
237 let openfontreq fid name
=
238 let s = "\045ullffffnnuu" in
239 let s = padcat s name
in
240 w16 s 2 (String.length
s / 4);
242 w16 s 8 (String.length name
);
246 let createglyphcursorreq fid cid cindex
=
247 let s = "\094u\008\000ccccffffffffssmmrrggbbRRGGBB" in
262 let mapwindowreq wid
=
263 let s = "\008u\002\000wwww" in
268 let changewindowattributesreq wid mask attrs
=
269 let s = "\002ullwwwwmmmm" in
270 let s = padcat s attrs
in
271 w16 s 2 (String.length
s / 4);
277 let configurewindowreq wid mask values
=
278 let s = "\012ullwwwwmmuu" in
279 let s = padcat s values
in
280 w16 s 2 (String.length
s / 4);
292 let clientmessage format seq wid typ
data =
293 let s = "\033fsswwwwtttt" in
294 let s = padcat s data in
302 let sendeventreq propagate destwid mask
data =
303 let s = "\025p\011\000wwwwmmmm" in
304 let s = padcat s data in
312 let resp = readstr sock
32 in
313 let opcode = r8 resp 0 in
314 match opcode land lnot
0x80 with
319 and resid
= r32 resp 4
322 error "code=%d serial=%d resid=%#x min=%d maj=%d\n%S"
323 code serial resid min maj
resp;
325 | 1 -> (* response *)
326 let rep = Queue.pop
state.fifo
in
329 | 2 -> (* key press *)
330 if Array.length
state.keymap
> 0
332 let code = r8 resp 1 in
333 let mask = r16 resp 28 in
334 let index = (mask land 1) lxor ((mask land 2) lsr 1) in
335 let keysym = state.keymap
.(code-state.mink
).(index) in
336 vlog "keysym = %x %c" keysym (Char.unsafe_chr
keysym);
337 state.t#key
keysym mask;
339 | 3 -> (* key release *)
340 if Array.length
state.keymap
> 0
342 let code = r8 resp 1 in
343 let mask = r16 resp 28 in
344 let index = (mask land 1) lxor ((mask land 2) lsr 1) in
345 let keysym = state.keymap
.(code-state.mink
).(index) in
346 vlog "release keysym = %x %c mask %#x"
347 keysym (Char.unsafe_chr
keysym) mask
349 | 4 -> (* buttonpress *)
353 and m = r16 resp 28 in
354 state.t#mouse
n true x y
m;
357 | 5 -> (* buttonrelease *)
361 and m = r16 resp 28 in
362 state.t#mouse
n false x y
m;
363 vlog "release %d %d %d" n x y
366 let x = r16s resp 24 in
367 let y = r16s resp 26 in
368 let m = r16 resp 28 in
370 then state.t#pmotion
x y
371 else state.t#motion
x y;
372 vlog "move %dx%d => %d" x y m
376 | 18 -> vlog "unmap";
379 if state.w
> 0 && state.h
> 0
380 then state.t#reshape
state.w
state.h
;
384 | 12 -> (* exposure *)
388 | 15 -> (* visibility *)
389 let vis = r8 resp 8 in
390 if vis != 2 then state.t#display
;
391 vlog "visibility %d" vis;
393 | 34 -> (* mapping *)
394 state.keymap
<- [||];
395 let s = getkeymapreq state.mink
(state.maxk
-state.mink
-1) in
396 sendwithrep sock
s (updkmap sock
);
398 | 33 -> (* clientmessage *)
399 let atom = r32 resp 8 in
400 if atom = state.protoatom
402 let atom = r32 resp 12 in
403 if atom = state.deleatom
408 | 21 -> (* reparent *)
411 | 22 -> (* configure *)
414 and h
= r16 resp 22 in
415 if w != state.w || h
!= state.h
423 dolog "event %d %S" n resp
429 if hasdata sock
then loop ();
435 let b = Buffer.create
16 in
436 String.iter
(fun c
->
437 Buffer.add_string
b (Printf.sprintf
"%02x" (Char.code c
))) s;
444 state.fullscreen
state.idbase
446 let s = "wwuuhhuu" in
449 let s = configurewindowreq state.idbase
0x000c s in
450 vlog "reshape %d %s %d" state.seq
(hexstr s) (String.length
s);
451 sendstr s state.sock
;
454 let setup sock screennum
=
455 let s = readstr sock
2 in
456 let n = String.length
s in
458 then error "failed to read X connection setup response n=%d" n;
461 let reasonlen = r8 s 1 in
462 let s = readstr sock
6 in
467 let data = readstr sock
len in
468 let reason = String.sub
data 0 reasonlen in
469 error "X connection failed maj=%d min=%d reason=%S"
472 | '
\002'
-> failwith
"X connection setup failed: authentication required";
475 let s = readstr sock
38 in
479 and idbase
= r32 s 10
480 and idmask
= r32 s 14
482 and screens
= r8 s 26
483 and formats
= r8 s 27
485 and maxkk
= r8 s 33 in
486 let data = readstr sock
(4*add
-32) in
487 let vendor = String.sub
data 0 vlen
in
488 let pos = ((vlen
+3) land lnot
3) + formats
*8 in
490 if screennum
>= screens
491 then error "invalid screen %d, max %d" screennum
(screens
-1);
495 let rec findscreen n pos = if n = screennum
then pos else
497 let ndepths = r8 s (pos+39) in
498 let rec skipdepths n pos = if n = ndepths then pos else
500 let nvisiuals = r16 s (pos+2) in
501 pos + nvisiuals*24 + 8
505 skipdepths n (pos+40)
511 let root = r32 data pos in
512 let w = r16 data (pos+20)
513 and h
= r16 data (pos+22) in
516 state.idbase
<- idbase
;
517 vlog "vendor = %S, maj=%d min=%d" vendor maj min
;
518 vlog "screens = %d formats = %d" screens formats
;
519 vlog "minkk = %d maxkk = %d" minkk maxkk
;
520 vlog "idbase = %#x idmask = %#x" idbase idmask
;
521 vlog "root=%#x %dx%d" root w h
;
524 + 0x00000001 (* KeyPress *)
525 (* + 0x00000002 *) (* KeyRelease *)
526 + 0x00000004 (* ButtonPress *)
527 + 0x00000008 (* ButtonRelease *)
528 + 0x00000010 (* EnterWindow *)
529 + 0x00000020 (* LeaveWindow *)
530 + 0x00000040 (* PointerMotion *)
531 (* + 0x00000080 *) (* PointerMotionHint *)
532 (* + 0x00000100 *) (* Button1Motion *)
533 (* + 0x00000200 *) (* Button2Motion *)
534 (* + 0x00000400 *) (* Button3Motion *)
535 (* + 0x00000800 *) (* Button4Motion *)
536 (* + 0x00001000 *) (* Button5Motion *)
537 + 0x00002000 (* ButtonMotion *)
538 (* + 0x00004000 *) (* KeymapState *)
539 + 0x00008000 (* Exposure *)
540 + 0x00010000 (* VisibilityChange *)
541 + 0x00020000 (* StructureNotify *)
542 (* + 0x00040000 *) (* ResizeRedirect *)
543 (* + 0x00080000 *) (* SubstructureNotify *)
544 (* + 0x00100000 *) (* SubstructureRedirect *)
545 (* + 0x00200000 *) (* FocusChange *)
546 (* + 0x00400000 *) (* PropertyChange *)
547 (* + 0x00800000 *) (* ColormapChange *)
548 (* + 0x01000000 *) (* OwnerGrabButton *)
550 let wid = state.idbase
in
551 let s = createwindowreq wid root 0 0 state.w state.h
0 mask in
554 let s = mapreq wid in
557 let s = getkeymapreq state.mink
(state.maxk
-state.mink
) in
558 sendwithrep sock
s (updkmap sock
);
560 sendintern sock
"WM_PROTOCOLS" false (fun resp ->
561 state.protoatom
<- r32 resp 8;
562 sendintern sock
"WM_DELETE_WINDOW" false (fun resp ->
563 state.deleatom
<- r32 resp 8;
564 let s = s32 state.deleatom
in
565 let s = changepropreq wid state.protoatom
4 32 s in
570 sendintern sock
"WM_CLASS" false (fun resp ->
571 let atom = r32 resp 8 in
572 let llpp = "llpp\000llpp\000" in
573 let s = changepropreq wid atom 31 8 llpp in
577 let s = openfontreq (wid+1) "cursor" in
580 Array.iteri
(fun i glyphindex
->
581 let s = createglyphcursorreq (wid+1) (wid+2+i) glyphindex
in
583 ) [|34;48;50;58;128;152|];
585 sendintern sock
"UTF8_STRING" false (fun resp ->
586 state.stringatom
<- r32 resp 8;
589 sendintern sock
"_NET_WM_STATE" true (fun resp ->
590 let nwmsatom = r32 resp 8 in
591 sendintern sock
"_NET_WM_STATE_FULLSCREEN" true (fun resp ->
592 let fsatom = r32 resp 8 in
596 let data = String.make
20 '
\000'
in
597 state.fs
<- not
state.fs
;
598 w32 data 0 (if state.fs
then 1 else 0);
601 let cm = clientmessage 32 0 wid nwmsatom data in
602 let s = sendeventreq 0 root 0x180000 cm in
611 error "unknown conection setup response %d" (Char.code c
)
614 let getauth haddr dnum
=
616 if haddr = "localhost"
617 then Unix.gethostname
()
620 let path = Filename.concat
(Sys.getenv
"HOME") ".Xauthority" in
621 let ic = open_in_bin
path in
622 let input_string ic len =
623 let s = String.create
len in
624 really_input
ic s 0 len;
628 let rb pos = Char.code (String.get
s pos) in
629 (rb 1) lor ((rb 0) lsl 8)
633 let s = input_string ic 2 in
637 let family = input_string ic 2 in
640 let num = int_of_string
nums in
644 vlog "family %S addr %S(%S) num %d(%d) name %S data %S"
645 family addr haddr num dnum
name data;
646 if addr = haddr && num = dnum
651 try find () with _
-> "", ""
658 let d = Sys.getenv
"DISPLAY" in
659 let colonpos = String.index d '
:'
in
660 let host = String.sub
d 0 colonpos in
661 let dispnum, screennum
=
663 let dotpos = String.index_from
d (colonpos + 1) '
.'
in
664 let disp = String.sub
d (colonpos + 1) (dotpos - colonpos - 1) in
665 let screen = String.sub
d (dotpos + 1) (String.length
d - dotpos - 1) in
666 int_of_string
disp, int_of_string
screen
668 let disp = String.sub
d (colonpos + 1) (String.length
d - colonpos - 1) in
669 int_of_string
disp, 0
671 let aname, adata
= getauth host dispnum in
673 if String.length
host = 0 || host = "unix"
675 let addr = Unix.ADDR_UNIX
("/tmp/.X11-unix/X" ^ string_of_int
dispnum) in
676 let fd = Unix.socket
Unix.PF_UNIX
Unix.SOCK_STREAM
0 in
677 Unix.connect
fd addr;
680 let h = Unix.gethostbyname
host in
681 let addr = h.Unix.h_addr_list
.(0) in
682 let port = 6000 + dispnum in
683 let fd = Unix.socket
Unix.PF_INET
Unix.SOCK_STREAM
0 in
684 Unix.connect
fd (Unix.ADDR_INET
(addr, port));
688 let s = "luMMmmnndduu" in
689 let s = padcat s aname in
690 let s = padcat s adata
in
693 w16 s 6 (String.length
aname);
694 w16 s 8 (String.length adata
);
703 let s = changepropreq state.idbase
39 state.stringatom
8 s in
704 sendstr s state.sock
;
707 let setcursor cursor
=
710 | CURSOR_INHERIT
-> -1
713 | CURSOR_CROSSHAIR
-> 0
716 let s = s32 (if n = -1 then 0 else state.idbase
+2+n) in
717 let s = changewindowattributesreq state.idbase
(*cursor*)0x4000 s in
718 sendstr s state.sock
;
722 state.fullscreen state.idbase
;
725 let withalt mask = mask land 8 != 0;;
726 let withctrl mask = mask land 4 != 0;;
727 let withshift mask = mask land 1 != 0;;