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