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";;
37 method reshape _ _
= ()
38 method mouse _ _ _ _ _
= ()
39 method motion _ _
= ()
40 method pmotion _ _
= ()
44 method winstate _
= ()
45 method quit
: 'a
. 'a
= exit
0
46 method scroll _ _
= ()
47 method zoom _ _ _
= ()
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
66 method scroll
: int -> int -> unit
67 method zoom
: float -> int -> int -> unit
68 method opendoc
: string -> unit
74 ; mutable keymap
: int array array
75 ; fifo
: (bytes
-> unit) Queue.t
77 ; mutable protoatom
: atom
78 ; mutable deleatom
: atom
79 ; mutable nwmsatom
: atom
80 ; mutable maxvatom
: atom
81 ; mutable maxhatom
: atom
82 ; mutable fulsatom
: atom
83 ; mutable idbase
: int
86 ; mutable fullscreen
: (int -> unit)
87 ; mutable setwmname
: (bytes
-> unit)
88 ; mutable actwin
: (unit -> unit)
89 ; mutable stringatom
: int
91 ; mutable sock
: Unix.file_descr
97 ; mutable curcurs
: cursor
98 ; mutable capslmask
: int
99 ; mutable numlmask
: int
100 ; mutable levl3mask
: int
101 ; mutable levl5mask
: int
106 | Fs
of (int * int * int * int)
113 ; fifo
= Queue.create
()
124 ; fullscreen
= (fun _
-> ())
125 ; setwmname
= (fun _
-> ())
126 ; actwin
= (fun _
-> ())
135 ; curcurs
= CURSOR_TEXT
144 let ordermagic = 'l'
;;
146 let makereq opcode len reqlen
=
147 let s = Bytes.create len
in
154 let s = Bytes.create n
in
156 let m = tempfailureretry
(Unix.read sock
s pos
) n
in
161 ignore
(tempfailureretry
(Unix.select
[sock
] [] []) 0.01);
162 loop (pos
+ m) (n
- m)
169 let sendstr1 s pos len sock
=
170 let s = Bytes.unsafe_to_string
s in
171 vlog
"%d <= %S" state.seq
s;
172 state.seq
<- state.seq
+ 1;
173 let n = tempfailureretry
(Unix.write_substring sock
s pos
) len
in
175 then error
"send %d returned %d" len
n;
178 let updkmap sock resp
=
179 let syms = r8 resp
1 in
180 let len = r32 resp
4 in
183 then readstr sock
(4*len)
186 let m = len / syms in
187 state.keymap
<- Array.make_matrix
188 (state.maxk
- state.mink
) syms 0xffffff;
189 let rec loop i
= if i
= m then () else
191 let rec loop2 k l
= if l
= syms then () else
192 let v = r32
data k in
193 state.keymap
.(i
).(l
) <- v;
202 let updmodmap sock resp
=
204 let len = r16 resp
4 in
207 then readstr sock
(len*4)
210 if len > 0 then (*???*)
211 let modmap = Array.make_matrix
8 n 0xffffff in
221 let code = r8
data p in
222 modmap.(l
).(m) <- code;
225 let ki = code - state.mink
in
228 let a = state.keymap
.(ki) in
230 if i
= Array.length
a || i
> 3
235 then state.capslmask
<- 2
243 let ki = code - state.mink
in
246 let a = state.keymap
.(ki) in
248 if i
= Array.length
a || i
> 3
253 | 0xfe03 -> state.levl3mask
<- 1 lsl l
254 | 0xfe11 -> state.levl5mask
<- 1 lsl l
255 | 0xff7f -> state.numlmask
<- 1 lsl l
269 let sendwithrep sock
s f
=
270 Queue.push f
state.fifo
;
271 sendstr1 s 0 (Bytes.length
s) sock
;
277 let b = Buffer.create
16 in
278 List.iter
(Buffer.add_bytes
b) ss
;
279 let bl = Buffer.length
b in
280 let pl = bl land 3 in
283 Buffer.add_substring
b pad 0 (4 - pl);
288 let padcat s1 s2
= padcatl [s1
; s2
];;
290 let internreq name onlyifexists
=
291 let s = makereq 16 8 8 in
292 let s = padcat s name
in
293 w8
s 1 (if onlyifexists
then 1 else 0);
294 w16
s 2 (Bytes.length
s / 4);
295 w16
s 4 (Bytes.length name
);
299 let sendintern sock
s onlyifexists f
=
300 let s = internreq s onlyifexists
in
301 sendwithrep sock
s f
;
304 let createwindowreq wid parent x y w h bw eventmask vid depth mid
=
305 let s = makereq 1 44 11 in
314 w16
s 22 0; (* copyfromparent *)
315 w32
s 24 vid
; (* visual *)
316 w32
s 28 0x2808; (* valuemask =
320 w32
s 32 0; (* border pixel*)
326 let createcolormapreq mid wid vid
=
327 let s = makereq 78 16 4 in
335 let getgeometryreq wid
=
336 let s = makereq 14 8 2 in
342 let s = makereq 8 8 2 in
347 let getkeymapreq first count
=
348 let s = makereq 101 8 2 in
354 let changepropreq wid prop typ format props
=
355 let s = makereq 18 24 0 in
356 let s = padcat s props
in
358 w16
s 2 (Bytes.length
s / 4);
363 let ful = Bytes.length props
/ (match format
with
367 | n -> error
"no idea what %d means" n)
373 let getpropreq delete wid prop typ
=
374 let s = makereq 20 24 6 in
375 w8
s 1 (if delete
then 1 else 0);
384 let configurewindowreq wid mask values
=
385 let s = makereq 12 12 0 in
386 let s = padcat s values
in
387 w16
s 2 (Bytes.length
s / 4);
394 let s = Bytes.create
4 in
399 let clientmessage format seq wid typ
data =
400 let s = makereq 33 12 0 in
401 let s = padcat s data in
409 let sendeventreq propagate destwid mask
data =
410 let s = makereq 25 12 11 in
411 let s = padcat s data in
419 let getmodifiermappingreq () =
423 let queryextensionreq name
=
424 let s = makereq 98 8 0 in
425 let s = padcat s name
in
426 w16
s 2 (Bytes.length
s / 4);
427 w16
s 4 (Bytes.length name
);
431 let getkeysym pkpk
code mask
=
432 if (pkpk
>= 0xff80 && pkpk
<= 0xffbd)
433 || (pkpk
>= 0x11000000 && pkpk
<= 0x1100ffff)
435 if mask
land state.numlmask
!= 0
437 let keysym = state.keymap
.(code-state.mink
).(1) in
438 if keysym = 0 then pkpk
else keysym
443 if pkpk
land 0xf000 = 0xf000
445 else (mask
land 1) lxor ((mask
land state.capslmask
) lsr 1)
448 if state.xkb
&& mask
land 0x2000 != 0
452 let l3 = (mask
land state.levl3mask
) != 0 in
453 let l4 = (mask
land state.levl5mask
) != 0 in
455 if l3 then (if l4 then 8 else 4) else (if l4 then 6 else 0)
457 let keysym = state.keymap
.(code-state.mink
).(index) in
458 if index land 1 = 1 && keysym = 0
459 then state.keymap
.(code-state.mink
).(index - 1)
464 let getkeysym code mask
=
465 let pkpk = state.keymap
.(code-state.mink
).(0) in
466 if state.xkb
&& pkpk lsr 8 = 0xfe (* XKB *)
468 else getkeysym pkpk code mask
472 let resp = readstr sock
32 in
473 let opcode = r8
resp 0 in
474 match opcode land lnot
0x80 with
479 and resid
= r32
resp 4
482 error
"code=%d serial=%d resid=%#x min=%d maj=%d\n%S"
483 code serial resid min maj
(Bytes.unsafe_to_string
resp);
485 | 1 -> (* response *)
486 let rep = Queue.pop
state.fifo
in
489 | 2 -> (* key press *)
490 if Array.length
state.keymap
> 0
492 let code = r8
resp 1 in
493 let mask = r16
resp 28 in
494 let keysym = getkeysym code mask in
495 vlog
"keysym = %x %c mask %#x code %d"
496 keysym (Char.unsafe_chr
keysym) mask code;
498 then state.t#key
keysym mask
500 | 3 -> (* key release *)
501 if Array.length
state.keymap
> 0
503 let code = r8
resp 1 in
504 let mask = r16
resp 28 in
505 let keysym = getkeysym code mask in
506 vlog
"release keysym = %x %c mask %#x code %d"
507 keysym (Char.unsafe_chr
keysym) mask code
509 | 4 -> (* buttonpress *)
513 and m = r16
resp 28 in
514 state.t#mouse
n true x y
m;
517 | 5 -> (* buttonrelease *)
521 and m = r16
resp 28 in
522 state.t#mouse
n false x y
m;
523 vlog
"release %d %d %d" n x y
526 let x = r16s
resp 24 in
527 let y = r16s
resp 26 in
528 let m = r16
resp 28 in
530 then state.t#pmotion
x y
531 else state.t#motion
x y;
532 vlog
"move %dx%d => %d" x y m
536 and y = r16s
resp 26 in
538 vlog
"enter %d %d" x y
551 | 12 -> (* exposure *)
555 | 15 -> (* visibility *)
560 | 1 -> PartiallyObscured
563 dolog
"unknown visibility %d" v;
567 vlog
"visibility %d" v;
569 | 34 -> (* mapping *)
571 let s = getkeymapreq state.mink
(state.maxk
-state.mink
-1) in
572 sendwithrep sock
s (updkmap sock
);
573 state.capslmask
<- 0;
574 state.levl3mask
<- 0;
575 state.levl5mask
<- 0;
577 let s = getmodifiermappingreq () in
578 sendwithrep sock
s (updmodmap sock
);
580 | 33 -> (* clientmessage *)
581 let atom = r32
resp 8 in
582 if atom = state.protoatom
584 let atom = r32
resp 12 in
585 if atom = state.deleatom
590 | 21 -> (* reparent *)
593 | 22 -> (* configure *)
597 and h
= r16
resp 22 in
598 vlog
"configure cur [%d %d %d %d] conf [%d %d %d %d]"
599 state.x state.y state.w
state.h
601 if w
!= state.w
|| h
!= state.h
602 then state.t#reshape w h
;
608 | 24 -> (* Gravity notify *)
611 | 28 -> (* Property notify *)
612 let atom = r32
resp 8 in
613 if atom = state.nwmsatom
615 let s = getpropreq false state.wid
atom 4 in
616 sendwithrep sock
s (fun resp ->
618 let len = r32
resp 4 in
619 let nitems = r32
resp 16 in
624 let s = readstr sock
(len*4) in
629 let atom = r32
s (i
*4) in
631 if atom = state.maxhatom
634 if atom = state.maxvatom
637 if atom = state.fulsatom
639 state.fs
<- Fs
(state.x, state.y,
650 state.t#winstate
(List.sort compare
wsl)
654 dolog
"event %d %S" n (Bytes.unsafe_to_string
resp)
660 if hasdata sock
then loop ();
665 let sendstr s ?
(pos
=0) ?
(len=Bytes.length
s) sock
=
666 sendstr1 s pos
len sock
;
667 if hasdata sock
then readresp sock
;
673 let s = Bytes.create
8 in
676 let s = configurewindowreq state.wid
0x000c s in
677 sendstr s state.sock
;
678 else state.fullscreen
state.wid
685 let syncsendwithrep sock secstowait
s f
=
686 let completed = ref false in
687 sendwithrep sock
s (fun resp -> f
resp; completed := true);
688 let now = Unix.gettimeofday
in
689 let deadline = now () +. secstowait
in
690 let rec readtillcompletion () =
692 let timeout = deadline -. now () in
695 else Unix.select
[sock
] [] [] timeout
697 let r, _
, _
= tempfailureretry
sf deadline in
699 | [] -> error
"didn't get X response in %f seconds, aborting" secstowait
703 then readtillcompletion ()
705 readtillcompletion ();
709 let s = mapreq state.wid
in
710 sendstr s state.sock
;
713 let syncsendintern sock secstowait
s onlyifexists f
=
714 let s = internreq s onlyifexists
in
715 syncsendwithrep sock secstowait
s f
;
718 let setup disp sock rootwid screennum w h
=
719 let s = readstr sock
2 in
720 let n = Bytes.length
s in
722 then error
"failed to read X connection setup response n=%d" n;
723 match Bytes.get
s 0 with
725 let reasonlen = r8
s 1 in
726 let s = readstr sock
6 in
731 let data = readstr sock
len in
732 let reason = Bytes.sub
data 0 reasonlen in
733 error
"X connection failed maj=%d min=%d reason=%S"
734 maj min
(Bytes.unsafe_to_string
reason)
736 | '
\002'
-> failwith
"X connection setup failed: authentication required";
739 let s = readstr sock
38 in
743 and idbase
= r32
s 10
744 and idmask
= r32
s 14
746 and screens
= r8
s 26
747 and formats
= r8
s 27
749 and maxkk
= r8
s 33 in
750 let data = readstr sock
(4*add
-32) in
751 let vendor = Bytes.sub
data 0 vlen
in
752 let pos = ((vlen
+3) land lnot
3) + formats
*8 in
754 if screennum
>= screens
755 then error
"invalid screen %d, max %d" screennum
(screens
-1);
758 let rec findscreen n pos =
763 let ndepths = r8
data (pos+39) in
764 let rec skipdepths n pos =
769 let nvisiuals = r16
data (pos+2) in
770 pos + nvisiuals*24 + 8
774 skipdepths n (pos+40)
780 let root = if rootwid
= 0 then r32
data pos else rootwid
in
781 let rootw = r16
data (pos+20)
782 and rooth
= r16
data (pos+22)
783 and rootdepth
= r8
data (pos+38)in
787 state.idbase
<- idbase
;
788 vlog
"vendor = %S, maj=%d min=%d" (Bytes.unsafe_to_string
vendor) maj min
;
789 vlog
"screens = %d formats = %d" screens formats
;
790 vlog
"minkk = %d maxkk = %d" minkk maxkk
;
791 vlog
"idbase = %#x idmask = %#x" idbase idmask
;
792 vlog
"root=%#x %dx%d" root rootw rooth
;
793 vlog
"wmm = %d, hmm = %d" (r16
data (pos+24)) (r16
data (pos+26));
794 vlog
"visualid = %#x" (r32
data (pos+32));
795 vlog
"root depth = %d" rootdepth
;
797 let wid = state.idbase
in
804 let vid = glxinit disp
wid screennum
in
805 let ndepths = r8
data (pos+39) in
806 let rec finddepth n'
pos =
808 then error
"cannot find depth for visual %#x" vid;
809 let depth = r8
data pos in
810 let nvisuals = r16
data (pos+2) in
811 let rec findvisual n pos =
813 then finddepth (n'
+1) pos
815 let id = r32
data pos in
818 else findvisual (n+1) (pos+24)
822 let depth = finddepth 0 (pos+40) in
824 let s = createcolormapreq mid root vid in
828 + 0x00000001 (* KeyPress *)
829 (* + 0x00000002 *) (* KeyRelease *)
830 + 0x00000004 (* ButtonPress *)
831 + 0x00000008 (* ButtonRelease *)
832 + 0x00000010 (* EnterWindow *)
833 + 0x00000020 (* LeaveWindow *)
834 + 0x00000040 (* PointerMotion *)
835 (* + 0x00000080 *) (* PointerMotionHint *)
836 (* + 0x00000100 *) (* Button1Motion *)
837 (* + 0x00000200 *) (* Button2Motion *)
838 (* + 0x00000400 *) (* Button3Motion *)
839 (* + 0x00000800 *) (* Button4Motion *)
840 (* + 0x00001000 *) (* Button5Motion *)
841 + 0x00002000 (* ButtonMotion *)
842 (* + 0x00004000 *) (* KeymapState *)
843 + 0x00008000 (* Exposure *)
844 + 0x00010000 (* VisibilityChange *)
845 + 0x00020000 (* StructureNotify *)
846 (* + 0x00040000 *) (* ResizeRedirect *)
847 (* + 0x00080000 *) (* SubstructureNotify *)
848 (* + 0x00100000 *) (* SubstructureRedirect *)
849 (* + 0x00200000 *) (* FocusChange *)
850 + 0x00400000 (* PropertyChange *)
851 (* + 0x00800000 *) (* ColormapChange *)
852 (* + 0x01000000 *) (* OwnerGrabButton *)
855 let s = createwindowreq wid root 0 0 w h
0 mask vid depth mid in
859 sock
(~
> "WM_PROTOCOLS") false (fun resp ->
860 state.protoatom
<- r32
resp 8;
862 sock
(~
> "WM_DELETE_WINDOW") false (fun resp ->
863 state.deleatom
<- r32
resp 8;
864 let s = s32 state.deleatom
in
865 let s = changepropreq wid state.protoatom
4 32 s in
871 sock
(~
> "WM_CLIENT_MACHINE") false (fun resp ->
872 let atom = r32
resp 8 in
875 try Unix.gethostname
()
877 dolog
"error getting host name: %s" @@ exntos exn
;
882 let s = changepropreq wid atom state.stringatom
8
886 sock
(~
> "_NET_WM_PID") false (fun resp ->
887 let atom = r32
resp 8 in
888 let pid = Unix.getpid
() in
890 let s = changepropreq wid atom 6(*cardinal*) 32 s in
895 state.actwin
<- (fun () ->
896 let s = Bytes.create
4 in
897 let s = configurewindowreq wid 0x40 s in
898 sendstr s state.sock
;
899 let s = mapreq wid in
900 sendstr s state.sock
;
904 sock
(~
> "_NET_ACTIVE_WINDOW") true (fun resp ->
905 let atom = r32
resp 8 in
906 state.actwin
<- (fun () ->
907 let data = Bytes.make
20 '
\000'
in
908 let cm = clientmessage 32 0 wid atom data in
909 let s = sendeventreq 0 root 0x180000 cm in
910 sendstr s state.sock
;
915 sock
2.0 (~
> "WM_CLASS") false (fun resp ->
916 let atom = r32
resp 8 in
917 let llpp = ~
> "llpp\000llpp\000" in
918 let s = changepropreq wid atom 31 8 llpp in
922 let s = getkeymapreq state.mink
(state.maxk
-state.mink
) in
923 sendwithrep sock
s (updkmap sock
);
925 let s = getmodifiermappingreq () in
926 sendwithrep sock
s (updmodmap sock
);
929 sock
(~
> "UTF8_STRING") true (fun resp ->
930 let atom = r32
resp 8 in
932 then state.stringatom
<- atom;
936 let s = changepropreq wid 39 state.stringatom
8 s in
937 sendstr s state.sock
;
939 state.setwmname <- setwmname;
941 sock
(~
> "_NET_WM_NAME") true (fun resp ->
942 let atom = r32
resp 8 in
944 then state.setwmname <- (fun s ->
946 let s = changepropreq wid atom state.stringatom
8 s in
947 sendstr s state.sock
;
951 state.fullscreen
<- (fun wid ->
952 let s = Bytes.create
16 in
959 let s = configurewindowreq wid 0x000f s in
960 sendstr s state.sock
;
961 state.fs
<- Fs
(state.x, state.y, state.w
, state.h
);
968 let s = configurewindowreq wid 0x000f s in
969 sendstr s state.sock
;
974 sock
(~
> "_NET_WM_STATE") true (fun resp ->
975 state.nwmsatom
<- r32
resp 8;
976 if state.nwmsatom
!= 0
978 sendintern sock
(~
> "_NET_WM_STATE_MAXIMIZED_VERT") true (fun resp ->
979 state.maxvatom
<- r32
resp 8;
981 sendintern sock
(~
> "_NET_WM_STATE_MAXIMIZED_HORZ") true (fun resp ->
982 state.maxhatom
<- r32
resp 8;
985 sock
(~
> "_NET_WM_STATE_FULLSCREEN") true (fun resp ->
986 state.fulsatom
<- r32
resp 8;
987 if state.fulsatom
!= 0
991 let data = Bytes.make
20 '
\000'
in
994 | NoFs
-> Fs
(-1, -1, -1, -1), 1
998 w32
data 4 state.fulsatom
;
1000 let cm = clientmessage 32 0 wid state.nwmsatom
data in
1001 let s = sendeventreq 0 root 0x180000 cm in
1008 let s = queryextensionreq (~
> "XKEYBOARD") in
1011 let present = r8
resp 8 in
1014 let maj = r8
resp 9 in
1015 let s = Bytes.create
8 in
1016 w8
s 0 maj; (* XKB *)
1017 w8
s 1 0; (* XKBUseExtension *)
1018 w16
s 2 2; (* request-length *)
1019 w16
s 4 1; (* wantedMajor *)
1020 w16
s 6 0; (* watnedMinor *)
1024 let supported = r8
resp 1 in
1025 state.xkb
<- supported != 0
1029 let s = getgeometryreq wid in
1030 syncsendwithrep sock
2.0 s (fun resp ->
1033 and h
= r16
resp 18 in
1039 error
"unknown connection setup response %d" (Char.code c
)
1042 let getauth haddr dnum
=
1044 if emptystr
haddr || haddr = "localhost"
1046 try Unix.gethostname
()
1048 dolog
"failed to resolve `%S': %s" haddr @@ exntos exn
;
1053 try Sys.getenv
"XAUTHORITY"
1055 try Filename.concat
(Sys.getenv
"HOME") ".Xauthority"
1056 with Not_found
-> E.s
1060 let rb pos = Char.code (Bytes.get
s pos) in
1061 (rb 1) lor ((rb 0) lsl 8)
1065 let s = really_input_string ic
2 in
1066 let n = r16be (~
> s) in
1067 really_input_string ic
n
1069 let family = really_input_string ic
2 in
1073 try Some
(int_of_string
nums)
1076 "display number(%S) is not an integer (corrupt %S?): %s"
1077 nums path @@ exntos exn
;
1083 vlog
"family %S addr %S(%S) num %S(%d) name %S data %S"
1084 family addr haddr nums dnum
name data;
1086 | Some num
when addr = haddr && num
= dnum
->
1093 | End_of_file
-> E.s, E.s
1095 dolog
"exception while reading X authority data (%S): %s"
1105 match open_in_bin
path with
1108 dolog
"failed to open X authority file `%S' : %s" path @@ exntos exn
;
1112 let init t rootwid
w h platform
=
1114 try Sys.getenv
"DISPLAY"
1116 error
"cannot get DISPLAY evironment variable: %s" @@ exntos exn
1120 then error
"invalid DISPLAY(%s) %S" w d
1122 let s = String.sub
d b (e
- b) in
1125 error
"invalid DISPLAY %S can not parse %s(%S): %s"
1129 if pos = String.length
d
1130 then error
"invalid DISPLAY %S no display number specified" d
1134 let rec pdispnum pos1
=
1135 if pos1
= String.length
d
1136 then getnum "display number" (pos+1) pos1
, 0
1140 let dispnum = getnum "display number" (pos+1) pos1
in
1141 let rec pscreennum pos2
=
1142 if pos2
= String.length
d
1143 then getnum "screen number" (pos1
+1) pos2
1146 | '
0'
.. '
9'
-> pscreennum (pos2
+1)
1148 error
"invalid DISPLAY %S, cannot parse screen number" d
1150 dispnum, pscreennum (pos1
+1)
1151 | '
0'
.. '
9'
-> pdispnum (pos1
+1)
1153 error
"invalid DISPLAY %S, cannot parse display number" d
1155 String.sub
d 0 pos, pdispnum (pos+1)
1159 let host, (dispnum, screennum
) = phost 0 in
1160 let aname, adata
= getauth host dispnum in
1163 if emptystr
host || host.[0] = '
/'
|| host = "unix"
1167 | Utils.Posx
-> Unix.ADDR_UNIX
d
1169 Unix.ADDR_UNIX
("\000/tmp/.X11-unix/X" ^ string_of_int
dispnum)
1170 | Utils.Punknown
| Utils.Psun
| Utils.Pbsd
->
1171 Unix.ADDR_UNIX
("/tmp/.X11-unix/X" ^ string_of_int
dispnum)
1173 Unix.socket
Unix.PF_UNIX
Unix.SOCK_STREAM
0, addr
1176 try Unix.gethostbyname
host
1177 with exn
-> error
"cannot resolve %S: %s" host @@ exntos exn
1179 let addr = h.Unix.h_addr_list
.(0) in
1180 let port = 6000 + dispnum in
1181 let fd = Unix.socket
Unix.PF_INET
Unix.SOCK_STREAM
0 in
1182 fd, (Unix.ADDR_INET
(addr, port))
1184 try Unix.connect
fd addr; fd
1185 with exn
-> error
"failed to connect to X: %s" @@ exntos exn
1188 let s = Bytes.create
12 in
1189 let s = padcat s (~
> aname) in
1190 let s = padcat s (~
> adata
) in
1191 Bytes.set
s 0 ordermagic;
1194 w16
s 6 (String.length
aname);
1195 w16
s 8 (String.length adata
);
1196 sendstr1 s 0 (Bytes.length
s) fd;
1198 setup d fd rootwid screennum
w h;
1200 fd, state.w, state.h;
1204 state.setwmname (~
> s);
1207 let setcursor cursor
=
1208 if cursor
!= state.curcurs
1211 state.curcurs
<- cursor
;
1216 state.fullscreen state.wid;
1219 let metamask = 0x40;;
1224 let withalt mask = mask land altmask != 0;;
1225 let withctrl mask = mask land ctrlmask != 0;;
1226 let withshift mask = mask land shiftmask != 0;;
1227 let withmeta mask = mask land metamask != 0;;
1228 let withnone mask = mask land (altmask + ctrlmask + shiftmask + metamask) = 0;;
1231 let t = Hashtbl.create
20
1232 and f
= Hashtbl.create
20 in
1234 List.iter
(fun s -> Hashtbl.add t s k) (n::nl
);
1238 let s = String.make
1 c
in
1239 add s [] (Char.code c
)
1242 let an = Char.code a and bn
= Char.code b in
1243 for i
= an to bn
do addc (Char.chr i
) done;
1248 String.iter
addc "`~!@#$%^&*()-_=+\\|[{]};:,./<>?";
1249 for i
= 0 to 29 do add ("f" ^ string_of_int
(i
+1)) [] (0xffbe + i
) done;
1250 add "space" [] 0x20;
1251 add "ret" ["return"; "enter"] 0xff0d;
1252 add "tab" [] 0xff09;
1253 add "left" [] 0xff51;
1254 add "right" [] 0xff53;
1255 add "home" [] 0xff50;
1256 add "end" [] 0xff57;
1257 add "ins" ["insert"] 0xff63;
1258 add "del" ["delete"] 0xffff;
1259 add "esc" ["escape"] 0xff1b;
1260 add "pgup" ["pageup"] 0xff55;
1261 add "pgdown" ["pagedown"] 0xff56;
1262 add "backspace" [] 0xff08;
1264 add "down" [] 0xff54;
1265 add "menu" [] 0xff67;
1270 try Hashtbl.find xlatf
k
1271 with Not_found
-> Printf.sprintf
"%#x" k;
1275 try Hashtbl.find xlatt name
1277 if String.length
name = 1
1278 then Char.code name.[0]
1279 else int_of_string
name;
1285 | 0xff08 -> Backspace
1307 | 0xffab -> Ascii '
+'
1308 | 0xffad -> Ascii '
-'
1310 | code when code > 31 && code < 128 -> Ascii
(Char.unsafe_chr
code)
1311 | code when code >= 0xffb0 && code <= 0xffb9 ->
1312 Ascii
(Char.unsafe_chr
(code - 0xffb0 + 0x30))
1313 | code when code >= 0xffbe && code <= 0xffc8 -> Fn
(code - 0xffbe + 1)
1314 | code when code land 0xff00 = 0xff00 -> Ctrl
code
1318 let fontsizefactor () = 1