utils.ml

   1 module E = struct
   2   let s = "";;
   3   let b = Bytes.of_string s;;
   4   let a = [||];;
   5 end;;
   6
   7 type platform = | Punknown | Plinux | Posx | Psun | Pbsd | Pcygwin;;
   8
   9 let tempfailureretry f a =
  10   let rec g () =
  11     try f a with Unix.Unix_error (Unix.EINTR, _, _) -> g ()
  12   in g ()
  13 ;;
  14
  15 external cloexec : Unix.file_descr -> unit = "ml_cloexec";;
  16 external hasdata : Unix.file_descr -> bool = "ml_hasdata";;
  17 external toutf8 : int -> string = "ml_keysymtoutf8";;
  18 external mbtoutf8 : string -> string = "ml_mbtoutf8";;
  19 external popen : string -> (Unix.file_descr * int) list -> int = "ml_popen";;
  20 external platform : unit -> (platform * string array)  = "ml_platform";;
  21
  22 let now = Unix.gettimeofday;;
  23 let platform, uname = platform ();;
  24 let dolog fmt = Format.ksprintf prerr_endline fmt;;
  25
  26 let exntos = function
  27   | Unix.Unix_error (e, s, a) -> Printf.sprintf "%s(%s) : %s (%d)"
  28       s a (Unix.error_message e) (Obj.magic e)
  29   | exn -> Printexc.to_string exn;
  30 ;;
  31
  32 let error fmt = Printf.kprintf failwith fmt;;
  33
  34 module IntSet = Set.Make (struct type t = int let compare = (-) end);;
  35
  36 let emptystr s = String.length s = 0;;
  37 let nonemptystr s = String.length s > 0;;
  38 let bound v minv maxv = max minv (min maxv v);;
  39
  40 let popen cmd fda =
  41   if platform = Pcygwin
  42   then failwith "popen not implemented under cygwin yet"
  43   else popen cmd fda;
  44 ;;
  45
  46 module Opaque :
  47 sig
  48   type t =  private string
  49   val of_string : string -> t
  50   val to_string : t -> string
  51 end
  52   =
  53 struct
  54   type t = string
  55   let of_string s = s
  56   let to_string t = t
  57 end
  58 ;;
  59
  60 let (~<) = Opaque.of_string;;
  61 let (~>) = Opaque.to_string;;
  62
  63 let int_of_string_with_suffix s =
  64   let l = String.length s in
  65   let s1, shift =
  66     if l > 1
  67     then
  68       let suffix = Char.lowercase s.[l-1] in
  69       match suffix with
  70       | 'k' -> String.sub s 0 (l-1), 10
  71       | 'm' -> String.sub s 0 (l-1), 20
  72       | 'g' -> String.sub s 0 (l-1), 30
  73       | _ -> s, 0
  74     else s, 0
  75   in
  76   let n = int_of_string s1 in
  77   let m = n lsl shift in
  78   if m < 0 || m < n
  79   then error "value too large"
  80   else m
  81 ;;
  82
  83 let string_with_suffix_of_int n =
  84   if n = 0
  85   then "0"
  86   else
  87     let units = [(30, "G"); (20, "M"); (10, "K")] in
  88     let prettyint n =
  89       let rec loop s n =
  90         let h = n mod 1000 in
  91         let n = n / 1000 in
  92         if n = 0
  93         then string_of_int h ^ s
  94         else (
  95           let s = Printf.sprintf "_%03d%s" h s in
  96           loop s n
  97         )
  98       in
  99       loop E.s n
 100     in
 101     let rec find = function
 102       | [] -> prettyint n
 103       | (shift, suffix) :: rest ->
 104           if (n land ((1 lsl shift) - 1)) = 0
 105           then prettyint (n lsr shift) ^ suffix
 106           else find rest
 107     in
 108     find units
 109 ;;
 110
 111 let color_of_string s =
 112   Scanf.sscanf s "%d/%d/%d" (fun r g b ->
 113     (float r /. 256.0, float g /. 256.0, float b /. 256.0)
 114   )
 115 ;;
 116
 117 let color_to_string (r, g, b) =
 118   let r = truncate (r *. 256.0)
 119   and g = truncate (g *. 256.0)
 120   and b = truncate (b *. 256.0) in
 121   Printf.sprintf "%d/%d/%d" r g b
 122 ;;
 123
 124 let abspath path =
 125   if Filename.is_relative path
 126   then
 127     let cwd = Sys.getcwd () in
 128     if Filename.is_implicit path
 129     then Filename.concat cwd path
 130     else Filename.concat cwd (Filename.basename path)
 131   else
 132     path
 133 ;;
 134
 135 let nindex s c =
 136   try String.index s c
 137   with Not_found -> -1
 138 ;;
 139
 140 module Ne = struct
 141   let clo fd f =
 142     try tempfailureretry Unix.close fd
 143     with exn -> f (exntos exn)
 144   ;;
 145 end;;
 146
 147 let getenvwithdef name def =
 148   match Sys.getenv name with
 149   | env -> env
 150   | exception Not_found -> def
 151 ;;
 152
 153 let newlinere = Str.regexp "[\r\n]";;
 154 let percentsre = Str.regexp "%s";;
 155
 156 let filelines path =
 157   let ic = open_in path in
 158   let b = Buffer.create (in_channel_length ic) in
 159   let rec loop () =
 160     match input_line ic with
 161     | (exception End_of_file) -> Buffer.contents b
 162     | line ->
 163        if Buffer.length b > 0
 164        then Buffer.add_char b '\n';
 165        Buffer.add_string b line;
 166        loop ()
 167   in
 168   let s = loop () in
 169   close_in ic;
 170   s;
 171 ;;
 172
 173 let unit () = ();;
 174
 175 let addchar s c =
 176   let b = Buffer.create (String.length s + 1) in
 177   Buffer.add_string b s;
 178   Buffer.add_char b c;
 179   Buffer.contents b;
 180 ;;
 181
 182 let btod b = if b then 1 else 0;;
 183
 184 let splitatspace =
 185   let r = Str.regexp " " in
 186   fun s -> Str.bounded_split r s 2;
 187 ;;
 188
 189 let boundastep h step =
 190   if step < 0
 191   then bound step ~-h 0
 192   else bound step 0 h
 193 ;;
 194
 195 let withoutlastutf8 s =
 196   let len = String.length s in
 197   if len = 0
 198   then s
 199   else
 200     let rec find pos =
 201       if pos = 0
 202       then pos
 203       else
 204         let b = Char.code s.[pos] in
 205         if b land 0b11000000 = 0b11000000
 206         then pos
 207         else find (pos-1)
 208     in
 209     let first =
 210       if Char.code s.[len-1] land 0x80 = 0
 211       then len-1
 212       else find (len-1)
 213     in
 214     String.sub s 0 first;
 215 ;;
 216
 217 let fdcontents fd =
 218   let l = 4096 in
 219   let b = Buffer.create l in
 220   let s = Bytes.create l in
 221   let rec loop () =
 222     let n = tempfailureretry (Unix.read fd s 0) l in
 223     if n = 0
 224     then Buffer.contents b
 225     else (
 226       Buffer.add_subbytes b s 0 n;
 227       loop ()
 228     )
 229   in
 230   loop ()
 231 ;;
 232
 233 let getcmdoutput errfun cmd =
 234   let reperror fmt = Printf.kprintf errfun fmt in
 235   let clofail s e = error "failed to close %s: %s" s e in
 236   match Unix.pipe () with
 237   | (exception exn) ->
 238      reperror "pipe failed: %s" (exntos exn);
 239      E.s
 240   | (r, w) ->
 241      match popen cmd [r, -1; w, 1] with
 242      | (exception exn) ->
 243         reperror "failed to execute %S: %s" cmd (exntos exn);
 244         E.s
 245      | pid ->
 246         Ne.clo w @@ clofail "write end of the pipe";
 247         let s =
 248           match Unix.waitpid [] pid with
 249           | (exception exn) ->
 250              reperror "waitpid on %S %d failed: %s" cmd pid (exntos exn);
 251              E.s
 252           | _pid, Unix.WEXITED 0 ->
 253              begin
 254                match fdcontents r with
 255                | (exception exn) ->
 256                   reperror "failed to read output of %S: %s" cmd (exntos exn);
 257                   E.s
 258                | s ->
 259                   let l = String.length s in
 260                   if l > 0 && s.[l-1] = '\n'
 261                   then String.sub s 0 (l-1)
 262                   else s
 263              end;
 264           | _pid, Unix.WEXITED n ->
 265              reperror "%S exited with error code %d" cmd n;
 266              E.s
 267           | _pid, Unix.WSIGNALED n ->
 268              reperror "%S was killed with signal %d" cmd n;
 269              E.s
 270           | _pid, Unix.WSTOPPED n ->
 271              reperror "%S was stopped by signal %d" cmd n;
 272              E.s
 273         in
 274         Ne.clo r @@ clofail "read end of the pipe";
 275         s
 276 ;;
 277
 278 let geturl s =
 279   let colonpos = try String.index s ':' with Not_found -> -1 in
 280   let len = String.length s in
 281   if colonpos >= 0 && colonpos + 3 < len
 282   then (
 283     if s.[colonpos+1] = '/' && s.[colonpos+2] = '/'
 284     then
 285       let schemestartpos =
 286         try String.rindex_from s colonpos ' '
 287         with Not_found -> -1
 288       in
 289       let scheme =
 290         String.sub s (schemestartpos+1) (colonpos-1-schemestartpos)
 291       in
 292       match scheme with
 293       | "http" | "https" | "ftp" | "mailto" ->
 294           let epos =
 295             try String.index_from s colonpos ' '
 296             with Not_found -> len
 297           in
 298           String.sub s (schemestartpos+1) (epos-1-schemestartpos)
 299       | _ -> E.s
 300     else E.s
 301   )
 302   else E.s
 303 ;;