wsi.ml

   1 type cursor =
   2     | CURSOR_INHERIT
   3     | CURSOR_INFO
   4     | CURSOR_CYCLE
   5     | CURSOR_CROSSHAIR
   6     | CURSOR_TEXT
   7 ;;
   8
   9 external cloexec : Unix.file_descr -> unit = "ml_cloexec";;
  10 external glx : int -> unit = "ml_glx";;
  11 external swapb : unit -> unit = "ml_swapb";;
  12 external hasdata : Unix.file_descr -> bool = "ml_hasdata";;
  13 external toutf8 : int -> string = "ml_keysymtoutf8";;
  14
  15 let dolog fmt = Format.kprintf prerr_endline fmt;;
  16 let vlog fmt = Format.kprintf ignore fmt;;
  17
  18 exception Quit;;
  19
  20 let onot = object
  21     method display = ()
  22     method reshape _ _ = ()
  23     method mouse _ _ _ _ _ = ()
  24     method motion _ _ = ()
  25     method pmotion _ _ = ()
  26     method key _ _ = ()
  27     method enter _ _ = ()
  28     method leave = ()
  29 end;;
  30
  31 class type t = object
  32   method display : unit
  33   method reshape : int -> int -> unit
  34   method mouse : int -> bool -> int -> int -> int -> unit
  35   method motion : int -> int -> unit
  36   method pmotion : int -> int -> unit
  37   method key : int -> int -> unit
  38   method enter : int -> int -> unit
  39   method leave : unit
  40 end;;
  41
  42 type state =
  43     { mutable mink : int
  44     ; mutable maxk : int
  45     ; mutable keymap : int array array
  46     ; fifo : (string -> unit) Queue.t
  47     ; mutable seq : int
  48     ; mutable protoatom : int
  49     ; mutable deleatom : int
  50     ; mutable idbase : int
  51     ; mutable fullscreen : (int -> unit)
  52     ; mutable stringatom : int
  53     ; mutable t : t
  54     ; mutable sock : Unix.file_descr
  55     ; mutable w : int
  56     ; mutable h : int
  57     ; mutable fs : bool
  58     ; mutable parent : int
  59     }
  60 ;;
  61
  62 let state =
  63   { mink = max_int
  64   ; maxk = min_int
  65   ; keymap = [||]
  66   ; fifo = Queue.create ()
  67   ; seq = 0
  68   ; protoatom = -1
  69   ; deleatom = -1
  70   ; idbase = -1
  71   ; fullscreen = (fun _ -> ())
  72   ; sock = Unix.stdin
  73   ; t = onot
  74   ; w = -1
  75   ; h = -1
  76   ; fs = false
  77   ; stringatom = 31
  78   ; parent = -1
  79   }
  80 ;;
  81
  82 let w8 s pos i = String.set s pos (Char.chr (i land 0xff));;
  83
  84 let w16 s pos i =
  85   w8 s pos i;
  86   w8 s (pos+1) (i lsr 8);
  87 ;;
  88
  89 let w32 s pos i =
  90   w16 s pos i;
  91   w16 s (pos+2) (i lsr 16);
  92 ;;
  93
  94 let r16 s pos =
  95   let rb pos1 = Char.code (String.get s (pos + pos1)) in
  96   (rb 0) lor ((rb 1) lsl 8)
  97 ;;
  98
  99 let r16s s pos =
 100   let i = r16 s pos in
 101   i - ((i land 0x8000) lsl 1);
 102 ;;
 103
 104 let r8 s pos = Char.code (String.get s pos);;
 105
 106 let r32 s pos =
 107   let rb pos1 = Char.code (String.get s (pos + pos1)) in
 108   let l = (rb 0) lor ((rb 1) lsl 8)
 109   and u = (rb 2) lor ((rb 3) lsl 8) in
 110   (u lsl 16) lor l
 111 ;;
 112
 113 let error fmt = Printf.kprintf failwith fmt;;
 114
 115 let readstr sock n =
 116   let s = String.create n in
 117   let rec loop pos n =
 118     let m = Unix.read sock s pos n in
 119     if n != m
 120     then (
 121       ignore (Unix.select [sock] [] [] 0.01);
 122       loop (pos + m) (n - m)
 123     )
 124   in
 125   loop 0 n;
 126   s;
 127 ;;
 128
 129 let sendstr1 s pos len sock =
 130   vlog "%d => %S" state.seq s;
 131   state.seq <- state.seq + 1;
 132   let n = Unix.send sock s pos len [] in
 133   if n != len
 134   then error "send %d returned %d" len n;
 135 ;;
 136
 137 let updkmap sock resp =
 138   let syms = r8 resp 1 in
 139   let len = r32 resp 4 in
 140   let data =
 141     if len > 0
 142     then readstr sock (4*len)
 143     else ""
 144   in
 145   let m = len / syms in
 146   state.keymap <- Array.make_matrix
 147     (state.maxk - state.mink) syms 0xffffff;
 148   let rec loop i = if i = m then () else
 149       let k = i*4*syms in
 150       let rec loop2 k l = if l = syms then () else
 151           let v = r32 data k in
 152           state.keymap.(i).(l) <- v;
 153           loop2 (k+4) (l+1)
 154       in
 155       loop2 k 0;
 156       loop (i+1);
 157   in
 158   loop 0;
 159 ;;
 160
 161 let sendwithrep sock s f =
 162   Queue.push f state.fifo;
 163   sendstr1 s 0 (String.length s) sock;
 164 ;;
 165
 166 let padcatl ss =
 167   let b = Buffer.create 16 in
 168   List.iter (Buffer.add_string b) ss;
 169   let bl = Buffer.length b in
 170   let pl = bl land 3 in
 171   if pl != 0
 172   then (
 173     let pad = "123" in
 174     Buffer.add_substring b pad 0 (4 - pl);
 175   );
 176   Buffer.contents b;
 177 ;;
 178
 179 let padcat s1 s2 = padcatl [s1; s2];;
 180
 181 let internreq name onlyifexists =
 182   let s = "\016\000\000\000\000\000\000\000" in
 183   let s = padcat s name in
 184   w8 s 1 (if onlyifexists then 1 else 0);
 185   w16 s 2 (String.length s / 4);
 186   w16 s 4 (String.length name);
 187   s;
 188 ;;
 189
 190 let sendintern sock s onlyifexists f =
 191   let s = internreq s onlyifexists in
 192   sendwithrep sock s f;
 193 ;;
 194
 195 let createwindowreq wid parent x y w h bw mask =
 196   let s = "\001\000\009\000wwwwppppxxyywwhhbwccvvvvmmmmeeee" in
 197   w32 s 4 wid;
 198   w32 s 8 parent;
 199   w16 s 12 x;
 200   w16 s 14 y;
 201   w16 s 16 w;
 202   w16 s 18 h;
 203   w16 s 20 bw;
 204   w16 s 22 1;
 205   w32 s 24 0;
 206   w32 s 28 0x800;                       (* eventmask *)
 207   w32 s 32 mask;
 208   s;
 209 ;;
 210
 211 let mapreq wid =
 212   let s = "\008u\002\000wwww" in
 213   w32 s 4 wid;
 214   s;
 215 ;;
 216
 217 let getkeymapreq first count =
 218   let s = "\101u\002\000fcuu" in
 219   w8 s 4 first;
 220   w8 s 5 count;
 221   s;
 222 ;;
 223
 224 let changepropreq wid prop typ format props =
 225   let s = "\018\000llwwwwppppttttfuuuLLLL" in
 226   let s = padcat s props in
 227   w16 s 2 (String.length s / 4);
 228   w32 s 4 wid;
 229   w32 s 8 prop;
 230   w32 s 12 typ;
 231   w8 s 16 format;
 232   let ful = String.length props / (match format with
 233     | 8 -> 1
 234     | 16 -> 2
 235     | 32 -> 4
 236     | n -> error "no idea what %d means" n)
 237   in
 238   w32 s 20 ful;
 239   s;
 240 ;;
 241
 242 let openfontreq fid name =
 243   let s = "\045ullffffnnuu" in
 244   let s = padcat s name in
 245   w16 s 2 (String.length s / 4);
 246   w32 s 4 fid;
 247   w16 s 8 (String.length name);
 248   s;
 249 ;;
 250
 251 let createglyphcursorreq fid cid cindex =
 252   let s = "\094u\008\000ccccffffffffssmmrrggbbRRGGBB" in
 253   w32 s 4 cid;
 254   w32 s 8 fid;
 255   w32 s 12 fid;
 256   w16 s 16 cindex;
 257   w16 s 18 (cindex+1);
 258   w16 s 20 0;
 259   w16 s 22 0;
 260   w16 s 24 0;
 261   w16 s 26 0xffff;
 262   w16 s 28 0xffff;
 263   w16 s 30 0xffff;
 264   s;
 265 ;;
 266
 267 let mapwindowreq wid =
 268   let s = "\008u\002\000wwww" in
 269   w32 s 4 wid;
 270   s;
 271 ;;
 272
 273 let changewindowattributesreq wid mask attrs =
 274   let s = "\002ullwwwwmmmm" in
 275   let s = padcat s attrs in
 276   w16 s 2 (String.length s / 4);
 277   w32 s 4 wid;
 278   w32 s 8 mask;
 279   s;
 280 ;;
 281
 282 let configurewindowreq wid mask values =
 283   let s = "\012ullwwwwmmuu" in
 284   let s = padcat s values in
 285   w16 s 2 (String.length s / 4);
 286   w32 s 4 wid;
 287   w16 s 8 mask;
 288   s;
 289 ;;
 290
 291 let s32 n =
 292   let s = "1234" in
 293   w32 s 0 n;
 294   s;
 295 ;;
 296
 297 let clientmessage format seq wid typ data =
 298   let s = "\033fsswwwwtttt" in
 299   let s = padcat s data in
 300   w8 s 1 format;
 301   w16 s 2 seq;
 302   w32 s 4 wid;
 303   w32 s 8 typ;
 304   s;
 305 ;;
 306
 307 let sendeventreq propagate destwid mask data =
 308   let s = "\025p\011\000wwwwmmmm" in
 309   let s = padcat s data in
 310   w8 s 1 propagate;
 311   w32 s 4 destwid;
 312   w32 s 8 mask;
 313   s;
 314 ;;
 315
 316 let getkeysym code mask =
 317   let index = (mask land 1) lxor ((mask land 2) lsr 1) in
 318   let keysym = state.keymap.(code-state.mink).(index) in
 319   if index = 1 && keysym = 0
 320   then state.keymap.(code-state.mink).(0)
 321   else keysym
 322 ;;
 323
 324 let readresp sock =
 325   let resp = readstr sock 32 in
 326   let opcode = r8 resp 0 in
 327   match opcode land lnot 0x80 with
 328   | 0 ->                                (* error *)
 329       let s = resp in
 330       let code = r8 s 1
 331       and serial = r16 s 2
 332       and resid = r32 resp 4
 333       and min = r16 s 8
 334       and maj = r8 s 10 in
 335       error "code=%d serial=%d resid=%#x min=%d maj=%d\n%S"
 336         code serial resid min maj resp;
 337
 338   | 1 ->                                (* response *)
 339       let rep = Queue.pop state.fifo in
 340       rep resp;
 341
 342   | 2 ->                                (* key press *)
 343       if Array.length state.keymap > 0
 344       then
 345         let code = r8 resp  1 in
 346         let mask = r16 resp 28 in
 347         let keysym = getkeysym code mask in
 348         vlog "keysym = %x %c" keysym (Char.unsafe_chr keysym);
 349         state.t#key keysym mask;
 350
 351   | 3 ->                                (* key release *)
 352       if Array.length state.keymap > 0
 353       then
 354         let code = r8 resp 1 in
 355         let mask = r16 resp 28 in
 356         let keysym = getkeysym code mask in
 357         vlog "release keysym = %x %c mask %#x"
 358           keysym (Char.unsafe_chr keysym) mask
 359
 360   | 4 ->                                (* buttonpress *)
 361       let n = r8 resp 1
 362       and x = r16s resp 24
 363       and y = r16s resp 26
 364       and m = r16 resp 28 in
 365       state.t#mouse n true x y m;
 366       vlog "press %d" n
 367
 368   | 5 ->                                (* buttonrelease *)
 369       let n = r8 resp 1
 370       and x = r16s resp 24
 371       and y = r16s resp 26
 372       and m = r16 resp 28 in
 373       state.t#mouse n false x y m;
 374       vlog "release %d %d %d" n x y
 375
 376   | 6 ->                                (* motion *)
 377       let x = r16s resp 24 in
 378       let y = r16s resp 26 in
 379       let m = r16 resp 28 in
 380       if m land 0x1f00 = 0
 381       then state.t#pmotion x y
 382       else state.t#motion x y;
 383       vlog "move %dx%d => %d" x y m
 384
 385   | 7 ->                                (* enter *)
 386       let x = r16s resp 24
 387       and y = r16s resp 26 in
 388       state.t#enter x y;
 389       vlog "enter %d %d" x y
 390
 391   | 8 ->                                (* leave *)
 392       state.t#leave
 393
 394   | 18 -> vlog "unmap";
 395
 396   | 19 ->                               (* map *)
 397       if state.parent = -1 && state.w > 0 && state.h > 0
 398       then state.t#reshape state.w state.h;
 399       state.t#display;
 400       vlog "map";
 401
 402   | 12 ->                               (* exposure *)
 403       vlog "exposure";
 404       state.t#display
 405
 406   | 15 ->                               (* visibility *)
 407       let vis = r8 resp 8 in
 408       if vis != 2 then state.t#display;
 409       vlog "visibility %d" vis;
 410
 411   | 34 ->                               (* mapping *)
 412       state.keymap <- [||];
 413       let s = getkeymapreq state.mink (state.maxk-state.mink-1) in
 414       sendwithrep sock s (updkmap sock);
 415
 416   | 33 ->                               (* clientmessage *)
 417       let atom = r32 resp 8 in
 418       if atom = state.protoatom
 419       then (
 420         let atom = r32 resp 12 in
 421         if atom = state.deleatom
 422         then raise Quit;
 423       );
 424       vlog "atom %#x" atom
 425
 426   | 21 ->                               (* reparent *)
 427       state.parent <- r32 resp 24;
 428       state.w <- -1;
 429       state.h <- -1;
 430       vlog "reparent"
 431
 432   | 22 ->                               (* configure *)
 433       vlog "configure";
 434       let w = r16 resp 20
 435       and h = r16 resp 22 in
 436       if w != state.w || h != state.h
 437       then (
 438         state.w <- w;
 439         state.h <- h;
 440         state.t#reshape w h;
 441       );
 442
 443   | n ->
 444       dolog "event %d %S" n resp
 445 ;;
 446
 447 let readresp sock =
 448   let rec loop () =
 449     readresp sock;
 450     if hasdata sock then loop ();
 451   in
 452   loop ();
 453 ;;
 454
 455 let sendstr s ?(pos=0) ?(len=String.length s) sock =
 456   sendstr1 s pos len sock;
 457   if hasdata sock then readresp sock;
 458 ;;
 459
 460 let hexstr s =
 461   let b = Buffer.create 16 in
 462   String.iter (fun c ->
 463     Buffer.add_string b (Printf.sprintf "%02x" (Char.code c))) s;
 464   Buffer.contents b;
 465 ;;
 466
 467 let reshape w h =
 468   if state.fs
 469   then
 470     state.fullscreen state.idbase
 471   ;
 472   let s = "wwuuhhuu" in
 473   w32 s 0 w;
 474   w32 s 4 h;
 475   let s = configurewindowreq state.idbase 0x000c s in
 476   vlog "reshape %d %s %d" state.seq (hexstr s) (String.length s);
 477   sendstr s state.sock;
 478 ;;
 479
 480 let setup sock screennum w h =
 481   let s = readstr sock 2 in
 482   let n = String.length s in
 483   if n != 2
 484   then error "failed to read X connection setup response n=%d" n;
 485   match s.[0] with
 486   | '\000' ->
 487       let reasonlen = r8 s 1 in
 488       let s = readstr sock 6 in
 489       let maj = r16 s 0
 490       and min = r16 s 2
 491       and add = r16 s 4 in
 492       let len = add*4 in
 493       let data = readstr sock len in
 494       let reason = String.sub data 0 reasonlen in
 495       error "X connection failed maj=%d min=%d reason=%S"
 496         maj min reason
 497
 498   | '\002' -> failwith "X connection setup failed: authentication required";
 499
 500   | '\001' ->
 501       let s       = readstr sock 38 in
 502       let maj     = r16 s 0
 503       and min     = r16 s 2
 504       and add     = r16 s 4
 505       and idbase  = r32 s 10
 506       and idmask  = r32 s 14
 507       and vlen    = r16 s 22
 508       and screens = r8 s 26
 509       and formats = r8 s 27
 510       and minkk   = r8 s 32
 511       and maxkk   = r8 s 33 in
 512       let data = readstr sock (4*add-32) in
 513       let vendor = String.sub data 0 vlen in
 514       let pos = ((vlen+3) land lnot 3) + formats*8 in
 515
 516       if screennum >= screens
 517       then error "invalid screen %d, max %d" screennum (screens-1);
 518
 519       let pos =
 520         let s = data in
 521         let rec findscreen n pos = if n = screennum then pos else
 522             let pos =
 523               let ndepths = r8 s (pos+39) in
 524               let rec skipdepths n pos = if n = ndepths then pos else
 525                   let pos =
 526                     let nvisiuals = r16 s (pos+2) in
 527                     pos + nvisiuals*24 + 8
 528                   in
 529                   skipdepths (n+1) pos
 530               in
 531               skipdepths n (pos+40)
 532             in
 533             findscreen (n+1) pos
 534         in
 535         findscreen 0 pos
 536       in
 537       let root = r32 data pos in
 538       let rootw = r16 data (pos+20)
 539       and rooth = r16 data (pos+22) in
 540       state.mink <- minkk;
 541       state.maxk <- maxkk;
 542       state.idbase <- idbase;
 543       vlog "vendor = %S, maj=%d min=%d" vendor maj min;
 544       vlog "screens = %d formats = %d" screens formats;
 545       vlog "minkk = %d maxkk = %d" minkk maxkk;
 546       vlog "idbase = %#x idmask = %#x" idbase idmask;
 547       vlog "root=%#x %dx%d" root rootw rooth;
 548
 549       let mask = 0
 550         + 0x00000001                    (* KeyPress *)
 551         (* + 0x00000002 *)              (* KeyRelease *)
 552         + 0x00000004                    (* ButtonPress *)
 553         + 0x00000008                    (* ButtonRelease *)
 554         + 0x00000010                    (* EnterWindow *)
 555         + 0x00000020                    (* LeaveWindow *)
 556         + 0x00000040                    (* PointerMotion *)
 557         (* + 0x00000080 *)              (* PointerMotionHint *)
 558         (* + 0x00000100 *)              (* Button1Motion *)
 559         (* + 0x00000200 *)              (* Button2Motion *)
 560         (* + 0x00000400 *)              (* Button3Motion *)
 561         (* + 0x00000800 *)              (* Button4Motion *)
 562         (* + 0x00001000 *)              (* Button5Motion *)
 563         + 0x00002000                    (* ButtonMotion *)
 564         (* + 0x00004000 *)              (* KeymapState *)
 565         + 0x00008000                    (* Exposure *)
 566         + 0x00010000                    (* VisibilityChange *)
 567         + 0x00020000                    (* StructureNotify *)
 568         (* + 0x00040000 *)              (* ResizeRedirect *)
 569         (* + 0x00080000 *)              (* SubstructureNotify *)
 570         (* + 0x00100000 *)              (* SubstructureRedirect *)
 571         (* + 0x00200000 *)              (* FocusChange *)
 572         (* + 0x00400000 *)              (* PropertyChange *)
 573         (* + 0x00800000 *)              (* ColormapChange *)
 574         (* + 0x01000000 *)              (* OwnerGrabButton *)
 575       in
 576       let wid = state.idbase in
 577       state.w <- w;
 578       state.h <- h;
 579       let s = createwindowreq wid root 0 0 w h 0 mask in
 580       sendstr s sock;
 581
 582       let s = mapreq wid in
 583       sendstr s sock;
 584
 585       let s = getkeymapreq state.mink (state.maxk-state.mink) in
 586       sendwithrep sock s (updkmap sock);
 587
 588       sendintern sock "WM_PROTOCOLS" false (fun resp ->
 589         state.protoatom <- r32 resp 8;
 590         sendintern sock "WM_DELETE_WINDOW" false (fun resp ->
 591           state.deleatom <- r32 resp 8;
 592           let s = s32 state.deleatom in
 593           let s = changepropreq wid state.protoatom 4 32 s in
 594           sendstr s sock;
 595         );
 596       );
 597
 598       sendintern sock "WM_CLASS" false (fun resp ->
 599         let atom = r32 resp 8 in
 600         let llpp = "llpp\000llpp\000" in
 601         let s = changepropreq wid atom 31 8 llpp in
 602         sendstr s sock;
 603       );
 604
 605       let s = openfontreq (wid+1) "cursor" in
 606       sendstr s sock;
 607
 608       Array.iteri (fun i glyphindex ->
 609         let s = createglyphcursorreq (wid+1) (wid+2+i) glyphindex in
 610         sendstr s sock;
 611       ) [|34;48;50;58;128;152|];
 612
 613       sendintern sock "UTF8_STRING" false (fun resp ->
 614         state.stringatom <- r32 resp 8;
 615       );
 616
 617       sendintern sock "_NET_WM_STATE" true (fun resp ->
 618         let nwmsatom = r32 resp 8 in
 619         sendintern sock "_NET_WM_STATE_FULLSCREEN" true (fun resp ->
 620           let fsatom = r32 resp 8 in
 621
 622           state.fullscreen <-
 623             (fun wid ->
 624               let data = String.make 20 '\000' in
 625               state.fs <- not state.fs;
 626               w32 data 0 (if state.fs then 1 else 0);
 627               w32 data 4 fsatom;
 628
 629               let cm = clientmessage 32 0 wid nwmsatom data in
 630               let s = sendeventreq 0 root 0x180000 cm in
 631               sendstr s sock;
 632               ()
 633           );
 634         );
 635       );
 636       glx wid
 637
 638   | c ->
 639       error "unknown conection setup response %d" (Char.code c)
 640 ;;
 641
 642 let getauth haddr dnum =
 643   let haddr =
 644     if haddr = "localhost"
 645     then
 646       try Unix.gethostname ()
 647       with exn ->
 648         dolog "failed to resolve `%S': %s" haddr (Printexc.to_string exn);
 649         haddr
 650     else haddr
 651   in
 652   let readauth ic =
 653     let input_string ic len =
 654       let s = String.create len in
 655       really_input ic s 0 len;
 656       s;
 657     in
 658     let r16 s =
 659       let rb pos = Char.code (String.get s pos) in
 660       (rb 1) lor ((rb 0) lsl 8)
 661     in
 662     let rec find () =
 663       let rs () =
 664         let s = input_string ic 2 in
 665         let n = r16 s in
 666         input_string ic n
 667       in
 668       let family = input_string ic 2 in
 669       let addr = rs () in
 670       let nums = rs () in
 671       let num = int_of_string nums in
 672       let name = rs () in
 673       let data = rs () in
 674
 675       vlog "family %S addr %S(%S) num %d(%d) name %S data %S"
 676         family addr haddr num dnum name data;
 677       if addr = haddr && num = dnum
 678       then name, data
 679       else find ()
 680     in
 681     let name, data =
 682       try find () with _ -> "", ""
 683     in
 684     close_in ic;
 685     name, data;
 686   in
 687   let path =
 688     try Sys.getenv "XAUTHORITY"
 689     with Not_found -> Filename.concat (Sys.getenv "HOME") ".Xauthority"
 690   in
 691   let opt =
 692     try Some (open_in_bin path)
 693     with exn ->
 694       dolog "failed to open X authority file `%S' : %s"
 695         path
 696         (Printexc.to_string exn);
 697       None
 698   in
 699   match opt with
 700   | None -> "", ""
 701   | Some ic -> readauth ic
 702 ;;
 703
 704 let init t w h =
 705   let d =
 706     try Sys.getenv "DISPLAY"
 707     with exn ->
 708       error "Could not get DISPLAY evironment variable: %s"
 709         (Printexc.to_string exn)
 710   in
 711   let colonpos = String.index d ':' in
 712   let host = String.sub d 0 colonpos in
 713   let dispnum, screennum =
 714     try
 715       let dotpos = String.index_from d (colonpos + 1) '.' in
 716       let disp = String.sub d (colonpos + 1) (dotpos - colonpos - 1) in
 717       let screen = String.sub d (dotpos + 1) (String.length d - dotpos - 1) in
 718       int_of_string disp, int_of_string screen
 719     with Not_found ->
 720       let disp = String.sub d (colonpos + 1) (String.length d - colonpos - 1) in
 721       int_of_string disp, 0
 722   in
 723   let aname, adata = getauth host dispnum in
 724   let fd =
 725     if String.length host = 0 || host = "unix"
 726     then
 727       let addr = Unix.ADDR_UNIX ("/tmp/.X11-unix/X" ^ string_of_int dispnum) in
 728       let fd = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
 729       Unix.connect fd addr;
 730       fd
 731     else
 732       let h = Unix.gethostbyname host in
 733       let addr = h.Unix.h_addr_list.(0) in
 734       let port = 6000 + dispnum in
 735       let fd = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
 736       Unix.connect fd (Unix.ADDR_INET (addr, port));
 737       fd
 738   in
 739   cloexec fd;
 740   let s = "luMMmmnndduu" in
 741   let s = padcat s aname in
 742   let s = padcat s adata in
 743   w16 s 2 11;
 744   w16 s 4 0;
 745   w16 s 6 (String.length aname);
 746   w16 s 8 (String.length adata);
 747   sendstr1 s 0 (String.length s) fd;
 748   state.sock <- fd;
 749   setup fd screennum w h;
 750   state.t <- t;
 751   fd;
 752 ;;
 753
 754 let settitle s =
 755   let s = changepropreq state.idbase 39 state.stringatom 8 s in
 756   sendstr s state.sock;
 757 ;;
 758
 759 let setcursor cursor =
 760   let n =
 761     match cursor with
 762     | CURSOR_INHERIT -> -1
 763     | CURSOR_INFO -> 3
 764     | CURSOR_CYCLE -> 2
 765     | CURSOR_CROSSHAIR -> 0
 766     | CURSOR_TEXT -> 5
 767   in
 768   let s = s32 (if n = -1 then 0 else state.idbase+2+n) in
 769   let s = changewindowattributesreq state.idbase (*cursor*)0x4000 s in
 770   sendstr s state.sock;
 771 ;;
 772
 773 let fullscreen () =
 774   state.fullscreen state.idbase;
 775 ;;
 776
 777 let metamask = 0x40;;
 778 let altmask = 8;;
 779 let shiftmask = 1;;
 780 let ctrlmask = 4;;
 781
 782 let withalt mask = mask land altmask != 0;;
 783 let withctrl mask = mask land ctrlmask != 0;;
 784 let withshift mask = mask land shiftmask != 0;;
 785 let withmeta mask = mask land metamask != 0;;
 786 let withnone mask = mask land (altmask + ctrlmask + shiftmask + metamask) = 0;;
 787
 788 let xlatt, xlatf =
 789   let t = Hashtbl.create 20
 790   and f = Hashtbl.create 20 in
 791   let add n nl k =
 792     List.iter (fun s -> Hashtbl.add t s k) (n::nl);
 793     Hashtbl.add f k n
 794   in
 795   let addc c =
 796     let s = String.create 1 in
 797     s.[0] <- c;
 798     add s [] (Char.code c)
 799   in
 800   let addcr a b =
 801     let an = Char.code a and bn = Char.code b in
 802     for i = an to bn do addc (Char.chr i) done;
 803   in
 804   addcr '0' '9';
 805   addcr 'a' 'z';
 806   addcr 'A' 'Z';
 807   String.iter addc "`~!@#$%^&*()-_=+\\|[{]};:,./?";
 808   for i = 0 to 29 do add ("f" ^ string_of_int (i+1)) [] (0xffbe + i) done;
 809   add "space" [] 0x20;
 810   add "return" ["ret"; "enter"] 0xff0d;
 811   add "tab" [] 0xff09;
 812   add "left" [] 0xff51;
 813   add "right" [] 0xff53;
 814   add "home" [] 0xff50;
 815   add "end" [] 0xff57;
 816   add "insert" ["ins"] 0xff63;
 817   add "delete" ["del"] 0xffff;
 818   add "escape" ["esc"] 0xff1b;
 819   add "pgup" ["pageup"] 0xff55;
 820   add "pgdown" ["pagedown"] 0xff56;
 821   add "backspace" [] 0xff08;
 822   add "up" [] 0xff52;
 823   add "down" [] 0xff54;
 824   t, f;
 825 ;;
 826
 827 let keyname k =
 828   try Hashtbl.find xlatf k
 829   with Not_found -> Printf.sprintf "%#x" k;
 830 ;;
 831
 832 let namekey name =
 833   try Hashtbl.find xlatt name
 834   with Not_found ->
 835     if String.length name = 1
 836     then Char.code name.[0]
 837     else error "can not find keysym for %S" name;
 838 ;;