scripts/merjisforwiki.ml

   1 (* Basic Merjis functions.
   2  * Copyright (C) 2004 Merjis Ltd.
   3  * Written By Richard W.M. Jones (rich@merjis.com)
   4  * $Id: merjisforwiki.ml,v 1.1 2004/09/07 10:14:09 rich Exp $
   5  *)
   6
   7 (* This is a copy of an internal library which we use at Merjis. *)
   8
   9 open Printf
  10 open ExtString
  11 open ExtList
  12
  13 (*----- Basic stuff. -----*)
  14
  15 let identity x = x
  16
  17 let unique =
  18   let n = ref 0 in
  19   fun () -> incr n; !n
  20
  21 let rec range a b =
  22   if a <= b then
  23     a :: range (a+1) b
  24   else
  25     []
  26
  27 (*----- String functions. -----*)
  28
  29 let string_contains substr str =
  30   try String.find str substr; true
  31   with String.Invalid_string -> false
  32
  33 let string_of_char = String.make 1
  34
  35 let truncate n str =
  36   if String.length str < n then str else String.sub str 0 (n-1)
  37
  38 (* These versions only work in the C locale for 7-bit characters. *)
  39 let isspace c =
  40   c = ' '
  41   (* || c = '\f' *) || c = '\n' || c = '\r' || c = '\t' (* || c = '\v' *)
  42
  43 let isalpha c =
  44   c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z'
  45
  46 let isdigit c =
  47   c >= '0' && c <= '9'
  48
  49 let isalnum c =
  50   c >= '0' && c <= '9' || c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z'
  51
  52 let islower c =
  53   c >= 'a' && c <= 'z'
  54
  55 let isupper c =
  56   c >= 'A' && c <= 'Z'
  57
  58 let isxdigit c =
  59   c >= '0' && c <= '9' || c >= 'a' && c <= 'f' || c >= 'A' && c <= 'F'
  60
  61 let triml ?(test = isspace) str =
  62   let i = ref 0 in
  63   let n = ref (String.length str) in
  64   while !n > 0 && test str.[!i]; do
  65     decr n;
  66     incr i
  67   done;
  68   if !i = 0 then str
  69   else String.sub str !i !n
  70
  71 let trimr ?(test = isspace) str =
  72   let n = ref (String.length str) in
  73   while !n > 0 && test str.[!n-1]; do
  74     decr n
  75   done;
  76   if !n = String.length str then str
  77   else String.sub str 0 !n
  78
  79 let trim ?(test = isspace) str =
  80   trimr (triml str)
  81
  82 let string_for_all f str =
  83   let len = String.length str in
  84   let rec loop i =
  85     if i = len then true
  86     else (
  87       let c = str.[i] in
  88       if not (f c) then false
  89       else loop (i+1)
  90     )
  91   in
  92   loop 0
  93
  94 let string_exists f str =
  95   let len = String.length str in
  96   let rec loop i =
  97     if i = len then false
  98     else (
  99       let c = str.[i] in
 100       if f c then true
 101       else loop (i+1)
 102     )
 103   in
 104   loop 0
 105
 106 let string_is_whitespace = string_for_all isspace
 107
 108 (*----- List functions. -----*)
 109
 110 let first n xs =
 111   fst (List.split_nth n xs)
 112
 113 let rec uniq ?(cmp = Pervasives.compare) = function
 114     [] -> []
 115   | [x] -> [x]
 116   | x :: y :: xs when compare x y = 0 ->
 117       uniq (x :: xs)
 118   | x :: y :: xs ->
 119       x :: uniq (y :: xs)
 120
 121 let sort_uniq ?cmp xs =
 122   let xs = List.sort ?cmp xs in
 123   let xs = uniq ?cmp xs in
 124   xs
 125
 126 let frequency ?(cmp = Pervasives.compare) xs =
 127   let xs = List.sort ~cmp xs in
 128   let rec loop = function
 129       [] -> []
 130     | [x] -> [1, x]
 131     | x :: y :: xs when cmp x y = 0 ->
 132         let rest = loop (y :: xs) in
 133         let (count, _), rest = List.hd rest, List.tl rest in
 134         (count+1, y) :: rest
 135     | x :: xs ->
 136         (1, x) :: loop xs
 137   in
 138   let xs = loop xs in
 139   List.rev (List.sort xs)
 140
 141 (* This version by Isaac Trotts. *)
 142 let group_by ?(cmp = Pervasives.compare) ls =
 143   let ls' =
 144     List.fold_left
 145       (fun acc (day1, x1) ->
 146          match acc with
 147              [] -> [day1, [x1]]
 148            | (day2, ls2) :: acctl ->
 149                if cmp day1 day2 = 0
 150                then (day1, x1 :: ls2) :: acctl
 151                else (day1, [x1]) :: acc)
 152       []
 153       ls
 154   in
 155   let ls' = List.rev ls' in
 156   List.map (fun (x, xs) -> x, List.rev xs) ls'
 157
 158 (*----- File functions. -----*)
 159
 160 let (//) = Filename.concat
 161
 162 let rec input_all_lines chan =
 163   try
 164     let line = input_line chan in
 165     line :: input_all_lines chan
 166   with
 167       End_of_file -> []
 168
 169 let input_all chan =
 170   let buf = Buffer.create 16384 in
 171   let tmpsize = 16384 in
 172   let tmp = String.create tmpsize in
 173   let n = ref 0 in
 174   while n := input chan tmp 0 tmpsize; !n > 0 do
 175     Buffer.add_substring buf tmp 0 !n;
 176   done;
 177   Buffer.contents buf
 178
 179 let input_file filename =
 180   let chan = open_in_bin filename in
 181   let data = input_all chan in
 182   close_in chan;
 183   data
 184
 185 let output_file filename data =
 186   let chan = open_out_bin filename in
 187   output_string chan data;
 188   close_out chan
 189
 190 let output_tempfile data =
 191   let filename, chan = Filename.open_temp_file "tmp" ".tmp" in
 192   output_string chan data;
 193   close_out chan;
 194   filename
 195
 196 (*----- Command functions. -----*)
 197
 198 let cmd cmd =
 199   let code = Sys.command cmd in
 200   if code <> 0 then failwith (cmd ^ ": error code " ^ string_of_int code)
 201
 202 let copy infile outfile =
 203   cmd (sprintf "cp %s %s" infile outfile)
 204
 205 let pget cmd =
 206   let chan = Unix.open_process_in cmd in
 207   let lines = input_all_lines chan in
 208   let stat = Unix.close_process_in chan in
 209   (match stat with
 210        Unix.WEXITED 0 -> ()
 211      | Unix.WEXITED i ->
 212          failwith ("command failed with code " ^ string_of_int i)
 213      | Unix.WSIGNALED i ->
 214          failwith ("command killed by signal " ^ string_of_int i)
 215      | Unix.WSTOPPED i ->
 216          failwith ("command stopped by signal " ^ string_of_int i));
 217   lines
 218
 219 let unlink file =
 220   try Unix.unlink file with Unix.Unix_error _ -> ()
 221
 222 (*----- Meta-functions. -----*)
 223 let notf f =
 224   fun v -> not (f v)
 225
 226 (*----- Time and date. -----*)
 227 let short_weekday = function
 228   | 0 -> "Sun" | 1 -> "Mon" | 2 -> "Tue" | 3 -> "Wed"
 229   | 4 -> "Thu" | 5 -> "Fri" | 6 -> "Sat" | 7 -> "Sun"
 230   | _ -> invalid_arg "short_weekday"
 231
 232 let short_month = function
 233   | 1 -> "Jan" | 2 -> "Feb" | 3 -> "Mar" | 4 -> "Apr"
 234   | 5 -> "May" | 6 -> "Jun" | 7 -> "Jul" | 8 -> "Aug"
 235   | 9 -> "Sep" | 10 -> "Oct" | 11 -> "Nov" | 12 -> "Dec"
 236   | _ -> invalid_arg "short_month"
 237
 238 (*----- Images. -----*)
 239
 240 (* Find the format of an image.  Uses the external 'identify' program,
 241  * part of ImageMagick.  Returns (mime_type, width, height).  Throws
 242  * Invalid_argument "image_identify" if the data is not an image.
 243  *)
 244 let image_identify_re = Pcre.regexp "^\\S+ ([A-Z]+) (\\d+)x(\\d+)"
 245
 246 let image_identify data =
 247   let filename = output_tempfile data in
 248   let in_chan = Unix.open_process_in ("identify " ^ filename) in
 249   let line = input_line in_chan in
 250   let status = Unix.close_process_in in_chan in
 251   unlink filename;
 252   (match status with
 253        Unix.WEXITED 0 ->                (* Identify was OK with it ... *)
 254          ()
 255      | Unix.WEXITED _ ->                (* Couldn't identify the file type. *)
 256          raise (Invalid_argument "image_identify")
 257      | Unix.WSIGNALED n ->
 258          failwith ("image_identify: 'identify' killed by signal " ^
 259                    string_of_int n)
 260      | Unix.WSTOPPED n ->
 261          failwith ("image_identify: 'identify' stopped by signal " ^
 262                    string_of_int n));
 263   try
 264     let subs = Pcre.exec ~rex:image_identify_re line in
 265     let type_string = Pcre.get_substring subs 1 in
 266     let width = int_of_string (Pcre.get_substring subs 2) in
 267     let height = int_of_string (Pcre.get_substring subs 3) in
 268     let typ =
 269       match type_string with
 270           "JPEG" -> "image/jpeg"
 271         | "GIF" -> "image/gif"
 272         | "PNG" -> "image/png"
 273         | _ -> raise (Invalid_argument "image_identify") in
 274     typ, width, height
 275   with
 276       Not_found ->
 277          raise (Invalid_argument "image_identify")
 278
 279 (* Make a thumbnail of an image.  This uses the ImageMagick program 'convert'.
 280  *)
 281 let image_thumbnail data max_width max_height =
 282   let filename = output_tempfile data in
 283   let cmd = sprintf "convert -size %dx%d %s -resize %dx%d -"
 284               max_width max_height filename max_width max_height in
 285   let in_chan = Unix.open_process_in cmd in
 286   let thumbnail = input_all in_chan in
 287   let status = Unix.close_process_in in_chan in
 288   unlink filename;
 289   (match status with
 290        Unix.WEXITED 0 ->                (* Convert was OK with it ... *)
 291          ()
 292      | Unix.WEXITED n ->                (* Convert failed. *)
 293          failwith ("convert: fail with error code " ^ string_of_int n)
 294      | Unix.WSIGNALED n ->
 295          failwith ("convert: killed by signal " ^ string_of_int n)
 296      | Unix.WSTOPPED n ->
 297          failwith ("convert: stopped by signal " ^ string_of_int n));
 298   let mime_type, width, height = image_identify thumbnail in
 299   thumbnail, mime_type, width, height
 300
 301 (*----- Files and MIME types. -----*)
 302
 303 let ws_re = Pcre.regexp "\\s+"
 304 let ext_re = Pcre.regexp "\\.([a-z0-9]+)$"
 305
 306 let mime_types =
 307   try
 308     let chan = open_in "/etc/mime.types" in
 309     let lines = input_all_lines chan in
 310     close_in chan;
 311     let lines = List.filter (fun line ->
 312                                not (string_is_whitespace line) &&
 313                                String.length line > 0 &&
 314                                line.[0] <> '#') lines in
 315     let res = ref [] in
 316     List.iter (fun line ->
 317                  let fields = Pcre.split ~rex:ws_re line in
 318                  match fields with
 319                      [] -> assert false
 320                    | typ :: exts ->
 321                        List.iter (fun ext ->
 322                                     res := (ext, typ) :: !res) exts) lines;
 323     !res
 324   with
 325       Sys_error _ -> []
 326
 327 let mime_type_of_filename name =
 328   try
 329     let subs = Pcre.exec ~rex:ext_re name in
 330     let ext = Pcre.get_substring subs 1 in
 331     let ext = String.lowercase ext in
 332     List.assoc ext mime_types
 333   with
 334       Not_found -> "application/octet-stream"