simon/ocaml-containers
1
0
Fork 0
mirror of https://github.com/c-cube/ocaml-containers.git synced 2025-12-06 03:05:28 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

remove some junk from misc/

Browse source
This commit is contained in:
Simon Cruanes 2014-11-04 20:56:38 +01:00
parent d3af230de9
commit d75317253d
17 changed files with 3 additions and 1688 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
_oasis
View file

@ -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

159
misc/actionMan.ml
View file

@ -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"

94
misc/actionMan.mli
View file

@ -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 *)

363
misc/bencode.ml
View file

@ -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 "@[<h>\"%s\"@]" s
| L l ->
Format.fprintf fmt "@[<hov 2>[@,";
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 "@[<hov 2>{@,";
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))

130
misc/bencode.mli
View file

@ -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 *)

136
misc/bencodeOnDisk.ml
View file

@ -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

60
misc/bencodeOnDisk.mli
View file

@ -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. *)

156
misc/bencodeStream.ml
View file

@ -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

65
misc/bencodeStream.mli
View file

@ -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

13
misc/bencode_write_par.sh
View file

@ -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

136
misc/bij.ml
View file

@ -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

22
misc/bij.mli
View file

@ -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

111
misc/tell.ml
View file

@ -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

73
misc/tell.mli
View file

@ -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

3
tests/run_tests.ml
View file

@ -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
]

71
tests/test_bencode.ml
View file

@ -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
]

91
tests/test_bij.ml
View file

@ -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
]