utils.ml

   1 module E = struct
   2   let s = "";;
   3   let b = Bytes.empty;;
   4   let a = [||];;
   5 end;;
   6
   7 type platform = | Punknown | Plinux | Posx | Psun | Pbsd | Pcygwin;;
   8
   9 let asciilower = let auld = Char.code 'A' - Char.code 'a' in function
  10   | ('A'..'Z') as c -> Char.code c - auld |> Char.chr
  11   | c -> c
  12 ;;
  13
  14 let tempfailureretry f a =
  15   let rec g () =
  16     try f a with Unix.Unix_error (Unix.EINTR, _, _) -> g ()
  17   in g ()
  18 ;;
  19
  20 external cloexec : Unix.file_descr -> unit = "ml_cloexec";;
  21 external hasdata : Unix.file_descr -> bool = "ml_hasdata";;
  22 external toutf8 : int -> string = "ml_keysymtoutf8";;
  23 external mbtoutf8 : string -> string = "ml_mbtoutf8";;
  24 external spawn : string -> (Unix.file_descr * int) list -> int = "ml_spawn";;
  25 external platform : unit -> (platform * string array) = "ml_platform";;
  26
  27 let now = Unix.gettimeofday;;
  28 let platform, uname = platform ();;
  29 let dolog fmt = Format.ksprintf prerr_endline fmt;;
  30
  31 let exntos = function
  32   | Unix.Unix_error (e, s, a) -> Printf.sprintf "%s(%s) : %s (%d)"
  33       s a (Unix.error_message e) (Obj.magic e)
  34   | exn -> Printexc.to_string exn
  35 ;;
  36
  37 let error fmt = Printf.kprintf failwith fmt;;
  38
  39 module IntSet = Set.Make (struct type t = int let compare = (-) end);;
  40
  41 let emptystr s = String.length s = 0;;
  42 let nonemptystr s = String.length s > 0;;
  43 let bound v minv maxv = max minv (min maxv v);;
  44
  45 let spawn cmd fda =
  46   if platform = Pcygwin
  47   then failwith "spawn not implemented under cygwin yet"
  48   else spawn cmd fda;
  49 ;;
  50
  51 module Opaque :
  52 sig
  53   type t = private string
  54   val of_string : string -> t
  55   val to_string : t -> string
  56 end
  57   =
  58 struct
  59   type t = string
  60   let of_string s = s
  61   let to_string t = t
  62 end
  63 ;;
  64
  65 let (~<) = Opaque.of_string;;
  66 let (~>) = Opaque.to_string;;
  67
  68 let int_of_string_with_suffix s =
  69   let l = String.length s in
  70   let s1, shift =
  71     if l > 1
  72     then
  73       let p = l-1 in
  74       match s.[p] with
  75       | 'k' | 'K' -> String.sub s 0 p, 10
  76       | 'm' | 'M' -> String.sub s 0 p, 20
  77       | 'g' | 'G' -> String.sub s 0 p, 30
  78       | _ -> s, 0
  79     else s, 0
  80   in
  81   let n = int_of_string s1 in
  82   let m = n lsl shift in
  83   if m < 0 || m < n
  84   then error "value too large"
  85   else m
  86 ;;
  87
  88 let string_with_suffix_of_int n =
  89   if n = 0
  90   then "0"
  91   else
  92     let units = [(30, "G"); (20, "M"); (10, "K")] in
  93     let prettyint n =
  94       let rec loop s n =
  95         let h = n mod 1000 in
  96         let n = n / 1000 in
  97         if n = 0
  98         then string_of_int h ^ s
  99         else (
 100           let s = Printf.sprintf "_%03d%s" h s in
 101           loop s n
 102         )
 103       in
 104       loop E.s n
 105     in
 106     let rec find = function
 107       | [] -> prettyint n
 108       | (shift, suffix) :: rest ->
 109           if (n land ((1 lsl shift) - 1)) = 0
 110           then prettyint (n lsr shift) ^ suffix
 111           else find rest
 112     in
 113     find units
 114 ;;
 115
 116 let color_of_string s =
 117   Scanf.sscanf s "%d/%d/%d" (fun r g b ->
 118     (float r /. 256.0, float g /. 256.0, float b /. 256.0)
 119   )
 120 ;;
 121
 122 let color_to_string (r, g, b) =
 123   let r = truncate (r *. 256.0)
 124   and g = truncate (g *. 256.0)
 125   and b = truncate (b *. 256.0) in
 126   Printf.sprintf "%d/%d/%d" r g b
 127 ;;
 128
 129 let abspath path =
 130   if Filename.is_relative path
 131   then
 132     let cwd = Sys.getcwd () in
 133     if Filename.is_implicit path
 134     then Filename.concat cwd path
 135     else Filename.concat cwd (Filename.basename path)
 136   else
 137     path
 138 ;;
 139
 140 let nindex s c =
 141   try String.index s c
 142   with Not_found -> -1
 143 ;;
 144
 145 module Ne = struct
 146   let clo fd f =
 147     try tempfailureretry Unix.close fd
 148     with exn -> f @@ exntos exn
 149   ;;
 150 end;;
 151
 152 let getenvwithdef name def =
 153   match Sys.getenv name with
 154   | env -> env
 155   | exception Not_found -> def
 156 ;;
 157
 158 let newlinere = Str.regexp "[\r\n]";;
 159 let percentsre = Str.regexp "%s";;
 160 let whitere = Str.regexp "[ \t]";;
 161
 162 let unit () = ();;
 163
 164 let addchar s c =
 165   let b = Buffer.create (String.length s + 1) in
 166   Buffer.add_string b s;
 167   Buffer.add_char b c;
 168   Buffer.contents b;
 169 ;;
 170
 171 let btod b = if b then 1 else 0;;
 172
 173 let splitatspace s = let open String in
 174   match index s ' ' with
 175   | pos -> sub s 0 pos :: sub s (pos+1) (length s - pos - 1) :: []
 176   | exception Not_found -> [s]
 177 ;;
 178
 179 let boundastep h step =
 180   if step < 0
 181   then bound step ~-h 0
 182   else bound step 0 h
 183 ;;
 184
 185 let withoutlastutf8 s =
 186   let len = String.length s in
 187   if len = 0
 188   then s
 189   else
 190     let rec find pos =
 191       if pos = 0
 192       then pos
 193       else
 194         let b = Char.code s.[pos] in
 195         if b land 0b11000000 = 0b11000000
 196         then pos
 197         else find (pos-1)
 198     in
 199     let first =
 200       if Char.code s.[len-1] land 0x80 = 0
 201       then len-1
 202       else find (len-1)
 203     in
 204     String.sub s 0 first;
 205 ;;
 206
 207 let fdcontents fd =
 208   let l = 4096 in
 209   let b = Buffer.create l in
 210   let s = Bytes.create l in
 211   let rec loop () =
 212     let n = tempfailureretry (Unix.read fd s 0) l in
 213     if n = 0
 214     then Buffer.contents b
 215     else (
 216       Buffer.add_subbytes b s 0 n;
 217       loop ()
 218     )
 219   in
 220   loop ()
 221 ;;
 222
 223 let filecontents path =
 224   let fd = Unix.openfile path [Unix.O_RDONLY] 0o0 in
 225   match fdcontents fd with
 226   | (exception exn) ->
 227       error "failed to read contents of %s: %s" path @@ exntos exn
 228   | s ->
 229       Ne.clo fd @@ error "failed to close descriptor for %s: %s" path;
 230       s
 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 spawn 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 =
 279   let re = Str.regexp {|.*\(\(https?\|ftp\|mailto\|file\)://[^ ]+\).*|} in
 280   fun s ->
 281     if Str.string_match re s 0
 282     then Str.matched_group 1 s
 283     else E.s
 284 ;;