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