wsi.ml

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