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