From 807220be0830826e99c4b74c5d6b41fe5ad2293e Mon Sep 17 00:00:00 2001 From: Stefano Zacchiroli Date: Mon, 7 Apr 2003 13:13:02 +0000 Subject: [PATCH] added zack's helpers --- helm/http_getter/zack.ml | 475 ++++++++++++++++++++++++++++++++++++++ helm/http_getter/zack.mli | 149 ++++++++++++ 2 files changed, 624 insertions(+) create mode 100644 helm/http_getter/zack.ml create mode 100644 helm/http_getter/zack.mli diff --git a/helm/http_getter/zack.ml b/helm/http_getter/zack.ml new file mode 100644 index 000000000..bc40f0c05 --- /dev/null +++ b/helm/http_getter/zack.ml @@ -0,0 +1,475 @@ +(* + * Zack's own OCaml library -- set of "helpers" function for the OCaml language + * + * Copyright (C) 2003: + * Stefano Zacchiroli + * + * This module is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This module is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this module; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + *) + +open Printf ;; + +exception Not_implemented ;; + +let (newline, newline_len) = + let default_newline = "\n" in + let newline = + match Sys.os_type with + | "Unix" -> "\n" + | "Win32" | "Cygwin" -> "\r\n" + | "MacOS" -> "\r" + | _ -> default_newline + in + (newline, String.length newline) +;; + +module ZLogic = + struct + + let non pred x = not (pred x) ;; + let conj p1 p2 x = (p1 x) && (p2 x) ;; + let disj p1 p2 x = (p1 x) || (p2 x) ;; + let imply p1 p2 x = (non p1) x || p2 x ;; + + let (&&&) = conj ;; + let (|||) = disj ;; + let (=>) = imply ;; + + end +;; + +module ZArray = + struct + + exception Found of int;; + + (** return the index of first element in ary on which pred is true *) + let index pred ary = + try + Array.iteri (fun idx e -> if pred e then raise (Found idx)) ary; + raise Not_found + with Found idx -> idx + ;; + (** as index but return the element itself instead of the index *) + let find pred ary = ary.(index pred ary) ;; + (** check if at least one element in ary satisfies pred *) + let exists pred ary = + try + ignore (find pred ary); + true + with Not_found -> false + ;; + (** check if all elements in ary satisfy pred *) + let for_all pred ary = not (exists (ZLogic.non pred) ary) ;; + + (** return a fresh array containing all elements of ary that satisfy pred + *) + let filter pred ary = + let indexes = (* indexes of element on which pred is satisfied *) + let (_, indexes) = + Array.fold_left + (fun (i, acc) e -> if pred e then (i+1, i::acc) else (i+1, acc)) + (0, []) + ary + in + List.rev indexes + in + let size = List.length indexes in + let newary = Array.make size ary.(0) in + let rec fill i = function + | [] -> () + | idx::tl -> + newary.(i) <- ary.(idx); + fill (i+1) tl + in + fill 0 indexes; + newary + ;; + + let lrotate () = + raise Not_implemented; () ;; + let rrotate () = + raise Not_implemented; () ;; + + end + +module ZDbm = + struct + (** fold on dbm key and values, processing order is not specified *) + let fold f init dbm = + let res = ref init in + Dbm.iter (fun key value -> res := f !res key value) dbm; + !res + ;; + end + +module ZHashtbl = + struct + let keys tbl = Hashtbl.fold (fun key _ acc -> key :: acc) tbl [] ;; + let values tbl = Hashtbl.fold (fun _ valu acc -> valu :: acc) tbl [] ;; + let remove_all tbl key = + for i = 1 to List.length (Hashtbl.find_all tbl key) do + Hashtbl.remove tbl key + done + ;; + end + +module ZList = + struct + (** tail recursive version of List.map *) + let map' f l = + let rec aux acc = function + | [] -> List.rev acc + | hd :: tl -> aux (f hd :: acc) tl + in + aux [] l + ;; + (** guarded map on lists. List.length output <= List.length input. + Not tail recursive *) + let rec map_if f pred = function + | [] -> [] + | hd::tl when pred hd -> f hd :: map_if f pred tl + | hd::tl -> map_if f pred tl + ;; + (** tail recursive version of map_if *) + let map_if' f pred l = + let rec aux acc = function + | [] -> List.rev acc + | hd::tl when pred hd -> aux (f hd :: acc) tl + | hd::tl -> aux acc tl + in + aux [] l + ;; + (** low level to implement assoc_all and assq_all *) + let assoc_all_gen eq key list = + let rec aux acc = function + | [] -> acc + | (k, v)::tl when (eq k key) -> aux (v :: acc) tl + | _::tl -> aux acc tl + in + List.rev (aux [] list) + ;; + (** return all binding of k in association list l in the order they appear + in l. Uses structural equality *) + let assoc_all k l = assoc_all_gen (=) k l ;; + (** as assoc_all but uses physical equality *) + let assq_all k l = assoc_all_gen (==) k l ;; + let lrotate = function + | [] -> raise (Invalid_argument "Zack.List.lrotate") + | hd::tl -> tl @ [hd] + ;; + let rrotate l = + match List.rev l with + | [] -> raise (Invalid_argument "Zack.List.rrotate") + | hd::tl -> hd :: List.rev tl + ;; + end + +module ZSys = + struct + let copy () = + raise Not_implemented; () ;; + end + +module ZUnix = + struct + + let mkdir () = + raise Not_implemented; () ;; + + let get_stats follow_symlink = + if follow_symlink then Unix.stat else Unix.lstat + ;; + (* low level for is_* predicates *) + let is_file_kind follow_symlink kind fname = + (get_stats follow_symlink fname).Unix.st_kind = kind + ;; + let is_regular ?(follow_symlink = true) = + is_file_kind follow_symlink Unix.S_REG ;; + let is_directory ?(follow_symlink = true) = + is_file_kind follow_symlink Unix.S_DIR ;; + let is_chardev ?(follow_symlink = true) = + is_file_kind follow_symlink Unix.S_CHR ;; + let is_blockdev ?(follow_symlink = true) = + is_file_kind follow_symlink Unix.S_BLK ;; + let is_symlink ?(follow_symlink = false) = + is_file_kind follow_symlink Unix.S_LNK ;; + let is_fifo ?(follow_symlink = true) = + is_file_kind follow_symlink Unix.S_FIFO ;; + let is_socket ?(follow_symlink = true) = + is_file_kind follow_symlink Unix.S_SOCK ;; + + let size ?(follow_symlink = true) fname = + (get_stats follow_symlink fname).Unix.st_size ;; + + (** return a list of all entries contained in a directory. Return order is + not specified *) + let ls dirname = + let dir = Unix.opendir dirname in + let rec aux acc = + match (try Some (Unix.readdir dir) with End_of_file -> None) with + | Some entry -> aux (entry :: acc) + | None -> acc + in + let res = aux [] in + Unix.closedir dir; + res + ;; + + end + +module ZString = + struct + + (** string -> char list *) + let explode s = + let chars = ref [] in + for i = String.length s - 1 downto 0 do + chars := s.[i] :: !chars + done; + !chars + ;; + + (** char list -> string *) + let implode l = + let buf = Buffer.create (List.length l) in + let rec implode' = function + | [] -> Buffer.contents buf + | hd::tl -> + Buffer.add_char buf hd; + implode' tl + in + implode' l + ;; + + (** perl's chomp, remove once trailing "\n", if any *) + let chomp s = + let len = String.length s in + let diff = len - newline_len in + if String.sub s diff newline_len = newline then (* trailing newline *) + String.sub s 0 diff + else + s + ;; + + (** map on string *) + let map f s = + for i = 0 to String.length s do + s.[i] <- f s.[i] + done + ;; + + (** fold_left on string *) + let fold_left f init s = + let len = String.length s in + let rec fold_left' idx acc = + if idx = len then + acc + else (* idx < len *) + fold_left' (idx + 1) (f acc s.[idx]) + in + fold_left' 0 init + ;; + + (* TODO Non funge *) + let fold_right f s init = + let len = String.length s in + let rec fold_right' idx acc = + if idx < 0 then + acc + else (* idx >= 0 *) + fold_right' (idx - 1) (f s.[idx] acc) + in + fold_right' len (init - 1) + ;; + + (** iter on string *) + let iter (f: char -> unit) = fold_left (fun _ c -> f c) () ;; + (* + let string_iter (f: char -> unit) s = + for i = 0 to String.length s do + f s.[i] + done + ;; + *) + + let filter () = + raise Not_implemented; () ;; + + (** create a string of length len and sets each char of them to the result + of applying f to the char's index *) + let init len f = + let str = String.create len in + for i = 0 to len - 1 do + str.[i] <- f i + done; + str + ;; + + end + +module ZRandom = + struct + + type ranges = (int * int) list + + let digit_range = [48, 57] ;; + let alpha_upper_range = [65, 90] ;; + let alpha_lower_range = [97, 122] ;; + let alpha_range = alpha_upper_range @ alpha_lower_range ;; + let alphanum_range = digit_range @ alpha_range ;; + let word_range = alphanum_range @ [95, 95] ;; (* alphanum + '_' *) + + let rec ranges_are_sane = function + | (min, max) :: tl -> + if min > max || min < 0 || max > 255 then + failwith (sprintf "ZRandom: invalid range %d .. %d" min max); + ranges_are_sane tl + | [] -> () + ;; + let size_of_ranges = (* assumption: ranges are sane *) + let rec aux acc = function + | [] -> acc + | ((min, max) as range) :: tl -> aux (acc + (max - min + 1)) tl + in + aux 0 + ;; + let nth_in_ranges idx ranges = (* assumption: ranges are sane *) + if ranges = [] then + failwith "ZRandom: no range provided"; + let rec aux idx = function + | [] -> assert false + | (min, max) :: tl -> + let nth = min + idx in + if nth <= max then nth else aux (nth - max - 1) tl + in + aux idx ranges + ;; + + (* low level for char and string *) + let char' ranges = + let int = Random.int (size_of_ranges ranges) in + Char.chr (nth_in_ranges int ranges) + ;; + + (** generate a random char inside provided ranges. Ranges are provided as + a list of int pairs. Each pair represent an inclusive interval of possible + character codes. Default range is [0, 255] *) + let char ?(ranges = [0,255]) () = + ranges_are_sane ranges; + char' ranges + ;; + + (** generate a string of random characters inside provided range *) + let string ?(ranges = [0,255]) len = + ranges_are_sane ranges; + ZString.init len (fun _ -> char' ranges) + ;; + + end + +module ZStream = + struct + + (** map on streams. Beware that this function build stream using + Stream.from. That kind of stream can't be mixed with ordinary streams *) + let map f stream = + Stream.from + (fun _ -> try Some (f (Stream.next stream)) with Stream.Failure -> None) + ;; + (** fold on streams. Beware that this function build stream using + Stream.from. That kind of stream can't be mixed with ordinary streams *) + let rec fold f init stream = + match (try Some (Stream.next stream) with Stream.Failure -> None) with + | Some item -> fold f (f init item) stream + | None -> init + ;; + + (** given an input channel return the stream of its lines (without + trailing new line) *) + let of_inchan ic = + Stream.from (fun _ -> try Some (input_line ic) with End_of_file -> None) + ;; + + end + + (** fold_left on input channel lines *) +let rec fold_in f init ic = + match (try Some (input_line ic) with End_of_file -> None) with + | Some l -> fold_in f (f init l) ic + | None -> init +;; + + (** iter on input channel lines *) +let iter_in f = fold_in (fun _ line -> f line) () ;; + + (** map on input channel lines *) +let map_in f ic = List.rev (fold_in (fun acc line -> f line :: acc) [] ic) ;; + + (** return list of lines read from an input channel *) +let input_lines ic = List.rev (fold_in (fun acc line -> line :: acc) [] ic) ;; + + (** read all data available on an input channel and return them as a string *) +let input_all = + let strlen = 8192 in + let buflen = 8192 * 2 in + let str = String.create strlen in + fun ic -> + let buf = Buffer.create buflen in + let rec input' () = + let bytes = input ic str 0 strlen in + if bytes = 0 then (* EOF *) + Buffer.contents buf + else begin + Buffer.add_substring buf str 0 bytes; + input' () + end + in + input' () +;; + + (** write a list of lines to an output channel. Newline is added at the end of + each line *) +let rec output_lines lines oc = + match lines with + | [] -> () + | hd::tl -> + output_string oc (hd ^ newline); + output_lines tl oc +;; + + (** read_lines on stdin *) +let read_lines () = input_lines stdin ;; + (** read_all on stdin *) +let read_all () = input_all stdin ;; + + (** Some constructor inverse *) +let unsome = function + | Some x -> x + | None -> raise (Invalid_argument "Zack.unsome") +;; + +module Array = ZArray ;; +module Dbm = ZDbm ;; +module Hashtbl = ZHashtbl ;; +module List = ZList ;; +module Logic = ZLogic ;; +module Random = ZRandom ;; +module Stream = ZStream ;; +module String = ZString ;; +module Sys = ZSys ;; +module Unix = ZUnix ;; + diff --git a/helm/http_getter/zack.mli b/helm/http_getter/zack.mli new file mode 100644 index 000000000..581bcfd05 --- /dev/null +++ b/helm/http_getter/zack.mli @@ -0,0 +1,149 @@ +(* + * Zack's own OCaml library -- set of "helpers" function for the OCaml language + * + * Copyright (C) 2003: + * Stefano Zacchiroli + * + * This module is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This module is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this module; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + *) + +exception Not_implemented + +val fold_in : ('a -> string -> 'a) -> 'a -> in_channel -> 'a +val iter_in : (string -> unit) -> in_channel -> unit +val map_in : (string -> 'a) -> in_channel -> 'a list +val input_lines : in_channel -> string list +val input_all : in_channel -> string +val output_lines : string list -> out_channel -> unit +val read_lines : unit -> string list +val read_all : unit -> string +val unsome : 'a option -> 'a + +module Array : + sig + val index : ('a -> bool) -> 'a array -> int + val find : ('a -> bool) -> 'a array -> 'a + + val exists : ('a -> bool) -> 'a array -> bool + val for_all : ('a -> bool) -> 'a array -> bool + + val filter : ('a -> bool) -> 'a array -> 'a array + +(* val lrotate : ?step:int -> 'a array -> 'a array *) +(* val rrotate : ?step:int -> 'a array -> 'a array *) + end + +module Dbm : + sig + val fold : ('a -> string -> string -> 'a) -> 'a -> Dbm.t -> 'a + end + +module Hashtbl : + sig + val keys : ('a, 'b) Hashtbl.t -> 'a list + val values : ('a, 'b) Hashtbl.t -> 'b list + + val remove_all : ('a, 'b) Hashtbl.t -> 'a -> unit + end + +module List : + sig + val map' : ('a -> 'b) -> 'a list -> 'b list + val map_if : ('a -> 'b) -> ('a -> bool) -> 'a list -> 'b list + val map_if' : ('a -> 'b) -> ('a -> bool) -> 'a list -> 'b list + + val assoc_all : 'a -> ('a * 'b) list -> 'b list + val assq_all : 'a -> ('a * 'b) list -> 'b list + + val lrotate : 'a list -> 'a list + val rrotate : 'a list -> 'a list +(* val List.lrotate: ?step:int -> 'a list -> 'a list *) +(* val List.rrotate: ?step:int -> 'a list -> 'a list *) + end + +module Logic : + sig + val non : ('a -> bool) -> 'a -> bool + val conj : ('a -> bool) -> ('a -> bool) -> 'a -> bool + val disj : ('a -> bool) -> ('a -> bool) -> 'a -> bool + val imply : ('a -> bool) -> ('a -> bool) -> 'a -> bool + + val ( &&& ) : ('a -> bool) -> ('a -> bool) -> 'a -> bool + val ( ||| ) : ('a -> bool) -> ('a -> bool) -> 'a -> bool + val ( => ) : ('a -> bool) -> ('a -> bool) -> 'a -> bool + end + +module Random : + sig + val digit_range : (int * int) list + val alpha_upper_range : (int * int) list + val alpha_lower_range : (int * int) list + val alpha_range : (int * int) list + val alphanum_range : (int * int) list + val word_range : (int * int) list + + val char : ?ranges:(int * int) list -> unit -> char + val string : ?ranges:(int * int) list -> int -> string + end + +module Stream : + sig + val map : ('a -> 'b) -> 'a Stream.t -> 'b Stream.t + val fold : ('a -> 'b -> 'a) -> 'a -> 'b Stream.t -> 'a + + val of_inchan : in_channel -> string Stream.t + end + +module String : + sig + val explode : string -> char list + val implode : char list -> string + + val chomp : string -> string + + val map : (char -> char) -> string -> unit + val fold_left : ('a -> char -> 'a) -> 'a -> string -> 'a +(* val fold_right : (char -> 'a -> 'a) -> string -> 'a -> 'a *) + val iter : (char -> unit) -> string -> unit +(* val filter : (char -> bool) -> string -> string *) + + val init : int -> (int -> char) -> string + end + +(* +module Sys : + sig + val copy : src:string -> dst:string -> unit + end +*) + +module Unix : + sig +(* val mkdir : ?parents:bool -> string -> unit *) + + val is_regular : ?follow_symlink:bool -> string -> bool + val is_directory : ?follow_symlink:bool -> string -> bool + val is_chardev : ?follow_symlink:bool -> string -> bool + val is_blockdev : ?follow_symlink:bool -> string -> bool + val is_symlink : ?follow_symlink:bool -> string -> bool + val is_fifo : ?follow_symlink:bool -> string -> bool + val is_socket : ?follow_symlink:bool -> string -> bool + + val size : ?follow_symlink:bool -> string -> int + + val ls : string -> string list + end + -- 2.39.2