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