helm/http_getter/zack.ml

   1 (*
   2  * Zack's own OCaml library -- set of "helpers" function for the OCaml language
   3  *
   4  * Copyright (C) 2003:
   5  *    Stefano Zacchiroli <zack@bononia.it>
   6  *
   7  *  This module is free software; you can redistribute it and/or
   8  *  modify it under the terms of the GNU General Public License
   9  *  as published by the Free Software Foundation; either version 2
  10  *  of the License, or (at your option) any later version.
  11  *
  12  *  This module is distributed in the hope that it will be useful,
  13  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  *  GNU General Public License for more details.
  16  *
  17  *  You should have received a copy of the GNU General Public License
  18  *  along with this module; if not, write to the Free Software
  19  *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  20  *  MA  02111-1307, USA.
  21  *)
  22
  23 open Printf ;;
  24
  25 exception Not_implemented ;;
  26
  27 let (newline, newline_len) =
  28   let default_newline = "\n" in
  29   let newline =
  30     match Sys.os_type with
  31     | "Unix" -> "\n"
  32     | "Win32" | "Cygwin" -> "\r\n"
  33     | "MacOS" -> "\r"
  34     | _ -> default_newline
  35   in
  36   (newline, String.length newline)
  37 ;;
  38
  39 module ZLogic =
  40   struct
  41
  42     let non pred x = not (pred x) ;;
  43     let conj p1 p2 x = (p1 x) && (p2 x) ;;
  44     let disj p1 p2 x = (p1 x) || (p2 x) ;;
  45     let imply p1 p2 x = (non p1) x || p2 x ;;
  46
  47     let (&&&) = conj ;;
  48     let (|||) = disj ;;
  49     let (=>) = imply ;;
  50
  51   end
  52 ;;
  53
  54 module ZArray =
  55   struct
  56
  57     exception Found of int;;
  58
  59       (** return the index of first element in ary on which pred is true *)
  60     let index pred ary =
  61       try
  62         Array.iteri (fun idx e -> if pred e then raise (Found idx)) ary;
  63         raise Not_found
  64       with Found idx -> idx
  65     ;;
  66       (** as index but return the element itself instead of the index *)
  67     let find pred ary = ary.(index pred ary) ;;
  68       (** check if at least one element in ary satisfies pred *)
  69     let exists pred ary =
  70       try
  71         ignore (find pred ary);
  72         true
  73       with Not_found -> false
  74     ;;
  75       (** check if all elements in ary satisfy pred *)
  76     let for_all pred ary = not (exists (ZLogic.non pred) ary) ;;
  77
  78       (** return a fresh array containing all elements of ary that satisfy pred
  79       *)
  80     let filter pred ary =
  81       let indexes = (* indexes of element on which pred is satisfied *)
  82         let (_, indexes) =
  83           Array.fold_left
  84             (fun (i, acc) e -> if pred e then (i+1, i::acc) else (i+1, acc))
  85             (0, [])
  86             ary
  87         in
  88         List.rev indexes
  89       in
  90       let size = List.length indexes in
  91       let newary = Array.make size ary.(0) in
  92       let rec fill i = function
  93         | [] -> ()
  94         | idx::tl ->
  95             newary.(i) <- ary.(idx);
  96             fill (i+1) tl
  97       in
  98       fill 0 indexes;
  99       newary
 100     ;;
 101
 102     let lrotate () =
 103       raise Not_implemented; () ;;
 104     let rrotate () =
 105       raise Not_implemented; () ;;
 106
 107   end
 108
 109 module ZDbm =
 110   struct
 111       (** fold on dbm key and values, processing order is not specified *)
 112     let fold f init dbm =
 113       let res = ref init in
 114       Dbm.iter (fun key value -> res := f !res key value) dbm;
 115       !res
 116     ;;
 117   end
 118
 119 module ZHashtbl =
 120   struct
 121     let keys tbl = Hashtbl.fold (fun key _ acc -> key :: acc) tbl [] ;;
 122     let values tbl = Hashtbl.fold (fun _ valu acc -> valu :: acc) tbl [] ;;
 123     let remove_all tbl key =
 124       for i = 1 to List.length (Hashtbl.find_all tbl key) do
 125         Hashtbl.remove tbl key
 126       done
 127     ;;
 128   end
 129
 130 module ZList =
 131   struct
 132       (** tail recursive version of List.map *)
 133     let map' f l =
 134       let rec aux acc = function
 135         | [] -> List.rev acc
 136         | hd :: tl -> aux (f hd :: acc) tl
 137       in
 138       aux [] l
 139     ;;
 140       (** guarded map on lists. List.length output <= List.length input.
 141       Not tail recursive *)
 142     let rec map_if f pred = function
 143       | [] -> []
 144       | hd::tl when pred hd -> f hd :: map_if f pred tl
 145       | hd::tl -> map_if f pred tl
 146     ;;
 147       (** tail recursive version of map_if *)
 148     let map_if' f pred l =
 149       let rec aux acc = function
 150         | [] -> List.rev acc
 151         | hd::tl when pred hd -> aux (f hd :: acc) tl
 152         | hd::tl -> aux acc tl
 153       in
 154       aux [] l
 155     ;;
 156       (** low level to implement assoc_all and assq_all *)
 157     let assoc_all_gen eq key list =
 158       let rec aux acc = function
 159         | [] -> acc
 160         | (k, v)::tl when (eq k key) -> aux (v :: acc) tl
 161         | _::tl -> aux acc tl
 162       in
 163       List.rev (aux [] list)
 164     ;;
 165       (** return all binding of k in association list l in the order they appear
 166       in l. Uses structural equality *)
 167     let assoc_all k l = assoc_all_gen (=) k l ;;
 168       (** as assoc_all but uses physical equality *)
 169     let assq_all k l = assoc_all_gen (==) k l ;;
 170     let lrotate = function
 171       | [] -> raise (Invalid_argument "Zack.List.lrotate")
 172       | hd::tl -> tl @ [hd]
 173     ;;
 174     let rrotate l =
 175       match List.rev l with
 176       | [] -> raise (Invalid_argument "Zack.List.rrotate")
 177       | hd::tl -> hd :: List.rev tl
 178     ;;
 179   end
 180
 181 module ZSys =
 182   struct
 183     let copy () =
 184       raise Not_implemented; () ;;
 185   end
 186
 187 module ZUnix =
 188   struct
 189
 190     let mkdir () =
 191       raise Not_implemented; () ;;
 192
 193     let get_stats follow_symlink =
 194       if follow_symlink then Unix.stat else Unix.lstat
 195     ;;
 196       (* low level for is_* predicates *)
 197     let is_file_kind follow_symlink kind fname =
 198       (get_stats follow_symlink fname).Unix.st_kind = kind
 199     ;;
 200     let is_regular ?(follow_symlink = true) =
 201       is_file_kind follow_symlink Unix.S_REG ;;
 202     let is_directory ?(follow_symlink = true) =
 203       is_file_kind follow_symlink Unix.S_DIR ;;
 204     let is_chardev ?(follow_symlink = true) =
 205       is_file_kind follow_symlink Unix.S_CHR ;;
 206     let is_blockdev ?(follow_symlink = true) =
 207       is_file_kind follow_symlink Unix.S_BLK ;;
 208     let is_symlink ?(follow_symlink = false) =
 209       is_file_kind follow_symlink Unix.S_LNK ;;
 210     let is_fifo ?(follow_symlink = true) =
 211       is_file_kind follow_symlink Unix.S_FIFO ;;
 212     let is_socket ?(follow_symlink = true) =
 213       is_file_kind follow_symlink Unix.S_SOCK ;;
 214
 215     let size ?(follow_symlink = true) fname =
 216       (get_stats follow_symlink fname).Unix.st_size ;;
 217
 218       (** return a list of all entries contained in a directory. Return order is
 219       not specified *)
 220     let ls dirname =
 221       let dir = Unix.opendir dirname in
 222       let rec aux acc =
 223         match (try Some (Unix.readdir dir) with End_of_file -> None) with
 224         | Some entry -> aux (entry :: acc)
 225         | None -> acc
 226       in
 227       let res = aux [] in
 228       Unix.closedir dir;
 229       res
 230     ;;
 231
 232   end
 233
 234 module ZString =
 235   struct
 236
 237       (** string -> char list *)
 238     let explode s =
 239       let chars = ref [] in
 240       for i = String.length s - 1 downto 0 do
 241         chars := s.[i] :: !chars
 242       done;
 243       !chars
 244     ;;
 245
 246       (** char list -> string *)
 247     let implode l =
 248       let buf = Buffer.create (List.length l) in
 249       let rec implode' = function
 250         | [] -> Buffer.contents buf
 251         | hd::tl ->
 252             Buffer.add_char buf hd;
 253             implode' tl
 254       in
 255       implode' l
 256     ;;
 257
 258       (** perl's chomp, remove once trailing "\n", if any *)
 259     let chomp s =
 260       let len = String.length s in
 261       let diff = len - newline_len in
 262       if String.sub s diff newline_len = newline then (* trailing newline *)
 263         String.sub s 0 diff
 264       else
 265         s
 266     ;;
 267
 268       (** map on string *)
 269     let map f s =
 270       for i = 0 to String.length s do
 271         s.[i] <- f s.[i]
 272       done
 273     ;;
 274
 275       (** fold_left on string *)
 276     let fold_left f init s =
 277       let len = String.length s in
 278       let rec fold_left' idx acc =
 279         if idx = len then
 280           acc
 281         else (* idx < len *)
 282           fold_left' (idx + 1) (f acc s.[idx])
 283       in
 284       fold_left' 0 init
 285     ;;
 286
 287     (* TODO Non funge *)
 288     let fold_right f s init =
 289       let len = String.length s in
 290       let rec fold_right' idx acc =
 291         if idx < 0 then
 292           acc
 293         else  (* idx >= 0 *)
 294           fold_right' (idx - 1) (f s.[idx] acc)
 295       in
 296       fold_right' len (init - 1)
 297     ;;
 298
 299       (** iter on string *)
 300     let iter (f: char -> unit) = fold_left (fun _ c -> f c) () ;;
 301     (*
 302     let string_iter (f: char -> unit) s =
 303       for i = 0 to String.length s do
 304         f s.[i]
 305       done
 306     ;;
 307     *)
 308
 309     let filter () =
 310       raise Not_implemented; () ;;
 311
 312       (** create a string of length len and sets each char of them to the result
 313       of applying f to the char's index *)
 314     let init len f =
 315       let str = String.create len in
 316       for i = 0 to len - 1 do
 317         str.[i] <- f i
 318       done;
 319       str
 320     ;;
 321
 322   end
 323
 324 module ZRandom =
 325   struct
 326
 327     type ranges = (int * int) list
 328
 329     let digit_range = [48, 57] ;;
 330     let alpha_upper_range = [65, 90] ;;
 331     let alpha_lower_range = [97, 122] ;;
 332     let alpha_range = alpha_upper_range @ alpha_lower_range ;;
 333     let alphanum_range = digit_range @ alpha_range ;;
 334     let word_range = alphanum_range @ [95, 95] ;; (* alphanum + '_' *)
 335
 336     let rec ranges_are_sane = function
 337       | (min, max) :: tl ->
 338           if min > max || min < 0 || max > 255 then
 339             failwith (sprintf "ZRandom: invalid range %d .. %d" min max);
 340           ranges_are_sane tl
 341       | [] -> ()
 342     ;;
 343     let size_of_ranges =  (* assumption: ranges are sane *)
 344       let rec aux acc = function
 345         | [] -> acc
 346         | ((min, max) as range) :: tl -> aux (acc + (max - min + 1)) tl
 347       in
 348       aux 0
 349     ;;
 350     let nth_in_ranges idx ranges =  (* assumption: ranges are sane *)
 351       if ranges = [] then
 352         failwith "ZRandom: no range provided";
 353       let rec aux idx = function
 354         | [] -> assert false
 355         | (min, max) :: tl ->
 356             let nth = min + idx in
 357             if nth <= max then nth else aux (nth - max - 1) tl
 358       in
 359       aux idx ranges
 360     ;;
 361
 362       (* low level for char and string *)
 363     let char' ranges =
 364       let int = Random.int (size_of_ranges ranges) in
 365       Char.chr (nth_in_ranges int ranges)
 366     ;;
 367
 368       (** generate a random char inside provided ranges. Ranges are provided as
 369       a list of int pairs. Each pair represent an inclusive interval of possible
 370       character codes. Default range is [0, 255] *)
 371     let char ?(ranges = [0,255]) () =
 372       ranges_are_sane ranges;
 373       char' ranges
 374     ;;
 375
 376       (** generate a string of random characters inside provided range *)
 377     let string ?(ranges = [0,255]) len =
 378       ranges_are_sane ranges;
 379       ZString.init len (fun _ -> char' ranges)
 380     ;;
 381
 382   end
 383
 384 module ZStream =
 385   struct
 386
 387       (** map on streams. Beware that this function build stream using
 388       Stream.from. That kind of stream can't be mixed with ordinary streams *)
 389     let map f stream =
 390       Stream.from
 391         (fun _ -> try Some (f (Stream.next stream)) with Stream.Failure -> None)
 392     ;;
 393       (** fold on streams. Beware that this function build stream using
 394       Stream.from. That kind of stream can't be mixed with ordinary streams *)
 395     let rec fold f init stream =
 396       match (try Some (Stream.next stream) with Stream.Failure -> None) with
 397       | Some item -> fold f (f init item) stream
 398       | None -> init
 399     ;;
 400
 401       (** given an input channel return the stream of its lines (without
 402       trailing new line) *)
 403     let of_inchan ic =
 404       Stream.from (fun _ -> try Some (input_line ic) with End_of_file -> None)
 405     ;;
 406
 407   end
 408
 409   (** fold_left on input channel lines *)
 410 let rec fold_in f init ic =
 411   match (try Some (input_line ic) with End_of_file -> None) with
 412   | Some l -> fold_in f (f init l) ic
 413   | None -> init
 414 ;;
 415
 416   (** iter on input channel lines *)
 417 let iter_in f = fold_in (fun _ line -> f line) () ;;
 418
 419   (** map on input channel lines *)
 420 let map_in f ic = List.rev (fold_in (fun acc line -> f line :: acc) [] ic) ;;
 421
 422   (** return list of lines read from an input channel *)
 423 let input_lines ic = List.rev (fold_in (fun acc line -> line :: acc) [] ic) ;;
 424
 425   (** read all data available on an input channel and return them as a string *)
 426 let input_all =
 427   let strlen = 8192 in
 428   let buflen = 8192 * 2 in
 429   let str = String.create strlen in
 430   fun ic ->
 431     let buf = Buffer.create buflen in
 432     let rec input' () =
 433       let bytes = input ic str 0 strlen in
 434       if bytes = 0 then (* EOF *)
 435         Buffer.contents buf
 436       else begin
 437         Buffer.add_substring buf str 0 bytes;
 438         input' ()
 439       end
 440     in
 441     input' ()
 442 ;;
 443
 444   (** write a list of lines to an output channel. Newline is added at the end of
 445   each line *)
 446 let rec output_lines lines oc =
 447   match lines with
 448   | [] -> ()
 449   | hd::tl ->
 450       output_string oc (hd ^ newline);
 451       output_lines tl oc
 452 ;;
 453
 454   (** read_lines on stdin *)
 455 let read_lines () = input_lines stdin ;;
 456   (** read_all on stdin *)
 457 let read_all () = input_all stdin ;;
 458
 459   (** Some constructor inverse *)
 460 let unsome  = function
 461   | Some x -> x
 462   | None -> raise (Invalid_argument "Zack.unsome")
 463 ;;
 464
 465 module Array = ZArray ;;
 466 module Dbm = ZDbm ;;
 467 module Hashtbl = ZHashtbl ;;
 468 module List = ZList ;;
 469 module Logic = ZLogic ;;
 470 module Random = ZRandom ;;
 471 module Stream = ZStream ;;
 472 module String = ZString ;;
 473 module Sys = ZSys ;;
 474 module Unix = ZUnix ;;
 475