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";;
38 method reshape _ _
= ()
39 method mouse _ _ _ _ _
= ()
40 method motion _ _
= ()
41 method pmotion _ _
= ()
45 method winstate _
= ()
46 method quit
: 'a
. 'a
= exit
0
47 method scroll _ _
= ()
48 method zoom _ _ _
= ()
55 method map
: bool -> unit
57 method visible
: visiblestate
-> unit
58 method reshape
: int -> int -> unit
59 method mouse
: int -> bool -> int -> int -> int -> unit
60 method motion
: int -> int -> unit
61 method pmotion
: int -> int -> unit
62 method key
: int -> int -> unit
63 method enter
: int -> int -> unit
65 method winstate
: winstate list
-> unit
67 method scroll
: int -> int -> unit
68 method zoom
: float -> int -> int -> unit
69 method opendoc
: string -> unit
75 ; mutable keymap
: int array array
76 ; fifo
: (bytes
-> unit) Queue.t
78 ; mutable protoatom
: atom
79 ; mutable deleatom
: atom
80 ; mutable nwmsatom
: atom
81 ; mutable maxvatom
: atom
82 ; mutable maxhatom
: atom
83 ; mutable fulsatom
: atom
84 ; mutable idbase
: int
87 ; mutable fullscreen
: (int -> unit)
88 ; mutable setwmname
: (bytes
-> unit)
89 ; mutable actwin
: (unit -> unit)
90 ; mutable stringatom
: int
92 ; mutable sock
: Unix.file_descr
98 ; mutable curcurs
: cursor
99 ; mutable capslmask
: int
100 ; mutable numlmask
: int
101 ; mutable levl3mask
: int
102 ; mutable levl5mask
: int
107 | Fs
of (int * int * int * int)
114 ; fifo
= Queue.create
()
125 ; fullscreen
= (fun _
-> ())
126 ; setwmname
= (fun _
-> ())
127 ; actwin
= (fun _
-> ())
136 ; curcurs
= CURSOR_TEXT
145 let ordermagic = 'l'
;;
147 let makereq opcode len reqlen
=
148 let s = Bytes.create len
in
155 let s = Bytes.create n
in
157 let m = tempfailureretry
(Unix.read sock
s pos
) n
in
162 ignore
(tempfailureretry
(Unix.select
[sock
] [] []) 0.01);
163 loop (pos
+ m) (n
- m)
170 let sendstr1 s pos len sock
=
171 let s = Bytes.unsafe_to_string
s in
172 vlog
"%d <= %S" state.seq
s;
173 state.seq
<- state.seq
+ 1;
174 let n = tempfailureretry
(Unix.write_substring sock
s pos
) len
in
176 then error
"send %d returned %d" len
n;
179 let updkmap sock resp
=
180 let syms = r8 resp
1 in
181 let len = r32 resp
4 in
184 then readstr sock
(4*len)
187 let m = len / syms in
188 state.keymap
<- Array.make_matrix
189 (state.maxk
- state.mink
) syms 0xffffff;
190 let rec loop i
= if i
= m then () else
192 let rec loop2 k l
= if l
= syms then () else
193 let v = r32
data k in
194 state.keymap
.(i
).(l
) <- v;
203 let updmodmap sock resp
=
205 let len = r16 resp
4 in
208 then readstr sock
(len*4)
211 if len > 0 then (*???*)
212 let modmap = Array.make_matrix
8 n 0xffffff in
222 let code = r8
data p in
223 modmap.(l
).(m) <- code;
226 let ki = code - state.mink
in
229 let a = state.keymap
.(ki) in
231 if i
= Array.length
a || i
> 3
236 then state.capslmask
<- 2
244 let ki = code - state.mink
in
247 let a = state.keymap
.(ki) in
249 if i
= Array.length
a || i
> 3
254 | 0xfe03 -> state.levl3mask
<- 1 lsl l
255 | 0xfe11 -> state.levl5mask
<- 1 lsl l
256 | 0xff7f -> state.numlmask
<- 1 lsl l
270 let sendwithrep sock
s f
=
271 Queue.push f
state.fifo
;
272 sendstr1 s 0 (Bytes.length
s) sock
;
278 let b = Buffer.create
16 in
279 List.iter
(Buffer.add_bytes
b) ss
;
280 let bl = Buffer.length
b in
281 let pl = bl land 3 in
284 Buffer.add_substring
b pad 0 (4 - pl);
289 let padcat s1 s2
= padcatl [s1
; s2
];;
291 let internreq name onlyifexists
=
292 let s = makereq 16 8 8 in
293 let s = padcat s name
in
294 w8
s 1 (if onlyifexists
then 1 else 0);
295 w16
s 2 (Bytes.length
s / 4);
296 w16
s 4 (Bytes.length name
);
300 let sendintern sock
s onlyifexists f
=
301 let s = internreq s onlyifexists
in
302 sendwithrep sock
s f
;
305 let createwindowreq wid parent x y w h bw eventmask vid depth mid
=
306 let s = makereq 1 48 12 in
315 w16
s 22 0; (* copyfromparent *)
316 w32
s 24 vid
; (* visual *)
317 w32
s 28 0x280a; (* valuemask =
322 w32
s 32 0; (* background pixel *)
323 w32
s 36 0; (* border pixel*)
329 let createcolormapreq mid wid vid
=
330 let s = makereq 78 16 4 in
338 let getgeometryreq wid
=
339 let s = makereq 14 8 2 in
345 let s = makereq 8 8 2 in
350 let getkeymapreq first count
=
351 let s = makereq 101 8 2 in
357 let changepropreq wid prop typ format props
=
358 let s = makereq 18 24 0 in
359 let s = padcat s props
in
361 w16
s 2 (Bytes.length
s / 4);
366 let ful = Bytes.length props
/ (match format
with
370 | n -> error
"no idea what %d means" n)
376 let getpropreq delete wid prop typ
=
377 let s = makereq 20 24 6 in
378 w8
s 1 (if delete
then 1 else 0);
387 let configurewindowreq wid mask values
=
388 let s = makereq 12 12 0 in
389 let s = padcat s values
in
390 w16
s 2 (Bytes.length
s / 4);
397 let s = Bytes.create
4 in
402 let clientmessage format seq wid typ
data =
403 let s = makereq 33 12 0 in
404 let s = padcat s data in
412 let sendeventreq propagate destwid mask
data =
413 let s = makereq 25 12 11 in
414 let s = padcat s data in
422 let getmodifiermappingreq () =
426 let queryextensionreq name
=
427 let s = makereq 98 8 0 in
428 let s = padcat s name
in
429 w16
s 2 (Bytes.length
s / 4);
430 w16
s 4 (Bytes.length name
);
434 let getkeysym pkpk
code mask
=
435 if (pkpk
>= 0xff80 && pkpk
<= 0xffbd)
436 || (pkpk
>= 0x11000000 && pkpk
<= 0x1100ffff)
438 if mask
land state.numlmask
!= 0
440 let keysym = state.keymap
.(code-state.mink
).(1) in
441 if keysym = 0 then pkpk
else keysym
446 if pkpk
land 0xf000 = 0xf000
448 else (mask
land 1) lxor ((mask
land state.capslmask
) lsr 1)
451 if state.xkb
&& mask
land 0x2000 != 0
455 let l3 = (mask
land state.levl3mask
) != 0 in
456 let l4 = (mask
land state.levl5mask
) != 0 in
458 if l3 then (if l4 then 8 else 4) else (if l4 then 6 else 0)
460 let keysym = state.keymap
.(code-state.mink
).(index) in
461 if index land 1 = 1 && keysym = 0
462 then state.keymap
.(code-state.mink
).(index - 1)
467 let getkeysym code mask
=
468 let pkpk = state.keymap
.(code-state.mink
).(0) in
469 if state.xkb
&& pkpk lsr 8 = 0xfe (* XKB *)
471 else getkeysym pkpk code mask
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;
501 then state.t#key
keysym mask
503 | 3 -> (* key release *)
504 if Array.length
state.keymap
> 0
506 let code = r8
resp 1 in
507 let mask = r16
resp 28 in
508 let keysym = getkeysym code mask in
509 vlog
"release keysym = %x %c mask %#x code %#d"
510 keysym (Char.unsafe_chr
keysym) mask code
512 | 4 -> (* buttonpress *)
516 and m = r16
resp 28 in
517 state.t#mouse
n true x y
m;
520 | 5 -> (* buttonrelease *)
524 and m = r16
resp 28 in
525 state.t#mouse
n false x y
m;
526 vlog
"release %d %d %d" n x y
529 let x = r16s
resp 24 in
530 let y = r16s
resp 26 in
531 let m = r16
resp 28 in
533 then state.t#pmotion
x y
534 else state.t#motion
x y;
535 vlog
"move %dx%d => %d" x y m
539 and y = r16s
resp 26 in
541 vlog
"enter %d %d" x y
554 | 12 -> (* exposure *)
558 | 15 -> (* visibility *)
563 | 1 -> PartiallyObscured
566 dolog
"unknown visibility %d" v;
570 vlog
"visibility %d" v;
572 | 34 -> (* mapping *)
574 let s = getkeymapreq state.mink
(state.maxk
-state.mink
-1) in
575 sendwithrep sock
s (updkmap sock
);
576 state.capslmask
<- 0;
577 state.levl3mask
<- 0;
578 state.levl5mask
<- 0;
580 let s = getmodifiermappingreq () in
581 sendwithrep sock
s (updmodmap sock
);
583 | 33 -> (* clientmessage *)
584 let atom = r32
resp 8 in
585 if atom = state.protoatom
587 let atom = r32
resp 12 in
588 if atom = state.deleatom
593 | 21 -> (* reparent *)
596 | 22 -> (* configure *)
600 and h
= r16
resp 22 in
601 vlog
"configure cur [%d %d %d %d] conf [%d %d %d %d]"
602 state.x state.y state.w
state.h
604 if w
!= state.w
|| h
!= state.h
605 then state.t#reshape w h
;
613 let atom = r32
resp 8 in
614 if atom = state.nwmsatom
616 let s = getpropreq false state.wid
atom 4 in
617 sendwithrep sock
s (fun resp ->
619 let len = r32
resp 4 in
620 let nitems = r32
resp 16 in
625 let s = readstr sock
(len*4) in
630 let atom = r32
s (i
*4) in
632 if atom = state.maxhatom
635 if atom = state.maxvatom
638 if atom = state.fulsatom
640 state.fs
<- Fs
(state.x, state.y,
651 state.t#winstate
(List.sort compare
wsl)
655 (* ignore gravity events *)
659 dolog
"event %d %S" n (Bytes.unsafe_to_string
resp)
665 if hasdata sock
then loop ();
670 let sendstr s ?
(pos
=0) ?
(len=Bytes.length
s) sock
=
671 sendstr1 s pos
len sock
;
672 if hasdata sock
then readresp sock
;
678 let s = Bytes.create
8 in
681 let s = configurewindowreq state.wid
0x000c s in
682 sendstr s state.sock
;
683 else state.fullscreen
state.wid
690 let syncsendwithrep sock secstowait
s f
=
691 let completed = ref false in
692 sendwithrep sock
s (fun resp -> f
resp; completed := true);
693 let now = Unix.gettimeofday
in
694 let deadline = now () +. secstowait
in
695 let rec readtillcompletion () =
697 let timeout = deadline -. now () in
700 else Unix.select
[sock
] [] [] timeout
702 let r, _
, _
= tempfailureretry
sf deadline in
704 | [] -> error
"didn't get X response in %f seconds, aborting" secstowait
708 then readtillcompletion ()
710 readtillcompletion ();
714 let s = mapreq state.wid
in
715 sendstr s state.sock
;
718 let syncsendintern sock secstowait
s onlyifexists f
=
719 let s = internreq s onlyifexists
in
720 syncsendwithrep sock secstowait
s f
;
723 let setup disp sock rootwid screennum w h
=
724 let s = readstr sock
2 in
725 let n = Bytes.length
s in
727 then error
"failed to read X connection setup response n=%d" n;
728 match Bytes.get
s 0 with
730 let reasonlen = r8
s 1 in
731 let s = readstr sock
6 in
736 let data = readstr sock
len in
737 let reason = Bytes.sub
data 0 reasonlen in
738 error
"X connection failed maj=%d min=%d reason=%S"
739 maj min
(Bytes.unsafe_to_string
reason)
741 | '
\002'
-> failwith
"X connection setup failed: authentication required";
744 let s = readstr sock
38 in
748 and idbase
= r32
s 10
749 and idmask
= r32
s 14
751 and screens
= r8
s 26
752 and formats
= r8
s 27
754 and maxkk
= r8
s 33 in
755 let data = readstr sock
(4*add
-32) in
756 let vendor = Bytes.sub
data 0 vlen
in
757 let pos = ((vlen
+3) land lnot
3) + formats
*8 in
759 if screennum
>= screens
760 then error
"invalid screen %d, max %d" screennum
(screens
-1);
763 let rec findscreen n pos =
768 let ndepths = r8
data (pos+39) in
769 let rec skipdepths n pos =
774 let nvisiuals = r16
data (pos+2) in
775 pos + nvisiuals*24 + 8
779 skipdepths n (pos+40)
785 let root = if rootwid
= 0 then r32
data pos else rootwid
in
786 let rootw = r16
data (pos+20)
787 and rooth
= r16
data (pos+22)
788 and rootdepth
= r8
data (pos+38)in
792 state.idbase
<- idbase
;
793 vlog
"vendor = %S, maj=%d min=%d" (Bytes.unsafe_to_string
vendor) maj min
;
794 vlog
"screens = %d formats = %d" screens formats
;
795 vlog
"minkk = %d maxkk = %d" minkk maxkk
;
796 vlog
"idbase = %#x idmask = %#x" idbase idmask
;
797 vlog
"root=%#x %dx%d" root rootw rooth
;
798 vlog
"wmm = %d, hmm = %d" (r16
data (pos+24)) (r16
data (pos+26));
799 vlog
"visualid = %#x" (r32
data (pos+32));
800 vlog
"root depth = %d" rootdepth
;
802 let wid = state.idbase
in
809 let vid = glxinit disp
wid screennum
in
810 let ndepths = r8
data (pos+39) in
811 let rec finddepth n'
pos =
813 then error
"cannot find depth for visual %#x" vid;
814 let depth = r8
data pos in
815 let nvisuals = r16
data (pos+2) in
816 let rec findvisual n pos =
818 then finddepth (n'
+1) pos
820 let id = r32
data pos in
823 else findvisual (n+1) (pos+24)
827 let depth = finddepth 0 (pos+40) in
829 let s = createcolormapreq mid root vid in
833 + 0x00000001 (* KeyPress *)
834 (* + 0x00000002 *) (* KeyRelease *)
835 + 0x00000004 (* ButtonPress *)
836 + 0x00000008 (* ButtonRelease *)
837 + 0x00000010 (* EnterWindow *)
838 + 0x00000020 (* LeaveWindow *)
839 + 0x00000040 (* PointerMotion *)
840 (* + 0x00000080 *) (* PointerMotionHint *)
841 (* + 0x00000100 *) (* Button1Motion *)
842 (* + 0x00000200 *) (* Button2Motion *)
843 (* + 0x00000400 *) (* Button3Motion *)
844 (* + 0x00000800 *) (* Button4Motion *)
845 (* + 0x00001000 *) (* Button5Motion *)
846 + 0x00002000 (* ButtonMotion *)
847 (* + 0x00004000 *) (* KeymapState *)
848 + 0x00008000 (* Exposure *)
849 + 0x00010000 (* VisibilityChange *)
850 + 0x00020000 (* StructureNotify *)
851 (* + 0x00040000 *) (* ResizeRedirect *)
852 (* + 0x00080000 *) (* SubstructureNotify *)
853 (* + 0x00100000 *) (* SubstructureRedirect *)
854 (* + 0x00200000 *) (* FocusChange *)
855 + 0x00400000 (* PropertyChange *)
856 (* + 0x00800000 *) (* ColormapChange *)
857 (* + 0x01000000 *) (* OwnerGrabButton *)
860 let s = createwindowreq wid root 0 0 w h
0 mask vid depth mid in
864 sock
(~
> "WM_PROTOCOLS") false (fun resp ->
865 state.protoatom
<- r32
resp 8;
867 sock
(~
> "WM_DELETE_WINDOW") false (fun resp ->
868 state.deleatom
<- r32
resp 8;
869 let s = s32 state.deleatom
in
870 let s = changepropreq wid state.protoatom
4 32 s in
876 sock
(~
> "WM_CLIENT_MACHINE") false (fun resp ->
877 let atom = r32
resp 8 in
880 try Unix.gethostname
()
882 dolog
"error getting host name: %s" @@ exntos exn
;
887 let s = changepropreq wid atom state.stringatom
8
891 sock
(~
> "_NET_WM_PID") false (fun resp ->
892 let atom = r32
resp 8 in
893 let pid = Unix.getpid
() in
895 let s = changepropreq wid atom 6(*cardinal*) 32 s in
900 state.actwin
<- (fun () ->
901 let s = Bytes.create
4 in
902 let s = configurewindowreq wid 0x40 s in
903 sendstr s state.sock
;
904 let s = mapreq wid in
905 sendstr s state.sock
;
909 sock
(~
> "_NET_ACTIVE_WINDOW") true (fun resp ->
910 let atom = r32
resp 8 in
911 state.actwin
<- (fun () ->
912 let data = Bytes.make
20 '
\000'
in
913 let cm = clientmessage 32 0 wid atom data in
914 let s = sendeventreq 0 root 0x180000 cm in
915 sendstr s state.sock
;
920 sock
2.0 (~
> "WM_CLASS") false (fun resp ->
921 let atom = r32
resp 8 in
922 let llpp = ~
> "llpp\000llpp\000" in
923 let s = changepropreq wid atom 31 8 llpp in
927 let s = getkeymapreq state.mink
(state.maxk
-state.mink
) in
928 sendwithrep sock
s (updkmap sock
);
930 let s = getmodifiermappingreq () in
931 sendwithrep sock
s (updmodmap sock
);
934 sock
(~
> "UTF8_STRING") true (fun resp ->
935 let atom = r32
resp 8 in
937 then state.stringatom
<- atom;
941 let s = changepropreq wid 39 state.stringatom
8 s in
942 sendstr s state.sock
;
944 state.setwmname <- setwmname;
946 sock
(~
> "_NET_WM_NAME") true (fun resp ->
947 let atom = r32
resp 8 in
949 then state.setwmname <- (fun s ->
951 let s = changepropreq wid atom state.stringatom
8 s in
952 sendstr s state.sock
;
956 state.fullscreen
<- (fun wid ->
957 let s = Bytes.create
16 in
964 let s = configurewindowreq wid 0x000f s in
965 sendstr s state.sock
;
966 state.fs
<- Fs
(state.x, state.y, state.w
, state.h
);
973 let s = configurewindowreq wid 0x000f s in
974 sendstr s state.sock
;
979 sock
(~
> "_NET_WM_STATE") true (fun resp ->
980 state.nwmsatom
<- r32
resp 8;
981 if state.nwmsatom
!= 0
983 sendintern sock
(~
> "_NET_WM_STATE_MAXIMIZED_VERT") true (fun resp ->
984 state.maxvatom
<- r32
resp 8;
986 sendintern sock
(~
> "_NET_WM_STATE_MAXIMIZED_HORZ") true (fun resp ->
987 state.maxhatom
<- r32
resp 8;
990 sock
(~
> "_NET_WM_STATE_FULLSCREEN") true (fun resp ->
991 state.fulsatom
<- r32
resp 8;
992 if state.fulsatom
!= 0
996 let data = Bytes.make
20 '
\000'
in
999 | NoFs
-> Fs
(-1, -1, -1, -1), 1
1003 w32
data 4 state.fulsatom
;
1005 let cm = clientmessage 32 0 wid state.nwmsatom
data in
1006 let s = sendeventreq 0 root 0x180000 cm in
1013 let s = queryextensionreq (~
> "XKEYBOARD") in
1016 let present = r8
resp 8 in
1019 let maj = r8
resp 9 in
1020 let s = Bytes.create
8 in
1021 w8
s 0 maj; (* XKB *)
1022 w8
s 1 0; (* XKBUseExtension *)
1023 w16
s 2 2; (* request-length *)
1024 w16
s 4 1; (* wantedMajor *)
1025 w16
s 6 0; (* watnedMinor *)
1029 let supported = r8
resp 1 in
1030 state.xkb
<- supported != 0
1034 let s = getgeometryreq wid in
1035 syncsendwithrep sock
2.0 s (fun resp ->
1038 and h
= r16
resp 18 in
1044 error
"unknown connection setup response %d" (Char.code c
)
1047 let getauth haddr dnum
=
1049 if emptystr
haddr || haddr = "localhost"
1051 try Unix.gethostname
()
1053 dolog
"failed to resolve `%S': %s" haddr @@ exntos exn
;
1058 try Sys.getenv
"XAUTHORITY"
1060 try Filename.concat
(Sys.getenv
"HOME") ".Xauthority"
1061 with Not_found
-> E.s
1065 let rb pos = Char.code (Bytes.get
s pos) in
1066 (rb 1) lor ((rb 0) lsl 8)
1070 let s = really_input_string ic
2 in
1071 let n = r16be (~
> s) in
1072 really_input_string ic
n
1074 let family = really_input_string ic
2 in
1078 try Some
(int_of_string
nums)
1081 "display number(%S) is not an integer (corrupt %S?): %s"
1082 nums path @@ exntos exn
;
1088 vlog
"family %S addr %S(%S) num %S(%d) name %S data %S"
1089 family addr haddr nums dnum
name data;
1091 | Some num
when addr = haddr && num
= dnum
->
1098 | End_of_file
-> E.s, E.s
1100 dolog
"exception while reading X authority data (%S): %s"
1110 match open_in_bin
path with
1113 dolog
"failed to open X authority file `%S' : %s" path @@ exntos exn
;
1117 let init t rootwid
w h platform
=
1119 try Sys.getenv
"DISPLAY"
1121 error
"cannot get DISPLAY evironment variable: %s" @@ exntos exn
1125 then error
"invalid DISPLAY(%s) %S" w d
1127 let s = String.sub
d b (e
- b) in
1130 error
"invalid DISPLAY %S can not parse %s(%S): %s"
1134 if pos = String.length
d
1135 then error
"invalid DISPLAY %S no display number specified" d
1139 let rec pdispnum pos1
=
1140 if pos1
= String.length
d
1141 then getnum "display number" (pos+1) pos1
, 0
1145 let dispnum = getnum "display number" (pos+1) pos1
in
1146 let rec pscreennum pos2
=
1147 if pos2
= String.length
d
1148 then getnum "screen number" (pos1
+1) pos2
1151 | '
0'
.. '
9'
-> pscreennum (pos2
+1)
1153 error
"invalid DISPLAY %S, cannot parse screen number" d
1155 dispnum, pscreennum (pos1
+1)
1156 | '
0'
.. '
9'
-> pdispnum (pos1
+1)
1158 error
"invalid DISPLAY %S, cannot parse display number" d
1160 String.sub
d 0 pos, pdispnum (pos+1)
1164 let host, (dispnum, screennum
) = phost 0 in
1165 let aname, adata
= getauth host dispnum in
1168 if emptystr
host || host.[0] = '
/'
|| host = "unix"
1172 | Utils.Posx
-> Unix.ADDR_UNIX
d
1174 Unix.ADDR_UNIX
("\000/tmp/.X11-unix/X" ^ string_of_int
dispnum)
1175 | Utils.Punknown
| Utils.Psun
| Utils.Pbsd
| Utils.Pcygwin
->
1176 Unix.ADDR_UNIX
("/tmp/.X11-unix/X" ^ string_of_int
dispnum)
1178 Unix.socket
Unix.PF_UNIX
Unix.SOCK_STREAM
0, addr
1181 try Unix.gethostbyname
host
1182 with exn
-> error
"cannot resolve %S: %s" host @@ exntos exn
1184 let addr = h.Unix.h_addr_list
.(0) in
1185 let port = 6000 + dispnum in
1186 let fd = Unix.socket
Unix.PF_INET
Unix.SOCK_STREAM
0 in
1187 fd, (Unix.ADDR_INET
(addr, port))
1189 try Unix.connect
fd addr; fd
1190 with exn
-> error
"failed to connect to X: %s" @@ exntos exn
1193 let s = Bytes.create
12 in
1194 let s = padcat s (~
> aname) in
1195 let s = padcat s (~
> adata
) in
1196 Bytes.set
s 0 ordermagic;
1199 w16
s 6 (String.length
aname);
1200 w16
s 8 (String.length adata
);
1201 sendstr1 s 0 (Bytes.length
s) fd;
1203 setup d fd rootwid screennum
w h;
1205 fd, state.w, state.h;
1209 state.setwmname (~
> s);
1212 let setcursor cursor
=
1213 if cursor
!= state.curcurs
1216 state.curcurs
<- cursor
;
1221 state.fullscreen state.wid;
1224 let metamask = 0x40;;
1229 let withalt mask = mask land altmask != 0;;
1230 let withctrl mask = mask land ctrlmask != 0;;
1231 let withshift mask = mask land shiftmask != 0;;
1232 let withmeta mask = mask land metamask != 0;;
1233 let withnone mask = mask land (altmask + ctrlmask + shiftmask + metamask) = 0;;
1236 let t = Hashtbl.create
20
1237 and f
= Hashtbl.create
20 in
1239 List.iter
(fun s -> Hashtbl.add t s k) (n::nl
);
1243 let s = String.make
1 c
in
1244 add s [] (Char.code c
)
1247 let an = Char.code a and bn
= Char.code b in
1248 for i
= an to bn
do addc (Char.chr i
) done;
1253 String.iter
addc "`~!@#$%^&*()-_=+\\|[{]};:,./<>?";
1254 for i
= 0 to 29 do add ("f" ^ string_of_int
(i
+1)) [] (0xffbe + i
) done;
1255 add "space" [] 0x20;
1256 add "ret" ["return"; "enter"] 0xff0d;
1257 add "tab" [] 0xff09;
1258 add "left" [] 0xff51;
1259 add "right" [] 0xff53;
1260 add "home" [] 0xff50;
1261 add "end" [] 0xff57;
1262 add "ins" ["insert"] 0xff63;
1263 add "del" ["delete"] 0xffff;
1264 add "esc" ["escape"] 0xff1b;
1265 add "pgup" ["pageup"] 0xff55;
1266 add "pgdown" ["pagedown"] 0xff56;
1267 add "backspace" [] 0xff08;
1269 add "down" [] 0xff54;
1270 add "menu" [] 0xff67;
1275 try Hashtbl.find xlatf
k
1276 with Not_found
-> Printf.sprintf
"%#x" k;
1280 try Hashtbl.find xlatt name
1282 if String.length
name = 1
1283 then Char.code name.[0]
1284 else int_of_string
name;
1290 | 0xff08 -> Backspace
1312 | 0xffab -> Ascii '
+'
1313 | 0xffad -> Ascii '
-'
1315 | code when code > 31 && code < 128 -> Ascii
(Char.unsafe_chr
code)
1316 | code when code >= 0xffb0 && code <= 0xffb9 ->
1317 Ascii
(Char.unsafe_chr
(code - 0xffb0 + 0x30))
1318 | code when code >= 0xffbe && code <= 0xffc8 -> Fn
(code - 0xffbe + 1)
1319 | code when code land 0xff00 = 0xff00 -> Ctrl
code
1323 let fontsizefactor () = 1