wsi/x11/wsi.ml

   1 open Utils
   2
   3 let (~>) = Bytes.unsafe_of_string
   4
   5 type cursor =
   6   | CURSOR_INHERIT
   7   | CURSOR_INFO
   8   | CURSOR_CYCLE
   9   | CURSOR_FLEUR
  10   | CURSOR_TEXT
  11
  12 type winstate =
  13   | MaxVert
  14   | MaxHorz
  15   | Fullscreen
  16
  17 type visiblestate =
  18   | Unobscured
  19   | PartiallyObscured
  20   | FullyObscured
  21
  22 type wid = int and screenno = int and vid = int and atom = int
  23
  24 external glxinit : string -> wid -> screenno -> vid = "ml_glxinit"
  25 external glxcompleteinit : unit -> unit = "ml_glxcompleteinit"
  26 external swapb : unit -> unit = "ml_swapb"
  27 external setcursor : cursor -> unit = "ml_setcursor"
  28
  29 module S = struct
  30   type fs =
  31     | NoFs
  32     | Fs of (int * int * int * int)
  33   and keycode = int
  34
  35   let mink       = ref max_int
  36   let maxk       = ref min_int
  37   let keymap     = ref E.a
  38   let fifo       = ref (Queue.create ())
  39   let seq        = ref 0
  40   let protoatom  = ref ~-1
  41   let deleatom   = ref ~-1
  42   let nwmsatom   = ref ~-1
  43   let maxvatom   = ref ~-1
  44   let maxhatom   = ref ~-1
  45   let fulsatom   = ref ~-1
  46   let idbase     = ref ~-1
  47   let wid        = ref ~-1
  48   let fid        = ref ~-1
  49   let fullscreen = ref (fun _ -> ())
  50   let setwmname  = ref (fun _ -> ())
  51   let actwin     = ref (fun _ -> ())
  52   let sock       = ref Unix.stdin
  53   let x          = ref ~-1
  54   let y          = ref ~-1
  55   let w          = ref ~-1
  56   let h          = ref ~-1
  57   let fs         = ref NoFs
  58   let stringatom = ref 31
  59   let curcurs    = ref CURSOR_TEXT
  60   let capslmask  = ref 0
  61   let numlmask   = ref 0
  62   let levl3mask  = ref 0
  63   let levl5mask  = ref 0
  64   let xkb        = ref false
  65   let fscale     = ref 1.0
  66   let t = ref (object
  67                 method display = ()
  68                 method map (_:bool) = ()
  69                 method expose = ()
  70                 method visible (_:visiblestate) = ()
  71                 method reshape (_:int) (_:int) = ()
  72                 method mouse (_:int) (_:bool) (_:int) (_:int) (_:int) = ()
  73                 method motion (_:int) (_:int) = ()
  74                 method pmotion (_:int) (_:int) = ()
  75                 method key (_:int) (_:int) = ()
  76                 method enter (_:int) (_:int) = ()
  77                 method leave = ()
  78                 method winstate (_:winstate list) = ()
  79                 method quit : 'a. 'a   = exit 0
  80                 method scroll (_:int) (_:int) = ()
  81                 method zoom (_:float) (_:int) (_:int) = ()
  82                 method opendoc (_:string) = ()
  83               end)
  84 end
  85
  86 let settitle s = !S.setwmname (~> s)
  87 let fullscreen () = !S.fullscreen !S.wid
  88 let fontsizescale n = float n *. !S.fscale |> truncate
  89
  90 let ordermagic = 'l'
  91 let metamask = 0x40
  92 let altmask = 8
  93 let shiftmask = 1
  94 let ctrlmask = 4
  95
  96 let withalt mask = mask land altmask != 0
  97 let withctrl mask = mask land ctrlmask != 0
  98 let withshift mask = mask land shiftmask != 0
  99 let withmeta mask = mask land metamask != 0
 100 let withnone mask = mask land (altmask + ctrlmask + shiftmask + metamask) = 0
 101
 102 let makereq opcode len reqlen =
 103   let s = Bytes.create len in
 104   w8 s 0 opcode;
 105   w16 s 2 reqlen;
 106   s
 107
 108 let readstr sock n =
 109   let s = Bytes.create n in
 110   let rec loop pos n =
 111     let m = tempfailureretry (Unix.read sock s pos) n in
 112     if m = 0
 113     then !S.t#quit;
 114     if n != m
 115     then (
 116       ignore (tempfailureretry (Unix.select [sock] [] []) 0.01);
 117       loop (pos + m) (n - m)
 118     )
 119   in
 120   loop 0 n;
 121   s
 122
 123 let sendstr1 s pos len sock =
 124   let s = Bytes.unsafe_to_string s in
 125   vlog "%d <= %S" !S.seq s;
 126   S.seq := !S.seq + 1;
 127   let n = tempfailureretry (Unix.write_substring sock s pos) len in
 128   if n != len
 129   then error "send %d returned %d" len n
 130
 131 let updkmap sock resp =
 132   let syms = r8 resp 1 in
 133   let len = r32 resp 4 in
 134   let data =
 135     if len > 0
 136     then readstr sock (4*len)
 137     else E.b
 138   in
 139   let m = len / syms in
 140   S.keymap := Array.make_matrix !S.maxk syms 0xffffff;
 141   let rec loop i =
 142     if i != m
 143     then
 144       let k = i*4*syms in
 145       let rec loop2 k l =
 146         if l != syms
 147         then
 148           let v = r32 data k in
 149           !S.keymap.(i).(l) <- v;
 150           loop2 (k+4) (l+1)
 151       in
 152       loop2 k 0;
 153       loop (i+1);
 154   in
 155   loop 0
 156
 157 let updmodmap sock resp =
 158   let n = r8 resp 1 in
 159   let len = r16 resp 4 in
 160   let data =
 161     if len > 0
 162     then readstr sock (len*4)
 163     else E.b
 164   in
 165   if len > 0
 166   then                      (*???*)
 167     let modmap = Array.make_matrix 8 n 0xffffff in
 168     let rec loop l =
 169       if l != 8
 170       then
 171         let p = l*n in
 172         let rec loop1 m =
 173           if m != n
 174           then
 175             let p = p+m in
 176             let code = r8 data p in
 177             modmap.(l).(m) <- code;
 178             if l = 1
 179             then (
 180               let ki = code - !S.mink in
 181               if ki >= 0
 182               then
 183                 let a = !S.keymap.(ki) in
 184                 let rec capsloop i =
 185                   if not (i = Array.length a || i > 3)
 186                   then
 187                     let s = a.(i) in
 188                     if s = 0xffe5
 189                     then S.capslmask := 2
 190                     else capsloop (i+1)
 191                 in
 192                 capsloop 0;
 193             )
 194             else (
 195               if l > 3
 196               then
 197                 let ki = code - !S.mink in
 198                 if ki >= 0
 199                 then
 200                   let a = !S.keymap.(ki) in
 201                   let rec lloop i =
 202                     if not (i = Array.length a || i > 3)
 203                     then
 204                       let s = a.(i) in
 205                       match s with
 206                       | 0xfe03 -> S.levl3mask := 1 lsl l
 207                       | 0xfe11 -> S.levl5mask := 1 lsl l
 208                       | 0xff7f -> S.numlmask  := 1 lsl l
 209                       | _ -> lloop (i+1)
 210                   in
 211                   lloop 0;
 212             );
 213             loop1 (m+1)
 214         in
 215         loop1 0;
 216         loop (l+1)
 217     in
 218     loop 0
 219
 220 let sendwithrep sock s f =
 221   Queue.push f !S.fifo;
 222   sendstr1 s 0 (Bytes.length s) sock
 223
 224 let padcat b1 b2 =
 225   let l1 = Bytes.length b1 and l2 = Bytes.length b2 in
 226   let l = (l1 + l2) land 3 in
 227   let pl = if l > 0 then 4 - l else 0 in
 228   let b = Bytes.create (l1 + l2 + pl) in
 229   Bytes.blit b1 0 b 0 l1;
 230   Bytes.blit b2 0 b l1 l2;
 231   b
 232
 233 let internreq name onlyifexists =
 234   let s = makereq 16 8 8 in
 235   let s = padcat s name in
 236   w8 s 1 (if onlyifexists then 1 else 0);
 237   w16 s 2 (Bytes.length s / 4);
 238   w16 s 4 (Bytes.length name);
 239   s
 240
 241 let sendintern sock s onlyifexists f =
 242   let s = internreq s onlyifexists in
 243   sendwithrep sock s f
 244
 245 let createwindowreq wid parent x y w h bw eventmask vid depth mid =
 246   let s = makereq 1 44 11 in
 247   w8 s 1 depth;
 248   w32 s 4 wid;
 249   w32 s 8 parent;
 250   w16 s 12 x;
 251   w16 s 14 y;
 252   w16 s 16 w;
 253   w16 s 18 h;
 254   w16 s 20 bw;
 255   w16 s 22 0;                           (* copyfromparent *)
 256   w32 s 24 vid;                         (* visual *)
 257   w32 s 28 0x2808;                      (* valuemask =
 258                                          | border pixel
 259                                          | event mask
 260                                          | colormap *)
 261   w32 s 32 0;                           (* border pixel*)
 262   w32 s 36 eventmask;
 263   w32 s 40 mid;
 264   s
 265
 266 let createcolormapreq mid wid vid =
 267   let s = makereq 78 16 4 in
 268   w8 s 1 0;
 269   w32 s 4 mid;
 270   w32 s 8 wid;
 271   w32 s 12 vid;
 272   s
 273
 274 let getgeometryreq wid =
 275   let s = makereq 14 8 2 in
 276   w32 s 4 wid;
 277   s
 278
 279 let mapreq wid =
 280   let s = makereq 8 8 2 in
 281   w32 s 4 wid;
 282   s
 283
 284 let getkeymapreq first count =
 285   let s = makereq 101 8 2 in
 286   w8 s 4 first;
 287   w8 s 5 count;
 288   s
 289
 290 let changepropreq wid prop typ format props =
 291   let s = makereq 18 24 0 in
 292   let s = padcat s props in
 293   w8 s 1 0;
 294   w16 s 2 (Bytes.length s / 4);
 295   w32 s 4 wid;
 296   w32 s 8 prop;
 297   w32 s 12 typ;
 298   w8 s 16 format;
 299   let ful = Bytes.length props / (match format with
 300                                   | 8 -> 1
 301                                   | 16 -> 2
 302                                   | 32 -> 4
 303                                   | n -> error "no idea what %d means" n)
 304   in
 305   w32 s 20 ful;
 306   s
 307
 308 let getpropreq delete wid prop typ =
 309   let s = makereq 20 24 6 in
 310   w8 s 1 (if delete then 1 else 0);
 311   w32 s 4 wid;
 312   w32 s 8 prop;
 313   w32 s 12 typ;
 314   w32 s 16 0;
 315   w32 s 20 2;
 316   s
 317
 318 let configurewindowreq wid mask values =
 319   let s = makereq 12 12 0 in
 320   let s = padcat s values in
 321   w16 s 2 (Bytes.length s / 4);
 322   w32 s 4 wid;
 323   w16 s 8 mask;
 324   s
 325
 326 let s32 n =
 327   let s = Bytes.create 4 in
 328   w32 s 0 n;
 329   s
 330
 331 let clientmessage format seq wid typ data =
 332   let s = makereq 33 12 0 in
 333   let s = padcat s data in
 334   w8 s 1 format;
 335   w16 s 2 seq;
 336   w32 s 4 wid;
 337   w32 s 8 typ;
 338   s
 339
 340 let sendeventreq propagate destwid mask data =
 341   let s = makereq 25 12 11 in
 342   let s = padcat s data in
 343   w8 s 1 propagate;
 344   w16 s 2 11;
 345   w32 s 4 destwid;
 346   w32 s 8 mask;
 347   s
 348
 349 let getmodifiermappingreq () =
 350   makereq 119 4 1
 351
 352 let queryextensionreq name =
 353   let s = makereq 98 8 0 in
 354   let s = padcat s name in
 355   w16 s 2 (Bytes.length s / 4);
 356   w16 s 4 (Bytes.length name);
 357   s
 358
 359 let getkeysym pkpk code mask =
 360   if (pkpk >= 0xff80 && pkpk <= 0xffbd)
 361      || (pkpk >= 0x11000000 && pkpk <= 0x1100ffff)
 362   then (
 363     if mask land !S.numlmask != 0
 364     then
 365       let keysym = !S.keymap.(code - !S.mink).(1) in
 366       if keysym = 0 then pkpk else keysym
 367     else pkpk
 368   )
 369   else (
 370     let shift =
 371       if pkpk land 0xf000 = 0xf000
 372       then 0
 373       else (mask land 1) lxor ((mask land !S.capslmask) lsr 1)
 374     in
 375     let index =
 376       if !S.xkb && mask land 0x2000 != 0
 377       then shift + 2
 378       else
 379         let l3 = (mask land !S.levl3mask) != 0 in
 380         let l4 = (mask land !S.levl5mask) != 0 in
 381         shift +
 382           if l3 then (if l4 then 8 else 4) else (if l4 then 6 else 0)
 383     in
 384     let keysym = !S.keymap.(code - !S.mink).(index) in
 385     if index land 1 = 1 && keysym = 0
 386     then !S.keymap.(code - !S.mink).(index - 1)
 387     else keysym
 388   )
 389
 390 let getkeysym code mask =
 391   let pkpk = !S.keymap.(code - !S.mink).(0) in
 392   if !S.xkb && pkpk lsr 8 = 0xfe (* XKB *)
 393   then 0
 394   else getkeysym pkpk code mask
 395
 396 let readresp sock =
 397   let resp = readstr sock 32 in
 398   let opcode = r8 resp 0 in
 399   match opcode land lnot 0x80 with
 400   | 0 ->                                (* error *)
 401      let s = resp in
 402      let code = r8 s 1
 403      and serial = r16 s 2
 404      and resid = r32 resp 4
 405      and min = r16 s 8
 406      and maj = r8 s 10 in
 407      error "code=%d serial=%d resid=%#x min=%d maj=%d\n%S"
 408        code serial resid min maj (Bytes.unsafe_to_string resp);
 409
 410   | 1 ->                                (* response *)
 411      let rep = Queue.pop !S.fifo in
 412      rep resp;
 413
 414   | 2 ->                                (* key press *)
 415      if Array.length !S.keymap > 0
 416      then
 417        let code = r8 resp 1 in
 418        let mask = r16 resp 28 in
 419        let keysym = getkeysym code mask in
 420        vlog "keysym = %x %c mask %#x code %d"
 421          keysym (Char.unsafe_chr keysym) mask code;
 422        if keysym != 0
 423        then !S.t#key keysym mask;
 424
 425   | 3 ->                                (* key release *)
 426      if Array.length !S.keymap > 0
 427      then
 428        let code = r8 resp 1 in
 429        let mask = r16 resp 28 in
 430        let keysym = getkeysym code mask in
 431        vlog "release keysym = %x %c mask %#x code %d"
 432          keysym (Char.unsafe_chr keysym) mask code;
 433
 434   | 4 ->                                (* buttonpress *)
 435      let n = r8 resp 1
 436      and x = r16s resp 24
 437      and y = r16s resp 26
 438      and m = r16 resp 28 in
 439      !S.t#mouse n true x y m;
 440      vlog "press %d" n;
 441
 442   | 5 ->                                (* buttonrelease *)
 443      let n = r8 resp 1
 444      and x = r16s resp 24
 445      and y = r16s resp 26
 446      and m = r16 resp 28 in
 447      !S.t#mouse n false x y m;
 448      vlog "release %d %d %d" n x y;
 449
 450   | 6 ->                                (* motion *)
 451      let x = r16s resp 24 in
 452      let y = r16s resp 26 in
 453      let m = r16 resp 28 in
 454      if m land 0x1f00 = 0
 455      then !S.t#pmotion x y
 456      else !S.t#motion x y;
 457      vlog "move %dx%d => %d" x y m;
 458
 459   | 7 ->                                (* enter *)
 460      let x = r16s resp 24
 461      and y = r16s resp 26 in
 462      !S.t#enter x y;
 463      vlog "enter %d %d" x y;
 464
 465   | 8 ->                                (* leave *)
 466      !S.t#leave;
 467
 468   | 18 ->                               (* unmap *)
 469      !S.t#map false;
 470      vlog "unmap";
 471
 472   | 19 ->                               (* map *)
 473      !S.t#map true;
 474      vlog "map";
 475
 476   | 12 ->                               (* exposure *)
 477      vlog "exposure";
 478      !S.t#expose;
 479
 480   | 15 ->                               (* visibility *)
 481      let v = r8 resp 8 in
 482      let vis =
 483        match v with
 484        | 0 -> Unobscured
 485        | 1 -> PartiallyObscured
 486        | 2 -> FullyObscured
 487        | _ ->
 488           dolog "unknown visibility %d" v;
 489           Unobscured
 490      in
 491      !S.t#visible vis;
 492      vlog "visibility %d" v;
 493
 494   | 11 ->                               (* keymapnotify *)
 495      S.keymap := E.a;
 496      let s = getkeymapreq !S.mink (!S.maxk - !S.mink-1) in
 497      sendwithrep sock s (updkmap sock);
 498      S.capslmask := 0;
 499      S.levl3mask := 0;
 500      S.levl5mask := 0;
 501      S.numlmask  := 0;
 502      let s = getmodifiermappingreq () in
 503      sendwithrep sock s (updmodmap sock);
 504
 505   | 33 ->                               (* clientmessage *)
 506      let atom = r32 resp 8 in
 507      if atom = !S.protoatom
 508      then
 509        let atom = r32 resp 12 in
 510        if atom = !S.deleatom
 511        then !S.t#quit;
 512      vlog "atom %#x" atom;
 513
 514   | 21 ->                               (* reparent *)
 515      vlog "reparent";
 516
 517   | 22 ->                               (* configure *)
 518      let x = r16s resp 16
 519      and y = r16s resp 18
 520      and w = r16 resp 20
 521      and h = r16 resp 22 in
 522      vlog "configure cur [%d %d %d %d] conf [%d %d %d %d]"
 523        !S.x !S.y !S.w !S.h
 524        x y w h;
 525      if w != !S.w || h != !S.h
 526      then !S.t#reshape w h;
 527      S.w := w;
 528      S.h := h;
 529      S.x := x;
 530      S.y := y;
 531
 532   | 24 ->                       (* Gravity notify *)
 533      ();
 534
 535   | 28 ->                       (* Property notify *)
 536      let atom = r32 resp 8 in
 537      if atom = !S.nwmsatom
 538      then
 539        let s = getpropreq false !S.wid atom 4 in
 540        sendwithrep sock s (fun resp ->
 541            S.fs := S.NoFs;
 542            let len = r32 resp 4 in
 543            let nitems = r32 resp 16 in
 544            let wsl =
 545              if len = 0
 546              then []
 547              else
 548                let s = readstr sock (len*4) in
 549                let rec loop wsl i =
 550                  if i = nitems
 551                  then wsl
 552                  else
 553                    let atom = r32 s (i*4) in
 554                    let wsl =
 555                      if atom = !S.maxhatom
 556                      then MaxHorz::wsl
 557                      else (
 558                        if atom = !S.maxvatom
 559                        then MaxVert::wsl
 560                        else (
 561                          if atom = !S.fulsatom
 562                          then (
 563                            S.fs := S.Fs (!S.x, !S.y, !S.w, !S.h);
 564                            Fullscreen::wsl
 565                          )
 566                          else wsl
 567                        )
 568                      )
 569                    in loop wsl (i+1)
 570                in
 571                loop [] 0
 572            in
 573            !S.t#winstate (List.sort compare wsl)
 574          );
 575
 576   | n -> dolog "event %d %S" n (Bytes.unsafe_to_string resp)
 577
 578 let readresp sock =
 579   let rec loop () =
 580     readresp sock;
 581     if hasdata sock then loop ();
 582   in
 583   loop ()
 584
 585 let sendstr s ?(pos=0) ?(len=Bytes.length s) sock =
 586   sendstr1 s pos len sock;
 587   if hasdata sock then readresp sock
 588
 589 let reshape w h =
 590   if !S.fs = S.NoFs
 591   then
 592     let s = Bytes.create 8 in
 593     w32 s 0 w;
 594     w32 s 4 h;
 595     let s = configurewindowreq !S.wid 0x000c s in
 596     sendstr s !S.sock;
 597   else !S.fullscreen !S.wid
 598
 599 let activatewin () =
 600   !S.actwin ()
 601
 602 let syncsendwithrep sock secstowait s f =
 603   let completed = ref false in
 604   sendwithrep sock s (fun resp -> f resp; completed := true);
 605   let now = Unix.gettimeofday in
 606   let deadline = now () +. secstowait in
 607   let rec readtillcompletion () =
 608     let sf deadline =
 609       let timeout = deadline -. now () in
 610       if timeout <= 0.0
 611       then [], [], []
 612       else Unix.select [sock] [] [] timeout
 613     in
 614     let r, _, _ = tempfailureretry sf deadline in
 615     match r with
 616     | [] -> error "didn't get X response in %f seconds, aborting" secstowait
 617     | _ ->
 618        readresp sock;
 619        if not !completed
 620        then readtillcompletion ();
 621   in
 622   readtillcompletion ()
 623
 624 let mapwin () =
 625   let s = mapreq !S.wid in
 626   sendstr s !S.sock
 627
 628 let syncsendintern sock secstowait s onlyifexists f =
 629   let s = internreq s onlyifexists in
 630   syncsendwithrep sock secstowait s f
 631
 632 let setup disp sock rootwid screennum w h =
 633   let s = readstr sock 2 in
 634   let n = Bytes.length s in
 635   if n != 2
 636   then error "failed to read X connection setup response n=%d" n;
 637   match Bytes.get s 0 with
 638   | '\000' ->
 639      let reasonlen = r8 s 1 in
 640      let s = readstr sock 6 in
 641      let maj = r16 s 0
 642      and min = r16 s 2
 643      and add = r16 s 4 in
 644      let len = add*4 in
 645      let data = readstr sock len in
 646      let reason = Bytes.sub data 0 reasonlen in
 647      error "X connection failed maj=%d min=%d reason=%S"
 648        maj min (Bytes.unsafe_to_string reason);
 649
 650   | '\002' -> error "X connection setup failed: authentication required";
 651
 652   | '\001' ->
 653      let s       = readstr sock 38 in
 654      let maj     = r16 s 0
 655      and min     = r16 s 2
 656      and add     = r16 s 4
 657      and idbase  = r32 s 10
 658      and idmask  = r32 s 14
 659      and vlen    = r16 s 22
 660      and screens = r8 s 26
 661      and formats = r8 s 27
 662      and minkk   = r8 s 32
 663      and maxkk   = r8 s 33 in
 664      let data = readstr sock (4*add-32) in
 665      let vendor = Bytes.sub data 0 vlen in
 666      let pos = ((vlen+3) land lnot 3) + formats*8 in
 667
 668      if screennum >= screens
 669      then error "invalid screen %d, max %d" screennum (screens-1);
 670
 671      let pos =
 672        let rec findscreen n pos =
 673          if n = screennum
 674          then pos
 675          else
 676            let pos =
 677              let ndepths = r8 data (pos+39) in
 678              let rec skipdepths n pos =
 679                if n = ndepths
 680                then pos
 681                else
 682                  let pos =
 683                    let nvisiuals = r16 data (pos+2) in
 684                    pos + nvisiuals*24 + 8
 685                  in
 686                  skipdepths (n+1) pos
 687              in
 688              skipdepths n (pos+40)
 689            in
 690            findscreen (n+1) pos
 691        in
 692        findscreen 0 pos
 693      in
 694      let root = if rootwid = 0 then r32 data pos else rootwid in
 695      let rootw = r16 data (pos+20)
 696      and rooth = r16 data (pos+22)
 697      and rootdepth = r8 data (pos+38)in
 698
 699      S.fscale := float rooth /. 1440.0;
 700      S.mink := minkk;
 701      S.maxk := maxkk;
 702      S.idbase := idbase;
 703      vlog "vendor = %S, maj=%d min=%d" (Bytes.unsafe_to_string vendor) maj min;
 704      vlog "screens = %d formats = %d" screens formats;
 705      vlog "minkk = %d maxkk = %d" minkk maxkk;
 706      vlog "idbase = %#x idmask = %#x" idbase idmask;
 707      vlog "root=%#x %dx%d" root rootw rooth;
 708      vlog "wmm = %d, hmm = %d" (r16 data (pos+24)) (r16 data (pos+26));
 709      vlog "visualid = %#x" (r32 data (pos+32));
 710      vlog "root depth = %d" rootdepth;
 711
 712      let wid = !S.idbase in
 713      let mid = wid+1 in
 714      let fid = mid+1 in
 715
 716      S.wid := wid;
 717      S.fid := fid;
 718
 719      let vid = glxinit disp wid screennum in
 720      let ndepths = r8 data (pos+39) in
 721      let rec finddepth n' pos =
 722        if n' = ndepths
 723        then error "cannot find depth for visual %#x" vid;
 724        let depth = r8 data pos in
 725        let nvisuals = r16 data (pos+2) in
 726        let rec findvisual n pos =
 727          if n = nvisuals
 728          then finddepth (n'+1) pos
 729          else
 730            let id = r32 data pos in
 731            if id = vid
 732            then depth
 733            else findvisual (n+1) (pos+24)
 734        in
 735        findvisual 0 (pos+8)
 736      in
 737      let depth = finddepth 0 (pos+40) in
 738
 739      let s = createcolormapreq mid root vid in
 740      sendstr s sock;
 741
 742      let mask = 0
 743                 + 0x00000001                    (* KeyPress *)
 744                 (* + 0x00000002 *)              (* KeyRelease *)
 745                 + 0x00000004                    (* ButtonPress *)
 746                 + 0x00000008                    (* ButtonRelease *)
 747                 + 0x00000010                    (* EnterWindow *)
 748                 + 0x00000020                    (* LeaveWindow *)
 749                 + 0x00000040                    (* PointerMotion *)
 750                 (* + 0x00000080 *)              (* PointerMotionHint *)
 751                 (* + 0x00000100 *)              (* Button1Motion *)
 752                 (* + 0x00000200 *)              (* Button2Motion *)
 753                 (* + 0x00000400 *)              (* Button3Motion *)
 754                 (* + 0x00000800 *)              (* Button4Motion *)
 755                 (* + 0x00001000 *)              (* Button5Motion *)
 756                 + 0x00002000                    (* ButtonMotion *)
 757                 + 0x00004000                    (* KeymapState *)
 758                 + 0x00008000                    (* Exposure *)
 759                 + 0x00010000                    (* VisibilityChange *)
 760                 + 0x00020000                    (* StructureNotify *)
 761                 (* + 0x00040000 *)              (* ResizeRedirect *)
 762                 (* + 0x00080000 *)              (* SubstructureNotify *)
 763                 (* + 0x00100000 *)              (* SubstructureRedirect *)
 764                 (* + 0x00200000 *)              (* FocusChange *)
 765                 + 0x00400000                    (* PropertyChange *)
 766                 (* + 0x00800000 *)              (* ColormapChange *)
 767                 (* + 0x01000000 *)              (* OwnerGrabButton *)
 768      in
 769
 770      let s = createwindowreq wid root 0 0 w h 0 mask vid depth mid in
 771      sendstr s sock;
 772
 773      sendintern
 774        sock (~> "WM_PROTOCOLS") false (fun resp ->
 775          S.protoatom := r32 resp 8;
 776          sendintern
 777            sock (~> "WM_DELETE_WINDOW") false (fun resp ->
 778              S.deleatom := r32 resp 8;
 779              let s = s32 !S.deleatom in
 780              let s = changepropreq wid !S.protoatom 4 32 s in
 781              sendstr s sock;
 782            );
 783        );
 784
 785      sendintern
 786        sock (~> "WM_CLIENT_MACHINE") false (fun resp ->
 787          let atom = r32 resp 8 in
 788          let empty = E.s in
 789          let hostname =
 790            try Unix.gethostname ()
 791            with exn ->
 792              dolog "error getting host name: %s" @@ exntos exn;
 793              empty
 794          in
 795          if hostname != empty
 796          then
 797            let s = changepropreq wid atom !S.stringatom 8
 798                      (~> hostname) in
 799            sendstr s sock;
 800            sendintern
 801              sock (~> "_NET_WM_PID") false (fun resp ->
 802                let atom = r32 resp 8 in
 803                let pid = Unix.getpid () in
 804                let s = s32 pid in
 805                let s = changepropreq wid atom 6(*cardinal*) 32 s in
 806                sendstr s sock;
 807              )
 808        );
 809
 810      S.actwin := (fun () ->
 811        let s = Bytes.create 4 in
 812        let s = configurewindowreq wid 0x40 s in
 813        sendstr s !S.sock;
 814        let s = mapreq wid in
 815        sendstr s !S.sock;
 816      );
 817
 818      sendintern
 819        sock (~> "_NET_ACTIVE_WINDOW") true (fun resp ->
 820          let atom = r32 resp 8 in
 821          S.actwin := (fun () ->
 822            let data = Bytes.make 20 '\000' in
 823            let cm = clientmessage 32 0 wid atom data in
 824            let s = sendeventreq 0 root 0x180000 cm in
 825            sendstr s !S.sock;
 826          );
 827        );
 828
 829      syncsendintern
 830        sock 2.0 (~> "WM_CLASS") false (fun resp ->
 831          let atom = r32 resp 8 in
 832          let llpp = ~> "llpp\000llpp\000" in
 833          let s = changepropreq wid atom 31 8 llpp in
 834          sendstr s sock;
 835        );
 836
 837      let s = getkeymapreq !S.mink (!S.maxk - !S.mink) in
 838      sendwithrep sock s (updkmap sock);
 839
 840      let s = getmodifiermappingreq () in
 841      sendwithrep sock s (updmodmap sock);
 842
 843      sendintern
 844        sock (~> "UTF8_STRING") true (fun resp ->
 845          let atom = r32 resp 8 in
 846          if atom != 0
 847          then S.stringatom := atom;
 848        );
 849
 850      let setwmname s =
 851        let s = changepropreq wid 39 !S.stringatom 8 s in
 852        sendstr s !S.sock;
 853      in
 854      S.setwmname := setwmname;
 855      sendintern
 856        sock (~> "_NET_WM_NAME") true (fun resp ->
 857          let atom = r32 resp 8 in
 858          if atom != 0
 859          then S.setwmname := (fun s ->
 860            setwmname s;
 861            let s = changepropreq wid atom !S.stringatom 8 s in
 862            sendstr s !S.sock;
 863          );
 864        );
 865
 866      sendintern
 867        sock (~> "_NET_WM_STATE") true (fun resp ->
 868          S.nwmsatom := r32 resp 8;
 869          if !S.nwmsatom != 0
 870          then (
 871            sendintern sock (~> "_NET_WM_STATE_MAXIMIZED_VERT") true (fun resp ->
 872                S.maxvatom := r32 resp 8;
 873              );
 874            sendintern sock (~> "_NET_WM_STATE_MAXIMIZED_HORZ") true (fun resp ->
 875                S.maxhatom := r32 resp 8;
 876              );
 877            sendintern
 878              sock (~> "_NET_WM_STATE_FULLSCREEN") false (fun resp ->
 879                S.fulsatom := r32 resp 8;
 880                if !S.fulsatom != 0
 881                then
 882                  S.fullscreen :=
 883                    (fun wid ->
 884                      let data = Bytes.make 20 '\000' in
 885                      let fs, f =
 886                        match !S.fs with
 887                        | S.NoFs -> S.Fs (-1, -1, -1, -1), 1
 888                        | S.Fs _ -> S.NoFs, 0
 889                      in
 890                      w32 data 0 f;
 891                      w32 data 4 !S.fulsatom;
 892
 893                      let cm = clientmessage 32 0 wid !S.nwmsatom data in
 894                      let s = sendeventreq 0 root 0x180000 cm in
 895                      sendstr s sock;
 896                      S.fs := fs;
 897                    );
 898              );
 899          );
 900        );
 901      let s = queryextensionreq (~> "XKEYBOARD") in
 902      sendwithrep
 903        sock s (fun resp ->
 904          let present = r8 resp 8 in
 905          if present != 0
 906          then (
 907            let maj = r8 resp 9 in
 908            let s = Bytes.create 8 in
 909            w8 s 0 maj;   (* XKB *)
 910            w8 s 1 0;     (* XKBUseExtension *)
 911            w16 s 2 2;    (* request-length *)
 912            w16 s 4 1;    (* wantedMajor *)
 913            w16 s 6 0;    (* watnedMinor *)
 914            sendwithrep
 915              sock s
 916              (fun resp ->
 917                let supported = r8 resp 1 in
 918                S.xkb := supported != 0
 919              )
 920          );
 921        );
 922      let s = getgeometryreq wid in
 923      syncsendwithrep sock 2.0 s (fun resp ->
 924          glxcompleteinit ();
 925          let w = r16 resp 16
 926          and h = r16 resp 18 in
 927          S.w := w;
 928          S.h := h;
 929        );
 930
 931   | c -> error "unknown connection setup response %d" (Char.code c)
 932
 933 let getauth haddr dnum =
 934   let haddr =
 935     if emptystr haddr || haddr = "localhost"
 936     then
 937       try Unix.gethostname ()
 938       with exn ->
 939         dolog "failed to resolve `%S': %s" haddr @@ exntos exn;
 940         haddr
 941     else haddr
 942   in
 943   let path, warn =
 944     try Sys.getenv "XAUTHORITY", true
 945     with Not_found ->
 946       try Filename.concat (Sys.getenv "HOME") ".Xauthority", false
 947       with Not_found -> E.s, false
 948   in
 949   let readauth ic =
 950     let r16be s =
 951       let rb pos = Char.code (Bytes.get s pos) in
 952       (rb 1) lor ((rb 0) lsl 8)
 953     in
 954     let rec find () =
 955       let rs () =
 956         let s = really_input_string ic 2 in
 957         let n = r16be (~> s) in
 958         really_input_string ic n
 959       in
 960       let family = really_input_string ic 2 in
 961       let addr = rs () in
 962       let nums = rs () in
 963       let optnum =
 964         match int_of_string nums with
 965         | n -> Some n
 966         | exception exn ->
 967            if nonemptystr nums
 968            then
 969              dolog "display number(%S) is not an integer (corrupt %S?): %s"
 970                nums path @@ exntos exn
 971            ;
 972            None
 973       in
 974       let name = rs () in
 975       let data = rs () in
 976
 977       vlog "family %S addr %S(%S) num %S(%d) name %S data %S"
 978         family addr haddr nums dnum name data;
 979       match optnum with
 980       | Some num when addr = haddr && num = dnum ->
 981          name, data
 982       | _ -> find ()
 983     in
 984     let name, data =
 985       try find ()
 986       with
 987       | End_of_file -> E.s, E.s
 988       | exn ->
 989          dolog "exception while reading X authority data (%S): %s"
 990            path @@ exntos exn;
 991          E.s, E.s
 992     in
 993     close_in ic;
 994     name, data;
 995   in
 996   if emptystr path
 997   then E.s, E.s
 998   else
 999     match open_in_bin path with
1000     | ic -> readauth ic
1001     | exception exn ->
1002        if warn
1003        then
1004          dolog "failed to open X authority file `%S' : %s" path @@ exntos exn
1005        ;
1006        E.s, E.s
1007
1008 let init t w h =
1009   let d =
1010     try Sys.getenv "DISPLAY"
1011     with exn ->
1012       error "cannot get DISPLAY evironment variable: %s" @@ exntos exn
1013   in
1014   let getnum w b e =
1015     if b = e
1016     then error "invalid DISPLAY(%s) %S" w d
1017     else
1018       let s = String.sub d b (e - b) in
1019       try int_of_string s
1020       with exn ->
1021         error "invalid DISPLAY %S can not parse %s(%S): %s" d w s @@ exntos exn
1022   in
1023   let rec phost pos =
1024     if pos = String.length d
1025     then error "invalid DISPLAY %S no display number specified" d
1026     else (
1027       if d.[pos] = ':'
1028       then
1029         let rec pdispnum pos1 =
1030           if pos1 = String.length d
1031           then getnum "display number" (pos+1) pos1, 0
1032           else
1033             match d.[pos1] with
1034             | '.' ->
1035                let dispnum = getnum "display number" (pos+1) pos1 in
1036                let rec pscreennum pos2 =
1037                  if pos2 = String.length d
1038                  then getnum "screen number" (pos1+1) pos2
1039                  else
1040                    match d.[pos2] with
1041                    | '0' .. '9' -> pscreennum (pos2+1)
1042                    | _ ->
1043                       error "invalid DISPLAY %S, cannot parse screen number" d
1044                in
1045                dispnum, pscreennum (pos1+1)
1046             | '0' .. '9' -> pdispnum (pos1+1)
1047             | _ -> error "invalid DISPLAY %S, cannot parse display number" d
1048         in
1049         String.sub d 0 pos, pdispnum (pos+1)
1050       else phost (pos+1)
1051     )
1052   in
1053   let host, (dispnum, screennum) = phost 0 in
1054   let aname, adata = getauth host dispnum in
1055   let fd =
1056     let fd, addr =
1057       if emptystr host || host.[0] = '/' || host = "unix"
1058       then
1059         (Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0,
1060          Unix.ADDR_UNIX ("\000/tmp/.X11-unix/X" ^ string_of_int dispnum))
1061       else
1062         let h =
1063           try Unix.gethostbyname host
1064           with exn -> error "cannot resolve %S: %s" host @@ exntos exn
1065         in
1066         let addr = h.Unix.h_addr_list.(0) in
1067         let port = 6000 + dispnum in
1068         let fd = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
1069         fd, (Unix.ADDR_INET (addr, port))
1070     in
1071     try Unix.connect fd addr; fd
1072     with exn -> error "failed to connect to X: %s" @@ exntos exn
1073   in
1074   Unix.set_close_on_exec fd;
1075   let s = Bytes.create 12 in
1076   let s = padcat s (~> aname) in
1077   let s = padcat s (~> adata) in
1078   Bytes.set s 0 ordermagic;
1079   w16 s 2 11;
1080   w16 s 4 0;
1081   w16 s 6 (String.length aname);
1082   w16 s 8 (String.length adata);
1083   sendstr1 s 0 (Bytes.length s) fd;
1084   S.sock := fd;
1085   setup d fd 0 screennum w h;
1086   S.t := t;
1087   fd, !S.w, !S.h
1088
1089 let setcursor cursor =
1090   if cursor != !S.curcurs
1091   then (
1092     setcursor cursor;
1093     S.curcurs := cursor;
1094   )
1095
1096 let xlatt, xlatf =
1097   let t = Hashtbl.create 20
1098   and f = Hashtbl.create 20 in
1099   let add n nl k =
1100     List.iter (fun s -> Hashtbl.add t s k) (n::nl);
1101     Hashtbl.add f k n
1102   in
1103   let addc c =
1104     let s = String.make 1 c in
1105     add s [] (Char.code c)
1106   in
1107   let addcr a b =
1108     let an = Char.code a and bn = Char.code b in
1109     for i = an to bn do addc (Char.chr i) done;
1110   in
1111   addcr '0' '9';
1112   addcr 'a' 'z';
1113   addcr 'A' 'Z';
1114   String.iter addc "`~!@#$%^&*()-_=+\\|[{]};:,./<>?";
1115   for i = 0 to 29 do add ("f" ^ string_of_int (i+1)) [] (0xffbe + i) done;
1116   add "space" [] 0x20;
1117   add "ret" ["return"; "enter"] 0xff0d;
1118   add "tab" [] 0xff09;
1119   add "left" [] 0xff51;
1120   add "right" [] 0xff53;
1121   add "home" [] 0xff50;
1122   add "end" [] 0xff57;
1123   add "ins" ["insert"] 0xff63;
1124   add "del" ["delete"] 0xffff;
1125   add "esc" ["escape"] 0xff1b;
1126   add "pgup" ["pageup"] 0xff55;
1127   add "pgdown" ["pagedown"] 0xff56;
1128   add "backspace" [] 0xff08;
1129   add "up" [] 0xff52;
1130   add "down" [] 0xff54;
1131   add "menu" [] 0xff67;
1132   t, f
1133
1134 let keyname k =
1135   try Hashtbl.find xlatf k
1136   with Not_found -> Printf.sprintf "%#x" k
1137
1138 let namekey name =
1139   try Hashtbl.find xlatt name
1140   with Not_found ->
1141     if String.length name = 1
1142     then Char.code name.[0]
1143     else int_of_string name
1144
1145 let ks2kt =
1146   let open Keys in
1147   function
1148   | 0xff08 -> Backspace
1149   | 0xff0d -> Enter
1150   | 0xff1b -> Escape
1151   | 0xff50 -> Home
1152   | 0xff51 -> Left
1153   | 0xff52 -> Up
1154   | 0xff53 -> Right
1155   | 0xff54 -> Down
1156   | 0xff55 -> Prior
1157   | 0xff56 -> Next
1158   | 0xff57 -> End
1159   | 0xff63 -> Insert
1160   | 0xff8d -> Enter
1161   | 0xff95 -> Home
1162   | 0xff96 -> Left
1163   | 0xff97 -> Up
1164   | 0xff98 -> Right
1165   | 0xff99 -> Down
1166   | 0xff9a -> Prior
1167   | 0xff9b -> Next
1168   | 0xff9c -> End
1169   | 0xff9f -> Delete
1170   | 0xffab -> Ascii '+'
1171   | 0xffad -> Ascii '-'
1172   | 0xffff -> Delete
1173   | code when code > 31 && code < 128 -> Ascii (Char.unsafe_chr code)
1174   | code when code >= 0xffb0 && code <= 0xffb9 ->
1175      Ascii (Char.unsafe_chr (code - 0xffb0 + 0x30))
1176   | code when code >= 0xffbe && code <= 0xffc8 -> Fn (code - 0xffbe + 1)
1177   | code when code land 0xff00 = 0xff00 -> Ctrl code
1178   | code -> Code code
1179
1180 let cAp = "https://github.com/astrand/xclip"