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