wsi.ml

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