3 let (~
>) = Bytes.unsafe_of_string
;;
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";;
31 external setwinbgcol
: int -> unit = "ml_setbgcol";;
33 let vlog fmt
= Format.ksprintf ignore fmt
;;
40 method reshape _ _
= ()
41 method mouse _ _ _ _ _
= ()
42 method motion _ _
= ()
43 method pmotion _ _
= ()
47 method winstate _
= ()
54 method map
: bool -> unit
56 method visible
: visiblestate
-> unit
57 method reshape
: int -> int -> unit
58 method mouse
: int -> bool -> int -> int -> int -> unit
59 method motion
: int -> int -> unit
60 method pmotion
: int -> int -> unit
61 method key
: int -> int -> unit
62 method enter
: int -> int -> unit
64 method winstate
: winstate list
-> unit
71 ; mutable keymap
: int array array
72 ; fifo
: (bytes
-> unit) Queue.t
74 ; mutable protoatom
: atom
75 ; mutable deleatom
: atom
76 ; mutable nwmsatom
: atom
77 ; mutable maxvatom
: atom
78 ; mutable maxhatom
: atom
79 ; mutable fulsatom
: atom
80 ; mutable idbase
: int
83 ; mutable fullscreen
: (int -> unit)
84 ; mutable setwmname
: (bytes
-> unit)
85 ; mutable actwin
: (unit -> unit)
86 ; mutable stringatom
: int
88 ; mutable sock
: Unix.file_descr
94 ; mutable curcurs
: cursor
95 ; mutable capslmask
: int
96 ; mutable numlmask
: int
97 ; mutable levl3mask
: int
98 ; mutable levl5mask
: int
103 | Fs
of (int * int * int * int)
110 ; fifo
= Queue.create
()
121 ; fullscreen
= (fun _
-> ())
122 ; setwmname
= (fun _
-> ())
123 ; actwin
= (fun _
-> ())
132 ; curcurs
= CURSOR_TEXT
141 let w8 s pos i
= Bytes.set s pos
(Char.chr
(i
land 0xff));;
142 let r8 s pos
= Char.code
(Bytes.get s pos
);;
144 let ordermagic = 'l'
;;
148 w8 s
(pos
+1) (i
lsr 8)
153 w16 s
(pos
+2) (i
lsr 16)
157 let rb pos1
= Char.code
(Bytes.get s
(pos
+ pos1
)) in
158 (rb 0) lor ((rb 1) lsl 8)
163 i - ((i land 0x8000) lsl 1)
167 let rb pos1
= Char.code
(Bytes.get s
(pos
+ pos1
)) in
168 let l = (rb 0) lor ((rb 1) lsl 8)
169 and u
= (rb 2) lor ((rb 3) lsl 8) in
173 let makereq opcode len reqlen
=
174 let s = Bytes.create len
in
181 let s = Bytes.create n
in
183 let m = tempfailureretry
(Unix.read sock
s pos
) n
in
188 ignore
(tempfailureretry
(Unix.select
[sock
] [] []) 0.01);
189 loop (pos
+ m) (n
- m)
196 let sendstr1 s pos len sock
=
197 let s = Bytes.unsafe_to_string
s in
198 vlog "%d <= %S" state.seq
s;
199 state.seq
<- state.seq
+ 1;
200 let n = tempfailureretry
(Unix.write_substring sock
s pos
) len
in
202 then error
"send %d returned %d" len
n;
205 let updkmap sock resp
=
206 let syms = r8 resp
1 in
207 let len = r32 resp
4 in
210 then readstr sock
(4*len)
213 let m = len / syms in
214 state.keymap
<- Array.make_matrix
215 (state.maxk
- state.mink
) syms 0xffffff;
216 let rec loop i = if i = m then () else
218 let rec loop2 k l = if l = syms then () else
219 let v = r32 data k in
220 state.keymap
.(i).(l) <- v;
229 let updmodmap sock resp
=
231 let len = r16 resp
4 in
234 then readstr sock
(len*4)
237 if len > 0 then (*???*)
238 let modmap = Array.make_matrix
8 n 0xffffff in
248 let code = r8 data p in
249 modmap.(l).(m) <- code;
252 let ki = code - state.mink
in
255 let a = state.keymap
.(ki) in
257 if i = Array.length
a || i > 3
262 then state.capslmask
<- 2
270 let ki = code - state.mink
in
273 let a = state.keymap
.(ki) in
275 if i = Array.length
a || i > 3
280 | 0xfe03 -> state.levl3mask
<- 1 lsl l
281 | 0xfe11 -> state.levl5mask
<- 1 lsl l
282 | 0xff7f -> state.numlmask
<- 1 lsl l
296 let sendwithrep sock
s f
=
297 Queue.push f
state.fifo
;
298 sendstr1 s 0 (Bytes.length
s) sock
;
304 let b = Buffer.create
16 in
305 List.iter
(Buffer.add_bytes
b) ss
;
306 let bl = Buffer.length
b in
307 let pl = bl land 3 in
310 Buffer.add_substring
b pad 0 (4 - pl);
315 let padcat s1 s2
= padcatl [s1
; s2
];;
317 let internreq name onlyifexists
=
318 let s = makereq 16 8 8 in
319 let s = padcat s name
in
320 w8 s 1 (if onlyifexists
then 1 else 0);
321 w16 s 2 (Bytes.length
s / 4);
322 w16 s 4 (Bytes.length name
);
326 let sendintern sock
s onlyifexists f
=
327 let s = internreq s onlyifexists
in
328 sendwithrep sock
s f
;
331 let createwindowreq wid parent x y w h bw eventmask vid depth mid
=
332 let s = makereq 1 48 12 in
341 w16 s 22 0; (* copyfromparent *)
342 w32 s 24 vid
; (* visual *)
343 w32 s 28 0x280a; (* valuemask =
348 w32 s 32 0; (* background pixel *)
349 w32 s 36 0; (* border pixel*)
355 let createcolormapreq mid wid vid
=
356 let s = makereq 78 16 4 in
364 let getgeometryreq wid
=
365 let s = makereq 14 8 2 in
371 let s = makereq 8 8 2 in
376 let getkeymapreq first count
=
377 let s = makereq 101 8 2 in
383 let changepropreq wid prop typ format props
=
384 let s = makereq 18 24 0 in
385 let s = padcat s props
in
387 w16 s 2 (Bytes.length
s / 4);
392 let ful = Bytes.length props
/ (match format
with
396 | n -> error
"no idea what %d means" n)
402 let getpropreq delete wid prop typ
=
403 let s = makereq 20 24 6 in
404 w8 s 1 (if delete
then 1 else 0);
413 let configurewindowreq wid mask values
=
414 let s = makereq 12 12 0 in
415 let s = padcat s values
in
416 w16 s 2 (Bytes.length
s / 4);
423 let s = Bytes.create
4 in
428 let clientmessage format seq wid typ
data =
429 let s = makereq 33 12 0 in
430 let s = padcat s data in
438 let sendeventreq propagate destwid mask
data =
439 let s = makereq 25 12 11 in
440 let s = padcat s data in
448 let getmodifiermappingreq () =
452 let queryextensionreq name
=
453 let s = makereq 98 8 0 in
454 let s = padcat s name
in
455 w16 s 2 (Bytes.length
s / 4);
456 w16 s 4 (Bytes.length name
);
460 let getkeysym pkpk
code mask
=
461 if (pkpk
>= 0xff80 && pkpk
<= 0xffbd)
462 || (pkpk
>= 0x11000000 && pkpk
<= 0x1100ffff)
464 if mask
land state.numlmask
!= 0
466 let keysym = state.keymap
.(code-state.mink
).(1) in
467 if keysym = 0 then pkpk
else keysym
472 if pkpk
land 0xf000 = 0xf000
474 else (mask
land 1) lxor ((mask
land state.capslmask
) lsr 1)
477 if state.xkb
&& mask
land 0x2000 != 0
481 let l3 = (mask
land state.levl3mask
) != 0 in
482 let l4 = (mask
land state.levl5mask
) != 0 in
484 if l3 then (if l4 then 8 else 4) else (if l4 then 6 else 0)
486 let keysym = state.keymap
.(code-state.mink
).(index) in
487 if index land 1 = 1 && keysym = 0
488 then state.keymap
.(code-state.mink
).(index - 1)
493 let getkeysym code mask
=
494 let pkpk = state.keymap
.(code-state.mink
).(0) in
495 if state.xkb
&& pkpk lsr 8 = 0xfe (* XKB *)
497 else getkeysym pkpk code mask
501 let resp = readstr sock
32 in
502 let opcode = r8 resp 0 in
503 match opcode land lnot
0x80 with
508 and resid
= r32 resp 4
511 error
"code=%d serial=%d resid=%#x min=%d maj=%d\n%S"
512 code serial resid min maj
(Bytes.unsafe_to_string
resp);
514 | 1 -> (* response *)
515 let rep = Queue.pop
state.fifo
in
518 | 2 -> (* key press *)
519 if Array.length
state.keymap
> 0
521 let code = r8 resp 1 in
522 let mask = r16 resp 28 in
523 let keysym = getkeysym code mask in
524 vlog "keysym = %x %c mask %#x code %d"
525 keysym (Char.unsafe_chr
keysym) mask code;
527 then state.t#key
keysym mask
529 | 3 -> (* key release *)
530 if Array.length
state.keymap
> 0
532 let code = r8 resp 1 in
533 let mask = r16 resp 28 in
534 let keysym = getkeysym code mask in
535 vlog "release keysym = %x %c mask %#x code %#d"
536 keysym (Char.unsafe_chr
keysym) mask code
538 | 4 -> (* buttonpress *)
542 and m = r16 resp 28 in
543 state.t#mouse
n true x y
m;
546 | 5 -> (* buttonrelease *)
550 and m = r16 resp 28 in
551 state.t#mouse
n false x y
m;
552 vlog "release %d %d %d" n x y
555 let x = r16s resp 24 in
556 let y = r16s resp 26 in
557 let m = r16 resp 28 in
559 then state.t#pmotion
x y
560 else state.t#motion
x y;
561 vlog "move %dx%d => %d" x y m
565 and y = r16s resp 26 in
567 vlog "enter %d %d" x y
580 | 12 -> (* exposure *)
584 | 15 -> (* visibility *)
589 | 1 -> PartiallyObscured
592 dolog
"unknown visibility %d" v;
596 vlog "visibility %d" v;
598 | 34 -> (* mapping *)
600 let s = getkeymapreq state.mink
(state.maxk
-state.mink
-1) in
601 sendwithrep sock
s (updkmap sock
);
602 state.capslmask
<- 0;
603 state.levl3mask
<- 0;
604 state.levl5mask
<- 0;
606 let s = getmodifiermappingreq () in
607 sendwithrep sock
s (updmodmap sock
);
609 | 33 -> (* clientmessage *)
610 let atom = r32 resp 8 in
611 if atom = state.protoatom
613 let atom = r32 resp 12 in
614 if atom = state.deleatom
619 | 21 -> (* reparent *)
622 | 22 -> (* configure *)
626 and h
= r16 resp 22 in
627 vlog "configure cur [%d %d %d %d] conf [%d %d %d %d]"
628 state.x state.y state.w
state.h
630 if w
!= state.w
|| h
!= state.h
631 then state.t#reshape w h
;
639 let atom = r32 resp 8 in
640 if atom = state.nwmsatom
642 let s = getpropreq false state.wid
atom 4 in
643 sendwithrep sock
s (fun resp ->
644 let len = r32 resp 4 in
645 let nitems = r32 resp 16 in
650 let s = readstr sock
(len*4) in
655 let atom = r32 s (i*4) in
657 if atom = state.maxhatom
660 if atom = state.maxvatom
663 if atom = state.fulsatom
665 state.fs
<- Fs
(state.x, state.y,
676 state.t#winstate
(List.sort compare
wsl)
680 dolog
"event %d %S" n (Bytes.unsafe_to_string
resp)
686 if hasdata sock
then loop ();
691 let sendstr s ?
(pos
=0) ?
(len=Bytes.length
s) sock
=
692 sendstr1 s pos
len sock
;
693 if hasdata sock
then readresp sock
;
699 let s = Bytes.create
8 in
702 let s = configurewindowreq state.wid
0x000c s in
703 sendstr s state.sock
;
704 else state.fullscreen
state.wid
711 let syncsendwithrep sock secstowait
s f
=
712 let completed = ref false in
713 sendwithrep sock
s (fun resp -> f
resp; completed := true);
714 let now = Unix.gettimeofday
in
715 let deadline = now () +. secstowait
in
716 let rec readtillcompletion () =
718 let timeout = deadline -. now () in
721 else Unix.select
[sock
] [] [] timeout
723 let r, _
, _
= tempfailureretry
sf deadline in
725 | [] -> error
"didn't get X response in %f seconds, aborting" secstowait
729 then readtillcompletion ()
731 readtillcompletion ();
735 let s = mapreq state.wid
in
736 sendstr s state.sock
;
739 let syncsendintern sock secstowait
s onlyifexists f
=
740 let s = internreq s onlyifexists
in
741 syncsendwithrep sock secstowait
s f
;
744 let setup disp sock rootwid screennum w h
=
745 let s = readstr sock
2 in
746 let n = Bytes.length
s in
748 then error
"failed to read X connection setup response n=%d" n;
749 match Bytes.get
s 0 with
751 let reasonlen = r8 s 1 in
752 let s = readstr sock
6 in
757 let data = readstr sock
len in
758 let reason = Bytes.sub
data 0 reasonlen in
759 error
"X connection failed maj=%d min=%d reason=%S"
760 maj min
(Bytes.unsafe_to_string
reason)
762 | '
\002'
-> failwith
"X connection setup failed: authentication required";
765 let s = readstr sock
38 in
769 and idbase
= r32 s 10
770 and idmask
= r32 s 14
772 and screens
= r8 s 26
773 and formats
= r8 s 27
775 and maxkk
= r8 s 33 in
776 let data = readstr sock
(4*add
-32) in
777 let vendor = Bytes.sub
data 0 vlen
in
778 let pos = ((vlen
+3) land lnot
3) + formats
*8 in
780 if screennum
>= screens
781 then error
"invalid screen %d, max %d" screennum
(screens
-1);
784 let rec findscreen n pos =
789 let ndepths = r8 data (pos+39) in
790 let rec skipdepths n pos =
795 let nvisiuals = r16 data (pos+2) in
796 pos + nvisiuals*24 + 8
800 skipdepths n (pos+40)
806 let root = if rootwid
= 0 then r32 data pos else rootwid
in
807 let rootw = r16 data (pos+20)
808 and rooth
= r16 data (pos+22)
809 and rootdepth
= r8 data (pos+38)in
813 state.idbase
<- idbase
;
814 vlog "vendor = %S, maj=%d min=%d" (Bytes.unsafe_to_string
vendor) maj min
;
815 vlog "screens = %d formats = %d" screens formats
;
816 vlog "minkk = %d maxkk = %d" minkk maxkk
;
817 vlog "idbase = %#x idmask = %#x" idbase idmask
;
818 vlog "root=%#x %dx%d" root rootw rooth
;
819 vlog "wmm = %d, hmm = %d" (r16 data (pos+24)) (r16 data (pos+26));
820 vlog "visualid = %#x" (r32 data (pos+32));
821 vlog "root depth = %d" rootdepth
;
823 let wid = state.idbase
in
830 let vid = glxinit disp
wid screennum
in
831 let ndepths = r8 data (pos+39) in
832 let rec finddepth n'
pos =
834 then error
"cannot find depth for visual %#x" vid;
835 let depth = r8 data pos in
836 let nvisuals = r16 data (pos+2) in
837 let rec findvisual n pos =
839 then finddepth (n'
+1) pos
841 let id = r32 data pos in
844 else findvisual (n+1) (pos+24)
848 let depth = finddepth 0 (pos+40) in
850 let s = createcolormapreq mid root vid in
854 + 0x00000001 (* KeyPress *)
855 (* + 0x00000002 *) (* KeyRelease *)
856 + 0x00000004 (* ButtonPress *)
857 + 0x00000008 (* ButtonRelease *)
858 + 0x00000010 (* EnterWindow *)
859 + 0x00000020 (* LeaveWindow *)
860 + 0x00000040 (* PointerMotion *)
861 (* + 0x00000080 *) (* PointerMotionHint *)
862 (* + 0x00000100 *) (* Button1Motion *)
863 (* + 0x00000200 *) (* Button2Motion *)
864 (* + 0x00000400 *) (* Button3Motion *)
865 (* + 0x00000800 *) (* Button4Motion *)
866 (* + 0x00001000 *) (* Button5Motion *)
867 + 0x00002000 (* ButtonMotion *)
868 (* + 0x00004000 *) (* KeymapState *)
869 + 0x00008000 (* Exposure *)
870 + 0x00010000 (* VisibilityChange *)
871 + 0x00020000 (* StructureNotify *)
872 (* + 0x00040000 *) (* ResizeRedirect *)
873 (* + 0x00080000 *) (* SubstructureNotify *)
874 (* + 0x00100000 *) (* SubstructureRedirect *)
875 (* + 0x00200000 *) (* FocusChange *)
876 + 0x00400000 (* PropertyChange *)
877 (* + 0x00800000 *) (* ColormapChange *)
878 (* + 0x01000000 *) (* OwnerGrabButton *)
881 let s = createwindowreq wid root 0 0 w h
0 mask vid depth mid in
885 sock
(~
> "WM_PROTOCOLS") false (fun resp ->
886 state.protoatom
<- r32 resp 8;
888 sock
(~
> "WM_DELETE_WINDOW") false (fun resp ->
889 state.deleatom
<- r32 resp 8;
890 let s = s32 state.deleatom
in
891 let s = changepropreq wid state.protoatom
4 32 s in
897 sock
(~
> "WM_CLIENT_MACHINE") false (fun resp ->
898 let atom = r32 resp 8 in
901 try Unix.gethostname
()
903 dolog
"error getting host name: %s" @@ exntos exn
;
908 let s = changepropreq wid atom state.stringatom
8
912 sock
(~
> "_NET_WM_PID") false (fun resp ->
913 let atom = r32 resp 8 in
914 let pid = Unix.getpid
() in
916 let s = changepropreq wid atom 6(*cardinal*) 32 s in
921 state.actwin
<- (fun () ->
922 let s = Bytes.create
4 in
923 let s = configurewindowreq wid 0x40 s in
924 sendstr s state.sock
;
925 let s = mapreq wid in
926 sendstr s state.sock
;
930 sock
(~
> "_NET_ACTIVE_WINDOW") true (fun resp ->
931 let atom = r32 resp 8 in
932 state.actwin
<- (fun () ->
933 let data = Bytes.make
20 '
\000'
in
934 let cm = clientmessage 32 0 wid atom data in
935 let s = sendeventreq 0 root 0x180000 cm in
936 sendstr s state.sock
;
941 sock
2.0 (~
> "WM_CLASS") false (fun resp ->
942 let atom = r32 resp 8 in
943 let llpp = ~
> "llpp\000llpp\000" in
944 let s = changepropreq wid atom 31 8 llpp in
948 let s = getkeymapreq state.mink
(state.maxk
-state.mink
) in
949 sendwithrep sock
s (updkmap sock
);
951 let s = getmodifiermappingreq () in
952 sendwithrep sock
s (updmodmap sock
);
955 sock
(~
> "UTF8_STRING") true (fun resp ->
956 let atom = r32 resp 8 in
958 then state.stringatom
<- atom;
962 let s = changepropreq wid 39 state.stringatom
8 s in
963 sendstr s state.sock
;
965 state.setwmname <- setwmname;
967 sock
(~
> "_NET_WM_NAME") true (fun resp ->
968 let atom = r32 resp 8 in
970 then state.setwmname <- (fun s ->
972 let s = changepropreq wid atom state.stringatom
8 s in
973 sendstr s state.sock
;
977 state.fullscreen
<- (fun wid ->
978 let s = Bytes.create
16 in
985 let s = configurewindowreq wid 0x000f s in
986 sendstr s state.sock
;
987 state.fs
<- Fs
(state.x, state.y, state.w
, state.h
);
994 let s = configurewindowreq wid 0x000f s in
995 sendstr s state.sock
;
1000 sock
(~
> "_NET_WM_STATE") true (fun resp ->
1001 state.nwmsatom
<- r32 resp 8;
1002 if state.nwmsatom
!= 0
1004 sendintern sock
(~
> "_NET_WM_STATE_MAXIMIZED_VERT") true (fun resp ->
1005 state.maxvatom
<- r32 resp 8;
1007 sendintern sock
(~
> "_NET_WM_STATE_MAXIMIZED_HORZ") true (fun resp ->
1008 state.maxhatom
<- r32 resp 8;
1011 sock
(~
> "_NET_WM_STATE_FULLSCREEN") true (fun resp ->
1012 state.fulsatom
<- r32 resp 8;
1013 if state.fulsatom
!= 0
1017 let data = Bytes.make
20 '
\000'
in
1020 | NoFs
-> Fs
(-1, -1, -1, -1), 1
1024 w32 data 4 state.fulsatom
;
1026 let cm = clientmessage 32 0 wid state.nwmsatom
data in
1027 let s = sendeventreq 0 root 0x180000 cm in
1034 let s = queryextensionreq (~
> "XKEYBOARD") in
1037 let present = r8 resp 8 in
1040 let maj = r8 resp 9 in
1041 let s = Bytes.create
8 in
1042 w8 s 0 maj; (* XKB *)
1043 w8 s 1 0; (* XKBUseExtension *)
1044 w16 s 2 2; (* request-length *)
1045 w16 s 4 1; (* wantedMajor *)
1046 w16 s 6 0; (* watnedMinor *)
1050 let supported = r8 resp 1 in
1051 state.xkb
<- supported != 0
1055 let s = getgeometryreq wid in
1056 syncsendwithrep sock
2.0 s (fun resp ->
1059 and h
= r16 resp 18 in
1065 error
"unknown connection setup response %d" (Char.code c
)
1068 let getauth haddr dnum
=
1070 if emptystr
haddr || haddr = "localhost"
1072 try Unix.gethostname
()
1074 dolog
"failed to resolve `%S': %s" haddr @@ exntos exn
;
1079 try Sys.getenv
"XAUTHORITY"
1081 try Filename.concat
(Sys.getenv
"HOME") ".Xauthority"
1082 with Not_found
-> E.s
1086 let rb pos = Char.code (Bytes.get
s pos) in
1087 (rb 1) lor ((rb 0) lsl 8)
1091 let s = really_input_string ic
2 in
1092 let n = r16be (~
> s) in
1093 really_input_string ic
n
1095 let family = really_input_string ic
2 in
1099 try Some
(int_of_string
nums)
1102 "display number(%S) is not an integer (corrupt %S?): %s"
1103 nums path @@ exntos exn
;
1109 vlog "family %S addr %S(%S) num %S(%d) name %S data %S"
1110 family addr haddr nums dnum
name data;
1112 | Some num
when addr = haddr && num
= dnum
->
1119 | End_of_file
-> E.s, E.s
1121 dolog
"exception while reading X authority data (%S): %s"
1131 match open_in_bin
path with
1134 dolog
"failed to open X authority file `%S' : %s" path @@ exntos exn
;
1138 let init t rootwid
w h platform
=
1140 try Sys.getenv
"DISPLAY"
1142 error
"cannot get DISPLAY evironment variable: %s" @@ exntos exn
1146 then error
"invalid DISPLAY(%s) %S" w d
1148 let s = String.sub
d b (e
- b) in
1151 error
"invalid DISPLAY %S can not parse %s(%S): %s"
1155 if pos = String.length
d
1156 then error
"invalid DISPLAY %S no display number specified" d
1160 let rec pdispnum pos1
=
1161 if pos1
= String.length
d
1162 then getnum "display number" (pos+1) pos1
, 0
1166 let dispnum = getnum "display number" (pos+1) pos1
in
1167 let rec pscreennum pos2
=
1168 if pos2
= String.length
d
1169 then getnum "screen number" (pos1
+1) pos2
1172 | '
0'
.. '
9'
-> pscreennum (pos2
+1)
1174 error
"invalid DISPLAY %S, cannot parse screen number" d
1176 dispnum, pscreennum (pos1
+1)
1177 | '
0'
.. '
9'
-> pdispnum (pos1
+1)
1179 error
"invalid DISPLAY %S, cannot parse display number" d
1181 String.sub
d 0 pos, pdispnum (pos+1)
1185 let host, (dispnum, screennum
) = phost 0 in
1186 let aname, adata
= getauth host dispnum in
1189 if emptystr
host || host.[0] = '
/'
|| host = "unix"
1193 | Utils.Posx
-> Unix.ADDR_UNIX
d
1195 Unix.ADDR_UNIX
("\000/tmp/.X11-unix/X" ^ string_of_int
dispnum)
1196 | Utils.Punknown
| Utils.Psun
| Utils.Pbsd
| Utils.Pcygwin
->
1197 Unix.ADDR_UNIX
("/tmp/.X11-unix/X" ^ string_of_int
dispnum)
1199 Unix.socket
Unix.PF_UNIX
Unix.SOCK_STREAM
0, addr
1202 try Unix.gethostbyname
host
1203 with exn
-> error
"cannot resolve %S: %s" host @@ exntos exn
1205 let addr = h.Unix.h_addr_list
.(0) in
1206 let port = 6000 + dispnum in
1207 let fd = Unix.socket
Unix.PF_INET
Unix.SOCK_STREAM
0 in
1208 fd, (Unix.ADDR_INET
(addr, port))
1210 try Unix.connect
fd addr; fd
1211 with exn
-> error
"failed to connect to X: %s" @@ exntos exn
1214 let s = Bytes.create
12 in
1215 let s = padcat s (~
> aname) in
1216 let s = padcat s (~
> adata
) in
1217 Bytes.set
s 0 ordermagic;
1220 w16 s 6 (String.length
aname);
1221 w16 s 8 (String.length adata
);
1222 sendstr1 s 0 (Bytes.length
s) fd;
1224 setup d fd rootwid screennum
w h;
1226 fd, state.w, state.h;
1230 state.setwmname (~
> s);
1233 let setcursor cursor
=
1234 if cursor
!= state.curcurs
1237 state.curcurs
<- cursor
;
1242 state.fullscreen state.wid;
1245 let metamask = 0x40;;
1250 let withalt mask = mask land altmask != 0;;
1251 let withctrl mask = mask land ctrlmask != 0;;
1252 let withshift mask = mask land shiftmask != 0;;
1253 let withmeta mask = mask land metamask != 0;;
1254 let withnone mask = mask land (altmask + ctrlmask + shiftmask + metamask) = 0;;
1257 let t = Hashtbl.create
20
1258 and f
= Hashtbl.create
20 in
1260 List.iter
(fun s -> Hashtbl.add t s k) (n::nl
);
1264 let s = String.make
1 c
in
1265 add s [] (Char.code c
)
1268 let an = Char.code a and bn
= Char.code b in
1269 for i = an to bn
do addc (Char.chr
i) done;
1274 String.iter
addc "`~!@#$%^&*()-_=+\\|[{]};:,./<>?";
1275 for i = 0 to 29 do add ("f" ^ string_of_int
(i+1)) [] (0xffbe + i) done;
1276 add "space" [] 0x20;
1277 add "ret" ["return"; "enter"] 0xff0d;
1278 add "tab" [] 0xff09;
1279 add "left" [] 0xff51;
1280 add "right" [] 0xff53;
1281 add "home" [] 0xff50;
1282 add "end" [] 0xff57;
1283 add "ins" ["insert"] 0xff63;
1284 add "del" ["delete"] 0xffff;
1285 add "esc" ["escape"] 0xff1b;
1286 add "pgup" ["pageup"] 0xff55;
1287 add "pgdown" ["pagedown"] 0xff56;
1288 add "backspace" [] 0xff08;
1290 add "down" [] 0xff54;
1291 add "menu" [] 0xff67;
1296 try Hashtbl.find xlatf
k
1297 with Not_found
-> Printf.sprintf
"%#x" k;
1301 try Hashtbl.find xlatt name
1303 if String.length
name = 1
1304 then Char.code name.[0]
1305 else int_of_string
name;
1311 | 0xff08 -> Backspace
1333 | 0xffab -> Ascii '
+'
1334 | 0xffad -> Ascii '
-'
1336 | code when code > 31 && code < 128 -> Ascii
(Char.unsafe_chr
code)
1337 | code when code >= 0xffb0 && code <= 0xffb9 ->
1338 Ascii
(Char.unsafe_chr
(code - 0xffb0 + 0x30))
1339 | code when code >= 0xffbe && code <= 0xffc8 -> Fn
(code - 0xffbe + 1)
1340 | code when code land 0xff00 = 0xff00 -> Ctrl
code