17 external glx1
: unit -> int = "ml_glx1";;
18 external glx2
: int -> unit = "ml_glx2";;
19 external glxsync
: unit -> unit = "ml_glxsync";;
20 external swapb
: unit -> unit = "ml_swapb";;
22 let vlog fmt
= Format.kprintf ignore fmt
;;
28 method reshape _ _
= ()
29 method mouse _ _ _ _ _
= ()
30 method motion _ _
= ()
31 method pmotion _ _
= ()
35 method winstate _
= ()
43 method reshape
: int -> int -> unit
44 method mouse
: int -> bool -> int -> int -> int -> unit
45 method motion
: int -> int -> unit
46 method pmotion
: int -> int -> unit
47 method key
: int -> int -> unit
48 method enter
: int -> int -> unit
50 method winstate
: winstate list
-> unit
57 ; mutable keymap
: int array array
58 ; fifo
: (string -> unit) Queue.t
60 ; mutable protoatom
: int
61 ; mutable deleatom
: int
62 ; mutable nwmsatom
: int
63 ; mutable maxvatom
: int
64 ; mutable maxhatom
: int
65 ; mutable fulsatom
: int
66 ; mutable idbase
: int
68 ; mutable fullscreen
: (int -> unit)
69 ; mutable setwmname
: (string -> unit)
70 ; mutable actwin
: (unit -> unit)
71 ; mutable stringatom
: int
73 ; mutable sock
: Unix.file_descr
79 ; mutable curcurs
: cursor
80 ; mutable capslmask
: int
81 ; mutable numlmask
: int
82 ; mutable levl3mask
: int
83 ; mutable levl5mask
: int
87 | Fs
of (int * int * int * int)
94 ; fifo
= Queue.create
()
104 ; fullscreen
= (fun _
-> ())
105 ; setwmname
= (fun _
-> ())
106 ; actwin
= (fun _
-> ())
115 ; curcurs
= CURSOR_INHERIT
125 let makereq opcode len reqlen
=
126 let s = String.create len
in
132 let recv fd
s pos len
=
133 Unix.recv fd
s pos len
[];
137 let s = String.create n
in
139 let m = tempfailureretry
(recv sock
s pos
) n
in
144 ignore
(tempfailureretry
(Unix.select
[sock
] [] []) 0.01);
145 loop (pos
+ m) (n
- m)
152 let sendstr1 s pos len sock
=
153 vlog "%d <= %S" state.seq
s;
154 state.seq
<- state.seq
+ 1;
155 let n = tempfailureretry
(Unix.send sock
s pos len
) [] in
157 then error
"send %d returned %d" len
n;
160 let updkmap sock resp
=
161 let syms = r8 resp
1 in
162 let len = r32 resp
4 in
165 then readstr sock
(4*len)
168 let m = len / syms in
169 state.keymap
<- Array.make_matrix
170 (state.maxk
- state.mink
) syms 0xffffff;
171 let rec loop i
= if i
= m then () else
173 let rec loop2 k l
= if l
= syms then () else
174 let v = r32
data k in
175 state.keymap
.(i
).(l
) <- v;
184 let updmodmap sock resp
=
186 let len = r16 resp
4 in
189 then readstr sock
(len*4)
192 if len > 0 then (*???*)
193 let modmap = Array.make_matrix
8 n 0xffffff in
194 let rec loop l
= if l
= 8 then () else
196 let rec loop1 m = if m = n then () else
198 let code = r8
data p in
199 modmap.(l
).(m) <- code;
202 let ki = code - state.mink
in
205 let a = state.keymap
.(ki) in
206 let rec capsloop i
= if i
= Array.length
a || i
> 3 then () else
209 then state.capslmask
<- 2
217 let ki = code - state.mink
in
220 let a = state.keymap
.(ki) in
221 let rec lloop i
= if i
= Array.length
a || i
> 3 then () else
224 | 0xfe03 -> state.levl3mask
<- 1 lsl l
225 | 0xfe11 -> state.levl5mask
<- 1 lsl l
226 | 0xff7f -> state.numlmask
<- 1 lsl l
240 let sendwithrep sock
s f
=
241 Queue.push f
state.fifo
;
242 sendstr1 s 0 (String.length
s) sock
;
246 let b = Buffer.create
16 in
247 List.iter
(Buffer.add_string
b) ss
;
248 let bl = Buffer.length
b in
249 let pl = bl land 3 in
253 Buffer.add_substring
b pad 0 (4 - pl);
258 let padcat s1 s2
= padcatl [s1
; s2
];;
260 let internreq name onlyifexists
=
261 let s = makereq 16 8 8 in
262 let s = padcat s name
in
263 w8
s 1 (if onlyifexists
then 1 else 0);
264 w16
s 2 (String.length
s / 4);
265 w16
s 4 (String.length name
);
269 let sendintern sock
s onlyifexists f
=
270 let s = internreq s onlyifexists
in
271 sendwithrep sock
s f
;
274 let createwindowreq wid parent x y w h bw eventmask vid depth mid
=
275 let s = makereq 1 48 12 in
284 w16
s 22 0; (* inputoutput *)
285 w32
s 24 vid
; (* visual *)
286 w32
s 28 0x280a; (* eventmask*)
294 let createcolormapreq mid wid vid
=
295 let s = makereq 78 16 4 in
303 let getgeometryreq wid
=
304 let s = makereq 14 8 2 in
310 let s = makereq 8 8 2 in
315 let getkeymapreq first count
=
316 let s = makereq 101 8 2 in
322 let changepropreq wid prop typ format props
=
323 let s = makereq 18 24 0 in
324 let s = padcat s props
in
326 w16
s 2 (String.length
s / 4);
331 let ful = String.length props
/ (match format
with
335 | n -> error
"no idea what %d means" n)
341 let getpropreq delete wid prop typ
=
342 let s = makereq 20 24 6 in
343 w8
s 1 (if delete
then 1 else 0);
352 let openfontreq fid name
=
353 let s = makereq 45 12 0 in
354 let s = padcat s name
in
355 w16
s 2 (String.length
s / 4);
357 w16
s 8 (String.length name
);
361 let createglyphcursorreq fid cid cindex
=
362 let s = makereq 94 32 8 in
377 let changewindowattributesreq wid mask attrs
=
378 let s = makereq 2 12 0 in
379 let s = padcat s attrs
in
380 w16
s 2 (String.length
s / 4);
386 let configurewindowreq wid mask values
=
387 let s = makereq 2 12 0 in
388 let s = padcat s values
in
389 w16
s 2 (String.length
s / 4);
401 let clientmessage format seq wid typ
data =
402 let s = makereq 33 12 0 in
403 let s = padcat s data in
411 let sendeventreq propagate destwid mask
data =
412 let s = makereq 25 12 11 in
413 let s = padcat s data in
421 let getmodifiermappingreq () =
425 let getkeysym code mask
=
426 let pkpk = state.keymap
.(code-state.mink
).(0) in
427 if (pkpk >= 0xff80 && pkpk <= 0xffbd)
428 || (pkpk >= 0x11000000 && pkpk <= 0x1100ffff)
430 if mask
land state.numlmask
!= 0
432 let keysym = state.keymap
.(code-state.mink
).(1) in
433 if keysym = 0 then pkpk else keysym
438 if pkpk land 0xf000 = 0xf000
440 else (mask
land 1) lxor ((mask
land state.capslmask
) lsr 1)
443 let l3 = (mask
land state.levl3mask
) != 0 in
444 let l4 = (mask
land state.levl5mask
) != 0 in
446 if l3 then (if l4 then 8 else 4) else (if l4 then 6 else 0)
448 let keysym = state.keymap
.(code-state.mink
).(index) in
449 if index land 1 = 1 && keysym = 0
450 then state.keymap
.(code-state.mink
).(index - 1)
456 let resp = readstr sock
32 in
457 let opcode = r8
resp 0 in
458 match opcode land lnot
0x80 with
463 and resid
= r32
resp 4
466 error
"code=%d serial=%d resid=%#x min=%d maj=%d\n%S"
467 code serial resid min maj
resp;
469 | 1 -> (* response *)
470 let rep = Queue.pop
state.fifo
in
473 | 2 -> (* key press *)
474 if Array.length
state.keymap
> 0
476 let code = r8
resp 1 in
477 let mask = r16
resp 28 in
478 let keysym = getkeysym code mask in
479 vlog "keysym = %x %c mask %#x code %d"
480 keysym (Char.unsafe_chr
keysym) mask code;
481 state.t#key
keysym mask;
483 | 3 -> (* key release *)
484 if Array.length
state.keymap
> 0
486 let code = r8
resp 1 in
487 let mask = r16
resp 28 in
488 let keysym = getkeysym code mask in
489 vlog "release keysym = %x %c mask %#x code %#d"
490 keysym (Char.unsafe_chr
keysym) mask code
492 | 4 -> (* buttonpress *)
496 and m = r16
resp 28 in
497 state.t#mouse
n true x y
m;
500 | 5 -> (* buttonrelease *)
504 and m = r16
resp 28 in
505 state.t#mouse
n false x y
m;
506 vlog "release %d %d %d" n x y
509 let x = r16s
resp 24 in
510 let y = r16s
resp 26 in
511 let m = r16
resp 28 in
513 then state.t#pmotion
x y
514 else state.t#motion
x y;
515 vlog "move %dx%d => %d" x y m
519 and y = r16s
resp 26 in
521 vlog "enter %d %d" x y
526 | 18 -> vlog "unmap";
531 | 12 -> (* exposure *)
535 | 15 -> (* visibility *)
536 let vis = r8
resp 8 in
537 if vis != 2 then state.t#visible
;
538 vlog "visibility %d" vis;
540 | 34 -> (* mapping *)
542 let s = getkeymapreq state.mink
(state.maxk
-state.mink
-1) in
543 sendwithrep sock
s (updkmap sock
);
544 state.capslmask
<- 0;
545 state.levl3mask
<- 0;
546 state.levl5mask
<- 0;
548 let s = getmodifiermappingreq () in
549 sendwithrep sock
s (updmodmap sock
);
551 | 33 -> (* clientmessage *)
552 let atom = r32
resp 8 in
553 if atom = state.protoatom
555 let atom = r32
resp 12 in
556 if atom = state.deleatom
561 | 21 -> (* reparent *)
564 | 22 -> (* configure *)
568 and h
= r16
resp 22 in
569 vlog "configure cur [%d %d %d %d] conf [%d %d %d %d]"
570 state.x state.y state.w
state.h
574 if w
!= state.w
|| h
!= state.h
585 let atom = r32
resp 8 in
586 if atom = state.nwmsatom
588 let s = getpropreq false state.idbase
atom 4 in
589 sendwithrep sock
s (fun resp ->
590 let len = r32
resp 4 in
591 let nitems = r32
resp 16 in
596 let s = readstr sock
(len*4) in
597 let rec loop wsl i
= if i
= nitems then wsl else
598 let atom = r32
s (i
*4) in
600 if atom = state.maxhatom
603 if atom = state.maxvatom
606 if atom = state.fulsatom
608 state.fs
<- Fs
(state.x, state.y, state.w
, state.h
);
618 state.t#winstate
(List.sort compare
wsl)
622 dolog
"event %d %S" n resp
628 if hasdata sock
then loop ();
633 let sendstr s ?
(pos
=0) ?
(len=String.length
s) sock
=
634 sendstr1 s pos
len sock
;
635 if hasdata sock
then readresp sock
;
641 let s = "wwuuhhuu" in
644 let s = configurewindowreq state.idbase
0x000c s in
645 sendstr s state.sock
;
646 else state.fullscreen
state.idbase
653 let syncsendwithrep sock secstowait
s f
=
654 let completed = ref false in
655 sendwithrep sock
s (fun resp -> f
resp; completed := true);
656 let now = Unix.gettimeofday
in
657 let deadline = now () +. secstowait
in
658 let rec readtillcompletion () =
660 let timeout = deadline -. now () in
663 else Unix.select
[sock
] [] [] timeout
665 let r, _
, _
= tempfailureretry
sf deadline in
667 | [] -> error
"didn't get X response in %f seconds, aborting" secstowait
671 then readtillcompletion ()
673 readtillcompletion ();
677 let s = mapreq state.idbase
in
678 sendstr s state.sock
;
681 let syncsendintern sock secstowait
s onlyifexists f
=
682 let s = internreq s onlyifexists
in
683 syncsendwithrep sock secstowait
s f
;
686 let setup sock screennum w h
=
687 let s = readstr sock
2 in
688 let n = String.length
s in
690 then error
"failed to read X connection setup response n=%d" n;
693 let reasonlen = r8
s 1 in
694 let s = readstr sock
6 in
699 let data = readstr sock
len in
700 let reason = String.sub
data 0 reasonlen in
701 error
"X connection failed maj=%d min=%d reason=%S"
704 | '
\002'
-> failwith
"X connection setup failed: authentication required";
707 let s = readstr sock
38 in
711 and idbase
= r32
s 10
712 and idmask
= r32
s 14
714 and screens
= r8
s 26
715 and formats
= r8
s 27
717 and maxkk
= r8
s 33 in
718 let data = readstr sock
(4*add
-32) in
719 let vendor = String.sub
data 0 vlen
in
720 let pos = ((vlen
+3) land lnot
3) + formats
*8 in
722 if screennum
>= screens
723 then error
"invalid screen %d, max %d" screennum
(screens
-1);
727 let rec findscreen n pos = if n = screennum
then pos else
729 let ndepths = r8
s (pos+39) in
730 let rec skipdepths n pos = if n = ndepths then pos else
732 let nvisiuals = r16
s (pos+2) in
733 pos + nvisiuals*24 + 8
737 skipdepths n (pos+40)
743 let root = r32
data pos in
744 let rootw = r16
data (pos+20)
745 and rooth
= r16
data (pos+22) in
748 state.idbase
<- idbase
;
749 vlog "vendor = %S, maj=%d min=%d" vendor maj min
;
750 vlog "screens = %d formats = %d" screens formats
;
751 vlog "minkk = %d maxkk = %d" minkk maxkk
;
752 vlog "idbase = %#x idmask = %#x" idbase idmask
;
753 vlog "root=%#x %dx%d" root rootw rooth
;
754 vlog "wmm = %d, hmm = %d" (r16
data (pos+24)) (r16
data (pos+26));
755 vlog "visualid = %#x " (r32
data (pos+32));
758 let ndepths = r8
data (pos+39) in
759 let rec finddepth n'
pos =
761 then error
"couldn't find depth for visual %#x" vid;
762 let depth = r8
data pos in
763 let nvisuals = r16
data (pos+2) in
764 let rec findvisual n pos =
766 then finddepth (n'
+1) pos
768 let id = r32
data pos in
771 else findvisual (n+1) (pos+24)
775 let depth = finddepth 0 (pos+40) in
777 let wid = state.idbase
in
783 let s = createcolormapreq mid root vid in
787 + 0x00000001 (* KeyPress *)
788 (* + 0x00000002 *) (* KeyRelease *)
789 + 0x00000004 (* ButtonPress *)
790 + 0x00000008 (* ButtonRelease *)
791 + 0x00000010 (* EnterWindow *)
792 + 0x00000020 (* LeaveWindow *)
793 + 0x00000040 (* PointerMotion *)
794 (* + 0x00000080 *) (* PointerMotionHint *)
795 (* + 0x00000100 *) (* Button1Motion *)
796 (* + 0x00000200 *) (* Button2Motion *)
797 (* + 0x00000400 *) (* Button3Motion *)
798 (* + 0x00000800 *) (* Button4Motion *)
799 (* + 0x00001000 *) (* Button5Motion *)
800 + 0x00002000 (* ButtonMotion *)
801 (* + 0x00004000 *) (* KeymapState *)
802 + 0x00008000 (* Exposure *)
803 + 0x00010000 (* VisibilityChange *)
804 + 0x00020000 (* StructureNotify *)
805 (* + 0x00040000 *) (* ResizeRedirect *)
806 (* + 0x00080000 *) (* SubstructureNotify *)
807 (* + 0x00100000 *) (* SubstructureRedirect *)
808 (* + 0x00200000 *) (* FocusChange *)
809 + 0x00400000 (* PropertyChange *)
810 (* + 0x00800000 *) (* ColormapChange *)
811 (* + 0x01000000 *) (* OwnerGrabButton *)
813 let s = createwindowreq wid root 0 0 w h
0 mask vid depth mid in
816 sendintern sock
"WM_PROTOCOLS" false (fun resp ->
817 state.protoatom
<- r32
resp 8;
818 sendintern sock
"WM_DELETE_WINDOW" false (fun resp ->
819 state.deleatom
<- r32
resp 8;
820 let s = s32 state.deleatom
in
821 let s = changepropreq wid state.protoatom
4 32 s in
826 sendintern sock
"WM_CLIENT_MACHINE" false (fun resp ->
827 let atom = r32
resp 8 in
830 try Unix.gethostname
()
832 dolog
"error getting host name: %s" (exntos exn
);
837 let s = changepropreq wid atom state.stringatom
8 hostname in
839 sendintern sock
"_NET_WM_PID" false (fun resp ->
840 let atom = r32
resp 8 in
841 let pid = Unix.getpid
() in
843 let s = changepropreq wid atom (* cardinal *)6 32 s in
848 state.actwin
<- (fun () ->
849 let s = String.create
4 in
850 let s = configurewindowreq wid 0x40 s in
851 sendstr s state.sock
;
852 let s = mapreq wid in
853 sendstr s state.sock
;
856 sendintern sock
"_NET_ACTIVE_WINDOW" true (fun resp ->
857 let atom = r32
resp 8 in
858 state.actwin
<- (fun () ->
859 let data = String.make
20 '
\000'
in
860 let cm = clientmessage 32 0 wid atom data in
861 let s = sendeventreq 0 root 0x180000 cm in
862 sendstr s state.sock
;
866 syncsendintern sock
2.0 "WM_CLASS" false (fun resp ->
867 let atom = r32
resp 8 in
868 let llpp = "llpp\000llpp\000" in
869 let s = changepropreq wid atom 31 8 llpp in
873 let s = getkeymapreq state.mink
(state.maxk
-state.mink
) in
874 sendwithrep sock
s (updkmap sock
);
876 let s = getmodifiermappingreq () in
877 sendwithrep sock
s (updmodmap sock
);
879 let s = openfontreq fid "cursor" in
882 Array.iteri
(fun i glyphindex
->
883 let s = createglyphcursorreq fid (fid+1+i
) glyphindex
in
885 ) [|34;48;50;58;128;152|];
887 sendintern sock
"UTF8_STRING" true (fun resp ->
888 let atom = r32
resp 8 in
890 then state.stringatom
<- atom;
894 let s = changepropreq wid 39 state.stringatom
8 s in
895 sendstr s state.sock
;
897 state.setwmname <- setwmname;
898 sendintern sock
"_NET_WM_NAME" true (fun resp ->
899 let atom = r32
resp 8 in
901 then state.setwmname <- (fun s ->
903 let s = changepropreq wid atom state.stringatom
8 s in
904 sendstr s state.sock
;
908 state.fullscreen
<- (fun wid ->
909 let s = "xxuuyyuuwwuuhhuu" in
916 let s = configurewindowreq wid 0x000f s in
917 sendstr s state.sock
;
918 state.fs
<- Fs
(state.x, state.y, state.w
, state.h
);
925 let s = configurewindowreq wid 0x000f s in
926 sendstr s state.sock
;
930 sendintern sock
"_NET_WM_STATE" true (fun resp ->
931 state.nwmsatom
<- r32
resp 8;
932 if state.nwmsatom
!= 0
934 sendintern sock
"_NET_WM_STATE_MAXIMIZED_VERT" true (fun resp ->
935 state.maxvatom
<- r32
resp 8;
937 sendintern sock
"_NET_WM_STATE_MAXIMIZED_HORZ" true (fun resp ->
938 state.maxhatom
<- r32
resp 8;
940 sendintern sock
"_NET_WM_STATE_FULLSCREEN" true (fun resp ->
941 state.fulsatom
<- r32
resp 8;
942 if state.fulsatom
!= 0
946 let data = String.make
20 '
\000'
in
949 | NoFs
-> Fs
(-1, -1, -1, -1), 1
953 w32
data 4 state.fulsatom
;
955 let cm = clientmessage 32 0 wid state.nwmsatom
data in
956 let s = sendeventreq 0 root 0x180000 cm in
963 let s = getgeometryreq wid in
964 syncsendwithrep sock
2.0 s (fun resp ->
967 and h
= r16
resp 18 in
973 error
"unknown conection setup response %d" (Char.code c
)
976 let getauth haddr dnum
=
978 if haddr = "localhost" || String.length
haddr = 0
980 try Unix.gethostname
()
982 dolog
"failed to resolve `%S': %s" haddr (exntos exn
);
987 try Sys.getenv
"XAUTHORITY"
989 try Filename.concat
(Sys.getenv
"HOME") ".Xauthority"
990 with Not_found
-> E.s
993 let input_string ic
len =
994 let s = String.create
len in
995 really_input ic
s 0 len;
999 let rb pos = Char.code (String.get
s pos) in
1000 (rb 1) lor ((rb 0) lsl 8)
1004 let s = input_string ic
2 in
1008 let family = input_string ic
2 in
1012 try Some
(int_of_string
nums)
1015 "display number(%S) is not an integer (corrupt %S?): %s"
1016 nums path (exntos exn
);
1022 vlog "family %S addr %S(%S) num %S(%d) name %S data %S"
1023 family addr haddr nums dnum
name data;
1025 | Some num
when addr = haddr && num
= dnum
->
1032 | End_of_file
-> E.s, E.s
1034 dolog
"exception while reading X authority data (%S): %s"
1043 if String.length
path = 0
1045 else Some
(open_in_bin
path)
1047 if Sys.file_exists
path
1049 dolog
"failed to open X authority file `%S' : %s"
1055 | Some ic
-> readauth ic
1058 let init t
w h osx
=
1060 try Sys.getenv
"DISPLAY"
1062 error
"could not get DISPLAY evironment variable: %s"
1067 then error
"invalid DISPLAY(%s) %S" w d
1069 let s = String.sub
d b (e
- b) in
1072 error
"invalid DISPLAY %S can not parse %s(%S): %s"
1076 if pos = String.length
d
1077 then error
"invalid DISPLAY %S no display number specified" d
1081 let rec pdispnum pos1
=
1082 if pos1
= String.length
d
1083 then getnum "display number" (pos+1) pos1
, 0
1087 let dispnum = getnum "display number" (pos+1) pos1
in
1088 let rec pscreennum pos2
=
1089 if pos2
= String.length
d
1090 then getnum "screen number" (pos1
+1) pos2
1093 | '
0'
.. '
9'
-> pscreennum (pos2
+1)
1095 error
"invalid DISPLAY %S, cannot parse screen number" d
1097 dispnum, pscreennum (pos1
+1)
1098 | '
0'
.. '
9'
-> pdispnum (pos1
+1)
1100 error
"invalid DISPLAY %S, cannot parse display number" d
1102 String.sub
d 0 pos, pdispnum (pos+1)
1106 let host, (dispnum, screennum
) = phost 0 in
1107 let aname, adata
= getauth host dispnum in
1110 if osx
|| String.length
host = 0 || host = "unix"
1114 then Unix.ADDR_UNIX
d
1115 else Unix.ADDR_UNIX
("/tmp/.X11-unix/X" ^ string_of_int
dispnum)
1117 let fd = Unix.socket
Unix.PF_UNIX
Unix.SOCK_STREAM
0 in
1121 try Unix.gethostbyname
host
1123 error
"cannot resolve %S: %s" host (exntos exn
)
1125 let addr = h.Unix.h_addr_list
.(0) in
1126 let port = 6000 + dispnum in
1127 let fd = Unix.socket
Unix.PF_INET
Unix.SOCK_STREAM
0 in
1128 fd, (Unix.ADDR_INET
(addr, port))
1130 try Unix.connect
fd addr; fd
1132 error
"failed to connect to X: %s" (exntos exn
)
1135 let s = String.create
12 in
1136 let s = padcat s aname in
1137 let s = padcat s adata
in
1138 s.[0] <- ordermagic
;
1141 w16
s 6 (String.length
aname);
1142 w16
s 8 (String.length adata
);
1143 sendstr1 s 0 (String.length
s) fd;
1145 setup fd screennum
w h;
1147 fd, state.w, state.h;
1154 let setcursor cursor
=
1155 if cursor
!= state.curcurs
1159 | CURSOR_INHERIT
-> -1
1162 | CURSOR_CROSSHAIR
-> 0
1165 let s = s32 (if n = -1 then 0 else state.fid+1+n) in
1166 let s = changewindowattributesreq state.idbase
(*cursor*)0x4000 s in
1167 sendstr s state.sock
;
1168 state.curcurs
<- cursor
;
1172 state.fullscreen state.idbase
;
1175 let metamask = 0x40;;
1180 let withalt mask = mask land altmask != 0;;
1181 let withctrl mask = mask land ctrlmask != 0;;
1182 let withshift mask = mask land shiftmask != 0;;
1183 let withmeta mask = mask land metamask != 0;;
1184 let withnone mask = mask land (altmask + ctrlmask + shiftmask + metamask) = 0;;
1187 let t = Hashtbl.create
20
1188 and f
= Hashtbl.create
20 in
1190 List.iter
(fun s -> Hashtbl.add t s k) (n::nl
);
1194 let s = String.create
1 in
1196 add s [] (Char.code c
)
1199 let an = Char.code a and bn
= Char.code b in
1200 for i
= an to bn
do addc (Char.chr i
) done;
1205 String.iter
addc "`~!@#$%^&*()-_=+\\|[{]};:,./<>?";
1206 for i
= 0 to 29 do add ("f" ^ string_of_int
(i
+1)) [] (0xffbe + i
) done;
1207 add "space" [] 0x20;
1208 add "ret" ["return"; "enter"] 0xff0d;
1209 add "tab" [] 0xff09;
1210 add "left" [] 0xff51;
1211 add "right" [] 0xff53;
1212 add "home" [] 0xff50;
1213 add "end" [] 0xff57;
1214 add "ins" ["insert"] 0xff63;
1215 add "del" ["delete"] 0xffff;
1216 add "esc" ["escape"] 0xff1b;
1217 add "pgup" ["pageup"] 0xff55;
1218 add "pgdown" ["pagedown"] 0xff56;
1219 add "backspace" [] 0xff08;
1221 add "down" [] 0xff54;
1222 add "menu" [] 0xff67;
1227 try Hashtbl.find xlatf
k
1228 with Not_found
-> Printf.sprintf
"%#x" k;
1232 try Hashtbl.find xlatt name
1234 if String.length
name = 1
1235 then Char.code name.[0]
1236 else int_of_string
name;