From d75317253d202f44f3d84c8d0a5a57450e7b797f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 4 Nov 2014 20:56:38 +0100 Subject: [PATCH] remove some junk from misc/ --- _oasis | 8 +- misc/actionMan.ml | 159 ----------------- misc/actionMan.mli | 94 ---------- misc/bencode.ml | 363 -------------------------------------- misc/bencode.mli | 130 -------------- misc/bencodeOnDisk.ml | 136 -------------- misc/bencodeOnDisk.mli | 60 ------- misc/bencodeStream.ml | 156 ---------------- misc/bencodeStream.mli | 65 ------- misc/bencode_write_par.sh | 13 -- misc/bij.ml | 136 -------------- misc/bij.mli | 22 --- misc/tell.ml | 111 ------------ misc/tell.mli | 73 -------- tests/run_tests.ml | 3 - tests/test_bencode.ml | 71 -------- tests/test_bij.ml | 91 ---------- 17 files changed, 3 insertions(+), 1688 deletions(-) delete mode 100644 misc/actionMan.ml delete mode 100644 misc/actionMan.mli delete mode 100644 misc/bencode.ml delete mode 100644 misc/bencode.mli delete mode 100644 misc/bencodeOnDisk.ml delete mode 100644 misc/bencodeOnDisk.mli delete mode 100644 misc/bencodeStream.ml delete mode 100644 misc/bencodeStream.mli delete mode 100755 misc/bencode_write_par.sh delete mode 100644 misc/tell.ml delete mode 100644 misc/tell.mli delete mode 100644 tests/test_bencode.ml delete mode 100644 tests/test_bij.ml diff --git a/_oasis b/_oasis index c289206a..73a75682 100644 --- a/_oasis +++ b/_oasis @@ -80,11 +80,9 @@ Library "containers_misc" Modules: Cache, FHashtbl, FlatHashtbl, Hashset, Heap, LazyGraph, PersistentGraph, PHashtbl, SkipList, SplayTree, SplayMap, Univ, - Bij, PiCalculus, Bencode, RAL, - UnionFind, SmallSet, AbsSet, CSM, - ActionMan, BencodeOnDisk, TTree, PrintBox, - HGraph, Automaton, Conv, Bidir, Iteratee, BTree, - Ty, Tell, BencodeStream, RatTerm, Cause, AVL, ParseReact + Bij, PiCalculus, RAL, UnionFind, SmallSet, AbsSet, CSM, + TTree, PrintBox, HGraph, Automaton, Conv, Bidir, Iteratee, + BTree, Ty, Cause, AVL, ParseReact BuildDepends: unix,containers FindlibName: misc FindlibParent: containers diff --git a/misc/actionMan.ml b/misc/actionMan.ml deleted file mode 100644 index 025df2a6..00000000 --- a/misc/actionMan.ml +++ /dev/null @@ -1,159 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {6 Action Language for command line} *) - -module Action = struct - type trigger = string - - type _ t = - | Return : 'a -> 'a t - | Bind : 'a t * ('a -> 'b t) -> 'b t - | Ignore : ('a t * 'b t) -> 'b t - | Any : string t - | ReadInt : (int -> 'a t) -> 'a t - | ReadString : (string -> 'a t) -> 'a t - | ReadBool : (bool -> 'a t) -> 'a t - | Choice : 'a t list -> 'a t - | Fail : string -> 'a t - - let return x = Return x - - let (>>=) x f = Bind (x, f) - - let (>>) x f = Bind (x, (fun _ -> f ())) - - let ( *>) a b = Ignore (a, b) - - let ignore x = x *> return () - - let any = Any - - let accept trigger = - Any >>= fun x -> - if x = trigger - then return () - else Fail ("expected trigger \"" ^ trigger ^ "\"") - - let with_string ?trigger f = - match trigger with - | None -> ReadString f - | Some t -> accept t *> ReadString f - - let with_int ?trigger f = - match trigger with - | None -> ReadInt f - | Some t -> accept t *> ReadInt f - - let with_bool ?trigger f = - match trigger with - | None -> ReadBool f - | Some t -> accept t *> ReadBool f - - let choice l = Choice l - - let repeat act = - let rec try_next acc = - choice - [ act >>= (fun x -> try_next (x::acc)) - ; return acc - ] - in - (try_next []) >>= (fun l -> return (List.rev l)) - - let opt act = - choice [ act >>= (fun x -> return (Some x)); return None ] - - let fail msg = Fail msg -end - -type 'a result = - | Ok of 'a - | Error of string - -type 'a partial_result = - | POk of 'a * int (* value and position in args *) - | PError of string (* error message *) - -let parse_args args (act : 'a Action.t) : 'a result = - let module A = Action in - (* interpret recursively, with backtracking. Returns partial result *) - let rec interpret : type a. string array -> int -> a Action.t -> a partial_result - = fun args i act -> - let n = Array.length args in - match act with - | A.Return x -> POk (x, i) - | A.Bind (x, f) -> - begin match interpret args i x with - | POk (x, i') -> interpret args i' (f x) - | PError msg -> PError msg - end - | A.Ignore (a, b) -> - begin match interpret args i a with - | POk (_, i') -> interpret args i' b - | PError msg -> PError msg - end - | A.Any when i >= n -> mk_error i "expected [any], reached end" - | A.Any -> POk (args.(i), i+1) - | A.ReadInt f when i >= n -> mk_error i "expected [int], reached end" - | A.ReadInt f -> - begin try - let j = int_of_string args.(i) in - interpret args (i+1) (f j) - with Failure _ -> mk_error i "expected [int]" - end - | A.ReadString _ when i >= n -> mk_error i "expected [string], reached end" - | A.ReadString f -> interpret args (i+1) (f args.(i)) - | A.ReadBool _ -> failwith "not implemented: read bool" (* TODO *) - | A.Fail msg -> mk_error i msg - | A.Choice l -> try_choices args i [] l - (* try the actions remaining in [l], whenre [errors] is the list - of errors in already tried branches *) - and try_choices : type a. string array -> int -> string list -> a Action.t list -> a partial_result - = fun args i errors l -> - match l with - | [] -> - let msg = Printf.sprintf "choice failed: [%s]" (String.concat " | " errors) in - mk_error i msg - | act::l' -> - begin match interpret args i act with - | POk _ as res -> res (* success! *) - | PError msg -> - try_choices args i (msg :: errors) l' - end - (* report error *) - and mk_error : type a. int -> string -> a partial_result - = fun i msg -> - PError (Printf.sprintf "at arg %d: %s" i msg) - in - match interpret args 1 act with - | POk (x,_) -> Ok x - | PError msg -> Error msg - -let parse act = parse_args Sys.argv act - -let print_doc oc act = - failwith "print_doc: not implemented" diff --git a/misc/actionMan.mli b/misc/actionMan.mli deleted file mode 100644 index bcced976..00000000 --- a/misc/actionMan.mli +++ /dev/null @@ -1,94 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {6 Action Language for command line} *) - -(** {2 Command-line Actions} *) - -module Action : sig - type 'a t - (** Action returning a 'a *) - - type trigger = string - (** Trigger a given action, based on the next token *) - - val return : 'a -> 'a t - (** Return a pure value *) - - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - (** CCSequence of arguments *) - - val (>>) : 'a t -> (unit -> 'b t) -> 'b t - (** Same as {! (>>=)}, but ignores the result of left side *) - - val ( *>) : 'a t -> 'b t -> 'b t - (** Accept left, then returns right *) - - val accept : trigger -> unit t - (** Accept the given trigger, fails otherwise *) - - val any : string t - (** Any token *) - - val with_string : ?trigger:trigger -> (string -> 'a t) -> 'a t - (** Command that takes a string *) - - val with_int : ?trigger:trigger -> (int -> 'a t) -> 'a t - (** Command that takes an integer *) - - val with_bool : ?trigger:trigger -> (bool -> 'a t) -> 'a t - - val opt : 'a t -> 'a option t - (** Optional action *) - - val repeat : 'a t -> 'a list t - (** Repeated action *) - - val choice : 'a t list -> 'a t - (** Choice between options. The first option of the list that - does not fail will be the result (backtracking is used!) *) - - val ignore : 'a t -> unit t - (** Ignore result *) - - val fail : string -> 'a t - (** Fail with given message *) -end - -(** {2 Main interface} *) - -type 'a result = - | Ok of 'a - | Error of string - -val parse_args : string array -> 'a Action.t -> 'a result - (** Parse given command line *) - -val parse : 'a Action.t -> 'a result - (** Parse Sys.argv *) - -val print_doc : out_channel -> 'a Action.t -> unit - (** Print documentation on given channel *) diff --git a/misc/bencode.ml b/misc/bencode.ml deleted file mode 100644 index 04e64656..00000000 --- a/misc/bencode.ml +++ /dev/null @@ -1,363 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {6 B-encoding} *) - - -module SMap = Map.Make(String) - -type t = - | I of int - | S of string - | L of t list - | D of t SMap.t - -let rec eq t1 t2 = match t1, t2 with - | I i1, I i2 -> i1 = i2 - | S s1, S s2 -> s1 = s2 - | L l1, L l2 -> - (try List.for_all2 eq l1 l2 with Invalid_argument _ -> false) - | D d1, D d2 -> - SMap.equal eq d1 d2 - | _ -> false - -let hash t = Hashtbl.hash t - -let dict_of_list l = - let d = List.fold_left - (fun d (k, v) -> SMap.add k v d) - SMap.empty l - in - D d - -(** {2 Serialization (encoding)} *) - -(* length of an encoded int, in bytes *) -let _len_int i = - match i with - | 0 -> 1 - | _ when i < 0 -> 2 + int_of_float (log10 (float_of_int ~-i)) - | _ -> 1 + int_of_float (log10 (float_of_int i)) - -(* length of an encoded string, in bytes *) -let _len_str s = - _len_int (String.length s) + 1 + String.length s - -let rec size t = match t with - | I i -> 2 + _len_int i - | S s -> _len_str s - | L l -> List.fold_left (fun acc i -> acc + size i) 2 l - | D map -> SMap.fold (fun k v acc -> acc + _len_str k + size v) map 2 - -let write_in_string t buf o = - let pos = ref o in - let rec append t = match t with - | I i -> write_char 'i'; write_int i; write_char 'e' - | S s -> write_str s - | L l -> - write_char 'l'; - List.iter append l; - write_char 'e'; - | D m -> - write_char 'd'; - SMap.iter (fun key t' -> write_str key; append t') m; - write_char 'e' - and write_int i = - let s = string_of_int i in - String.blit s 0 buf !pos (String.length s); - pos := !pos + String.length s - and write_str s = - write_int (String.length s); - write_char ':'; - String.blit s 0 buf !pos (String.length s); - pos := !pos + String.length s - and write_char c = - buf.[!pos] <- c; - incr pos - in - append t - -let to_string t = - let len = size t in - let s = String.create len in - write_in_string t s 0; - s - -let to_buf buf t = - Buffer.add_string buf (to_string t) - -let to_chan ch t = - let b = Buffer.create 25 in - to_buf b t; - Buffer.output_buffer ch b - -let fmt formatter t = - let b = Buffer.create 25 in - to_buf b t; - Format.pp_print_string formatter (Buffer.contents b) - -let rec pretty fmt t = match t with - | I i -> Format.fprintf fmt "%d" i - | S s -> Format.fprintf fmt "@[\"%s\"@]" s - | L l -> - Format.fprintf fmt "@[[@,"; - List.iteri (fun i t' -> (if i > 0 then Format.pp_print_char fmt ' '); pretty fmt t') l; - Format.fprintf fmt "]@]"; - | D d -> - Format.fprintf fmt "@[{@,"; - SMap.iter - (fun k t' -> Format.fprintf fmt "%a -> %a@ " pretty (S k) pretty t') - d; - Format.fprintf fmt "}@]"; - () - -let pretty_to_str t = - let b = Buffer.create 15 in - Format.fprintf (Format.formatter_of_buffer b) "%a@?" pretty t; - Buffer.contents b - -(** {2 Deserialization (decoding)} *) - -(** Deserialization is based on the {! decoder} type. Parsing can be - incremental, in which case the input is provided chunk by chunk and - the decoder contains the parsing state. Once a B-encoded value - has been parsed, other values can still be read. *) - -type decoder = { - mutable buf : string; (* buffer *) - mutable i : int; (* index in buf *) - mutable len : int; (* length of substring to read *) - mutable c : int; (* line *) - mutable l : int; (* column *) - mutable state : parse_result; - mutable stack : partial_state list; -} - -(** Result of parsing *) -and parse_result = - | ParseOk of t - | ParseError of string - | ParsePartial - -(** Partial state of the parser *) -and partial_state = - | PS_I of bool * int (* sign and integer *) - | PS_S of int ref * string (* index in string, plus string *) - | PS_L of t list - | PS_D of t SMap.t (* in dictionary *) - | PS_D_key of string * t SMap.t (* parsed key, wait for value *) - | PS_return of t (* bottom of stack *) - | PS_error of string (* error *) - -let mk_decoder () = - let dec = { - buf = ""; - i = 0; - len = 0; - c = 0; - l = 0; - state = ParsePartial; - stack = []; - } in - dec - -let is_empty dec = dec.len = 0 -let cur dec = dec.buf.[dec.i] - -let junk dec = - (* update line/column *) - (if cur dec = '\n' - then (dec.c <- 0; dec.l <- dec.l + 1) - else dec.c <- dec.c + 1); - dec.i <- dec.i + 1; - dec.len <- dec.len - 1 - -let next dec = - let c = cur dec in - junk dec; - c - -(* parse value *) -let rec parse_rec dec = - match dec.stack with - | [PS_return v] -> (* return value *) - dec.stack <- []; - dec.state <- ParseOk v; - dec.state - | [PS_error s] -> (* failure *) - dec.stack <- []; - dec.state <- ParseError s; - dec.state - | _ -> - if is_empty dec then ParsePartial (* wait *) - else begin - let c = next dec in - (match dec.stack, c with - | (PS_I (sign, i)) :: stack, '0' .. '9' -> - dec.stack <- PS_I (sign, (Char.code c - Char.code '0') + 10 * i) :: stack; - | (PS_I (_, 0)) :: stack, '-' -> - dec.stack <- PS_I (false, 0) :: stack (* negative number *) - | (PS_I (sign, i)) :: stack, 'e' -> - dec.stack <- stack; - push_value dec (I (if sign then i else ~- i)) - | ((PS_D _ | PS_D_key _ | PS_L _) :: _ | []), '0' .. '9' -> - (* initial length of string *) - dec.stack <- (PS_I (true, Char.code c - Char.code '0')) :: dec.stack - | (PS_I (sign, i)) :: stack, ':' -> - if i < 0 - then error dec "string length cannot be negative" - else if i = 0 then (* empty string *) - let _ = dec.stack <- stack in - push_value dec (S "") - else (* prepare to parse a string *) - dec.stack <- (PS_S (ref 0, String.create i)) :: stack; - | (PS_S (n, s)) :: stack, _ -> - s.[!n] <- c; - incr n; - (* value completed *) - (if !n = String.length s - then - let _ = dec.stack <- stack in - push_value dec (S s)); - | stack, 'i' -> - dec.stack <- (PS_I (true, 0)) :: stack - | stack, 'l' -> - dec.stack <- PS_L [] :: stack; - | stack, 'd' -> - dec.stack <- PS_D SMap.empty :: stack - | (PS_L l) :: stack, 'e' -> (* end of list *) - dec.stack <- stack; - push_value dec (L (List.rev l)) - | (PS_D d) :: stack, 'e' -> (* end of dict *) - dec.stack <- stack; - push_value dec (D d) - | (PS_D_key _) :: _, 'e' -> (* error *) - error dec "missing value in dict" - | _ -> (* generic error *) - error dec (Printf.sprintf "expected value, got %c" c)); - parse_rec dec - end -(* When a value is parsed, push it on the stack (possibly collapsing it) *) -and push_value dec v = - match v, dec.stack with - | _, [] -> - dec.stack <- [PS_return v] (* finished *) - | _, (PS_L l) :: stack -> - (* add to list *) - dec.stack <- (PS_L (v :: l)) :: stack; - | S key, ((PS_D d) :: stack) -> - (* new key for the map *) - dec.stack <- (PS_D_key (key, d)) :: stack; - | _, ((PS_D d) :: _) -> - (* error: key must be string *) - error dec "dict keys must be strings" - | _, (PS_D_key (key, d)) :: stack -> - (* new binding for the map *) - dec.stack <- (PS_D (SMap.add key v d)) :: stack; - | _ -> assert false -(* signal error *) -and error dec msg = - let msg = Printf.sprintf "Bencode: error at line %d, column %d: %s" - dec.l dec.c msg in - dec.stack <- [PS_error msg] - -(* exported parse function *) -let parse dec s i len = - (if i < 0 || i+len > String.length s - then invalid_arg "Bencode.parse: not a valid substring"); - (* add the input to [dec] *) - if dec.len = 0 - then begin - dec.buf <- String.copy s; - dec.i <- i; - dec.len <- len; - end else begin - (* use a buffer to merge the stored input and the new input *) - let buf' = String.create (dec.len + len - dec.i) in - String.blit dec.buf dec.i buf' 0 dec.len; - String.blit s i buf' dec.len len; - dec.buf <- buf'; - dec.i <- 0; - dec.len <- dec.len + len - dec.i; - end; - (* state machine *) - parse_rec dec - -let parse_resume d = parse_rec d - -let reset dec = - dec.l <- 0; - dec.c <- 0; - dec.i <- 0; - dec.len <- 0; - dec.state <- ParsePartial; - dec.stack <- []; - () - -let state dec = dec.state - -let rest dec = - String.sub dec.buf dec.i dec.len - -let rest_size dec = - dec.len - -let parse_string s = - let dec = mk_decoder () in - parse dec s 0 (String.length s) - -let of_string s = - match parse_string s with - | ParseOk t -> t - | ParsePartial -> invalid_arg "Bencode: partial parse" - | ParseError msg -> invalid_arg msg - -(** {2 Iterator} *) - -type 'a sequence = ('a -> unit) -> unit - -let of_seq seq = - fun k -> - let decoder = mk_decoder () in - (* read a string *) - let rec read_chunk str = - match parse decoder str 0 (String.length str) with - | ParseOk v -> - k v; (* yield, and parse the rest of the string *) - resume () - | ParseError e -> raise (Invalid_argument e) - | ParsePartial -> () (* wait for next chunk *) - and resume () = match parse_resume decoder with - | ParseOk v -> - k v; - resume () - | ParseError e -> raise (Invalid_argument e) - | ParsePartial -> () (* wait for next chunk *) - in - seq read_chunk - -let to_seq seq = - fun k -> seq (fun b -> k (to_string b)) - diff --git a/misc/bencode.mli b/misc/bencode.mli deleted file mode 100644 index 5af81b98..00000000 --- a/misc/bencode.mli +++ /dev/null @@ -1,130 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {6 B-encoding} *) - -(** This implements encoding and decoding using the {i B-encode} format. - See {{: http://en.wikipedia.org/wiki/Bencode} wikipedia} for more details - *) - -module SMap : Map.S with type key = string - -type t = - | I of int - | S of string - | L of t list - | D of t SMap.t - -val eq : t -> t -> bool -val hash : t -> int - -val dict_of_list : (string * t) list -> t - -(** {2 Serialization (encoding)} *) - -val size : t -> int - (** Size needed for serialization *) - -val write_in_string : t -> string -> int -> unit - (** [write_in_string v buf o] writes the value [v] in the string, - starting at offset [o]. The portion of the string starting from [o] - must be big enough (ie >= [size v]) *) - -val to_buf : Buffer.t -> t -> unit -val to_string : t -> string -val to_chan : out_channel -> t -> unit -val fmt : Format.formatter -> t -> unit - -val pretty : Format.formatter -> t -> unit - (** Print the tree itself, not its encoding *) - -val pretty_to_str : t -> string - (** Print the tree into a string *) - -(** {2 Deserialization (decoding)} *) - -(** Deserialization is based on the {! decoder} type. Parsing can be - incremental, in which case the input is provided chunk by chunk and - the decoder contains the parsing state. Once a B-encoded value - has been parsed, other values can still be read. - - This implementation does accept leading zeros, because it simplifies - the code. *) - -type decoder - (** Decoding state *) - -val mk_decoder : unit -> decoder - (** Create a new decoder *) - -type parse_result = - | ParseOk of t - | ParseError of string - | ParsePartial - -val parse : decoder -> string -> int -> int -> parse_result - (** [parse dec s i len] uses the partial state stored in [dec] and - the substring of [s] starting at index [i] with length [len]. - It can return an error, a value or just [ParsePartial] if - more input is needed *) - -val parse_resume : decoder -> parse_result - (** Resume where the previous call to {!parse} stopped (may have - returned a value while some input is not processed) *) - -val reset : decoder -> unit - (** Reset the decoder to its pristine state, ready to parse something - different. Before that, {! rest} and {! rest_size} can be used - to recover the part of the input that has not been consumed yet. *) - -val state : decoder -> parse_result - (** Current state of the decoder *) - -val rest : decoder -> string - (** What remains after parsing (the additional, unused input) *) - -val rest_size : decoder -> int - (** Length of [rest d]. 0 indicates that the whole input has been consumed. *) - -val parse_string : string -> parse_result - (** Parse a full value from this string. *) - -val of_string : string -> t - (** Parse the string. @raise Invalid_argument if it fails to parse. *) - -(** {2 Iterator} *) - -type 'a sequence = ('a -> unit) -> unit - -val of_seq : string sequence -> t sequence - (** Given a sequence of strings into Bencode values. Strings can be - the result of {!Unix.read}, for instance, they don't need to be - valid bencode individually; Only their concatenation should - be a valid stream of Bencode values. - - @raise Invalid_argument if a parsing error occurs. *) - -val to_seq : t sequence -> string sequence - (** Serialize each value in the sequence of Bencode values *) diff --git a/misc/bencodeOnDisk.ml b/misc/bencodeOnDisk.ml deleted file mode 100644 index 4fc55882..00000000 --- a/misc/bencodeOnDisk.ml +++ /dev/null @@ -1,136 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Serialize Bencode on disk with persistency guarantees} - - This module provides an append-only interface to some file, with - synchronized access and fsync() called after every write. - - It currently uses [Unix.O_SYNC] to guarantee that writes are saved to - the disk, so {b WRITES ARE SLOW}. On the other hand, several - processes can access the same file and append data without risks of - losing written values or race conditions. - - Similarly, reads are atomic (require locking) and provide only - a fold interface. - *) - -type t = { - file : Unix.file_descr; - lock_file : Unix.file_descr; -} - -let open_out ?lock filename = - let lock = match lock with - | None -> filename - | Some l -> l - in - let lock_file = Unix.openfile lock [Unix.O_CREAT; Unix.O_WRONLY] 0o644 in - let file = Unix.openfile filename - [Unix.O_CREAT; Unix.O_APPEND; Unix.O_WRONLY; Unix.O_SYNC] 0o644 - in - { file; lock_file; } - -let close_out out = - Unix.close out.file - -let write_string out s = - Unix.lockf out.lock_file Unix.F_LOCK 0; - try - (* go to the end of the file *) - ignore (Unix.lseek out.file 0 Unix.SEEK_END); - (* call write() until everything is written *) - let rec write_all n = - if n >= String.length s - then () - else - let n' = n + Unix.write out.file s n (String.length s - n) in - write_all n' - in - write_all 0; - Unix.lockf out.lock_file Unix.F_ULOCK 0; - with e -> - (* unlock in any case *) - Unix.lockf out.lock_file Unix.F_ULOCK 0; - raise e - -let write out b = - let s = Bencode.to_string b in - write_string out s - -let write_batch out l = - let buf = Buffer.create 255 in - List.iter (fun b -> Bencode.to_buf buf b) l; - let s = Buffer.contents buf in - write_string out s - -type 'a result = - | Ok of 'a - | Error of string - -let read ?lock filename acc f = - let lock = match lock with - | None -> filename - | Some l -> l - in - (* lock file before reading, to observe a consistent state *) - let lock_file = Unix.openfile lock [Unix.O_CREAT; Unix.O_RDONLY] 0o644 in - Unix.lockf lock_file Unix.F_RLOCK 0; - try - let file = Unix.openfile filename [Unix.O_RDONLY] 0o644 in - (* read bencode values *) - let decoder = Bencode.mk_decoder () in - let len = 256 in - let buf = String.create len in - (* read a chunk of input and parse it *) - let rec next_val acc = - let n = Unix.read file buf 0 len in - if n = 0 - then Ok acc (* finished *) - else match Bencode.parse decoder buf 0 n with - | Bencode.ParseOk v -> - let acc = f acc v in - resume acc - | Bencode.ParseError e -> Error e - | Bencode.ParsePartial -> next_val acc - (* consume what remains of input *) - and resume acc = match Bencode.parse_resume decoder with - | Bencode.ParseOk v -> - let acc = f acc v in - resume acc - | Bencode.ParseError e -> Error e - | Bencode.ParsePartial -> next_val acc - in - let res = next_val acc in - (* cleanup *) - Unix.close file; - Unix.lockf lock_file Unix.F_ULOCK 0; - Unix.close lock_file; - res - with e -> - Unix.lockf lock_file Unix.F_ULOCK 0; - Unix.close lock_file; - raise e diff --git a/misc/bencodeOnDisk.mli b/misc/bencodeOnDisk.mli deleted file mode 100644 index b55c1ef5..00000000 --- a/misc/bencodeOnDisk.mli +++ /dev/null @@ -1,60 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Serialize Bencode on disk with persistency guarantees} - - This module provides an append-only interface to some file, with - synchronized access and fsync() called after every write. - It needs {b Extunix} to compile (needs fsync). - *) - -type t - (** Handle to a file on which we can append values atomically *) - -val open_out : ?lock:string -> string -> t - (** Open the given file for appending values. Creates the file - if it doesn't exist. - @param lock, if provided, is the name of the lock file used. By default, - the file that is provided for writing is also used for locking. - @raise Unix.Unix_error if some IO error occurs. *) - -val close_out : t -> unit - (** Close the file descriptor *) - -val write : t -> Bencode.t -> unit - (** Write "atomically" a value to the end of the file *) - -val write_batch : t -> Bencode.t list -> unit - (** Write several values at once, at the end of the file *) - -type 'a result = - | Ok of 'a - | Error of string - -val read : ?lock:string -> string -> 'a -> ('a -> Bencode.t -> 'a) -> 'a result - (** Fold on values serialized in the given file. - @param lock see {!open_out}. - @raise Unix.Unix_error if some IO error occurs. *) diff --git a/misc/bencodeStream.ml b/misc/bencodeStream.ml deleted file mode 100644 index 5d2fa2fa..00000000 --- a/misc/bencodeStream.ml +++ /dev/null @@ -1,156 +0,0 @@ - -(* -copyright (c) 2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Full-Streaming API of Bencode} *) - -type token = - | Int of int - | String of string - | BeginDict - | BeginList - | End - -module Encode = struct - type sink = - [ `File of string - | `Out of out_channel - | `Buf of Buffer.t - ] - - type t = { - write_string : string -> unit; - write_char : char -> unit; - on_close : unit -> unit; - } - - let nop() = () - - let create = function - | `Out o -> - { write_string=output_string o - ; write_char=output_char o - ; on_close = nop - } - | `File f -> - let o = open_out f in - { write_string=output_string o - ; write_char=output_char o - ; on_close = (fun () -> close_out o) - } - | `Buf b -> - { write_string=Buffer.add_string b - ; write_char=Buffer.add_char b - ; on_close =nop - } - - let push out tok = match tok with - | Int i -> - out.write_char 'i'; - out.write_string (string_of_int i); - out.write_char 'e' - | String s -> - out.write_string (string_of_int (String.length s)); - out.write_char ':'; - out.write_string s - | BeginDict -> - out.write_char 'd' - | End -> - out.write_char 'e' - | BeginList -> - out.write_char 'l' -end - -module Decode = struct - type result = - | Yield of token - | Error of string - | Await (** The user needs to call {!feed} with some input *) - - type state = - | Start - | ParsingInt of int - | ParsingString of string - - type t = { - mutable buf : string; (* buffer *) - mutable i : int; (* index in buf *) - mutable len : int; (* length of substring to read *) - mutable c : int; (* line *) - mutable l : int; (* column *) - mutable state : state; - } - - let create () = { - buf = ""; - i = 0; - len = 0; - c = 0; - l = 0; - state = Start; - } - - let is_empty dec = dec.len = 0 - let cur dec = dec.buf.[dec.i] - - let junk dec = - (* update line/column *) - (if cur dec = '\n' - then (dec.c <- 0; dec.l <- dec.l + 1) - else dec.c <- dec.c + 1); - dec.i <- dec.i + 1; - dec.len <- dec.len - 1 - - let next dec = - let c = cur dec in - junk dec; - c - - (* - (* parse value *) - let rec parse_rec dec = - if is_empty dec then Await (* wait *) - else begin - let c = next dec in - match dec.state, c with - | Start, 'l' -> - Yield StartList - | Start, 'd' -> - Yield StartDict - | Start, 'e' -> - Yield End - | Start, 'i' -> - dec.state <- ParsingInt 0 - | ParsingString i, 'e' -> - dec.state <- Start; - Yield (Int i) - | - *) - - let feed dec = assert false - - let next dec = assert false -end - diff --git a/misc/bencodeStream.mli b/misc/bencodeStream.mli deleted file mode 100644 index bb5f2d87..00000000 --- a/misc/bencodeStream.mli +++ /dev/null @@ -1,65 +0,0 @@ - -(* -copyright (c) 2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Full-Streaming API of Bencode} *) - -type token = - | Int of int - | String of string - | BeginDict - | BeginList - | End - -module Encode : sig - type t - - type sink = - [ `File of string - | `Out of out_channel - | `Buf of Buffer.t - ] - - val create : sink -> t - - val push : t -> token -> unit -end - -module Decode : sig - type t - - val create : unit -> t - (** Create a new decoder with the given source. *) - - val feed : t -> string -> unit - (** For manual mode, provide some input *) - - type result = - | Yield of token - | Error of string (** Invalid B-encode *) - | Await (** The user needs to call {!feed} with some input *) - - val next : t -> result -end diff --git a/misc/bencode_write_par.sh b/misc/bencode_write_par.sh deleted file mode 100755 index a441a5aa..00000000 --- a/misc/bencode_write_par.sh +++ /dev/null @@ -1,13 +0,0 @@ -#!/bin/sh - -# call n instances of ./bencode_write.native on the same file - -N=$1 -FILE=$2 - -echo "call script $N times on file $FILE" -for i in `seq $N` ; do - ./bencode_write.native "$FILE" & -done - -wait diff --git a/misc/bij.ml b/misc/bij.ml index 0147e072..2831e017 100644 --- a/misc/bij.ml +++ b/misc/bij.ml @@ -105,139 +105,3 @@ let hashtbl ma mb = List.iter (fun (k,v) -> Hashtbl.add h k v) l; h) (list_ (pair ma mb)) - -(** {2 Translations} *) - -module TrBencode = struct - module B = Bencode - - let rec encode: type a. bij:a t -> a -> B.t = - fun ~bij x -> match bij, x with - | Unit, () -> B.I 0 - | String, s -> B.S s - | Int, i -> B.I i - | Float, f -> B.S (string_of_float f) - | Bool, b -> B.I (if b then 1 else 0) - | List bij', l -> - let l' = List.map (fun x -> encode ~bij:bij' x) l in - B.L l' - | Many bij', [] -> raise (EncodingError "many: got empty list") - | Many bij', l -> - let l' = List.map (fun x -> encode ~bij:bij' x) l in - B.L l' - | Opt bij', None -> B.L [] - | Opt bij', Some x -> B.L [encode ~bij:bij' x] - | Pair (bija, bijb), (a, b) -> - B.L [encode ~bij:bija a; encode ~bij:bijb b] - | Triple (bija, bijb, bijc), (a, b, c) -> - B.L [encode ~bij:bija a; encode ~bij:bijb b; encode ~bij:bijc c] - | Quad (bija, bijb, bijc, bijd), (a, b, c, d) -> - B.L [encode ~bij:bija a; encode ~bij:bijb b; - encode ~bij:bijc c; encode ~bij:bijd d] - | Quint (bija, bijb, bijc, bijd, bije), (a, b, c, d, e) -> - B.L [encode ~bij:bija a; encode ~bij:bijb b; - encode ~bij:bijc c; encode ~bij:bijd d; - encode ~bij:bije e] - | Guard (check, bij'), x -> - if not (check x) then raise (EncodingError "check failed"); - encode ~bij:bij' x - | Map (inject, _, bij'), x -> - encode ~bij:bij' (inject x) - | Switch (inject, _), x -> - let key, BranchTo (bij',y) = inject x in - B.D (B.SMap.singleton key (encode ~bij:bij' y)) - - let rec decode: type a. bij:a t -> B.t -> a - = fun ~bij b -> match bij, b with - | Unit, B.I 0 -> () - | String, B.S s -> s - | Int, B.I i -> i - | Float, B.S s -> - begin try - let f = float_of_string s in - f - with Failure _ -> - raise (DecodingError "expected float") - end - | Bool, B.I 0 -> false - | Bool, B.I _ -> true - | List bij', B.L l -> - List.map (fun b -> decode ~bij:bij' b) l - | Many bij', B.L [] -> - raise (DecodingError "expected nonempty list") - | Many bij', B.L l -> - List.map (fun b -> decode ~bij:bij' b) l - | Opt bij', B.L [] -> None - | Opt bij', B.L [x] -> Some (decode ~bij:bij' x) - | Opt bij', B.L _ -> - raise (DecodingError "expected [] or [_]") - | Pair (bija, bijb), B.L [a; b] -> - decode ~bij:bija a, decode ~bij:bijb b - | Triple (bija, bijb, bijc), B.L [a; b; c] -> - decode ~bij:bija a, decode ~bij:bijb b, decode ~bij:bijc c - | Quad (bija, bijb, bijc, bijd), B.L [a; b; c; d] -> - decode ~bij:bija a, decode ~bij:bijb b, - decode ~bij:bijc c, decode ~bij:bijd d - | Quint (bija, bijb, bijc, bijd, bije), B.L [a; b; c; d; e] -> - decode ~bij:bija a, decode ~bij:bijb b, - decode ~bij:bijc c, decode ~bij:bijd d, - decode ~bij:bije e - | Guard (check, bij'), x -> - let y = decode ~bij:bij' x in - if not (check y) then raise (DecodingError "check failed"); - y - | Map (_, extract, bij'), b -> - let x = decode ~bij:bij' b in - extract x - | Switch (_, extract), B.D d when B.SMap.cardinal d = 1 -> - let key, value = B.SMap.choose d in - let BranchFrom (bij', convert) = extract key in - convert (decode ~bij:bij' value) - | _ -> raise (DecodingError "bad case") - - let to_string ~bij x = B.to_string (encode ~bij x) - - let of_string ~bij s = - let b = B.of_string s in - decode ~bij b - - let read ~bij ic = - let d = B.mk_decoder () in - let buf = String.create 256 in - let rec read_chunk() = - let n = input ic buf 0 (String.length buf) in - if n = 0 - then raise (DecodingError "unexpected EOF") - else match B.parse d buf 0 n with - | B.ParsePartial -> read_chunk() - | B.ParseError s -> raise (DecodingError s) - | B.ParseOk b -> decode ~bij b - in - read_chunk() - - let read_stream ~bij ic = - let d = B.mk_decoder () in - let buf = String.create 256 in - let rec try_parse n = match B.parse d buf 0 n with - | B.ParsePartial -> read_chunk() - | B.ParseError s -> raise (DecodingError s) - | B.ParseOk b -> Some (decode ~bij b) - and read_chunk() = - let n = input ic buf 0 (String.length buf) in - if n = 0 - then match B.parse_resume d with - | B.ParsePartial -> None - | B.ParseError s -> raise (DecodingError s) - | B.ParseOk b -> Some (decode ~bij b) - else try_parse n - in - Stream.from (fun _ -> read_chunk()) - - let write ~bij oc x = - let b = encode ~bij x in - B.to_chan oc b; - flush oc - - let write_stream ~bij oc str = - Stream.iter (fun x -> write ~bij oc x) str -end diff --git a/misc/bij.mli b/misc/bij.mli index 9448ea63..4bbc8756 100644 --- a/misc/bij.mli +++ b/misc/bij.mli @@ -163,25 +163,3 @@ exception EncodingError of string exception DecodingError of string (** Raised when decoding is impossible *) - -(** {2 Translations} *) - -module TrBencode : sig - val encode : bij:'a t -> 'a -> Bencode.t - - val decode : bij:'a t -> Bencode.t -> 'a - - val to_string : bij:'a t -> 'a -> string - - val of_string : bij:'a t -> string -> 'a - - val read : bij:'a t -> in_channel -> 'a - (** Read a single value from the channel *) - - val read_stream : bij:'a t -> in_channel -> 'a Stream.t - - val write : bij:'a t -> out_channel -> 'a -> unit - - val write_stream : bij:'a t -> out_channel -> 'a Stream.t -> unit -end - diff --git a/misc/tell.ml b/misc/tell.ml deleted file mode 100644 index 530a4bcc..00000000 --- a/misc/tell.ml +++ /dev/null @@ -1,111 +0,0 @@ - -(* -copyright (c) 2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Hierarchic logging} *) - -module BS = BencodeStream - -type t = { - name : string; - out : out_channel; - encoder : BS.Encode.t; - cleanup : bool; - mutable context : string list; -} - -let __new_name = - let r = ref 0 in - fun () -> - let name = Printf.sprintf "Tell.log_%d" !r in - incr r; - name - -let to_chan ?(cleanup=false) o = { - name = __new_name (); - out = o; - encoder = BS.Encode.create (`Out o); - cleanup; - context = []; -} - -let to_file filename = - let o = open_out filename in - to_chan ~cleanup:true o - -let close log = - if log.cleanup - then close_out log.out - -let step log msg = - BS.Encode.push log.encoder BS.BeginDict; - BS.Encode.push log.encoder (BS.String "step"); - BS.Encode.push log.encoder (BS.String msg); - BS.Encode.push log.encoder BS.End - -let enter log = - BS.Encode.push log.encoder BS.BeginList - -let exit log = - BS.Encode.push log.encoder BS.End - -let within ~log f = - BS.Encode.push log.encoder BS.BeginDict; - BS.Encode.push log.encoder (BS.String "section"); - try - let x = f () in - BS.Encode.push log.encoder BS.End; - x - with e -> - BS.Encode.push log.encoder BS.End; - raise e - -module B = struct - let step ~log format = - exit log; - let b = Buffer.create 24 in - Printf.kbprintf - (fun b -> - BS.Encode.push log.encoder (BS.String (Buffer.contents b))) - b format - - let enter ~log format = - let b = Buffer.create 24 in - let x = Printf.kbprintf - (fun b -> - BS.Encode.push log.encoder (BS.String (Buffer.contents b))) - b format - in - enter log; - x - - let exit ~log format = - exit log; - let b = Buffer.create 24 in - Printf.kbprintf - (fun b -> - BS.Encode.push log.encoder (BS.String (Buffer.contents b))) - b format -end diff --git a/misc/tell.mli b/misc/tell.mli deleted file mode 100644 index 6f17ffc6..00000000 --- a/misc/tell.mli +++ /dev/null @@ -1,73 +0,0 @@ - -(* -copyright (c) 2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Hierarchic logging} *) - -type t - -val to_file : string -> t -(** Create a logger that outputs to the given file *) - -val to_chan : ?cleanup:bool -> out_channel -> t -(** Obtain a logger that outputs to the given channel. - @param cleanup if true, will close the channel on exit; - if false or not explicited, won't do anything. *) - -(** {2 Raw functions} *) - -val step : t -> string -> unit - -val close : t -> unit -(** Close the logger. It will be unusable afterwards. *) - -(** {2 Hierarchy} *) - -val enter : t -> unit -(** Enter a new subsection *) - -val exit : t -> unit -(** Exit the current subsection *) - -val within : log:t -> (unit -> 'a) -> 'a -(** Enter a new subsection, evaluate the given function, - exit the subsection and return the function's result. - Also protects against exceptions. *) - -(** {2 Buffer-formatting output} -The following functions use a {!Buffer.t} to create the message, -then send it to their logger. *) - -module B : sig - val enter : log:t -> ('a, Buffer.t, unit, unit) format4 -> 'a - (** Enter a new (sub-)section with the given message *) - - val exit : log:t -> ('a, Buffer.t, unit, unit) format4 -> 'a - (** Exit (close) the current sub-section. *) - - val step : log:t -> ('a, Buffer.t, unit, unit) format4 -> 'a - (** Unit step within the current section *) -end - diff --git a/tests/run_tests.ml b/tests/run_tests.ml index 858df690..631379e5 100644 --- a/tests/run_tests.ml +++ b/tests/run_tests.ml @@ -6,11 +6,9 @@ let suite = "all_tests" >::: [ Test_pHashtbl.suite; Test_PersistentHashtbl.suite; - Test_bencode.suite; Test_bv.suite; Test_PiCalculus.suite; Test_splayMap.suite; - Test_bij.suite; Test_CCHeap.suite; Test_cc.suite; Test_puf.suite; @@ -29,7 +27,6 @@ let props = QCheck.flatten [ Test_PersistentHashtbl.props ; Test_bv.props - ; Test_bencode.props ; Test_vector.props ] diff --git a/tests/test_bencode.ml b/tests/test_bencode.ml deleted file mode 100644 index 3bfb5c6f..00000000 --- a/tests/test_bencode.ml +++ /dev/null @@ -1,71 +0,0 @@ - -open OUnit -open Containers_misc - -module B = Bencode - -let test1 () = - let s = "li42ei0ei-200ee" in - match B.parse_string s with - | B.ParseError msg -> - OUnit.assert_failure (Printf.sprintf "should parse, got %s" msg) - | B.ParsePartial -> - OUnit.assert_failure "should parse, got partial" - | B.ParseOk b -> - OUnit.assert_equal (B.L [B.I 42; B.I 0; B.I ~-200]) b - -let test2 () = - let b = - B.dict_of_list [ - "foo", B.I 42; - "bar", B.L [B.I 0; B.S "caramba si"]; - "", B.S ""; - ] - in - let s = B.to_string b in - (* Printf.printf "serialized to %s\n" s; *) - let b' = B.of_string s in - OUnit.assert_equal ~cmp:B.eq ~printer:B.to_string b b' - -let test3 () = - let b = B.dict_of_list [ - "a", B.I 1; - "b", B.S "bbbb"; - "l", B.L [B.I 0; B.I 0; B.S "zero\n\t \x00"]; - "d", B.dict_of_list ["foo", B.S "bar"]; - ] in - let s = B.to_string b in - (* Printf.printf "serialized to %s\n" s; *) - let b' = B.of_string s in - OUnit.assert_equal ~cmp:B.eq ~printer:B.to_string b b' - -let suite = - "test_bencode" >::: - [ "test1" >:: test1; - "test2" >:: test2; - "test3" >:: test3; - ] - -open QCheck - -let check_decode_encode = - let gen = Arbitrary.( - let base = choose - [ lift (fun i -> B.I i) small_int - ; lift (fun s -> B.S s) string - ] - in - fix ~max:3 ~base (fun sub -> - choose - [ lift B.dict_of_list (list (pair string sub)) - ; lift (fun l -> B.L l) (list sub) - ; sub - ])) - in - let prop b = B.eq (B.of_string (B.to_string b)) b in - let name = "bencode_decode_encode_bij" in - mk_test ~name gen prop - -let props = - [ check_decode_encode - ] diff --git a/tests/test_bij.ml b/tests/test_bij.ml deleted file mode 100644 index 869bd9b1..00000000 --- a/tests/test_bij.ml +++ /dev/null @@ -1,91 +0,0 @@ - -open OUnit -open Containers_misc - -module Sequence = CCSequence - -let pp_int_list l = - let b = Buffer.create 4 in - CCList.pp CCInt.pp b l; - Buffer.contents b - -let test_intlist n () = - let bij = Bij.(list_ int_) in - let l = Sequence.to_list (Sequence.int_range ~start:0 ~stop:n) in - let s = Bij.TrBencode.to_string ~bij l in - let l' = Bij.TrBencode.of_string ~bij s in - OUnit.assert_equal ~printer:pp_int_list l l' - -type term = - | Const of string - | Int of int - | App of term list - -let bij_term = - let bij = Bij.fix - (fun bij -> - Bij.switch - ~inject:(function - | Const s -> "const", Bij.(BranchTo (string_, s)) - | Int i -> "int", Bij.(BranchTo (int_, i)) - | App l -> "app", Bij.(BranchTo (list_ (Lazy.force bij), l))) - ~extract:(function - | "const" -> Bij.(BranchFrom (string_, fun x -> Const x)) - | "int" -> Bij.BranchFrom (Bij.int_, fun x -> Int x) - | "app" -> Bij.(BranchFrom (list_ (Lazy.force bij), fun l -> App l)) - | _ -> raise Bij.(DecodingError "unexpected case switch")) - ) - in - bij - -let test_rec () = - let t = App [Const "foo"; App [Const "bar"; Int 1; Int 2]; Int 3; Const "hello"] in - let s = Bij.TrBencode.to_string ~bij:bij_term t in - (* Printf.printf "to: %s\n" s; *) - let t' = Bij.TrBencode.of_string ~bij:bij_term s in - OUnit.assert_equal t t' - -let random_str len = - let s = String.make len ' ' in - for i = 0 to len - 1 do - s.[i] <- "abcdefghijklmnopqrstuvwxyz".[Random.int 26] - done; - s - -let rec random_term depth = - if depth = 0 - then if Random.bool () - then Const (random_str (1 + Random.int 5)) - else Int (Random.int 20) - else - let len = Random.int (1 + Random.int 10) in - let seq = Sequence.map (fun _ -> random_term (depth-1)) - (Sequence.int_range ~start:1 ~stop:len) in - App (Sequence.to_list seq) - -let test_term_random ?(depth=5) n () = - for i = 0 to n - 1 do - let t = random_term depth in - let s = Bij.TrBencode.to_string ~bij:bij_term t in - let t' = Bij.TrBencode.of_string ~bij:bij_term s in - OUnit.assert_equal t t' - done - -let test_complicated () = - let bij = Bij.(triple int_ (pair bool_ (many float_)) - (map ~inject:(fun (a,b) -> (b,a)) ~extract:(fun (b,a) -> a,b) (pair int_ bool_))) in - let x = (1, (true, [1.; 2.; 3.]), (false, 42)) in - let s = Bij.TrBencode.to_string ~bij x in - let x' = Bij.TrBencode.of_string ~bij s in - OUnit.assert_equal x x' - -let suite = - "test_bij" >::: - [ "test_intlist10" >:: test_intlist 10 - ; "test_intlist100" >:: test_intlist 100 - ; "test_intlist10_000" >:: test_intlist 10_000 - ; "test_rec" >:: test_rec - ; "test_term_random100" >:: test_term_random 100 - ; "test_term_random100_depth10" >:: test_term_random ~depth:10 100 - ; "test_complicated" >:: test_complicated - ]