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