Fix delete behavior in presentation mode corner case
[llpp.git] / wsi.ml
blob9f764c7cfc011965e926281961df0a55f7663e0e
1 type cursor =
2 | CURSOR_INHERIT
3 | CURSOR_INFO
4 | CURSOR_CYCLE
5 | CURSOR_CROSSHAIR
6 | CURSOR_TEXT
7 ;;
9 external cloexec : Unix.file_descr -> unit = "ml_cloexec";;
10 external glx : int -> unit = "ml_glx";;
11 external glxsync : unit -> unit = "ml_glxsync";;
12 external swapb : unit -> unit = "ml_swapb";;
13 external hasdata : Unix.file_descr -> bool = "ml_hasdata";;
14 external toutf8 : int -> string = "ml_keysymtoutf8";;
16 let dolog fmt = Format.kprintf prerr_endline fmt;;
17 let vlog fmt = Format.kprintf ignore fmt;;
19 let onot = object
20 method display = ()
21 method expose = ()
22 method reshape _ _ = ()
23 method mouse _ _ _ _ _ = ()
24 method motion _ _ = ()
25 method pmotion _ _ = ()
26 method key _ _ = ()
27 method enter _ _ = ()
28 method leave = ()
29 method quit = exit 0
30 end;;
32 class type t = object
33 method display : unit
34 method expose : unit
35 method reshape : int -> int -> unit
36 method mouse : int -> bool -> int -> int -> int -> unit
37 method motion : int -> int -> unit
38 method pmotion : int -> int -> unit
39 method key : int -> int -> unit
40 method enter : int -> int -> unit
41 method leave : unit
42 method quit : unit
43 end;;
45 type state =
46 { mutable mink : int
47 ; mutable maxk : int
48 ; mutable keymap : int array array
49 ; fifo : (string -> unit) Queue.t
50 ; mutable seq : int
51 ; mutable protoatom : int
52 ; mutable deleatom : int
53 ; mutable idbase : int
54 ; mutable fullscreen : (int -> unit)
55 ; mutable setwmname : (string -> unit)
56 ; mutable stringatom : int
57 ; mutable t : t
58 ; mutable sock : Unix.file_descr
59 ; mutable x : int
60 ; mutable y : int
61 ; mutable w : int
62 ; mutable h : int
63 ; mutable fs : fs
64 ; mutable curcurs : cursor
66 and fs =
67 | NoFs
68 | Fs of (int * int * int * int)
71 let state =
72 { mink = max_int
73 ; maxk = min_int
74 ; keymap = [||]
75 ; fifo = Queue.create ()
76 ; seq = 0
77 ; protoatom = -1
78 ; deleatom = -1
79 ; idbase = -1
80 ; fullscreen = (fun _ -> ())
81 ; setwmname = (fun _ -> ())
82 ; sock = Unix.stdin
83 ; t = onot
84 ; x = -1
85 ; y = -1
86 ; w = -1
87 ; h = -1
88 ; fs = NoFs
89 ; stringatom = 31
90 ; curcurs = CURSOR_INHERIT
94 let w8 s pos i = String.set s pos (Char.chr (i land 0xff));;
96 let w16 s pos i =
97 w8 s pos i;
98 w8 s (pos+1) (i lsr 8);
101 let w32 s pos i =
102 w16 s pos i;
103 w16 s (pos+2) (i lsr 16);
106 let r16 s pos =
107 let rb pos1 = Char.code (String.get s (pos + pos1)) in
108 (rb 0) lor ((rb 1) lsl 8)
111 let r16s s pos =
112 let i = r16 s pos in
113 i - ((i land 0x8000) lsl 1);
116 let r8 s pos = Char.code (String.get s pos);;
118 let r32 s pos =
119 let rb pos1 = Char.code (String.get s (pos + pos1)) in
120 let l = (rb 0) lor ((rb 1) lsl 8)
121 and u = (rb 2) lor ((rb 3) lsl 8) in
122 (u lsl 16) lor l
125 let exntos = function
126 | Unix.Unix_error (e, s, a) -> Printf.sprintf "%s(%s):%s(%d)"
127 s a (Unix.error_message e) (Obj.magic e)
128 | exn -> Printexc.to_string exn;
131 let error fmt = Printf.kprintf failwith fmt;;
133 let readstr sock n =
134 let s = String.create n in
135 let rec loop pos n =
136 let m = Unix.read sock s pos n in
137 if m = 0
138 then state.t#quit;
139 if n != m
140 then (
141 ignore (Unix.select [sock] [] [] 0.01);
142 loop (pos + m) (n - m)
145 loop 0 n;
149 let sendstr1 s pos len sock =
150 vlog "%d => %S" state.seq s;
151 state.seq <- state.seq + 1;
152 let n = Unix.send sock s pos len [] in
153 if n != len
154 then error "send %d returned %d" len n;
157 let updkmap sock resp =
158 let syms = r8 resp 1 in
159 let len = r32 resp 4 in
160 let data =
161 if len > 0
162 then readstr sock (4*len)
163 else ""
165 let m = len / syms in
166 state.keymap <- Array.make_matrix
167 (state.maxk - state.mink) syms 0xffffff;
168 let rec loop i = if i = m then () else
169 let k = i*4*syms in
170 let rec loop2 k l = if l = syms then () else
171 let v = r32 data k in
172 state.keymap.(i).(l) <- v;
173 loop2 (k+4) (l+1)
175 loop2 k 0;
176 loop (i+1);
178 loop 0;
181 let sendwithrep sock s f =
182 Queue.push f state.fifo;
183 sendstr1 s 0 (String.length s) sock;
186 let padcatl ss =
187 let b = Buffer.create 16 in
188 List.iter (Buffer.add_string b) ss;
189 let bl = Buffer.length b in
190 let pl = bl land 3 in
191 if pl != 0
192 then (
193 let pad = "123" in
194 Buffer.add_substring b pad 0 (4 - pl);
196 Buffer.contents b;
199 let padcat s1 s2 = padcatl [s1; s2];;
201 let internreq name onlyifexists =
202 let s = "\016\000\000\000\000\000\000\000" in
203 let s = padcat s name in
204 if onlyifexists then w8 s 1 1;
205 w16 s 2 (String.length s / 4);
206 w16 s 4 (String.length name);
210 let sendintern sock s onlyifexists f =
211 let s = internreq s onlyifexists in
212 sendwithrep sock s f;
215 let createwindowreq wid parent x y w h bw mask =
216 let s = "\001\000\009\000wwwwppppxxyywwhhbwccvvvvmmmmeeee" in
217 w32 s 4 wid;
218 w32 s 8 parent;
219 w16 s 12 x;
220 w16 s 14 y;
221 w16 s 16 w;
222 w16 s 18 h;
223 w16 s 20 bw;
224 w16 s 22 1;
225 w32 s 24 0;
226 w32 s 28 0x800; (* eventmask *)
227 w32 s 32 mask;
231 let getgeometryreq wid =
232 let s = "\014u\002\000dddd" in
233 w32 s 4 wid;
237 let mapreq wid =
238 let s = "\008u\002\000wwww" in
239 w32 s 4 wid;
243 let getkeymapreq first count =
244 let s = "\101u\002\000fcuu" in
245 w8 s 4 first;
246 w8 s 5 count;
250 let changepropreq wid prop typ format props =
251 let s = "\018\000llwwwwppppttttfuuuLLLL" in
252 let s = padcat s props in
253 w16 s 2 (String.length s / 4);
254 w32 s 4 wid;
255 w32 s 8 prop;
256 w32 s 12 typ;
257 w8 s 16 format;
258 let ful = String.length props / (match format with
259 | 8 -> 1
260 | 16 -> 2
261 | 32 -> 4
262 | n -> error "no idea what %d means" n)
264 w32 s 20 ful;
268 let openfontreq fid name =
269 let s = "\045ullffffnnuu" in
270 let s = padcat s name in
271 w16 s 2 (String.length s / 4);
272 w32 s 4 fid;
273 w16 s 8 (String.length name);
277 let createglyphcursorreq fid cid cindex =
278 let s = "\094u\008\000ccccffffffffssmmrrggbbRRGGBB" in
279 w32 s 4 cid;
280 w32 s 8 fid;
281 w32 s 12 fid;
282 w16 s 16 cindex;
283 w16 s 18 (cindex+1);
284 w16 s 20 0;
285 w16 s 22 0;
286 w16 s 24 0;
287 w16 s 26 0xffff;
288 w16 s 28 0xffff;
289 w16 s 30 0xffff;
293 let changewindowattributesreq wid mask attrs =
294 let s = "\002ullwwwwmmmm" in
295 let s = padcat s attrs in
296 w16 s 2 (String.length s / 4);
297 w32 s 4 wid;
298 w32 s 8 mask;
302 let configurewindowreq wid mask values =
303 let s = "\012ullwwwwmmuu" in
304 let s = padcat s values in
305 w16 s 2 (String.length s / 4);
306 w32 s 4 wid;
307 w16 s 8 mask;
311 let s32 n =
312 let s = "1234" in
313 w32 s 0 n;
317 let clientmessage format seq wid typ data =
318 let s = "\033fsswwwwtttt" in
319 let s = padcat s data in
320 w8 s 1 format;
321 w16 s 2 seq;
322 w32 s 4 wid;
323 w32 s 8 typ;
327 let sendeventreq propagate destwid mask data =
328 let s = "\025p\011\000wwwwmmmm" in
329 let s = padcat s data in
330 w8 s 1 propagate;
331 w32 s 4 destwid;
332 w32 s 8 mask;
336 let getkeysym code mask =
337 let index = (mask land 1) lxor ((mask land 2) lsr 1) in
338 let keysym = state.keymap.(code-state.mink).(index) in
339 if index = 1 && keysym = 0
340 then state.keymap.(code-state.mink).(0)
341 else keysym
344 let readresp sock =
345 let resp = readstr sock 32 in
346 let opcode = r8 resp 0 in
347 match opcode land lnot 0x80 with
348 | 0 -> (* error *)
349 let s = resp in
350 let code = r8 s 1
351 and serial = r16 s 2
352 and resid = r32 resp 4
353 and min = r16 s 8
354 and maj = r8 s 10 in
355 error "code=%d serial=%d resid=%#x min=%d maj=%d\n%S"
356 code serial resid min maj resp;
358 | 1 -> (* response *)
359 let rep = Queue.pop state.fifo in
360 rep resp;
362 | 2 -> (* key press *)
363 if Array.length state.keymap > 0
364 then
365 let code = r8 resp 1 in
366 let mask = r16 resp 28 in
367 let keysym = getkeysym code mask in
368 vlog "keysym = %x %c" keysym (Char.unsafe_chr keysym);
369 state.t#key keysym mask;
371 | 3 -> (* key release *)
372 if Array.length state.keymap > 0
373 then
374 let code = r8 resp 1 in
375 let mask = r16 resp 28 in
376 let keysym = getkeysym code mask in
377 vlog "release keysym = %x %c mask %#x"
378 keysym (Char.unsafe_chr keysym) mask
380 | 4 -> (* buttonpress *)
381 let n = r8 resp 1
382 and x = r16s resp 24
383 and y = r16s resp 26
384 and m = r16 resp 28 in
385 state.t#mouse n true x y m;
386 vlog "press %d" n
388 | 5 -> (* buttonrelease *)
389 let n = r8 resp 1
390 and x = r16s resp 24
391 and y = r16s resp 26
392 and m = r16 resp 28 in
393 state.t#mouse n false x y m;
394 vlog "release %d %d %d" n x y
396 | 6 -> (* motion *)
397 let x = r16s resp 24 in
398 let y = r16s resp 26 in
399 let m = r16 resp 28 in
400 if m land 0x1f00 = 0
401 then state.t#pmotion x y
402 else state.t#motion x y;
403 vlog "move %dx%d => %d" x y m
405 | 7 -> (* enter *)
406 let x = r16s resp 24
407 and y = r16s resp 26 in
408 state.t#enter x y;
409 vlog "enter %d %d" x y
411 | 8 -> (* leave *)
412 state.t#leave
414 | 18 -> vlog "unmap";
416 | 19 -> (* map *)
417 vlog "map";
419 | 12 -> (* exposure *)
420 vlog "exposure";
421 state.t#expose
423 | 15 -> (* visibility *)
424 let vis = r8 resp 8 in
425 if vis != 2 then state.t#expose;
426 vlog "visibility %d" vis;
428 | 34 -> (* mapping *)
429 state.keymap <- [||];
430 let s = getkeymapreq state.mink (state.maxk-state.mink-1) in
431 sendwithrep sock s (updkmap sock);
433 | 33 -> (* clientmessage *)
434 let atom = r32 resp 8 in
435 if atom = state.protoatom
436 then (
437 let atom = r32 resp 12 in
438 if atom = state.deleatom
439 then state.t#quit;
441 vlog "atom %#x" atom
443 | 21 -> (* reparent *)
444 vlog "reparent"
446 | 22 -> (* configure *)
447 let x = r16s resp 16
448 and y = r16s resp 18
449 and w = r16 resp 20
450 and h = r16 resp 22 in
451 vlog "configure cur [%d %d %d %d] conf [%d %d %d %d]"
452 state.x state.y state.w state.h
453 x y w h
455 glxsync ();
456 if w != state.w || h != state.h
457 then (
458 state.t#reshape w h;
460 state.w <- w;
461 state.h <- h;
462 state.x <- x;
463 state.y <- y;
464 state.t#expose
466 | n ->
467 dolog "event %d %S" n resp
470 let readresp sock =
471 let rec loop () =
472 readresp sock;
473 if hasdata sock then loop ();
475 loop ();
478 let sendstr s ?(pos=0) ?(len=String.length s) sock =
479 sendstr1 s pos len sock;
480 if hasdata sock then readresp sock;
483 let reshape w h =
484 if state.fs = NoFs
485 then
486 let s = "wwuuhhuu" in
487 w32 s 0 w;
488 w32 s 4 h;
489 let s = configurewindowreq state.idbase 0x000c s in
490 sendstr s state.sock;
491 else state.fullscreen state.idbase
494 let setup sock screennum w h =
495 let s = readstr sock 2 in
496 let n = String.length s in
497 if n != 2
498 then error "failed to read X connection setup response n=%d" n;
499 match s.[0] with
500 | '\000' ->
501 let reasonlen = r8 s 1 in
502 let s = readstr sock 6 in
503 let maj = r16 s 0
504 and min = r16 s 2
505 and add = r16 s 4 in
506 let len = add*4 in
507 let data = readstr sock len in
508 let reason = String.sub data 0 reasonlen in
509 error "X connection failed maj=%d min=%d reason=%S"
510 maj min reason
512 | '\002' -> failwith "X connection setup failed: authentication required";
514 | '\001' ->
515 let s = readstr sock 38 in
516 let maj = r16 s 0
517 and min = r16 s 2
518 and add = r16 s 4
519 and idbase = r32 s 10
520 and idmask = r32 s 14
521 and vlen = r16 s 22
522 and screens = r8 s 26
523 and formats = r8 s 27
524 and minkk = r8 s 32
525 and maxkk = r8 s 33 in
526 let data = readstr sock (4*add-32) in
527 let vendor = String.sub data 0 vlen in
528 let pos = ((vlen+3) land lnot 3) + formats*8 in
530 if screennum >= screens
531 then error "invalid screen %d, max %d" screennum (screens-1);
533 let pos =
534 let s = data in
535 let rec findscreen n pos = if n = screennum then pos else
536 let pos =
537 let ndepths = r8 s (pos+39) in
538 let rec skipdepths n pos = if n = ndepths then pos else
539 let pos =
540 let nvisiuals = r16 s (pos+2) in
541 pos + nvisiuals*24 + 8
543 skipdepths (n+1) pos
545 skipdepths n (pos+40)
547 findscreen (n+1) pos
549 findscreen 0 pos
551 let root = r32 data pos in
552 let rootw = r16 data (pos+20)
553 and rooth = r16 data (pos+22) in
554 state.mink <- minkk;
555 state.maxk <- maxkk;
556 state.idbase <- idbase;
557 vlog "vendor = %S, maj=%d min=%d" vendor maj min;
558 vlog "screens = %d formats = %d" screens formats;
559 vlog "minkk = %d maxkk = %d" minkk maxkk;
560 vlog "idbase = %#x idmask = %#x" idbase idmask;
561 vlog "root=%#x %dx%d" root rootw rooth;
563 let mask = 0
564 + 0x00000001 (* KeyPress *)
565 (* + 0x00000002 *) (* KeyRelease *)
566 + 0x00000004 (* ButtonPress *)
567 + 0x00000008 (* ButtonRelease *)
568 + 0x00000010 (* EnterWindow *)
569 + 0x00000020 (* LeaveWindow *)
570 + 0x00000040 (* PointerMotion *)
571 (* + 0x00000080 *) (* PointerMotionHint *)
572 (* + 0x00000100 *) (* Button1Motion *)
573 (* + 0x00000200 *) (* Button2Motion *)
574 (* + 0x00000400 *) (* Button3Motion *)
575 (* + 0x00000800 *) (* Button4Motion *)
576 (* + 0x00001000 *) (* Button5Motion *)
577 + 0x00002000 (* ButtonMotion *)
578 (* + 0x00004000 *) (* KeymapState *)
579 + 0x00008000 (* Exposure *)
580 + 0x00010000 (* VisibilityChange *)
581 + 0x00020000 (* StructureNotify *)
582 (* + 0x00040000 *) (* ResizeRedirect *)
583 (* + 0x00080000 *) (* SubstructureNotify *)
584 (* + 0x00100000 *) (* SubstructureRedirect *)
585 (* + 0x00200000 *) (* FocusChange *)
586 (* + 0x00400000 *) (* PropertyChange *)
587 (* + 0x00800000 *) (* ColormapChange *)
588 (* + 0x01000000 *) (* OwnerGrabButton *)
590 let wid = state.idbase in
591 let s = createwindowreq wid root 0 0 w h 0 mask in
592 sendstr s sock;
594 let s = mapreq wid in
595 sendstr s sock;
597 let s = getkeymapreq state.mink (state.maxk-state.mink) in
598 sendwithrep sock s (updkmap sock);
600 sendintern sock "WM_PROTOCOLS" false (fun resp ->
601 state.protoatom <- r32 resp 8;
602 sendintern sock "WM_DELETE_WINDOW" false (fun resp ->
603 state.deleatom <- r32 resp 8;
604 let s = s32 state.deleatom in
605 let s = changepropreq wid state.protoatom 4 32 s in
606 sendstr s sock;
610 sendintern sock "WM_CLASS" false (fun resp ->
611 let atom = r32 resp 8 in
612 let llpp = "llpp\000llpp\000" in
613 let s = changepropreq wid atom 31 8 llpp in
614 sendstr s sock;
617 let s = openfontreq (wid+1) "cursor" in
618 sendstr s sock;
620 Array.iteri (fun i glyphindex ->
621 let s = createglyphcursorreq (wid+1) (wid+2+i) glyphindex in
622 sendstr s sock;
623 ) [|34;48;50;58;128;152|];
625 sendintern sock "UTF8_STRING" true (fun resp ->
626 let atom = r32 resp 8 in
627 if atom != 0
628 then state.stringatom <- atom;
631 let setwmname s =
632 let s = changepropreq state.idbase 39 state.stringatom 8 s in
633 sendstr s state.sock;
635 state.setwmname <- setwmname;
636 sendintern sock "_NET_WM_NAME" true (fun resp ->
637 let atom = r32 resp 8 in
638 if atom != 0
639 then state.setwmname <- (fun s ->
640 setwmname s;
641 let s = changepropreq state.idbase atom state.stringatom 8 s in
642 sendstr s state.sock;
646 state.fullscreen <- (fun wid ->
647 let s = "xxuuyyuuwwuuhhuu" in
648 match state.fs with
649 | NoFs ->
650 w32 s 0 0;
651 w32 s 4 0;
652 w32 s 8 rootw;
653 w32 s 12 rooth;
654 let s = configurewindowreq wid 0x000f s in
655 sendstr s state.sock;
656 state.fs <- Fs (state.x, state.y, state.w, state.h);
658 | Fs (x, y, w, h) ->
659 w32 s 0 x;
660 w32 s 4 y;
661 w32 s 8 w;
662 w32 s 12 h;
663 let s = configurewindowreq wid 0x000f s in
664 sendstr s state.sock;
665 state.fs <- NoFs;
668 sendintern sock "_NET_WM_STATE" true (fun resp ->
669 let nwmsatom = r32 resp 8 in
670 if nwmsatom != 0
671 then
672 sendintern sock "_NET_WM_STATE_FULLSCREEN" true (fun resp ->
673 let fsatom = r32 resp 8 in
674 if fsatom != 0
675 then
676 state.fullscreen <-
677 (fun wid ->
678 let data = String.make 20 '\000' in
679 let fs, f =
680 match state.fs with
681 | NoFs -> Fs (-1, -1, -1, -1), 1
682 | Fs _ -> NoFs, 0
684 w32 data 0 f;
685 w32 data 4 fsatom;
687 let cm = clientmessage 32 0 wid nwmsatom data in
688 let s = sendeventreq 0 root 0x180000 cm in
689 sendstr s sock;
690 state.fs <- fs;
694 let s = getgeometryreq wid in
695 let completed = ref false in
696 sendwithrep sock s (fun resp ->
697 glx wid;
698 let w = r16 resp 16
699 and h = r16 resp 18 in
700 state.w <- w;
701 state.h <- h;
702 completed := true;
704 let now = Unix.gettimeofday in
705 let deadline = now () +. 2.0 in
706 let rec readtillcompletion () =
707 let r, _, _ = Unix.select [sock] [] [] (deadline -. now ()) in
708 match r with
709 | [] -> readtillcompletion ()
710 | _ ->
711 readresp sock;
712 if not !completed
713 then readtillcompletion ()
715 readtillcompletion ();
717 | c ->
718 error "unknown conection setup response %d" (Char.code c)
721 let getauth haddr dnum =
722 let haddr =
723 if haddr = "localhost" || String.length haddr = 0
724 then
725 try Unix.gethostname ()
726 with exn ->
727 dolog "failed to resolve `%S': %s" haddr (exntos exn);
728 haddr
729 else haddr
731 let readauth ic =
732 let input_string ic len =
733 let s = String.create len in
734 really_input ic s 0 len;
737 let r16 s =
738 let rb pos = Char.code (String.get s pos) in
739 (rb 1) lor ((rb 0) lsl 8)
741 let rec find () =
742 let rs () =
743 let s = input_string ic 2 in
744 let n = r16 s in
745 input_string ic n
747 let family = input_string ic 2 in
748 let addr = rs () in
749 let nums = rs () in
750 let num = int_of_string nums in
751 let name = rs () in
752 let data = rs () in
754 vlog "family %S addr %S(%S) num %d(%d) name %S data %S"
755 family addr haddr num dnum name data;
756 if addr = haddr && num = dnum
757 then name, data
758 else find ()
760 let name, data =
761 try find () with _ -> "", ""
763 close_in ic;
764 name, data;
766 let path =
767 try Sys.getenv "XAUTHORITY"
768 with Not_found ->
769 try Filename.concat (Sys.getenv "HOME") ".Xauthority"
770 with Not_found -> ""
772 let opt =
774 if String.length path = 0
775 then None
776 else Some (open_in_bin path)
777 with exn ->
778 if Sys.file_exists path
779 then
780 dolog "failed to open X authority file `%S' : %s"
781 path (exntos exn);
782 None
784 match opt with
785 | None -> "", ""
786 | Some ic -> readauth ic
789 let init t w h osx =
790 let d =
791 try Sys.getenv "DISPLAY"
792 with exn ->
793 error "could not get DISPLAY evironment variable: %s"
794 (exntos exn)
796 let getnum w b e =
797 if b = e
798 then error "invalid DISPLAY(%s) %S" w d
799 else
800 let s = String.sub d b (e - b) in
801 try int_of_string s
802 with exn ->
803 error "invalid DISPLAY %S can not parse %s(%S): %s"
804 d w s (exntos exn)
806 let rec phost pos =
807 if pos = String.length d
808 then error "invalid DISPLAY %S no display number specified" d
809 else (
810 if d.[pos] = ':'
811 then
812 let rec pdispnum pos1 =
813 if pos1 = String.length d
814 then getnum "display number" (pos+1) pos1, 0
815 else
816 match d.[pos1] with
817 | '.' ->
818 let dispnum = getnum "display number" (pos+1) pos1 in
819 let rec pscreennum pos2 =
820 if pos2 = String.length d
821 then getnum "screen number" (pos1+1) pos2
822 else
823 match d.[pos2] with
824 | '0' .. '9' -> pscreennum (pos2+1)
825 | _ ->
826 error "invalid DISPLAY %S, cannot parse screen number" d
828 dispnum, pscreennum (pos1+1)
829 | '0' .. '9' -> pdispnum (pos1+1)
830 | _ ->
831 error "invalid DISPLAY %S, cannot parse display number" d
833 String.sub d 0 pos, pdispnum (pos+1)
834 else phost (pos+1)
837 let host, (dispnum, screennum) = phost 0 in
838 let aname, adata = getauth host dispnum in
839 let fd =
840 let fd, addr =
841 if osx || String.length host = 0 || host = "unix"
842 then
843 let addr =
844 if osx
845 then Unix.ADDR_UNIX d
846 else Unix.ADDR_UNIX ("/tmp/.X11-unix/X" ^ string_of_int dispnum)
848 let fd = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
849 fd, addr
850 else
851 let h =
852 try Unix.gethostbyname host
853 with exn ->
854 error "cannot resolve %S: %s" host (exntos exn)
856 let addr = h.Unix.h_addr_list.(0) in
857 let port = 6000 + dispnum in
858 let fd = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
859 fd, (Unix.ADDR_INET (addr, port))
861 try Unix.connect fd addr; fd
862 with exn ->
863 error "failed to connect to X: %s" (exntos exn)
865 cloexec fd;
866 let s = "luMMmmnndduu" in
867 let s = padcat s aname in
868 let s = padcat s adata in
869 w16 s 2 11;
870 w16 s 4 0;
871 w16 s 6 (String.length aname);
872 w16 s 8 (String.length adata);
873 sendstr1 s 0 (String.length s) fd;
874 state.sock <- fd;
875 setup fd screennum w h;
876 state.t <- t;
877 fd, state.w, state.h;
880 let settitle s =
881 state.setwmname s;
884 let setcursor cursor =
885 if cursor != state.curcurs
886 then
887 let n =
888 match cursor with
889 | CURSOR_INHERIT -> -1
890 | CURSOR_INFO -> 3
891 | CURSOR_CYCLE -> 2
892 | CURSOR_CROSSHAIR -> 0
893 | CURSOR_TEXT -> 5
895 let s = s32 (if n = -1 then 0 else state.idbase+2+n) in
896 let s = changewindowattributesreq state.idbase (*cursor*)0x4000 s in
897 sendstr s state.sock;
898 state.curcurs <- cursor;
901 let fullscreen () =
902 state.fullscreen state.idbase;
905 let metamask = 0x40;;
906 let altmask = 8;;
907 let shiftmask = 1;;
908 let ctrlmask = 4;;
910 let withalt mask = mask land altmask != 0;;
911 let withctrl mask = mask land ctrlmask != 0;;
912 let withshift mask = mask land shiftmask != 0;;
913 let withmeta mask = mask land metamask != 0;;
914 let withnone mask = mask land (altmask + ctrlmask + shiftmask + metamask) = 0;;
916 let xlatt, xlatf =
917 let t = Hashtbl.create 20
918 and f = Hashtbl.create 20 in
919 let add n nl k =
920 List.iter (fun s -> Hashtbl.add t s k) (n::nl);
921 Hashtbl.add f k n
923 let addc c =
924 let s = String.create 1 in
925 s.[0] <- c;
926 add s [] (Char.code c)
928 let addcr a b =
929 let an = Char.code a and bn = Char.code b in
930 for i = an to bn do addc (Char.chr i) done;
932 addcr '0' '9';
933 addcr 'a' 'z';
934 addcr 'A' 'Z';
935 String.iter addc "`~!@#$%^&*()-_=+\\|[{]};:,./<>?";
936 for i = 0 to 29 do add ("f" ^ string_of_int (i+1)) [] (0xffbe + i) done;
937 add "space" [] 0x20;
938 add "ret" ["return"; "enter"] 0xff0d;
939 add "tab" [] 0xff09;
940 add "left" [] 0xff51;
941 add "right" [] 0xff53;
942 add "home" [] 0xff50;
943 add "end" [] 0xff57;
944 add "ins" ["insert"] 0xff63;
945 add "del" ["delete"] 0xffff;
946 add "esc" ["escape"] 0xff1b;
947 add "pgup" ["pageup"] 0xff55;
948 add "pgdown" ["pagedown"] 0xff56;
949 add "backspace" [] 0xff08;
950 add "up" [] 0xff52;
951 add "down" [] 0xff54;
952 t, f;
955 let keyname k =
956 try Hashtbl.find xlatf k
957 with Not_found -> Printf.sprintf "%#x" k;
960 let namekey name =
961 try Hashtbl.find xlatt name
962 with Not_found ->
963 if String.length name = 1
964 then Char.code name.[0]
965 else int_of_string name;