wsi.ml

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