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