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";;
31 let vlog fmt
= Format.ksprintf ignore fmt
;;
38 method reshape _ _
= ()
39 method mouse _ _ _ _ _
= ()
40 method motion _ _
= ()
41 method pmotion _ _
= ()
45 method winstate _
= ()
51 method map
: bool -> unit
53 method visible
: visiblestate
-> unit
54 method reshape
: int -> int -> unit
55 method mouse
: int -> bool -> int -> int -> int -> unit
56 method motion
: int -> int -> unit
57 method pmotion
: int -> int -> unit
58 method key
: int -> int -> unit
59 method enter
: int -> int -> unit
61 method winstate
: winstate list
-> unit
68 ; mutable keymap
: int array array
69 ; fifo
: (bytes
-> unit) Queue.t
71 ; mutable protoatom
: atom
72 ; mutable deleatom
: atom
73 ; mutable nwmsatom
: atom
74 ; mutable maxvatom
: atom
75 ; mutable maxhatom
: atom
76 ; mutable fulsatom
: atom
77 ; mutable idbase
: int
80 ; mutable fullscreen
: (int -> unit)
81 ; mutable setwmname
: (bytes
-> unit)
82 ; mutable actwin
: (unit -> unit)
83 ; mutable stringatom
: int
85 ; mutable sock
: Unix.file_descr
91 ; mutable curcurs
: cursor
92 ; mutable capslmask
: int
93 ; mutable numlmask
: int
94 ; mutable levl3mask
: int
95 ; mutable levl5mask
: int
99 | Fs
of (int * int * int * int)
106 ; fifo
= Queue.create
()
117 ; fullscreen
= (fun _
-> ())
118 ; setwmname
= (fun _
-> ())
119 ; actwin
= (fun _
-> ())
128 ; curcurs
= CURSOR_INHERIT
138 let makereq opcode len reqlen
=
139 let s = Bytes.create len
in
145 let recv fd
s pos len
=
146 Unix.read fd
s pos len
;
150 let s = Bytes.create n
in
152 let m = tempfailureretry
(recv sock
s pos
) n
in
157 ignore
(tempfailureretry
(Unix.select
[sock
] [] []) 0.01);
158 loop (pos
+ m) (n
- m)
165 let sendstr1 s pos len sock
=
166 let s = Bytes.unsafe_to_string
s in
167 vlog "%d <= %S" state.seq
s;
168 state.seq
<- state.seq
+ 1;
169 let n = tempfailureretry
(Unix.write_substring sock
s pos
) len
in
171 then error
"send %d returned %d" len
n;
174 let updkmap sock resp
=
175 let syms = r8 resp
1 in
176 let len = r32 resp
4 in
179 then readstr sock
(4*len)
182 let m = len / syms in
183 state.keymap
<- Array.make_matrix
184 (state.maxk
- state.mink
) syms 0xffffff;
185 let rec loop i
= if i
= m then () else
187 let rec loop2 k l
= if l
= syms then () else
188 let v = r32
data k in
189 state.keymap
.(i
).(l
) <- v;
198 let updmodmap sock resp
=
200 let len = r16 resp
4 in
203 then readstr sock
(len*4)
206 if len > 0 then (*???*)
207 let modmap = Array.make_matrix
8 n 0xffffff in
208 let rec loop l
= if l
= 8 then () else
210 let rec loop1 m = if m = n then () else
212 let code = r8
data p in
213 modmap.(l
).(m) <- code;
216 let ki = code - state.mink
in
219 let a = state.keymap
.(ki) in
220 let rec capsloop i
= if i
= Array.length
a || i
> 3 then () else
223 then state.capslmask
<- 2
231 let ki = code - state.mink
in
234 let a = state.keymap
.(ki) in
235 let rec lloop i
= if i
= Array.length
a || i
> 3 then () else
238 | 0xfe03 -> state.levl3mask
<- 1 lsl l
239 | 0xfe11 -> state.levl5mask
<- 1 lsl l
240 | 0xff7f -> state.numlmask
<- 1 lsl l
254 let sendwithrep sock
s f
=
255 Queue.push f
state.fifo
;
256 sendstr1 s 0 (Bytes.length
s) sock
;
262 let b = Buffer.create
16 in
263 List.iter
(Buffer.add_bytes
b) ss
;
264 let bl = Buffer.length
b in
265 let pl = bl land 3 in
268 Buffer.add_substring
b pad 0 (4 - pl);
273 let padcat s1 s2
= padcatl [s1
; s2
];;
275 let internreq name onlyifexists
=
276 let s = makereq 16 8 8 in
277 let s = padcat s name
in
278 w8
s 1 (if onlyifexists
then 1 else 0);
279 w16
s 2 (Bytes.length
s / 4);
280 w16
s 4 (Bytes.length name
);
284 let sendintern sock
s onlyifexists f
=
285 let s = internreq s onlyifexists
in
286 sendwithrep sock
s f
;
289 let createwindowreq wid parent x y w h bw eventmask vid depth mid
=
290 let s = makereq 1 48 12 in
299 w16
s 22 0; (* copyfromparent *)
300 w32
s 24 vid
; (* visual *)
301 w32
s 28 0x280a; (* valuemask =
306 w32
s 32 0; (* background pixel *)
307 w32
s 36 0; (* border pixel*)
313 let createcolormapreq mid wid vid
=
314 let s = makereq 78 16 4 in
322 let getgeometryreq wid
=
323 let s = makereq 14 8 2 in
329 let s = makereq 8 8 2 in
334 let getkeymapreq first count
=
335 let s = makereq 101 8 2 in
341 let changepropreq wid prop typ format props
=
342 let s = makereq 18 24 0 in
343 let s = padcat s props
in
345 w16
s 2 (Bytes.length
s / 4);
350 let ful = Bytes.length props
/ (match format
with
354 | n -> error
"no idea what %d means" n)
360 let getpropreq delete wid prop typ
=
361 let s = makereq 20 24 6 in
362 w8
s 1 (if delete
then 1 else 0);
371 let openfontreq fid name
=
372 let s = makereq 45 12 0 in
373 let s = padcat s name
in
374 w16
s 2 (Bytes.length
s / 4);
376 w16
s 8 (Bytes.length name
);
380 let createglyphcursorreq fid cid cindex
=
381 let s = makereq 94 32 8 in
396 let changewindowattributesreq wid mask attrs
=
397 let s = makereq 2 12 0 in
398 let s = padcat s attrs
in
399 w16
s 2 (Bytes.length
s / 4);
405 let configurewindowreq wid mask values
=
406 let s = makereq 12 12 0 in
407 let s = padcat s values
in
408 w16
s 2 (Bytes.length
s / 4);
415 let s = Bytes.create
4 in
420 let clientmessage format seq wid typ
data =
421 let s = makereq 33 12 0 in
422 let s = padcat s data in
430 let sendeventreq propagate destwid mask
data =
431 let s = makereq 25 12 11 in
432 let s = padcat s data in
440 let getmodifiermappingreq () =
444 let getkeysym code mask
=
445 let pkpk = state.keymap
.(code-state.mink
).(0) in
446 if (pkpk >= 0xff80 && pkpk <= 0xffbd)
447 || (pkpk >= 0x11000000 && pkpk <= 0x1100ffff)
449 if mask
land state.numlmask
!= 0
451 let keysym = state.keymap
.(code-state.mink
).(1) in
452 if keysym = 0 then pkpk else keysym
457 if pkpk land 0xf000 = 0xf000
459 else (mask
land 1) lxor ((mask
land state.capslmask
) lsr 1)
462 let l3 = (mask
land state.levl3mask
) != 0 in
463 let l4 = (mask
land state.levl5mask
) != 0 in
465 if l3 then (if l4 then 8 else 4) else (if l4 then 6 else 0)
467 let keysym = state.keymap
.(code-state.mink
).(index) in
468 if index land 1 = 1 && keysym = 0
469 then state.keymap
.(code-state.mink
).(index - 1)
475 let resp = readstr sock
32 in
476 let opcode = r8
resp 0 in
477 match opcode land lnot
0x80 with
482 and resid
= r32
resp 4
485 error
"code=%d serial=%d resid=%#x min=%d maj=%d\n%S"
486 code serial resid min maj
(Bytes.unsafe_to_string
resp);
488 | 1 -> (* response *)
489 let rep = Queue.pop
state.fifo
in
492 | 2 -> (* key press *)
493 if Array.length
state.keymap
> 0
495 let code = r8
resp 1 in
496 let mask = r16
resp 28 in
497 let keysym = getkeysym code mask in
498 vlog "keysym = %x %c mask %#x code %d"
499 keysym (Char.unsafe_chr
keysym) mask code;
500 state.t#key
keysym mask;
502 | 3 -> (* key release *)
503 if Array.length
state.keymap
> 0
505 let code = r8
resp 1 in
506 let mask = r16
resp 28 in
507 let keysym = getkeysym code mask in
508 vlog "release keysym = %x %c mask %#x code %#d"
509 keysym (Char.unsafe_chr
keysym) mask code
511 | 4 -> (* buttonpress *)
515 and m = r16
resp 28 in
516 state.t#mouse
n true x y
m;
519 | 5 -> (* buttonrelease *)
523 and m = r16
resp 28 in
524 state.t#mouse
n false x y
m;
525 vlog "release %d %d %d" n x y
528 let x = r16s
resp 24 in
529 let y = r16s
resp 26 in
530 let m = r16
resp 28 in
532 then state.t#pmotion
x y
533 else state.t#motion
x y;
534 vlog "move %dx%d => %d" x y m
538 and y = r16s
resp 26 in
540 vlog "enter %d %d" x y
553 | 12 -> (* exposure *)
557 | 15 -> (* visibility *)
562 | 1 -> PartiallyObscured
565 dolog
"unknown visibility %d" v;
569 vlog "visibility %d" v;
571 | 34 -> (* mapping *)
573 let s = getkeymapreq state.mink
(state.maxk
-state.mink
-1) in
574 sendwithrep sock
s (updkmap sock
);
575 state.capslmask
<- 0;
576 state.levl3mask
<- 0;
577 state.levl5mask
<- 0;
579 let s = getmodifiermappingreq () in
580 sendwithrep sock
s (updmodmap sock
);
582 | 33 -> (* clientmessage *)
583 let atom = r32
resp 8 in
584 if atom = state.protoatom
586 let atom = r32
resp 12 in
587 if atom = state.deleatom
592 | 21 -> (* reparent *)
595 | 22 -> (* configure *)
599 and h
= r16
resp 22 in
600 vlog "configure cur [%d %d %d %d] conf [%d %d %d %d]"
601 state.x state.y state.w
state.h
604 if w
!= state.w
|| h
!= state.h
615 let atom = r32
resp 8 in
616 if atom = state.nwmsatom
618 let s = getpropreq false state.wid
atom 4 in
619 sendwithrep sock
s (fun resp ->
620 let len = r32
resp 4 in
621 let nitems = r32
resp 16 in
626 let s = readstr sock
(len*4) in
627 let rec loop wsl i
= if i
= nitems then wsl else
628 let atom = r32
s (i
*4) in
630 if atom = state.maxhatom
633 if atom = state.maxvatom
636 if atom = state.fulsatom
638 state.fs
<- Fs
(state.x, state.y, state.w
, state.h
);
648 state.t#winstate
(List.sort compare
wsl)
652 dolog
"event %d %S" n (Bytes.unsafe_to_string
resp)
658 if hasdata sock
then loop ();
663 let sendstr s ?
(pos
=0) ?
(len=Bytes.length
s) sock
=
664 sendstr1 s pos
len sock
;
665 if hasdata sock
then readresp sock
;
671 let s = Bytes.create
8 in
674 let s = configurewindowreq state.wid
0x000c s in
675 sendstr s state.sock
;
676 else state.fullscreen
state.wid
683 let syncsendwithrep sock secstowait
s f
=
684 let completed = ref false in
685 sendwithrep sock
s (fun resp -> f
resp; completed := true);
686 let now = Unix.gettimeofday
in
687 let deadline = now () +. secstowait
in
688 let rec readtillcompletion () =
690 let timeout = deadline -. now () in
693 else Unix.select
[sock
] [] [] timeout
695 let r, _
, _
= tempfailureretry
sf deadline in
697 | [] -> error
"didn't get X response in %f seconds, aborting" secstowait
701 then readtillcompletion ()
703 readtillcompletion ();
707 let s = mapreq state.wid
in
708 sendstr s state.sock
;
711 let syncsendintern sock secstowait
s onlyifexists f
=
712 let s = internreq s onlyifexists
in
713 syncsendwithrep sock secstowait
s f
;
716 let setup disp sock rootwid screennum w h
=
717 let s = readstr sock
2 in
718 let n = Bytes.length
s in
720 then error
"failed to read X connection setup response n=%d" n;
721 match Bytes.get
s 0 with
723 let reasonlen = r8
s 1 in
724 let s = readstr sock
6 in
729 let data = readstr sock
len in
730 let reason = Bytes.sub
data 0 reasonlen in
731 error
"X connection failed maj=%d min=%d reason=%S"
732 maj min
(Bytes.unsafe_to_string
reason)
734 | '
\002'
-> failwith
"X connection setup failed: authentication required";
737 let s = readstr sock
38 in
741 and idbase
= r32
s 10
742 and idmask
= r32
s 14
744 and screens
= r8
s 26
745 and formats
= r8
s 27
747 and maxkk
= r8
s 33 in
748 let data = readstr sock
(4*add
-32) in
749 let vendor = Bytes.sub
data 0 vlen
in
750 let pos = ((vlen
+3) land lnot
3) + formats
*8 in
752 if screennum
>= screens
753 then error
"invalid screen %d, max %d" screennum
(screens
-1);
756 let rec findscreen n pos = if n = screennum
then pos else
758 let ndepths = r8
data (pos+39) in
759 let rec skipdepths n pos = if n = ndepths then pos else
761 let nvisiuals = r16
data (pos+2) in
762 pos + nvisiuals*24 + 8
766 skipdepths n (pos+40)
772 let root = if rootwid
= 0 then r32
data pos else rootwid
in
773 let rootw = r16
data (pos+20)
774 and rooth
= r16
data (pos+22)
775 and rootdepth
= r8
data (pos+38)in
779 state.idbase
<- idbase
;
780 vlog "vendor = %S, maj=%d min=%d" (Bytes.unsafe_to_string
vendor) maj min
;
781 vlog "screens = %d formats = %d" screens formats
;
782 vlog "minkk = %d maxkk = %d" minkk maxkk
;
783 vlog "idbase = %#x idmask = %#x" idbase idmask
;
784 vlog "root=%#x %dx%d" root rootw rooth
;
785 vlog "wmm = %d, hmm = %d" (r16
data (pos+24)) (r16
data (pos+26));
786 vlog "visualid = %#x " (r32
data (pos+32));
787 vlog "root depth = %d" rootdepth
;
789 let wid = state.idbase
in
796 let vid = glxinit disp
wid screennum
in
797 let ndepths = r8
data (pos+39) in
798 let rec finddepth n'
pos =
800 then error
"couldn't find depth for visual %#x" vid;
801 let depth = r8
data pos in
802 let nvisuals = r16
data (pos+2) in
803 let rec findvisual n pos =
805 then finddepth (n'
+1) pos
807 let id = r32
data pos in
810 else findvisual (n+1) (pos+24)
814 let depth = finddepth 0 (pos+40) in
816 let s = createcolormapreq mid root vid in
820 + 0x00000001 (* KeyPress *)
821 (* + 0x00000002 *) (* KeyRelease *)
822 + 0x00000004 (* ButtonPress *)
823 + 0x00000008 (* ButtonRelease *)
824 + 0x00000010 (* EnterWindow *)
825 + 0x00000020 (* LeaveWindow *)
826 + 0x00000040 (* PointerMotion *)
827 (* + 0x00000080 *) (* PointerMotionHint *)
828 (* + 0x00000100 *) (* Button1Motion *)
829 (* + 0x00000200 *) (* Button2Motion *)
830 (* + 0x00000400 *) (* Button3Motion *)
831 (* + 0x00000800 *) (* Button4Motion *)
832 (* + 0x00001000 *) (* Button5Motion *)
833 + 0x00002000 (* ButtonMotion *)
834 (* + 0x00004000 *) (* KeymapState *)
835 + 0x00008000 (* Exposure *)
836 + 0x00010000 (* VisibilityChange *)
837 + 0x00020000 (* StructureNotify *)
838 (* + 0x00040000 *) (* ResizeRedirect *)
839 (* + 0x00080000 *) (* SubstructureNotify *)
840 (* + 0x00100000 *) (* SubstructureRedirect *)
841 (* + 0x00200000 *) (* FocusChange *)
842 + 0x00400000 (* PropertyChange *)
843 (* + 0x00800000 *) (* ColormapChange *)
844 (* + 0x01000000 *) (* OwnerGrabButton *)
847 let s = createwindowreq wid root 0 0 w h
0 mask vid depth mid in
850 sendintern sock
(~
> "WM_PROTOCOLS") false (fun resp ->
851 state.protoatom
<- r32
resp 8;
853 sock
(~
> "WM_DELETE_WINDOW") false (fun resp ->
854 state.deleatom
<- r32
resp 8;
855 let s = s32 state.deleatom
in
856 let s = changepropreq wid state.protoatom
4 32 s in
861 sendintern sock
(~
> "WM_CLIENT_MACHINE") false (fun resp ->
862 let atom = r32
resp 8 in
865 try Unix.gethostname
()
867 dolog
"error getting host name: %s" (exntos exn
);
872 let s = changepropreq wid atom state.stringatom
8
875 sendintern sock
(~
> "_NET_WM_PID") false (fun resp ->
876 let atom = r32
resp 8 in
877 let pid = Unix.getpid
() in
879 let s = changepropreq wid atom 6(*cardinal*) 32 s in
884 state.actwin
<- (fun () ->
885 let s = Bytes.create
4 in
886 let s = configurewindowreq wid 0x40 s in
887 sendstr s state.sock
;
888 let s = mapreq wid in
889 sendstr s state.sock
;
892 sendintern sock
(~
> "_NET_ACTIVE_WINDOW") true (fun resp ->
893 let atom = r32
resp 8 in
894 state.actwin
<- (fun () ->
895 let data = Bytes.make
20 '
\000'
in
896 let cm = clientmessage 32 0 wid atom data in
897 let s = sendeventreq 0 root 0x180000 cm in
898 sendstr s state.sock
;
902 syncsendintern sock
2.0 (~
> "WM_CLASS") false (fun resp ->
903 let atom = r32
resp 8 in
904 let llpp = ~
> "llpp\000llpp\000" in
905 let s = changepropreq wid atom 31 8 llpp in
909 let s = getkeymapreq state.mink
(state.maxk
-state.mink
) in
910 sendwithrep sock
s (updkmap sock
);
912 let s = getmodifiermappingreq () in
913 sendwithrep sock
s (updmodmap sock
);
915 let s = openfontreq fid (~
> "cursor") in
918 Array.iteri
(fun i glyphindex
->
919 let s = createglyphcursorreq fid (fid+1+i
) glyphindex
in
921 ) [|34;48;50;58;128;152|];
923 sendintern sock
(~
> "UTF8_STRING") true (fun resp ->
924 let atom = r32
resp 8 in
926 then state.stringatom
<- atom;
930 let s = changepropreq wid 39 state.stringatom
8 s in
931 sendstr s state.sock
;
933 state.setwmname <- setwmname;
934 sendintern sock
(~
> "_NET_WM_NAME") true (fun resp ->
935 let atom = r32
resp 8 in
937 then state.setwmname <- (fun s ->
939 let s = changepropreq wid atom state.stringatom
8 s in
940 sendstr s state.sock
;
944 state.fullscreen
<- (fun wid ->
945 let s = Bytes.create
16 in
952 let s = configurewindowreq wid 0x000f s in
953 sendstr s state.sock
;
954 state.fs
<- Fs
(state.x, state.y, state.w
, state.h
);
961 let s = configurewindowreq wid 0x000f s in
962 sendstr s state.sock
;
966 sendintern sock
(~
> "_NET_WM_STATE") true (fun resp ->
967 state.nwmsatom
<- r32
resp 8;
968 if state.nwmsatom
!= 0
970 sendintern sock
(~
> "_NET_WM_STATE_MAXIMIZED_VERT") true (fun resp ->
971 state.maxvatom
<- r32
resp 8;
973 sendintern sock
(~
> "_NET_WM_STATE_MAXIMIZED_HORZ") true (fun resp ->
974 state.maxhatom
<- r32
resp 8;
976 sendintern sock
(~
> "_NET_WM_STATE_FULLSCREEN") true (fun resp ->
977 state.fulsatom
<- r32
resp 8;
978 if state.fulsatom
!= 0
982 let data = Bytes.make
20 '
\000'
in
985 | NoFs
-> Fs
(-1, -1, -1, -1), 1
989 w32
data 4 state.fulsatom
;
991 let cm = clientmessage 32 0 wid state.nwmsatom
data in
992 let s = sendeventreq 0 root 0x180000 cm in
999 let s = getgeometryreq wid in
1000 syncsendwithrep sock
2.0 s (fun resp ->
1003 and h
= r16
resp 18 in
1009 error
"unknown conection setup response %d" (Char.code c
)
1012 let getauth haddr dnum
=
1014 if haddr = "localhost" || String.length
haddr = 0
1016 try Unix.gethostname
()
1018 dolog
"failed to resolve `%S': %s" haddr (exntos exn
);
1023 try Sys.getenv
"XAUTHORITY"
1025 try Filename.concat
(Sys.getenv
"HOME") ".Xauthority"
1026 with Not_found
-> E.s
1030 let rb pos = Char.code (Bytes.get
s pos) in
1031 (rb 1) lor ((rb 0) lsl 8)
1035 let s = really_input_string ic
2 in
1036 let n = r16be (~
> s) in
1037 really_input_string ic
n
1039 let family = really_input_string ic
2 in
1043 try Some
(int_of_string
nums)
1046 "display number(%S) is not an integer (corrupt %S?): %s"
1047 nums path (exntos exn
);
1053 vlog "family %S addr %S(%S) num %S(%d) name %S data %S"
1054 family addr haddr nums dnum
name data;
1056 | Some num
when addr = haddr && num
= dnum
->
1063 | End_of_file
-> E.s, E.s
1065 dolog
"exception while reading X authority data (%S): %s"
1074 if String.length
path = 0
1076 else Some
(open_in_bin
path)
1078 if Sys.file_exists
path
1080 dolog
"failed to open X authority file `%S' : %s"
1086 | Some ic
-> readauth ic
1089 let init t rootwid
w h platform
=
1091 try Sys.getenv
"DISPLAY"
1093 error
"could not get DISPLAY evironment variable: %s"
1098 then error
"invalid DISPLAY(%s) %S" w d
1100 let s = String.sub
d b (e
- b) in
1103 error
"invalid DISPLAY %S can not parse %s(%S): %s"
1107 if pos = String.length
d
1108 then error
"invalid DISPLAY %S no display number specified" d
1112 let rec pdispnum pos1
=
1113 if pos1
= String.length
d
1114 then getnum "display number" (pos+1) pos1
, 0
1118 let dispnum = getnum "display number" (pos+1) pos1
in
1119 let rec pscreennum pos2
=
1120 if pos2
= String.length
d
1121 then getnum "screen number" (pos1
+1) pos2
1124 | '
0'
.. '
9'
-> pscreennum (pos2
+1)
1126 error
"invalid DISPLAY %S, cannot parse screen number" d
1128 dispnum, pscreennum (pos1
+1)
1129 | '
0'
.. '
9'
-> pdispnum (pos1
+1)
1131 error
"invalid DISPLAY %S, cannot parse display number" d
1133 String.sub
d 0 pos, pdispnum (pos+1)
1137 let host, (dispnum, screennum
) = phost 0 in
1138 let aname, adata
= getauth host dispnum in
1141 if String.length
host = 0 || host = "unix"
1145 | Utils.Posx
-> Unix.ADDR_UNIX
d
1147 Unix.ADDR_UNIX
("\000/tmp/.X11-unix/X" ^ string_of_int
dispnum)
1148 | Utils.Punknown
| Utils.Psun
| Utils.Pbsd
| Utils.Pcygwin
->
1149 Unix.ADDR_UNIX
("/tmp/.X11-unix/X" ^ string_of_int
dispnum)
1151 Unix.socket
Unix.PF_UNIX
Unix.SOCK_STREAM
0, addr
1154 try Unix.gethostbyname
host
1156 error
"cannot resolve %S: %s" host (exntos exn
)
1158 let addr = h.Unix.h_addr_list
.(0) in
1159 let port = 6000 + dispnum in
1160 let fd = Unix.socket
Unix.PF_INET
Unix.SOCK_STREAM
0 in
1161 fd, (Unix.ADDR_INET
(addr, port))
1163 try Unix.connect
fd addr; fd
1165 error
"failed to connect to X: %s" (exntos exn
)
1168 let s = Bytes.create
12 in
1169 let s = padcat s (~
> aname) in
1170 let s = padcat s (~
> adata
) in
1171 Bytes.set
s 0 ordermagic
;
1174 w16
s 6 (String.length
aname);
1175 w16
s 8 (String.length adata
);
1176 sendstr1 s 0 (Bytes.length
s) fd;
1178 setup d fd rootwid screennum
w h;
1180 fd, state.w, state.h;
1184 state.setwmname (~
> s);
1187 let setcursor cursor
=
1188 if cursor
!= state.curcurs
1192 | CURSOR_INHERIT
-> -1
1195 | CURSOR_CROSSHAIR
-> 0
1198 let s = s32 (if n = -1 then 0 else state.fid+1+n) in
1199 let s = changewindowattributesreq state.wid 0x4000(*cursor*) s in
1200 sendstr s state.sock
;
1201 state.curcurs
<- cursor
;
1205 state.fullscreen state.wid;
1208 let metamask = 0x40;;
1213 let withalt mask = mask land altmask != 0;;
1214 let withctrl mask = mask land ctrlmask != 0;;
1215 let withshift mask = mask land shiftmask != 0;;
1216 let withmeta mask = mask land metamask != 0;;
1217 let withnone mask = mask land (altmask + ctrlmask + shiftmask + metamask) = 0;;
1220 let t = Hashtbl.create
20
1221 and f
= Hashtbl.create
20 in
1223 List.iter
(fun s -> Hashtbl.add t s k) (n::nl
);
1227 let s = String.make
1 c
in
1228 add s [] (Char.code c
)
1231 let an = Char.code a and bn
= Char.code b in
1232 for i
= an to bn
do addc (Char.chr i
) done;
1237 String.iter
addc "`~!@#$%^&*()-_=+\\|[{]};:,./<>?";
1238 for i
= 0 to 29 do add ("f" ^ string_of_int
(i
+1)) [] (0xffbe + i
) done;
1239 add "space" [] 0x20;
1240 add "ret" ["return"; "enter"] 0xff0d;
1241 add "tab" [] 0xff09;
1242 add "left" [] 0xff51;
1243 add "right" [] 0xff53;
1244 add "home" [] 0xff50;
1245 add "end" [] 0xff57;
1246 add "ins" ["insert"] 0xff63;
1247 add "del" ["delete"] 0xffff;
1248 add "esc" ["escape"] 0xff1b;
1249 add "pgup" ["pageup"] 0xff55;
1250 add "pgdown" ["pagedown"] 0xff56;
1251 add "backspace" [] 0xff08;
1253 add "down" [] 0xff54;
1254 add "menu" [] 0xff67;
1259 try Hashtbl.find xlatf
k
1260 with Not_found
-> Printf.sprintf
"%#x" k;
1264 try Hashtbl.find xlatt name
1266 if String.length
name = 1
1267 then Char.code name.[0]
1268 else int_of_string
name;