From 85e70adf5868546c7b1b2a1f4e676de9f0108997 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Thu, 10 Jan 2013 11:34:42 +0000 Subject: [PATCH 001/199] Initial import Based on xen-api-libs ad02a87e6a46bbec27e79398906afcf682cfe71e --- INSTALL | 7 + Makefile | 38 + _oasis | 17 + _tags | 39 + configure | 27 + lib/META | 12 + lib/arrayext.ml | 59 + lib/arrayext.mli | 68 + lib/backtrace.ml | 33 + lib/backtrace.mli | 14 + lib/base64.ml | 86 + lib/base64.mli | 20 + lib/base64_main.ml | 28 + lib/bigbuffer.ml | 111 + lib/bigbuffer.mli | 25 + lib/config.ml | 109 + lib/config.mli | 27 + lib/date.ml | 72 + lib/date.mli | 49 + lib/either.ml | 42 + lib/either.mli | 21 + lib/encodings.ml | 201 ++ lib/encodings.mli | 203 ++ lib/extentlistSet.ml | 106 + lib/extentlistSet.mli | 27 + lib/extentlistset_test.ml | 92 + lib/filenameext.ml | 30 + lib/filenameext.mli | 14 + lib/fring.ml | 80 + lib/fring.mli | 51 + lib/fun.ml | 22 + lib/fun.mli | 12 + lib/gzip.ml | 97 + lib/gzip.mli | 24 + lib/hashtblext.ml | 40 + lib/hashtblext.mli | 20 + lib/int64ext.ml | 17 + lib/int64ext.mli | 17 + lib/lazyList.ml | 20 + lib/lazyList.mli | 16 + lib/libstdext_stubs.clib | 7 + lib/listext.ml | 232 ++ lib/listext.mli | 211 ++ lib/mapext.ml | 47 + lib/mapext.mli | 31 + lib/monad.ml | 70 + lib/monad.mli | 70 + lib/opt.ml | 82 + lib/opt.mli | 27 + lib/pervasiveext.ml | 64 + lib/pervasiveext.mli | 30 + lib/qring.ml | 141 + lib/qring.mli | 41 + lib/range.ml | 44 + lib/range.mli | 33 + lib/ring.ml | 72 + lib/ring.mli | 24 + lib/set_test.ml | 31 + lib/set_test.mli | 15 + lib/sha1sum.ml | 64 + lib/sha1sum.mli | 17 + lib/stdext.mllib | 35 + lib/stringext.ml | 217 ++ lib/stringext.mli | 123 + lib/tar.ml | 376 +++ lib/tar.mli | 112 + lib/threadext.ml | 411 +++ lib/threadext.mli | 93 + lib/trie.ml | 180 ++ lib/trie.mli | 58 + lib/unixext.ml | 703 +++++ lib/unixext.mli | 196 ++ lib/unixext_open_stubs.c | 60 + lib/unixext_stubs.c | 445 +++ lib/unixext_write_stubs.c | 65 + lib/vIO.ml | 107 + lib/vIO.mli | 33 + lib/zerocheck.ml | 48 + lib/zerocheck.mli | 41 + lib/zerocheck_stub.c | 127 + myocamlbuild.ml | 491 ++++ setup.ml | 5728 +++++++++++++++++++++++++++++++++++++ 82 files changed, 12995 insertions(+) create mode 100644 INSTALL create mode 100644 Makefile create mode 100644 _oasis create mode 100644 _tags create mode 100755 configure create mode 100644 lib/META create mode 100644 lib/arrayext.ml create mode 100644 lib/arrayext.mli create mode 100644 lib/backtrace.ml create mode 100644 lib/backtrace.mli create mode 100644 lib/base64.ml create mode 100644 lib/base64.mli create mode 100644 lib/base64_main.ml create mode 100644 lib/bigbuffer.ml create mode 100644 lib/bigbuffer.mli create mode 100644 lib/config.ml create mode 100644 lib/config.mli create mode 100644 lib/date.ml create mode 100644 lib/date.mli create mode 100644 lib/either.ml create mode 100644 lib/either.mli create mode 100644 lib/encodings.ml create mode 100644 lib/encodings.mli create mode 100644 lib/extentlistSet.ml create mode 100644 lib/extentlistSet.mli create mode 100644 lib/extentlistset_test.ml create mode 100644 lib/filenameext.ml create mode 100644 lib/filenameext.mli create mode 100644 lib/fring.ml create mode 100644 lib/fring.mli create mode 100644 lib/fun.ml create mode 100644 lib/fun.mli create mode 100644 lib/gzip.ml create mode 100644 lib/gzip.mli create mode 100644 lib/hashtblext.ml create mode 100644 lib/hashtblext.mli create mode 100644 lib/int64ext.ml create mode 100644 lib/int64ext.mli create mode 100644 lib/lazyList.ml create mode 100644 lib/lazyList.mli create mode 100644 lib/libstdext_stubs.clib create mode 100644 lib/listext.ml create mode 100644 lib/listext.mli create mode 100644 lib/mapext.ml create mode 100644 lib/mapext.mli create mode 100644 lib/monad.ml create mode 100644 lib/monad.mli create mode 100644 lib/opt.ml create mode 100644 lib/opt.mli create mode 100644 lib/pervasiveext.ml create mode 100644 lib/pervasiveext.mli create mode 100644 lib/qring.ml create mode 100644 lib/qring.mli create mode 100644 lib/range.ml create mode 100644 lib/range.mli create mode 100644 lib/ring.ml create mode 100644 lib/ring.mli create mode 100644 lib/set_test.ml create mode 100644 lib/set_test.mli create mode 100644 lib/sha1sum.ml create mode 100644 lib/sha1sum.mli create mode 100644 lib/stdext.mllib create mode 100644 lib/stringext.ml create mode 100644 lib/stringext.mli create mode 100644 lib/tar.ml create mode 100644 lib/tar.mli create mode 100644 lib/threadext.ml create mode 100644 lib/threadext.mli create mode 100644 lib/trie.ml create mode 100644 lib/trie.mli create mode 100644 lib/unixext.ml create mode 100644 lib/unixext.mli create mode 100644 lib/unixext_open_stubs.c create mode 100644 lib/unixext_stubs.c create mode 100644 lib/unixext_write_stubs.c create mode 100644 lib/vIO.ml create mode 100644 lib/vIO.mli create mode 100644 lib/zerocheck.ml create mode 100644 lib/zerocheck.mli create mode 100644 lib/zerocheck_stub.c create mode 100644 myocamlbuild.ml create mode 100644 setup.ml diff --git a/INSTALL b/INSTALL new file mode 100644 index 00000000000..0bcb15394e1 --- /dev/null +++ b/INSTALL @@ -0,0 +1,7 @@ +Just do: + + $ make + +then from root: + + # make install diff --git a/Makefile b/Makefile new file mode 100644 index 00000000000..68f2e0e9a49 --- /dev/null +++ b/Makefile @@ -0,0 +1,38 @@ +# OASIS_START +# DO NOT EDIT (digest: bc1e05bfc8b39b664f29dae8dbd3ebbb) + +SETUP = ocaml setup.ml + +build: setup.data + $(SETUP) -build $(BUILDFLAGS) + +doc: setup.data build + $(SETUP) -doc $(DOCFLAGS) + +test: setup.data build + $(SETUP) -test $(TESTFLAGS) + +all: + $(SETUP) -all $(ALLFLAGS) + +install: setup.data + $(SETUP) -install $(INSTALLFLAGS) + +uninstall: setup.data + $(SETUP) -uninstall $(UNINSTALLFLAGS) + +reinstall: setup.data + $(SETUP) -reinstall $(REINSTALLFLAGS) + +clean: + $(SETUP) -clean $(CLEANFLAGS) + +distclean: + $(SETUP) -distclean $(DISTCLEANFLAGS) + +setup.data: + $(SETUP) -configure $(CONFIGUREFLAGS) + +.PHONY: build doc test all install uninstall reinstall clean distclean configure + +# OASIS_STOP diff --git a/_oasis b/_oasis new file mode 100644 index 00000000000..f9ea5b8038a --- /dev/null +++ b/_oasis @@ -0,0 +1,17 @@ +OASISFormat: 0.3 +Name: stdext +Version: 0.1 +Synopsis: Standard extension library +License: LGPL-2.1 with OCaml linking exception +Authors: various +Copyrights: (C) 2012 Citrix +BuildTools: ocamlbuild +Plugins: DevFiles (0.3), META (0.3) + +Library stdext + Path: lib + Modules: Arrayext, Backtrace, Base64, Bigbuffer, Config, Date, Either, Encodings, ExtentlistSet, Filenameext, Fring, Fun, Gzip, Hashtblext, Int64ext, LazyList, Listext, Mapext, Monad, Opt, Pervasiveext, Qring, Range, Ring, Sha1sum, Stringext, Tar, Threadext, Trie, Unixext, VIO, Zerocheck + CSources: unixext_open_stubs.c, unixext_stubs.c, unixext_write_stubs.c, zerocheck_stub.c + BuildDepends: threads, uuidm, forkexec, unix + + diff --git a/_tags b/_tags new file mode 100644 index 00000000000..14974f9b5a9 --- /dev/null +++ b/_tags @@ -0,0 +1,39 @@ +# OASIS_START +# DO NOT EDIT (digest: 7560e1cd1f3b4dabc60a9f8ebb35ba86) +# Ignore VCS directories, you can use the same kind of rule outside +# OASIS_START/STOP if you want to exclude directories that contains +# useless stuff for the build process +<**/.svn>: -traverse +<**/.svn>: not_hygienic +".bzr": -traverse +".bzr": not_hygienic +".hg": -traverse +".hg": not_hygienic +".git": -traverse +".git": not_hygienic +"_darcs": -traverse +"_darcs": not_hygienic +# Library stdext +"lib/stdext.cmxs": use_stdext +: use_libstdext_stubs +: pkg_threads +: pkg_uuidm +: pkg_forkexec +: pkg_unix +"lib/unixext_open_stubs.c": pkg_threads +"lib/unixext_open_stubs.c": pkg_uuidm +"lib/unixext_open_stubs.c": pkg_forkexec +"lib/unixext_open_stubs.c": pkg_unix +"lib/unixext_stubs.c": pkg_threads +"lib/unixext_stubs.c": pkg_uuidm +"lib/unixext_stubs.c": pkg_forkexec +"lib/unixext_stubs.c": pkg_unix +"lib/unixext_write_stubs.c": pkg_threads +"lib/unixext_write_stubs.c": pkg_uuidm +"lib/unixext_write_stubs.c": pkg_forkexec +"lib/unixext_write_stubs.c": pkg_unix +"lib/zerocheck_stub.c": pkg_threads +"lib/zerocheck_stub.c": pkg_uuidm +"lib/zerocheck_stub.c": pkg_forkexec +"lib/zerocheck_stub.c": pkg_unix +# OASIS_STOP diff --git a/configure b/configure new file mode 100755 index 00000000000..97ed012e660 --- /dev/null +++ b/configure @@ -0,0 +1,27 @@ +#!/bin/sh + +# OASIS_START +# DO NOT EDIT (digest: 425187ed8bfdbdd207fd76392dd243a7) +set -e + +FST=true +for i in "$@"; do + if $FST; then + set -- + FST=false + fi + + case $i in + --*=*) + ARG=${i%%=*} + VAL=${i##*=} + set -- "$@" "$ARG" "$VAL" + ;; + *) + set -- "$@" "$i" + ;; + esac +done + +ocaml setup.ml -configure "$@" +# OASIS_STOP diff --git a/lib/META b/lib/META new file mode 100644 index 00000000000..bc913638344 --- /dev/null +++ b/lib/META @@ -0,0 +1,12 @@ +# OASIS_START +# DO NOT EDIT (digest: 7a78a259a7957a9cdde948237e0bf2d5) +version = "0.1" +description = "Standard extension library" +requires = "threads uuidm forkexec unix" +archive(byte) = "stdext.cma" +archive(byte, plugin) = "stdext.cma" +archive(native) = "stdext.cmxa" +archive(native, plugin) = "stdext.cmxs" +exists_if = "stdext.cma" +# OASIS_STOP + diff --git a/lib/arrayext.ml b/lib/arrayext.ml new file mode 100644 index 00000000000..800373cf3c6 --- /dev/null +++ b/lib/arrayext.ml @@ -0,0 +1,59 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +module Array = struct include Array + +(* Useful for vector addition. *) +let map2 f a b = + let len = length a in + if len <> length b then invalid_arg "map2"; + init len (fun i -> f a.(i) b.(i)) + +(* Useful for vector dot product. *) +let fold_left2 f x a b = + let len = length a in + if len <> length b then invalid_arg "fold_left2"; + let r = ref x in + for i = 0 to len - 1 do + r := f !r a.(i) b.(i) + done; + !r + +(* Useful for vector dot product. *) +let fold_right2 f a b x = + let len = length a in + if len <> length b then invalid_arg "fold_right2"; + let r = ref x in + for i = len - 1 downto 0 do + r := f a.(i) b.(i) !r + done; + !r + +let index e a = + let len = length a in + let rec check i = + if len <= i then -1 + else if get a i = e then i + else check (i + 1) + in check 0 + +let inner fold_left2 base f l1 l2 g = + fold_left2 (fun accu e1 e2 -> g accu (f e1 e2)) base l1 l2 + +let mem e a = + index e a <> -1 + +let remove n a = + append (sub a 0 n) (sub a (n+1) (length a - n - 1)) + +end diff --git a/lib/arrayext.mli b/lib/arrayext.mli new file mode 100644 index 00000000000..94a13521297 --- /dev/null +++ b/lib/arrayext.mli @@ -0,0 +1,68 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +module Array : +sig + external length : 'a array -> int = "%array_length" + external get : 'a array -> int -> 'a = "%array_safe_get" + external set : 'a array -> int -> 'a -> unit = "%array_safe_set" + external make : int -> 'a -> 'a array = "caml_make_vect" + external create : int -> 'a -> 'a array = "caml_make_vect" + val init : int -> (int -> 'a) -> 'a array + val make_matrix : int -> int -> 'a -> 'a array array + val create_matrix : int -> int -> 'a -> 'a array array + val append : 'a array -> 'a array -> 'a array + val concat : 'a array list -> 'a array + val sub : 'a array -> int -> int -> 'a array + val copy : 'a array -> 'a array + val fill : 'a array -> int -> int -> 'a -> unit + val blit : 'a array -> int -> 'a array -> int -> int -> unit + val to_list : 'a array -> 'a list + val of_list : 'a list -> 'a array + val iter : ('a -> unit) -> 'a array -> unit + val map : ('a -> 'b) -> 'a array -> 'b array + val iteri : (int -> 'a -> unit) -> 'a array -> unit + val mapi : (int -> 'a -> 'b) -> 'a array -> 'b array + val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a + val fold_right : ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b + val sort : ('a -> 'a -> int) -> 'a array -> unit + val stable_sort : ('a -> 'a -> int) -> 'a array -> unit + val fast_sort : ('a -> 'a -> int) -> 'a array -> unit + external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get" + external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" + + (** Map a function over a pair of arrays simultaneously. *) + val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array + + (** Fold a function over a pair of arrays simultaneously. *) + val fold_left2 : + ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a + + (** Fold a function over a pair of arrays simultaneously. *) + val fold_right2 : + ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c + + (** Get first index of an element in the array, or -1. *) + val index : 'a -> 'a array -> int + + (** Compute the inner product of two arrays. *) + val inner : + (('a -> 'b -> 'c -> 'd) -> 'e -> 'f -> 'g -> 'h) -> + 'e -> ('b -> 'c -> 'i) -> 'f -> 'g -> ('a -> 'i -> 'd) -> 'h + + (** Check if an element appears in the array. *) + val mem : 'a -> 'a array -> bool + + (** Remove the element at specified position from the array. *) + val remove : int -> 'a array -> 'a array +end diff --git a/lib/backtrace.ml b/lib/backtrace.ml new file mode 100644 index 00000000000..a0d55887255 --- /dev/null +++ b/lib/backtrace.ml @@ -0,0 +1,33 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +let get_backtrace () = + let b = Printexc.get_backtrace () in + let nicify_locator s = + try + match Stringext.String.split ',' s with + | file :: line :: character :: [] -> + let i = String.index_from file 0 '"' + 1 in + let i2 = String.index_from file i '"' in + String.concat "" [ String.sub file i (i2 - i); ":"; + (try String.sub line 6 (String.length line - 6) with _ -> line); "."; + (try String.sub character 12 (String.length character - 12) with _ -> character) ] + | _ -> s + with _ -> s + in + try + let list = Stringext.String.split '\n' b in + let list = List.filter ((<>) "") list in + "Raised at " ^ (String.concat " -> " (List.map nicify_locator list)) + with _ -> + b diff --git a/lib/backtrace.mli b/lib/backtrace.mli new file mode 100644 index 00000000000..4d693b0f6b4 --- /dev/null +++ b/lib/backtrace.mli @@ -0,0 +1,14 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +val get_backtrace : unit -> string diff --git a/lib/base64.ml b/lib/base64.ml new file mode 100644 index 00000000000..1713e804369 --- /dev/null +++ b/lib/base64.ml @@ -0,0 +1,86 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +open Stringext + +let code = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" +let padding = '=' + +let of_char x = if x = padding then 0 else String.index code x + +let to_char x = code.[x] + +let strip_whitespace s = + String.implode (List.filter (fun x->not (List.mem x [' ';'\t';'\n';'\r'])) (String.explode s)) + +let decode x = + let x = strip_whitespace x in + let words = String.length x / 4 in + let padding = + if String.length x = 0 then 0 else ( + if x.[String.length x - 2] = padding + then 2 else (if x.[String.length x - 1] = padding then 1 else 0)) in + let output = String.make (words * 3 - padding) '\000' in + for i = 0 to words - 1 do + let a = of_char x.[4 * i + 0] + and b = of_char x.[4 * i + 1] + and c = of_char x.[4 * i + 2] + and d = of_char x.[4 * i + 3] in + let n = (a lsl 18) lor (b lsl 12) lor (c lsl 6) lor d in + let x = (n lsr 16) land 255 + and y = (n lsr 8) land 255 + and z = n land 255 in + output.[3 * i + 0] <- char_of_int x; + if i <> words - 1 || padding < 2 then output.[3 * i + 1] <- char_of_int y; + if i <> words - 1 || padding < 1 then output.[3 * i + 2] <- char_of_int z; + done; + output + +let encode x = + let length = String.length x in + let words = (length + 2) / 3 in (* rounded up *) + let padding = if length mod 3 = 0 then 0 else 3 - (length mod 3) in + let output = String.make (words * 4) '\000' in + let get i = if i >= length then 0 else int_of_char x.[i] in + for i = 0 to words - 1 do + let x = get (3 * i + 0) + and y = get (3 * i + 1) + and z = get (3 * i + 2) in + let n = (x lsl 16) lor (y lsl 8) lor z in + let a = (n lsr 18) land 63 + and b = (n lsr 12) land 63 + and c = (n lsr 6) land 63 + and d = n land 63 in + output.[4 * i + 0] <- to_char a; + output.[4 * i + 1] <- to_char b; + output.[4 * i + 2] <- to_char c; + output.[4 * i + 3] <- to_char d; + done; + for i = 1 to padding do + output.[String.length output - i] <- '='; + done; + output + +let test x = + let x' = encode x in + let x'' = decode x' in + if x <> x'' + then failwith (Printf.sprintf "Original: '%s'; encoded = '%s'; decoded = '%s'" x x' x'') + +let tests = [ "hello"; + "this is a basic test"; "1"; "22"; "333"; "4444"; "5555"; + "\000"; "\000\000"; "\000\000\000"; "\000\000\000\000" ] + +(* +let _ = List.iter test tests +*) diff --git a/lib/base64.mli b/lib/base64.mli new file mode 100644 index 00000000000..46cc7c03dde --- /dev/null +++ b/lib/base64.mli @@ -0,0 +1,20 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** decode a string encoded in base64. Will leave trailing NULLs on the string + padding it out to a multiple of 3 characters *) +val decode: string -> string + +(** encode a string into base64 *) +val encode: string -> string diff --git a/lib/base64_main.ml b/lib/base64_main.ml new file mode 100644 index 00000000000..7f76e39c50f --- /dev/null +++ b/lib/base64_main.ml @@ -0,0 +1,28 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +open Base64 + +let usage () = + output_string stderr (Printf.sprintf "Usage: %s (encode|decode) string\n" Sys.argv.(0)); + exit 1 + +let _ = + if Array.length Sys.argv <> 3 then usage (); + match Sys.argv.(1) with + | "encode" -> + print_string (encode Sys.argv.(2)) + | "decode" -> + print_string (decode Sys.argv.(2)) + | _ -> + usage () diff --git a/lib/bigbuffer.ml b/lib/bigbuffer.ml new file mode 100644 index 00000000000..fec2e92abf1 --- /dev/null +++ b/lib/bigbuffer.ml @@ -0,0 +1,111 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +type t = { + mutable cells: string option array; + mutable index: int64; +} + +let cell_size = 4096 +let default_array_len = 16 + +let make () = { cells = Array.make default_array_len None; index = 0L } + +let length bigbuf = bigbuf.index + +let get bigbuf n = + let array_offset = Int64.to_int (Int64.div n (Int64.of_int cell_size)) in + let cell_offset = Int64.to_int (Int64.rem n (Int64.of_int cell_size)) in + match bigbuf.cells.(array_offset) with + | None -> "".[0] + | Some buf -> buf.[cell_offset] + +let rec append_substring bigbuf s offset len = + let array_offset = Int64.to_int (Int64.div bigbuf.index (Int64.of_int cell_size)) in + let cell_offset = Int64.to_int (Int64.rem bigbuf.index (Int64.of_int cell_size)) in + + if Array.length bigbuf.cells <= array_offset then ( + (* we need to reallocate the array *) + bigbuf.cells <- Array.append bigbuf.cells (Array.make default_array_len None) + ); + + let buf = match bigbuf.cells.(array_offset) with + | None -> + let newbuf = String.create cell_size in + bigbuf.cells.(array_offset) <- Some newbuf; + newbuf + | Some buf -> + buf + in + if len + cell_offset <= cell_size then ( + String.blit s offset buf cell_offset len; + bigbuf.index <- Int64.add bigbuf.index (Int64.of_int len); + ) else ( + let rlen = cell_size - cell_offset in + String.blit s offset buf cell_offset rlen; + bigbuf.index <- Int64.add bigbuf.index (Int64.of_int rlen); + append_substring bigbuf s (offset + rlen) (len - rlen) + ); + () + +let append_string b s = append_substring b s 0 (String.length s) + +let to_fct bigbuf f = + let array_offset = Int64.to_int (Int64.div bigbuf.index (Int64.of_int cell_size)) in + let cell_offset = Int64.to_int (Int64.rem bigbuf.index (Int64.of_int cell_size)) in + + (* copy all complete cells *) + for i = 0 to array_offset - 1 + do + match bigbuf.cells.(i) with + | None -> (* should never happen *) () + | Some cell -> f cell + done; + + if(cell_offset > 0) then + (* copy last cell *) + begin match bigbuf.cells.(array_offset) with + | None -> (* Should never happen (any more) *) () + | Some cell -> f (String.sub cell 0 cell_offset) + end + + +let to_string bigbuf = + if bigbuf.index > (Int64.of_int Sys.max_string_length) then + failwith "cannot allocate string big enough"; + + let dest = String.create (Int64.to_int bigbuf.index) in + let destoff = ref 0 in + to_fct bigbuf (fun s -> + let len = String.length s in + String.blit s 0 dest !destoff len; + destoff := !destoff + len + ); + dest + + +let test max = + let rec inner n = + if n>max then () else begin + let bb = make () in + let s = String.create n in + append_substring bb s 0 n; + assert ((to_string bb)=s); + inner (n+1) + end + in + inner 0 + +let to_stream bigbuf outchan = + to_fct bigbuf (fun s -> output_string outchan s) diff --git a/lib/bigbuffer.mli b/lib/bigbuffer.mli new file mode 100644 index 00000000000..b56764e0c58 --- /dev/null +++ b/lib/bigbuffer.mli @@ -0,0 +1,25 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +type t +val make : unit -> t +val length : t -> int64 +val get : t -> int64 -> char +val append_substring : t -> string -> int -> int -> unit + +(** [append_string b s] appends the string [x] to the big buffer [b] *) +val append_string : t -> string -> unit + +val to_fct : t -> (string -> unit) -> unit +val to_string : t -> string +val to_stream : t -> out_channel -> unit diff --git a/lib/config.ml b/lib/config.ml new file mode 100644 index 00000000000..527c23bbd5a --- /dev/null +++ b/lib/config.ml @@ -0,0 +1,109 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +type ty = + | Set_bool of bool ref + | Set_int of int ref + | Set_string of string ref + | Set_float of float ref + | Unit of (unit -> unit) + | Bool of (bool -> unit) + | Int of (int -> unit) + | String of (string -> unit) + | Float of (float -> unit) + +exception Error of (string * string) list + +let trim_start lc s = + let len = String.length s and i = ref 0 in + while !i < len && (List.mem s.[!i] lc) + do + incr i + done; + if !i < len then String.sub s !i (len - !i) else "" + +let trim_end lc s = + let i = ref (String.length s - 1) in + while !i > 0 && (List.mem s.[!i] lc) + do + decr i + done; + if !i >= 0 then String.sub s 0 (!i + 1) else "" + +let rec split ?limit:(limit=(-1)) c s = + let i = try String.index s c with Not_found -> -1 in + let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in + if i = -1 || nlimit = 0 then + [ s ] + else + let a = String.sub s 0 i + and b = String.sub s (i + 1) (String.length s - i - 1) in + a :: (split ~limit: nlimit c b) + +let parse_line stream = + let lc = [ ' '; '\t' ] in + let trim_spaces s = trim_end lc (trim_start lc s) in + let to_config s = + match split ~limit:2 '=' s with + | k :: v :: [] -> Some (trim_end lc k, trim_start lc v) + | _ -> None in + let rec read_filter_line () = + try + let line = trim_spaces (input_line stream) in + if String.length line > 0 && line.[0] <> '#' then + match to_config line with + | None -> read_filter_line () + | Some x -> x :: read_filter_line () + else + read_filter_line () + with + End_of_file -> [] in + read_filter_line () + +let parse filename = + let stream = open_in filename in + let cf = parse_line stream in + close_in stream; + cf + +let validate cf expected other = + let err = ref [] in + let append x = err := x :: !err in + List.iter (fun (k, v) -> + try + if not (List.mem_assoc k expected) then + other k v + else let ty = List.assoc k expected in + match ty with + | Unit f -> f () + | Bool f -> f (bool_of_string v) + | String f -> f v + | Int f -> f (int_of_string v) + | Float f -> f (float_of_string v) + | Set_bool r -> r := (bool_of_string v) + | Set_string r -> r := v + | Set_int r -> r := int_of_string v + | Set_float r -> r := (float_of_string v) + with + | Not_found -> append (k, "unknown key") + | Failure "int_of_string" -> append (k, "expect int arg") + | Failure "bool_of_string" -> append (k, "expect bool arg") + | Failure "float_of_string" -> append (k, "expect float arg") + | exn -> append (k, Printexc.to_string exn) + ) cf; + if !err != [] then raise (Error !err) + +(** read a filename, parse and validate, and return the errors if any *) +let read filename expected other = + let cf = parse filename in + validate cf expected other diff --git a/lib/config.mli b/lib/config.mli new file mode 100644 index 00000000000..5cef5c63b80 --- /dev/null +++ b/lib/config.mli @@ -0,0 +1,27 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +exception Error of (string * string) list + +type ty = + | Set_bool of bool ref + | Set_int of int ref + | Set_string of string ref + | Set_float of float ref + | Unit of (unit -> unit) + | Bool of (bool -> unit) + | Int of (int -> unit) + | String of (string -> unit) + | Float of (float -> unit) + +val read: string -> (string * ty) list -> (string -> string -> unit) -> unit diff --git a/lib/date.ml b/lib/date.ml new file mode 100644 index 00000000000..ea82a9d2239 --- /dev/null +++ b/lib/date.ml @@ -0,0 +1,72 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +type iso8601 = string +type rfc822 = string + +let of_float x = + let time = Unix.gmtime x in + Printf.sprintf "%04d%02d%02dT%02d:%02d:%02dZ" + (time.Unix.tm_year+1900) + (time.Unix.tm_mon+1) + time.Unix.tm_mday + time.Unix.tm_hour + time.Unix.tm_min + time.Unix.tm_sec + +let months = [| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun"; + "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec" |] +let days = [| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |] + +let rfc822_of_float x = + let time = Unix.gmtime x in + Printf.sprintf "%s, %d %s %d %02d:%02d:%02d GMT" + days.(time.Unix.tm_wday) time.Unix.tm_mday + months.(time.Unix.tm_mon) (time.Unix.tm_year+1900) + time.Unix.tm_hour time.Unix.tm_min time.Unix.tm_sec + +let rfc822_to_string x = x + +(* Convert tm in localtime to calendar time, x *) +let to_float_localtime x = + Scanf.sscanf x "%04d%02d%02dT%02d:%02d:%02d" + (fun y mon d h min s -> + fst (Unix.mktime { Unix.tm_year = y - 1900; + tm_mon = mon - 1; + tm_mday = d; + tm_hour = h; + tm_min = min; + tm_sec = s; + (* These are ignored: *) + tm_wday = 0; tm_yday = 0; tm_isdst = true; + })) + +(* Convert tm in UTC back into calendar time x (using offset between above + UTC and localtime fns to determine offset between UTC and localtime, then + correcting for this) +*) +let to_float x = + let t = Unix.time() in + let offset = (to_float_localtime (of_float t)) -. t in + (to_float_localtime x) -. offset + +let to_string x = x +let of_string x = x + +let assert_utc x = + try + Scanf.sscanf x "%_[0-9]T%_[0-9]:%_[0-9]:%_[0-9]Z" () + with _ -> invalid_arg x + +let never = of_float 0.0 diff --git a/lib/date.mli b/lib/date.mli new file mode 100644 index 00000000000..79a1d2b273e --- /dev/null +++ b/lib/date.mli @@ -0,0 +1,49 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +(** Additional types and functions for dates *) + +(** {2 ISO 8601 Dates} *) + +(** An ISO-8601 date/time type. *) +type iso8601 + +(** Convert calendar time [x] (as returned by e.g. Unix.time), to time in UTC. *) +val of_float : float -> iso8601 + +(** Convert date/time to a float value: the number of seconds since 00:00:00 UTC, 1 Jan 1970. *) +val to_float : iso8601 -> float + +(** Convert date/time to an ISO 8601 formatted string. *) +val to_string : iso8601 -> string + +(** Convert ISO 8601 formatted string to a date/time value. *) +val of_string : string -> iso8601 + +(** Raises an Invalid_argument exception if the given date is not a UTC date. + * A UTC date is an ISO 8601 strings that ends with the character 'Z'. *) +val assert_utc : iso8601 -> unit + +(** Representation of the concept "never" (actually 00:00:00 UTC, 1 Jan 1970). *) +val never: iso8601 + +(** {2 RFC 822 Dates} *) + +(** An RFC 822 date/time type. *) +type rfc822 + +(** Convert calendar time [x] (as returned by e.g. Unix.time), to RFC 822. *) +val rfc822_of_float : float -> rfc822 + +(** Convert RFC 822 date/time to a formatted string. *) +val rfc822_to_string : rfc822 -> string diff --git a/lib/either.ml b/lib/either.ml new file mode 100644 index 00000000000..8cfd9b33342 --- /dev/null +++ b/lib/either.ml @@ -0,0 +1,42 @@ +open Pervasiveext +open Listext + +type ('a,'b) t = Left of 'a | Right of 'b + +module Monad = Monad.M2.Make (struct + + type ('a, 'b) m = ('b, 'a) t + + let bind value f = + match value with + | Left value -> Left value + | Right value -> f value + + let return value = Right value + +end) + +let left x = Left x +let right x = Right x +let is_left = function + | Left _ -> true + | Right _ -> false +let is_right x = not ++ is_left $ x +let to_option = function + | Right x -> Some x + | Left _ -> None + +let cat_right l = List.unbox_list ++ List.map to_option $ l + +let join = function + | Right (Right x) -> Right x + | Left x -> Left (Left x) + | Right (Left x) -> Left (Right x) + +let swap = function + | Right x -> Left x + | Left x -> Right x + +let of_exception f = + try Right (f ()) + with e -> Left e diff --git a/lib/either.mli b/lib/either.mli new file mode 100644 index 00000000000..494f4ea153b --- /dev/null +++ b/lib/either.mli @@ -0,0 +1,21 @@ +(* Inspired by Haskell's Either, as a way to enhance option with + information about what went wrong. + + Right is commonly used for success + Left is commonly used for failure. + *) + +type ('a,'b) t = Left of 'a | Right of 'b +module Monad : sig include Monad.M2.MONAD with type ('a, 'b) m = ('b, 'a) t end + +val left : 'a -> ('a, 'b) t +val right: 'b -> ('a, 'b) t +val is_left: ('a, 'b) t -> bool +val is_right: ('a, 'b) t -> bool + +val cat_right: ('a, 'b) t list -> 'b list +(* Brings Right values closer to the surface. *) +val join: ('a, ('b, 'c) t) t -> (('a, 'b) t, 'c) t + +val swap : ('a, 'b) t -> ('b, 'a) t +val of_exception : (unit -> 'a) -> (exn, 'a) t diff --git a/lib/encodings.ml b/lib/encodings.ml new file mode 100644 index 00000000000..15c35136b0e --- /dev/null +++ b/lib/encodings.ml @@ -0,0 +1,201 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +exception UCS_value_out_of_range +exception UCS_value_prohibited_in_UTF8 +exception UCS_value_prohibited_in_XML +exception UTF8_character_incomplete +exception UTF8_header_byte_invalid +exception UTF8_continuation_byte_invalid +exception UTF8_encoding_not_canonical +exception String_incomplete + +(* === Utility Functions === *) + +let ( +++ ) = Int32.add +let ( --- ) = Int32.sub +let ( &&& ) = Int32.logand +let ( ||| ) = Int32.logor +let ( <<< ) = Int32.shift_left +let ( >>> ) = Int32.shift_right_logical + +(* === Unicode Functions === *) + +module UCS = struct + + let min_value = 0x000000l + let max_value = 0x1fffffl + + let is_non_character value = false + || (0xfdd0l <= value && value <= 0xfdefl) (* case 1 *) + || (Int32.logand 0xfffel value = 0xfffel) (* case 2 *) + + let is_out_of_range value = + value < min_value || value > max_value + + let is_surrogate value = + (0xd800l <= value && value <= 0xdfffl) + +end + +module XML = struct + + let is_forbidden_control_character value = value < 0x20l + && value <> 0x09l + && value <> 0x0al + && value <> 0x0dl + +end + +(* === UCS Validators === *) + +module type UCS_VALIDATOR = sig + + val validate : int32 -> unit + +end + +module UTF8_UCS_validator : UCS_VALIDATOR = struct + + let validate value = + if UCS.is_out_of_range value then raise UCS_value_out_of_range; + if UCS.is_non_character value then raise UCS_value_prohibited_in_UTF8; + if UCS.is_surrogate value then raise UCS_value_prohibited_in_UTF8 + +end + +module XML_UTF8_UCS_validator : UCS_VALIDATOR = struct + + let validate value = + UTF8_UCS_validator.validate value; + if XML.is_forbidden_control_character value + then raise UCS_value_prohibited_in_XML + +end + +(* ==== Character Codecs ==== *) + +module type CHARACTER_DECODER = sig + val decode_character : string -> int -> int32 * int +end + +module type CHARACTER_ENCODER = sig + val encode_character : int32 -> string +end + +module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) = struct + let width_required_for_ucs_value value = + if value < 0x000080l (* 1 << 7 *) then 1 else + if value < 0x000800l (* 1 << 11 *) then 2 else + if value < 0x010000l (* 1 << 16 *) then 3 else 4 + + (* === Decoding === *) + + let decode_header_byte byte = + if byte land 0b10000000 = 0b00000000 then (byte , 1) else + if byte land 0b11100000 = 0b11000000 then (byte land 0b0011111, 2) else + if byte land 0b11110000 = 0b11100000 then (byte land 0b0001111, 3) else + if byte land 0b11111000 = 0b11110000 then (byte land 0b0000111, 4) else + raise UTF8_header_byte_invalid + + let decode_continuation_byte byte = + if byte land 0b11000000 = 0b10000000 then byte land 0b00111111 else + raise UTF8_continuation_byte_invalid + + let decode_character string index = + let value, width = decode_header_byte (Char.code string.[index]) in + let value = if width = 1 then (Int32.of_int value) + else begin + let value = ref (Int32.of_int value) in + for index = index + 1 to index + width - 1 do + let chunk = decode_continuation_byte (Char.code string.[index]) in + value := (!value <<< 6) ||| (Int32.of_int chunk) + done; + if width > (width_required_for_ucs_value !value) + then raise UTF8_encoding_not_canonical; + !value + end in + UCS_validator.validate value; + (value, width) + + (* === Encoding === *) + + let encode_header_byte width value = + match width with + | 1 -> value + | 2 -> value ||| 0b11000000l + | 3 -> value ||| 0b11100000l + | 4 -> value ||| 0b11110000l + | _ -> raise UCS_value_out_of_range + + let encode_continuation_byte value = + ((value &&& 0b00111111l) ||| 0b10000000l, value >>> 6) + + let encode_character value = + UCS_validator.validate value; + let width = width_required_for_ucs_value value in + let string = String.make width ' ' in + (* Start by encoding the continuation bytes in reverse order. *) + let rec encode_continuation_bytes remainder index = + if index = 0 then remainder else + let byte, remainder = encode_continuation_byte remainder in + string.[index] <- Char.chr (Int32.to_int byte); + encode_continuation_bytes remainder (index - 1) in + let remainder = encode_continuation_bytes value (width - 1) in + (* Finish by encoding the header byte. *) + let byte = encode_header_byte width remainder in + string.[0] <- Char.chr (Int32.to_int byte); + string + +end + +module UTF8_codec = UTF8_CODEC ( UTF8_UCS_validator) +module XML_UTF8_codec = UTF8_CODEC (XML_UTF8_UCS_validator) + +(* === String Validators === *) + +module type STRING_VALIDATOR = sig + + val is_valid : string -> bool + val validate : string -> unit + val longest_valid_prefix : string -> string + +end + +exception Validation_error of int * exn + +module String_validator (Decoder : CHARACTER_DECODER) : STRING_VALIDATOR = struct + + let validate string = + let index = ref 0 and length = String.length string in + begin try + while !index < length do + let value, width = Decoder.decode_character string !index in + index := !index + width + done; + with + | Invalid_argument _ -> raise String_incomplete + | error -> raise (Validation_error (!index, error)) + end; assert (!index = length) + + let is_valid string = + try validate string; true with _ -> false + + let longest_valid_prefix string = + try validate string; string + with Validation_error (index, reason) -> String.sub string 0 index + +end + +module UTF8 = String_validator ( UTF8_codec) +module UTF8_XML = String_validator (XML_UTF8_codec) diff --git a/lib/encodings.mli b/lib/encodings.mli new file mode 100644 index 00000000000..b028f014f82 --- /dev/null +++ b/lib/encodings.mli @@ -0,0 +1,203 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +(** Encoding helper modules *) + +(** {2 Exceptions} *) + +exception UCS_value_out_of_range +exception UCS_value_prohibited_in_UTF8 +exception UCS_value_prohibited_in_XML +exception UTF8_header_byte_invalid +exception UTF8_continuation_byte_invalid +exception UTF8_encoding_not_canonical +exception String_incomplete + +(** {2 UCS Validators} *) + +(** Validates UCS character values. *) +module type UCS_VALIDATOR = sig + val validate : int32 -> unit +end + +(** Accepts all values within the UCS character value range + * except those which are invalid for all UTF-8 documents. *) +module UTF8_UCS_validator : UCS_VALIDATOR + +(** Accepts all values within the UCS character value range except + * those which are invalid for all UTF-8-encoded XML documents. *) +module XML_UTF8_UCS_validator : UCS_VALIDATOR + +module UCS : sig + val min_value : int32 + val max_value : int32 + + (** Returns true if and only if the given value corresponds to a UCS *) + (** non-character. Such non-characters are forbidden for use in open *) + (** interchange of Unicode text data, and include the following: *) + (** 1. values from 0xFDD0 to 0xFDEF; and *) + (** 2. values 0xnFFFE and 0xnFFFF, where (0x0 <= n <= 0x10). *) + (** See the Unicode 5.0 Standard, section 16.7 for further details. *) + val is_non_character : int32 -> bool + + (** Returns true if and only if the given value lies outside the *) + (** entire UCS range. *) + val is_out_of_range : int32 -> bool + + (** Returns true if and only if the given value corresponds to a UCS *) + (** surrogate code point, only for use in UTF-16 encoded strings. *) + (** See the Unicode 5.0 Standard, section 16.6 for further details. *) + val is_surrogate : int32 -> bool +end + +val (+++) : int32 -> int32 -> int32 +val (---) : int32 -> int32 -> int32 +val (&&&) : int32 -> int32 -> int32 +val (|||) : int32 -> int32 -> int32 +val (<<<) : int32 -> int -> int32 +val (>>>) : int32 -> int -> int32 + +module XML : sig + (** Returns true if and only if the given value corresponds to *) + (** a forbidden control character as defined in section 2.2 of *) + (** the XML specification, version 1.0. *) + val is_forbidden_control_character : int32 -> bool +end + +(** {2 Character Codecs} *) + +module type CHARACTER_ENCODER = sig + + (** Encodes a single character value, returning a string containing *) + (** the character. Raises an error if the character value is invalid. *) + val encode_character : int32 -> string + +end + +module type CHARACTER_DECODER = sig + (** Decodes a single character embedded within a string. Given a string *) + (** and an index into that string, returns a tuple (value, width) where: *) + (** value = the value of the character at the given index; and *) + (** width = the width of the character at the given index, in bytes. *) + (** Raises an appropriate error if the character is invalid. *) + val decode_character : string -> int -> int32 * int +end + +module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) : sig + (** Given a valid UCS value, returns the canonical *) + (** number of bytes required to encode the value. *) + val width_required_for_ucs_value : int32 -> int + + (** {3 Decoding} *) + + (** Decodes a header byte, returning a tuple (v, w) where: *) + (** v = the (partial) value contained within the byte; and *) + (** w = the total width of the encoded character, in bytes. *) + val decode_header_byte : int -> int * int + + (** Decodes a continuation byte, returning the *) + (** 6-bit-wide value contained within the byte. *) + val decode_continuation_byte : int -> int + + (** Decodes a single character embedded within a string. Given a string *) + (** and an index into that string, returns a tuple (value, width) where: *) + (** value = the value of the character at the given index; and *) + (** width = the width of the character at the given index, in bytes. *) + (** Raises an appropriate error if the character is invalid. *) + val decode_character : string -> int -> int32 * int + + (** {3 Encoding} *) + + (** Encodes a header byte for the given parameters, where: *) + (** width = the total width of the encoded character, in bytes; *) + (** value = the most significant bits of the original UCS value. *) + val encode_header_byte : int -> int32 -> int32 + + (** Encodes a continuation byte from the given UCS *) + (** remainder value, returning a tuple (b, r), where: *) + (** b = the continuation byte; *) + (** r = a new UCS remainder value. *) + val encode_continuation_byte : int32 -> int32 * int32 + + (** Encodes a single character value, returning a string containing *) + (** the character. Raises an error if the character value is invalid. *) + val encode_character : int32 -> string +end + +module UTF8_codec : sig + val width_required_for_ucs_value : int32 -> int + val decode_header_byte : int -> int * int + val decode_continuation_byte : int -> int + val decode_character : string -> int -> int32 * int + + val encode_header_byte : int -> int32 -> int32 + val encode_continuation_byte : int32 -> int32 * int32 + val encode_character : int32 -> string +end + +module XML_UTF8_codec : sig + val width_required_for_ucs_value : int32 -> int + val decode_header_byte : int -> int * int + val decode_continuation_byte : int -> int + val decode_character : string -> int -> int32 * int + + val encode_header_byte : int -> int32 -> int32 + val encode_continuation_byte : int32 -> int32 * int32 + val encode_character : int32 -> string +end + +(** {2 String Validators} *) + +(** Provides functionality for validating and processing + * strings according to a particular character encoding. *) +module type STRING_VALIDATOR = sig + + (** Returns true if and only if the given string is validly-encoded. *) + val is_valid : string -> bool + + (** Raises an encoding error if the given string is not validly-encoded. *) + val validate: string -> unit + + (** Returns the longest validly-encoded prefix of the given string. *) + val longest_valid_prefix : string -> string + +end + +module String_validator (Decoder : CHARACTER_DECODER) : STRING_VALIDATOR + +(** Represents a validation error as a tuple [(i,e)], where: + * [i] = the index of the first non-compliant character; + * [e] = the reason for non-compliance. *) +exception Validation_error of int * exn + +(** Provides functions for validating and processing + * strings according to the UTF-8 character encoding. + * + * Validly-encoded strings must satisfy RFC 3629. + * + * For further information, see: + * http://www.rfc.net/rfc3629.html *) +module UTF8 : STRING_VALIDATOR + +(** Provides functions for validating and processing + * strings according to the UTF-8 character encoding, + * with certain additional restrictions on UCS values + * imposed by the XML specification. + * + * Validly-encoded strings must satisfy both RFC 3629 + * and section 2.2 of the XML specification. + * + * For further information, see: + * http://www.rfc.net/rfc3629.html + * http://www.w3.org/TR/REC-xml/#charsets *) +module UTF8_XML : STRING_VALIDATOR diff --git a/lib/extentlistSet.ml b/lib/extentlistSet.ml new file mode 100644 index 00000000000..eda19a8c8d9 --- /dev/null +++ b/lib/extentlistSet.ml @@ -0,0 +1,106 @@ + +module type Number = sig + type t + val zero: t + val add : t -> t -> t + val sub : t -> t -> t +end + +module ExtentlistSet (A : Number) = +struct + type extent = A.t * A.t + type t = extent list + + let ($+) = A.add + let ($-) = A.sub + + let empty = [] + + let sort list : t = + List.sort (fun x y -> compare (fst x) (fst y)) list + + let remove_zeroes = List.filter (fun (_, y) -> y <> A.zero) + + let union (list1: t) (list2: t) : t = + let combined = sort (list1 @ list2) in + let rec inner l acc = + match l with + | (s1,e1)::(s2,e2)::ls -> + let extent1_end = s1 $+ e1 in + if extent1_end < s2 then + inner ((s2,e2)::ls) ((s1,e1)::acc) + else + let extent2_end = s2 $+ e2 in + if extent1_end > extent2_end then + inner ((s1,e1)::ls) acc + else + inner ((s1,s2 $+ e2 $- s1)::ls) acc + | (s1,e1)::[] -> (s1,e1)::acc + | [] -> [] + in List.rev (inner combined []) + + let intersection (list1: t) (list2: t) = + let rec inner l1 l2 acc = + match (l1,l2) with + | (s1,e1)::l1s , (s2,e2)::l2s -> + if s1 > s2 then inner l2 l1 acc else + if s1 $+ e1 < s2 then inner l1s l2 acc else + if s1 < s2 then inner ((s2,e1 $+ s1 $- s2)::l1s) l2 acc else + (* s1=s2 *) + if e1 < e2 then + inner l1s ((s2 $+ e1,e2 $- e1)::l2s) ((s1,e1)::acc) + else if e1 > e2 then + inner ((s1 $+ e2,e1 $- e2)::l1s) l2s ((s2,e2)::acc) + else (* e1=e2 *) + inner l1s l2s ((s1,e1)::acc) + | _ -> List.rev acc + in + remove_zeroes(inner list1 list2 []) + + let difference (list1: t) (list2: t) : t = + let rec inner l1 l2 acc = + match (l1,l2) with + | (s1,e1)::l1s , (s2,e2)::l2s -> + if s1 s2 then + inner ((s2,s1 $+ e1 $- s2)::l1s) l2 ((s1,s2 $- s1)::acc) + else + inner l1s l2 ((s1,e1)::acc) + end else if s1>s2 then begin + if s2 $+ e2 > s1 then + inner l1 ((s1,s2 $+ e2 $- s1)::l2s) acc + else + inner l1 l2s acc + end else begin + (* s1=s2 *) + if e1 > e2 then + inner ((s1 $+ e2,e1 $- e2)::l1s) l2s acc + else if e1 < e2 then + inner l1s ((s2 $+ e1,e2 $- e1)::l2s) acc + else + inner l1s l2s acc + end + | l1s, [] -> (List.rev acc) @ l1s + | [], _ -> List.rev acc + in + remove_zeroes(inner list1 list2 []) + + let of_list (list: extent list) : t = + let l = sort list in + let rec inner ls acc = + match ls with + | (s1,e1)::(s2,e2)::rest -> + (* extents should be non-overlapping *) + if s1 $+ e1 > s2 then failwith "Bad list" + (* adjacent extents should be coalesced *) + else if s1 $+ e1=s2 then inner ((s1,e1 $+ e2)::rest) acc + else inner ((s2,e2)::rest) ((s1,e1)::acc) + | (s1,e1)::[] -> List.rev ((s1,e1)::acc) + | [] -> List.rev acc + in + inner l [] + + let fold_left = List.fold_left + + let to_list x = x +end diff --git a/lib/extentlistSet.mli b/lib/extentlistSet.mli new file mode 100644 index 00000000000..e46e29a8e51 --- /dev/null +++ b/lib/extentlistSet.mli @@ -0,0 +1,27 @@ +(** A module to represent sets of elements as (start, length) pairs. *) + +(** Elements must be 'Numbers': *) +module type Number = sig + type t + val zero: t + val add : t -> t -> t + val sub : t -> t -> t + +end + +(** Representation of a Set *) +module ExtentlistSet: functor (A : Number) -> sig + type extent = A.t * A.t + type t + + val empty : t + + val union : t -> t -> t + val intersection : t -> t -> t + val difference : t -> t -> t + + val of_list : extent list -> t + val to_list : t -> extent list + val fold_left : ('a -> extent -> 'a) -> 'a -> t -> 'a +end + diff --git a/lib/extentlistset_test.ml b/lib/extentlistset_test.ml new file mode 100644 index 00000000000..524cb4dc832 --- /dev/null +++ b/lib/extentlistset_test.ml @@ -0,0 +1,92 @@ +(* We will check if a list of set equalities hold over random inputs *) + +open Set_test + +(* We test using the integer domain only. *) +module Intextentlist = ExtentlistSet.ExtentlistSet(struct + type t=int + let zero=0 + let add=(+) + let sub=(-) +end) +open Intextentlist + +(* Sets are finite, up to cardinality [size] *) +let size = 1000 + +module Tests = SetEqualities(struct + type t = Intextentlist.t + let universe = of_list [(0, size)] + let (+) = union + let (^) = intersection + let (-) = difference + + let not x = universe - x + let (=) x y = (x - y = empty) && (y - x = empty) + let extent_to_string (s, l) = Printf.sprintf "(%d, %d)" s l + let to_string xs = String.concat ", " (List.map extent_to_string (to_list xs)) +end) +(* Given a triple of inputs, check that all the set equalities hold *) +let one (a, b, c) = List.iter (fun f -> f a b c) Tests.all + +open LazyList + +(** [make p s e] return an extentlist starting at [s], ending before [e] where + an integer x is covered by the extentlist iff [p x] *) +let make p s e = + let rec ints acc a b = if a < b then ints (a :: acc) (a + 1) b else acc in + of_list (List.fold_left (fun acc x -> if p x then (x, 1)::acc else acc) [] (ints [] s e)) + +(* A lazy-list of random triples (a, b, c)*) +let random_inputs = + let one () = make (fun _ -> Random.bool ()) 0 (size - 1) in + (* Create triples of random inputs for the checker *) + let three () = one (), one (), one () in + let rec f () = lazy (Cons(three (), f ())) in + f () + +let _ = + let n = 1000 in + iter (fun _ -> ()) (take n (map one random_inputs)); + Printf.printf "%d random sets of maximum size %d checked.\n" n size + +type run = + | Empty of int + | Full of int +let to_run_list xs = + let rec inner acc index = function + | [] -> acc + | (x, y) :: xs -> inner (Full y :: (Empty (x - index)) :: acc) (x + y) xs in let map f xs = + let rec inner acc f = function + | [] -> acc + | (x :: xs) -> inner ((f x)::acc) f xs in + inner [] f xs in + + List.rev (inner [] 0 xs) + +let _ = + (* vhds have max size of 2 TiB, in 2 MiB blocks => 2**20 blocks *) + (* The BAT consists of up to 2**20 blocks in any order *) + (* Worst case for us is as many singleton blocks as possible, which *) + (* can't be coalesced because they don't have neighbours. The maximum *) + (* number of blocks is achieved with the allocation pattern 10101010... *) + (* i.e. 2**19 singleton blocks. *) + + (* As a bitmap we would have 2**19 / 2**3 = 2**16 bytes (64kbit) *) + let worst_case = make (fun x -> x mod 2 = 1) 0 (1024*1024/2/12) in + let hex (a, b) = Printf.sprintf "%x,%x" a b in + let to_string xs = "[" ^ (String.concat ";" (Listext.List.map_tr hex xs)) ^ "]" in + + + Printf.printf "generated\n"; + let x = to_list worst_case in +Printf.printf "got a list\n"; + let y = Listext.List.map_tr hex x in +Printf.printf "got lots of strings\n"; + let s = to_string (to_list worst_case) in + Printf.printf "Extent size=%d\n" (String.length s); + let string_of_run = function + | Empty x -> Printf.sprintf "-%d" x + | Full x -> Printf.sprintf "+%d" x in + let s' = String.concat ";" (Listext.List.map_tr string_of_run (to_run_list x)) in + Printf.printf "Runs size=%d\n" (String.length s') diff --git a/lib/filenameext.ml b/lib/filenameext.ml new file mode 100644 index 00000000000..eb15bc6773e --- /dev/null +++ b/lib/filenameext.ml @@ -0,0 +1,30 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** Makes a new file in the same directory as 'otherfile' *) +let temp_file_in_dir otherfile = + let base_dir = Filename.dirname otherfile in + let rec keep_trying () = + try + let uuid = Uuidm.to_string (Uuidm.create `V4) in + let newfile = base_dir ^ "/" ^ uuid in + Unix.close (Unix.openfile newfile [Unix.O_CREAT; Unix.O_TRUNC; Unix.O_EXCL] 0o600); + newfile + with + Unix.Unix_error (Unix.EEXIST, _, _) -> keep_trying () + in + keep_trying () + + + diff --git a/lib/filenameext.mli b/lib/filenameext.mli new file mode 100644 index 00000000000..5529c3959a9 --- /dev/null +++ b/lib/filenameext.mli @@ -0,0 +1,14 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +val temp_file_in_dir : string -> string diff --git a/lib/fring.ml b/lib/fring.ml new file mode 100644 index 00000000000..2a7439161f0 --- /dev/null +++ b/lib/fring.ml @@ -0,0 +1,80 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +type t = { size: int; mutable current: int; data: (float,Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t ; } + +let make size init = + let ring = + { size = size; current = size - 1; data = Bigarray.Array1.create Bigarray.float32 Bigarray.c_layout size; } + in + Bigarray.Array1.fill ring.data init; + ring + +let copy x = + let y = make x.size 0. in + Bigarray.Array1.blit x.data y.data; + y.current <- x.current; + y + +let length ring = ring.size + +let push ring e = + ring.current <- ring.current + 1; + if ring.current = ring.size then + ring.current <- 0; + Bigarray.Array1.set ring.data ring.current e + +let peek ring i = + if i >= ring.size then + raise (Invalid_argument "peek: index"); + let index = + let offset = ring.current - i in + if offset >= 0 then offset else ring.size + offset in + Bigarray.Array1.get ring.data index + +let top ring = Bigarray.Array1.get ring.data ring.current + +let iter_nb ring f nb = + if nb > ring.size then + raise (Invalid_argument "iter_nb: nb"); + (* FIXME: OPTIMIZE ME with 2 Array.iter ? *) + for i = 0 to nb - 1 + do + f (peek ring i) + done + +(* iter directly on all element without using the index *) +let iter f a = + for i=0 to Bigarray.Array1.dim a - 1 do + f (Bigarray.Array1.get a i) + done + +let raw_iter ring f = + iter f ring.data + +let iter ring f = iter_nb ring f (ring.size) + +let get_nb ring nb = + if nb > ring.size then + raise (Invalid_argument "get_nb: nb"); + let a = Array.create nb (top ring) in + for i = 1 to nb - 1 + do + (* FIXME: OPTIMIZE ME with 2 Array.blit *) + a.(i) <- peek ring i + done; + a + +let get ring = get_nb ring (ring.size) + diff --git a/lib/fring.mli b/lib/fring.mli new file mode 100644 index 00000000000..c14aa503ff5 --- /dev/null +++ b/lib/fring.mli @@ -0,0 +1,51 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +(** Ring structures *) + +type t = { + size : int; + mutable current : int; + data : (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t; +} + +(** create a ring structure with [size] record; records initialised to [init] *) +val make : int -> float -> t + +(** create a duplicate ring structure *) +val copy : t -> t + +(** length of the ring *) +val length : t -> int + +(** push into the ring one element *) +val push : t -> float -> unit + +(** get the i{^th} old element from the ring *) +val peek : t -> int -> float + +(** get the top element of the ring *) +val top : t -> float + +(** iterate over nb element of the ring, starting from the top *) +val iter_nb : t -> (float -> 'a) -> int -> unit + +val raw_iter : t -> (float -> 'a) -> unit + +(** iterate over all elements of the ring, starting from the top *) +val iter : t -> (float -> 'a) -> unit + +(** get array of latest [nb] value *) +val get_nb : t -> int -> float array + +val get : t -> float array diff --git a/lib/fun.ml b/lib/fun.ml new file mode 100644 index 00000000000..4088caca3f5 --- /dev/null +++ b/lib/fun.ml @@ -0,0 +1,22 @@ + + +(* just forgets it's second argument: *) +let const a b = a + +let uncurry f (a,b) = f a b + +let id a = a + +let flip f a b = f b a + +let on op f x y = op (f x) (f y) + +let comp f g x = f (g x) +let (++) f g x = comp f g x + +let comp2 f g a b = f (g a b) +let (+++) f g a b = comp2 f g a b + +let (|>) a f = f a + +let ($) f a = f a diff --git a/lib/fun.mli b/lib/fun.mli new file mode 100644 index 00000000000..e563ed05caf --- /dev/null +++ b/lib/fun.mli @@ -0,0 +1,12 @@ +val const : 'a -> 'b -> 'a +val uncurry : ('a -> 'b -> 'c) -> ('a * 'b) -> 'c +val id : 'a -> 'a +val flip : ('a -> 'b -> 'c) -> ('b -> 'a -> 'c) +val on : ('b -> 'b -> 'c) -> ('a -> 'b) -> 'a -> 'a -> 'c +val comp : ('b -> 'c) -> ('a -> 'b) -> ('a -> 'c) +val comp2 : ('b -> 'c) -> ('a1 -> 'a2 -> 'b) -> ('a1 -> 'a2 -> 'c) +val (+++) : ('c -> 'd) -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'd +val (++) : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c +(** Forward pipe operator: facilitates left-to-right function composition. *) +val (|>) : 'a -> ('a -> 'b) -> 'b +val ($) : ('a -> 'b) -> 'a -> 'b diff --git a/lib/gzip.ml b/lib/gzip.ml new file mode 100644 index 00000000000..8e81b728361 --- /dev/null +++ b/lib/gzip.ml @@ -0,0 +1,97 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +open Pervasiveext + +(** Path to the gzip binary *) +let gzip = "/bin/gzip" + +(** Helper function to prevent double-closes of file descriptors *) +let close to_close fd = + if List.mem fd !to_close then Unix.close fd; + to_close := List.filter (fun x -> fd <> x) !to_close + +type zcat_mode = Compress | Decompress + +type input_type = + | Active (** we provide a function which writes into the compressor and a fd output *) + | Passive (** we provide an fd input and a function which reads from the compressor *) + +(* start cmd with lowest priority so that it doesn't + use up all cpu resources in dom0 +*) +let lower_priority cmd args = + let ionice="/usr/bin/ionice" in + let ionice_args=["-c";"3"] in (*io idle*) + let nice="/bin/nice" in + let nice_args=["-n";"19"] in (*lowest priority*) + let extra_args=nice_args@[ionice]@ionice_args in + let new_cmd=nice in + let new_args=extra_args@[cmd]@args in + (new_cmd,new_args) + +(** Runs a zcat process which is either: + i) a compressor; or (ii) a decompressor + and which has either + i) an active input (ie a function and a pipe) + passive output (fd); or + ii) a passive input (fd) + active output (ie a function and a pipe) +*) +let go (mode: zcat_mode) (input: input_type) fd f = + let zcat_out, zcat_in = Unix.pipe() in + + let to_close = ref [ zcat_in; zcat_out ] in + let close = close to_close in + + finally + (fun () -> + let args = if mode = Compress then [] else ["--decompress"] @ [ "--stdout"; "--force" ] in + + let stdin, stdout, close_now, close_later = match input with + | Active -> + Some zcat_out, (* input comes from the pipe+fn *) + Some fd, (* supplied fd is written to *) + zcat_out, (* we close this now *) + zcat_in (* close this before waitpid *) + | Passive -> + Some fd, (* supplied fd is read from *) + Some zcat_in, (* output goes into the pipe+fn *) + zcat_in, (* we close this now *) + zcat_out in (* close this before waitpid *) + let (gzip,args)=lower_priority gzip args in + let pid = Forkhelpers.safe_close_and_exec stdin stdout None [] gzip args in + close close_now; + finally + (fun () -> + f close_later + ) + (fun () -> + let failwith_error s = + let mode = if mode = Compress then "Compression" else "Decompression" in + let msg = Printf.sprintf "%s via zcat failed: %s" mode s in + Printf.eprintf "%s" msg; + failwith msg + in + close close_later; + match snd (Forkhelpers.waitpid pid) with + | Unix.WEXITED 0 -> (); + | Unix.WEXITED i -> failwith_error (Printf.sprintf "exit code %d" i) + | Unix.WSIGNALED i -> failwith_error (Printf.sprintf "killed by signal: %s" (Unixext.string_of_signal i)) + | Unix.WSTOPPED i -> failwith_error (Printf.sprintf "stopped by signal: %s" (Unixext.string_of_signal i)) + ) + ) (fun () -> List.iter close !to_close) + +let compress fd f = go Compress Active fd f +let decompress fd f = go Decompress Active fd f + +let decompress_passive fd f = go Decompress Passive fd f diff --git a/lib/gzip.mli b/lib/gzip.mli new file mode 100644 index 00000000000..b8613a3769e --- /dev/null +++ b/lib/gzip.mli @@ -0,0 +1,24 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** Runs a compression process which is fed from a pipe whose entrance is passed to 'f' + and whose output is 'ofd' *) +val compress: Unix.file_descr -> (Unix.file_descr -> unit) -> unit + +(** Runs a decompression process which is fed from a pipe whose entrance is passed to 'f' + and whose output is 'ofd' *) +val decompress: Unix.file_descr -> (Unix.file_descr -> 'a) -> 'a + +(* Experimental decompressor which is fed from an fd and writes to a pipe *) +val decompress_passive: Unix.file_descr -> (Unix.file_descr -> 'a) -> 'a diff --git a/lib/hashtblext.ml b/lib/hashtblext.ml new file mode 100644 index 00000000000..c0065dfa513 --- /dev/null +++ b/lib/hashtblext.ml @@ -0,0 +1,40 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +let to_list tbl = + Hashtbl.fold (fun k v acc -> (k, v) :: acc) tbl [] + +let fold_keys tbl = + Hashtbl.fold (fun k v acc -> k :: acc) tbl [] + +let fold_values tbl = + Hashtbl.fold (fun k v acc -> v :: acc) tbl [] + +let add_empty tbl k v = + if not (Hashtbl.mem tbl k) then + Hashtbl.add tbl k v + +let add_list tbl l = + List.iter (fun (k, v) -> Hashtbl.add tbl k v) l + +let remove_other_keys tbl valid_keys = + let keys = fold_keys tbl in + let maybe_remove k = + if not (List.mem k valid_keys) then Hashtbl.remove tbl k in + List.iter maybe_remove keys + +let of_list l = + let tbl = Hashtbl.create (List.length l) in + add_list tbl l; + tbl diff --git a/lib/hashtblext.mli b/lib/hashtblext.mli new file mode 100644 index 00000000000..c1a25a850f0 --- /dev/null +++ b/lib/hashtblext.mli @@ -0,0 +1,20 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + val to_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list + val fold_keys : ('a, 'b) Hashtbl.t -> 'a list + val fold_values : ('a, 'b) Hashtbl.t -> 'b list + val add_empty : ('a, 'b) Hashtbl.t -> 'a -> 'b -> unit + val add_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list -> unit + val remove_other_keys : ('a, 'b) Hashtbl.t -> 'a list -> unit + val of_list : ('a * 'b) list -> ('a, 'b) Hashtbl.t diff --git a/lib/int64ext.ml b/lib/int64ext.ml new file mode 100644 index 00000000000..27c3442671a --- /dev/null +++ b/lib/int64ext.ml @@ -0,0 +1,17 @@ +module Int64 = struct + + module Operators = struct + + let ( +++ ) = Int64.add + let ( --- ) = Int64.sub + let ( *** ) = Int64.mul + let ( /// ) = Int64.div + let ( &&& ) = Int64.logand + let ( ||| ) = Int64.logor + let ( <<< ) = Int64.shift_left + let ( >>> ) = Int64.shift_right_logical + let ( !!! ) = Int64.lognot + + end + +end diff --git a/lib/int64ext.mli b/lib/int64ext.mli new file mode 100644 index 00000000000..c8441f54f6c --- /dev/null +++ b/lib/int64ext.mli @@ -0,0 +1,17 @@ +module Int64 : sig + + module Operators : sig + + val ( +++ ) : int64 -> int64 -> int64 + val ( --- ) : int64 -> int64 -> int64 + val ( *** ) : int64 -> int64 -> int64 + val ( /// ) : int64 -> int64 -> int64 + val ( &&& ) : int64 -> int64 -> int64 + val ( ||| ) : int64 -> int64 -> int64 + val ( <<< ) : int64 -> int -> int64 + val ( >>> ) : int64 -> int -> int64 + val ( !!! ) : int64 -> int64 + + end + +end \ No newline at end of file diff --git a/lib/lazyList.ml b/lib/lazyList.ml new file mode 100644 index 00000000000..9b0b93e2e37 --- /dev/null +++ b/lib/lazyList.ml @@ -0,0 +1,20 @@ +(* A lazy-list implementation *) + +type 'a elt = + | Empty + | Cons of 'a * 'a t +and 'a t = 'a elt lazy_t + +let rec map f xs = lazy(match Lazy.force xs with + | Empty -> Empty + | Cons(x, xs) -> Cons(f x, map f xs)) + +let rec take n xs = lazy(match n, Lazy.force xs with + | 0, _ -> Empty + | n, Empty -> raise Not_found + | n, Cons(x, xs) -> Cons(x, take (n - 1) xs)) + +let rec iter f xs = match Lazy.force xs with + | Empty -> () + | Cons(x, xs) -> f x; iter f xs + diff --git a/lib/lazyList.mli b/lib/lazyList.mli new file mode 100644 index 00000000000..f6355a85e8a --- /dev/null +++ b/lib/lazyList.mli @@ -0,0 +1,16 @@ +(** A lazy-list *) + +(** A forced lazy list element *) +type 'a elt = Empty | Cons of 'a * 'a t + +(** A lazy list *) +and 'a t = 'a elt lazy_t + +(** [map f xs] returns the list [f 1; f 2; ...; f n] *) +val map : ('a -> 'b) -> 'a t -> 'b t + +(** [take n xs] returns the list truncated to the first [n] elements *) +val take : int -> 'a t -> 'a t + +(** [iter f xs] applies every list element to [f] *) +val iter : ('a -> 'b) -> 'a t -> unit diff --git a/lib/libstdext_stubs.clib b/lib/libstdext_stubs.clib new file mode 100644 index 00000000000..8cbca027bcc --- /dev/null +++ b/lib/libstdext_stubs.clib @@ -0,0 +1,7 @@ +# OASIS_START +# DO NOT EDIT (digest: 6a87487702231dfad360de7126120d50) +unixext_open_stubs.o +unixext_stubs.o +unixext_write_stubs.o +zerocheck_stub.o +# OASIS_STOP diff --git a/lib/listext.ml b/lib/listext.ml new file mode 100644 index 00000000000..57f5baddadb --- /dev/null +++ b/lib/listext.ml @@ -0,0 +1,232 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +open Fun +module List = struct include List + +module Monad = Monad.M1.Make (struct + + type 'a m = 'a list + + let bind list f = + let rec inner result = function + | x :: xs -> inner (List.rev_append (f x) result) xs + | [] -> List.rev result + in + inner [] list + + let return x = [x] + +end) + +(** Turn a list into a set *) +let rec setify = function + | [] -> [] + | (x::xs) -> if mem x xs then setify xs else x::(setify xs) + +let subset s1 s2 = List.fold_left (&&) true (List.map (fun s->List.mem s s2) s1) +let set_equiv s1 s2 = (subset s1 s2) && (subset s2 s1) + +let iteri f list = ignore (fold_left (fun i x -> f i x; i+1) 0 list) +let iteri_right f list = ignore (fold_right (fun x i -> f i x; i+1) list 0) + +let rec inv_assoc k = function + | [] -> raise Not_found + | (v, k') :: _ when k = k' -> v + | _ :: t -> inv_assoc k t + +(* Tail-recursive map. *) +let map_tr f l = rev (rev_map f l) + +let count pred l = + fold_left (fun count e -> count + if pred e then 1 else 0) 0 l + +let position pred l = + let aux (i, is) e = i + 1, if pred e then i :: is else is in + snd (fold_left aux (0, []) l) + +let mapi f l = + let rec aux n = function + | h :: t -> let h = f n h in h :: aux (n + 1) t + | [] -> [] in + aux 0 l + +let rev_mapi f l = + let rec aux n accu = function + | h :: t -> aux (n + 1) (f n h :: accu) t + | [] -> accu in + aux 0 [] l + +let mapi_tr f l = rev (rev_mapi f l) + +let rec chop i l = match i, l with + | 0, l -> [], l + | i, h :: t -> (fun (fr, ba) -> h :: fr, ba) (chop (i - 1) t) + | _ -> invalid_arg "chop" + +let rev_chop i l = + let rec aux i fr ba = match i, fr, ba with + | 0, fr, ba -> (fr, ba) + | i, fr, h :: t -> aux (i - 1) (h :: fr) t + | _ -> invalid_arg "rev_chop" in + aux i [] l + +let chop_tr i l = + (fun (fr, ba) -> rev fr, ba) (rev_chop i l) + +let rec dice m l = match chop m l with + | l, [] -> [l] + | l1, l2 -> l1 :: dice m l2 + +let sub i j l = + fst (chop_tr (j - i) (snd (rev_chop i l))) + +let remove i l = match rev_chop i l with + | rfr, _ :: t -> rev_append rfr t + | _ -> invalid_arg "remove" + +let extract i l = match rev_chop i l with + | rfr, h :: t -> h, rev_append rfr t + | _ -> invalid_arg "extract" + +let insert i e l = match rev_chop i l with + rfr, ba -> rev_append rfr (e :: ba) + +let replace i e l = match rev_chop i l with + | rfr, _ :: t -> rev_append rfr (e :: t) + | _ -> invalid_arg "replace" + +let morph i f l = match rev_chop i l with + | rfr, h :: t -> rev_append rfr (f h :: t) + | _ -> invalid_arg "morph" + +let rec between e = function + | [] -> [] + | [h] -> [h] + | h :: t -> h :: e :: between e t + + +let between_tr e l = + let rec aux accu e = function + | [] -> rev accu + | [h] -> rev (h :: accu) + | h :: t -> aux (e :: h :: accu) e t in + aux [] e l + +let randomize l = + let extract_rand l = extract (Random.int (length l)) l in + let rec aux accu = function + | [] -> accu + | l -> (fun (h, t) -> aux (h :: accu) t) (extract_rand l) in + aux [] l + +let rec distribute e = function + | (h :: t) as l -> + (e :: l) :: (map (fun x -> h :: x) (distribute e t)) + | [] -> [ [ e ] ] + +let rec permute = function + | e :: rest -> flatten (map (distribute e) (permute rest)) + | [] -> [ [] ] + +let rec aux_rle_eq eq l2 x n = function + | [] -> rev ((x, n) :: l2) + | h :: t when eq x h -> aux_rle_eq eq l2 x (n + 1) t + | h :: t -> aux_rle_eq eq ((x, n) :: l2) h 1 t + +let rle_eq eq l = + match l with [] -> [] | h :: t -> aux_rle_eq eq [] h 1 t + +let rle l = rle_eq ( = ) l + +let unrle l = + let rec aux2 accu i c = match i with + | 0 -> accu + | i when i>0 -> aux2 (c :: accu) (i - 1) c + | _ -> invalid_arg "unrle" in + let rec aux accu = function + | [] -> rev accu + | (i, c) :: t -> aux (aux2 accu i c) t in + aux [] l + +let inner fold_left2 base f l1 l2 g = + fold_left2 (fun accu e1 e2 -> g accu (f e1 e2)) base l1 l2 + +let rec is_sorted compare list = + match list with + | x :: y :: list -> + if compare x y <= 0 + then is_sorted compare (y :: list) + else false + | _ -> + true + +let intersect xs ys = List.filter (fun x -> List.mem x ys) xs + +let set_difference a b = List.filter (fun x -> not(List.mem x b)) a + +let assoc_default k l d = + if List.mem_assoc k l then List.assoc k l else d + +let map_assoc_with_key op al = + List.map (fun (k, v1) -> (k, op k v1)) al + +(* Like the Lisp cons *) +let cons a b = a :: b + +(* Could use fold_left to get the same value, but that would necessarily go through the whole list everytime, instead of the first n items, only. *) +(* ToDo: This is complicated enough to warrant a test. *) +(* Is it wise to fail silently on negative values? (They are treated as zero, here.) + Pro: Would mask fewer bugs. + Con: Less robust. +*) +let take n list = + let rec helper i acc list = + if i <= 0 || list = [] + then acc + else helper (i-1) (List.hd list :: acc) (List.tl list) + in List.rev $ helper n [] list + +(* Thanks to sharing we only use linear space. (Roughly double the space needed for the spine of the original list) *) +let rec tails = function + | [] -> [[]] + | (_::xs) as l -> l :: tails xs + +let safe_hd = function + | a::_ -> Some a + | [] -> None + +let replace_assoc key new_value existing = + (key, new_value) :: (List.filter (fun (k, _) -> k <> key) existing) + +let update_assoc update existing = + update @ (List.filter (fun (k, _) -> not (List.mem_assoc k update)) existing) + +let make_assoc op l = map (fun key -> key, op key) l + +let unbox_list a = List.map Opt.unbox (List.filter Opt.is_boxed a) + +let filter_map f list = + (unbox_list +++ map) f list + +let restrict_with_default default keys al = + make_assoc (fun k -> assoc_default k al default) keys + +let range lower = + let rec aux accu upper = + if lower >= upper + then accu + else aux (upper-1::accu) (upper-1) in + aux [] + +end diff --git a/lib/listext.mli b/lib/listext.mli new file mode 100644 index 00000000000..ab141d5b694 --- /dev/null +++ b/lib/listext.mli @@ -0,0 +1,211 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +module List : +sig + module Monad : sig include Monad.M1.MONAD with type 'a m = 'a list end + val setify : 'a list -> 'a list + val subset : 'a list -> 'a list -> bool + val set_equiv : 'a list -> 'a list -> bool + val length : 'a list -> int + val hd : 'a list -> 'a + val tl : 'a list -> 'a list + val nth : 'a list -> int -> 'a + val rev : 'a list -> 'a list + val append : 'a list -> 'a list -> 'a list + val rev_append : 'a list -> 'a list -> 'a list + val concat : 'a list list -> 'a list + val flatten : 'a list list -> 'a list + val iter : ('a -> unit) -> 'a list -> unit + val map : ('a -> 'b) -> 'a list -> 'b list + val rev_map : ('a -> 'b) -> 'a list -> 'b list + val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a + val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b + val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit + val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a + val fold_right2 : + ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c + val for_all : ('a -> bool) -> 'a list -> bool + val exists : ('a -> bool) -> 'a list -> bool + val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + val mem : 'a -> 'a list -> bool + val memq : 'a -> 'a list -> bool + val find : ('a -> bool) -> 'a list -> 'a + val filter : ('a -> bool) -> 'a list -> 'a list + val find_all : ('a -> bool) -> 'a list -> 'a list + val partition : ('a -> bool) -> 'a list -> 'a list * 'a list + val assoc : 'a -> ('a * 'b) list -> 'b + val assq : 'a -> ('a * 'b) list -> 'b + val mem_assoc : 'a -> ('a * 'b) list -> bool + val mem_assq : 'a -> ('a * 'b) list -> bool + val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list + val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list + val split : ('a * 'b) list -> 'a list * 'b list + val combine : 'a list -> 'b list -> ('a * 'b) list + val sort : ('a -> 'a -> int) -> 'a list -> 'a list + val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list + val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list + val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list + + (** Perform a lookup on an association list of (value, key) pairs. *) + val inv_assoc : 'a -> ('b * 'a) list -> 'b + + (** A tail-recursive map. *) + val map_tr : ('a -> 'b) -> 'a list -> 'b list + + (** Count the number of list elements matching the given predicate. *) + val count : ('a -> bool) -> 'a list -> int + + (** Find the indices of all elements matching the given predicate. *) + val position : ('a -> bool) -> 'a list -> int list + + (** Map the given function over a list, supplying the integer + index as well as the element value. *) + val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list + + val iteri : (int -> 'a -> unit) -> 'a list -> unit + + val iteri_right : (int -> 'a -> unit) -> 'a list -> unit + + (** Map the given function over a list in reverse order. *) + val rev_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list + + (** Tail-recursive [mapi]. *) + val mapi_tr : (int -> 'a -> 'b) -> 'a list -> 'b list + + (** Split a list at the given index to give a pair of lists. *) + val chop : int -> 'a list -> 'a list * 'a list + + (** Split a list at the given index to give a pair of lists, the first in + reverse order. *) + val rev_chop : int -> 'a list -> 'a list * 'a list + + (** Tail-recursive [chop]. *) + val chop_tr : int -> 'a list -> 'a list * 'a list + + (** Split a list into lists with the given number of elements. *) + val dice : int -> 'a list -> 'a list list + + (** Extract the sub-list between the given indices. *) + val sub : int -> int -> 'a list -> 'a list + + (** Remove the element at the given index. *) + val remove : int -> 'a list -> 'a list + + (** Extract the element at the given index, returning the element and the + list without that element. *) + val extract : int -> 'a list -> 'a * 'a list + + (** Insert the given element at the given index. *) + val insert : int -> 'a -> 'a list -> 'a list + + (** Replace the element at the given index with the given value. *) + val replace : int -> 'a -> 'a list -> 'a list + + (** Apply the given function to the element at the given index. *) + val morph : int -> ('a -> 'a) -> 'a list -> 'a list + + (** Insert the element [e] between every pair of adjacent elements in the + given list. *) + val between : 'a -> 'a list -> 'a list + + (** Tail-recursive [between]. *) + val between_tr : 'a -> 'a list -> 'a list + + (** Generate a random permutation of the given list. *) + val randomize : 'a list -> 'a list + + (** Distribute the given element over the given list, returning a list of + lists with the new element in each position. *) + val distribute : 'a -> 'a list -> 'a list list + + (** Generate all permutations of the given list. *) + val permute : 'a list -> 'a list list + + (** Run-length encode the given list using the given equality function. *) + val rle_eq : ('a -> 'a -> bool) -> 'a list -> ('a * int) list + + (** Run-length encode the given list using built-in equality. *) + val rle : 'a list -> ('a * int) list + + (** Decode a run-length encoded list. *) + val unrle : (int * 'a) list -> 'a list + + (** Compute the inner product of two lists. *) + val inner : + (('a -> 'b -> 'c -> 'd) -> 'e -> 'f -> 'g -> 'h) -> + 'e -> ('b -> 'c -> 'i) -> 'f -> 'g -> ('a -> 'i -> 'd) -> 'h + + (** Applies a function f that generates optional values, to each + of the items in a list A [a1; ...; am], generating a new list of + non-optional values B [b1; ...; bn], with m >= n. For each value + a in list A, list B contains a corresponding value b if and only + if the application of (f a) results in Some b. *) + val filter_map : ('a -> 'b option) -> 'a list -> 'b list + + (** Returns true if and only if the given list is in sorted order + according to the given comparison function. *) + val is_sorted : ('a -> 'a -> int) -> 'a list -> bool + + (** Returns the intersection of two lists. *) + val intersect : 'a list -> 'a list -> 'a list + + (** Returns the set difference of two lists *) + val set_difference : 'a list -> 'a list -> 'a list + + (** Act as List.assoc, but return the given default value if the + key is not in the list. *) + val assoc_default : 'a -> ('a * 'b) list -> 'b -> 'b + + (** [map_assoc_with_key op al] transforms every value in [al] based on the + key and the value using [op]. *) + val map_assoc_with_key : ('k -> 'v1 -> 'v2) -> ('k * 'v1) list -> ('k * 'v2) list + + (* Like Lisp cons*) + val cons : 'a -> 'a list -> 'a list + + (** [take n list] returns the first [n] elements of [list] (or less if list + is shorter).*) + val take : int -> 'a list -> 'a list + + val tails : 'a list -> ('a list) list + val safe_hd : 'a list -> 'a option + + (** Replace the value belonging to a key in an association list. Adds the key/value pair + * if it does not yet exist in the list. If the same key occurs multiple time in the original + * list, all occurances are removed and replaced by a single new key/value pair. + * This function is useful is the assoc list is used as a lightweight map/hashtable/dictonary. *) + val replace_assoc : 'a -> 'b -> ('a * 'b) list -> ('a * 'b) list + + (** Includes everything from [update] and all key/value pairs from [existing] for + * which the key does not exist in [update]. In other words, it is like [replace_assoc] + * but then given a whole assoc list of updates rather than a single key/value pair. *) + val update_assoc : ('a * 'b) list -> ('a * 'b) list -> ('a * 'b) list + + val make_assoc : ('a -> 'b) -> 'a list -> ('a * 'b) list + + (** Unbox all values from the option list. *) + val unbox_list : 'a option list -> 'a list + + (** [restrict_with_default default keys al] makes a new association map + from [keys] to previous values for [keys] in [al]. If a key is not found + in [al], the [default] is used. *) + val restrict_with_default : 'v -> 'k list -> ('k * 'v) list -> ('k * 'v) list + + (** range lower upper = [lower; lower + 1; ...; upper - 1] + Returns the empty list if lower >= upper. *) + val range : int -> int -> int list +end diff --git a/lib/mapext.ml b/lib/mapext.ml new file mode 100644 index 00000000000..8f20866d7a4 --- /dev/null +++ b/lib/mapext.ml @@ -0,0 +1,47 @@ + +module type S = + sig + type key + type +'a t + val empty: 'a t + val is_empty: 'a t -> bool + val add: key -> 'a -> 'a t -> 'a t + val find: key -> 'a t -> 'a + val remove: key -> 'a t -> 'a t + val mem: key -> 'a t -> bool + val iter: (key -> 'a -> unit) -> 'a t -> unit + val map: ('a -> 'b) -> 'a t -> 'b t + val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + + val fromHash : (key, 'a) Hashtbl.t -> 'a t + + val filter : ('a -> bool) -> 'a t -> 'a t + + (* values: gives the list of values of the map. *) + val values : 'a t -> 'a list + + val fromListWith : ('a -> 'a -> 'a) -> (key * 'a) list -> 'a t + val adjust : ('a -> 'a) -> key -> 'a t -> 'a t + + end + +module Make(Ord: Map.OrderedType) = struct + include Map.Make (Ord) + + let fromHash h = Hashtbl.fold add h empty + let filter pred m = fold (fun k v acc -> (if pred v then add k v else Fun.id) acc) m empty + (* values: gives the list of values of the map. *) + let values m = fold (Fun.const Listext.List.cons) m [] + + let fromListWith op list = List.fold_left (fun map (k,v) -> + add k (if mem k map + then op v (find k map) + else v) map) + empty list + let adjust op k m = try add k (op (find k m)) m with Not_found -> m + + +end diff --git a/lib/mapext.mli b/lib/mapext.mli new file mode 100644 index 00000000000..9613768104e --- /dev/null +++ b/lib/mapext.mli @@ -0,0 +1,31 @@ +module type S = + sig + type key + type +'a t + val empty: 'a t + val is_empty: 'a t -> bool + val add: key -> 'a -> 'a t -> 'a t + val find: key -> 'a t -> 'a + val remove: key -> 'a t -> 'a t + val mem: key -> 'a t -> bool + val iter: (key -> 'a -> unit) -> 'a t -> unit + val map: ('a -> 'b) -> 'a t -> 'b t + val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + + val fromHash : (key, 'a) Hashtbl.t -> 'a t + val filter : ('a -> bool) -> 'a t -> 'a t + + (* values: gives the list of values of the map. *) + val values : 'a t -> 'a list + + val fromListWith : ('a -> 'a -> 'a) -> (key * 'a) list -> 'a t + (* Update a value at a specific key with the result of the + provided function. When the key is not a member of the map, the + original map is returned. *) + val adjust : ('a -> 'a) -> key -> 'a t -> 'a t + end + +module Make (Ord : Map.OrderedType) : S with type key = Ord.t diff --git a/lib/monad.ml b/lib/monad.ml new file mode 100644 index 00000000000..aaf2bbbab33 --- /dev/null +++ b/lib/monad.ml @@ -0,0 +1,70 @@ +(* + * Copyright (C) 2010-2011 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** 1-parameter monads. *) +module M1 = struct + + module type BASE = + sig + type 'a m + val bind : 'a m -> ('a -> 'b m) -> 'b m + val return : 'a -> 'a m + end + + module type MONAD = + sig + type 'a m + val (>>=) : 'a m -> ('a -> 'b m) -> 'b m + val bind : 'a m -> ('a -> 'b m) -> 'b m + val return : 'a -> 'a m + end + + module Make (B : BASE) : MONAD with type 'a m = 'a B.m = + struct + type 'a m = 'a B.m + let (>>=) = B.bind + let bind = B.bind + let return = B.return + end + +end + +(** 2-parameter monads. *) +module M2 = struct + + module type BASE = + sig + type ('a, 'x) m + val bind : ('a, 'x) m -> ('a -> ('b, 'x) m) -> ('b, 'x) m + val return : 'a -> ('a, 'x) m + end + + module type MONAD = + sig + type ('a, 'x) m + val (>>=) : ('a, 'x) m -> ('a -> ('b, 'x) m) -> ('b, 'x) m + val bind : ('a, 'x) m -> ('a -> ('b, 'x) m) -> ('b, 'x) m + val return : 'a -> ('a, 'x) m + end + + module Make (B : BASE) : MONAD with type ('a, 'x) m = ('a, 'x) B.m = + struct + type ('a, 'x) m = ('a, 'x) B.m + let (>>=) = B.bind + let bind = B.bind + let return = B.return + end + +end + diff --git a/lib/monad.mli b/lib/monad.mli new file mode 100644 index 00000000000..7bce3a96a6a --- /dev/null +++ b/lib/monad.mli @@ -0,0 +1,70 @@ +(* + * Copyright (C) 2010-2011 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** 1-parameter monads. *) +module M1 : sig + + module type BASE = + sig + type 'a m + val bind : 'a m -> ('a -> 'b m) -> 'b m + val return : 'a -> 'a m + end + + module type MONAD = + sig + type 'a m + val ( >>= ) : 'a m -> ('a -> 'b m) -> 'b m + val bind : 'a m -> ('a -> 'b m) -> 'b m + val return : 'a -> 'a m + end + + module Make : functor (B : BASE) -> + sig + type 'a m = 'a B.m + val ( >>= ) : 'a m -> ('a -> 'b m) -> 'b m + val bind : 'a m -> ('a -> 'b m) -> 'b m + val return : 'a -> 'a m + end + +end + +(** 2-parameter monads. *) +module M2 : sig + + module type BASE = + sig + type ('a, 'b) m + val bind : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m + val return : 'a -> ('a, 'b) m + end + + module type MONAD = + sig + type ('a, 'b) m + val ( >>= ) : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m + val bind : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m + val return : 'a -> ('a, 'b) m + end + + module Make : functor (B : BASE) -> + sig + type ('a, 'b) m = ('a, 'b) B.m + val ( >>= ) : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m + val bind : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m + val return : 'a -> ('a, 'b) m + end + +end + diff --git a/lib/opt.ml b/lib/opt.ml new file mode 100644 index 00000000000..a26f238ea7d --- /dev/null +++ b/lib/opt.ml @@ -0,0 +1,82 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(* Perhaps it's better to use `option' from the ocaml-extlib extension + * to the standard library instead? (Although it would not suffice, + * since it's not a super-set of our `opt'.) + * (http://code.google.com/p/ocaml-extlib/) + *) + +open Pervasiveext + +module Monad = Monad.M1.Make (struct + + type 'a m = 'a option + + let bind option f = + match option with + | None -> None + | Some result -> f result + + let return x = Some x + +end) + +let iter f = function + | Some x -> f x + | None -> () + +let map f = function + | Some x -> Some(f x) + | None -> None + +let default d = function + | Some x -> x + | None -> d + +let unbox = function + | Some x -> x + | None -> raise Not_found + +let is_boxed = function + | Some _ -> true + | None -> false + +let is_some = is_boxed + +let is_none = function + | Some _ -> false + | None -> true + +let to_list = function + | Some x -> [x] + | None -> [] + +let fold_left f accu = function + | Some x -> f accu x + | None -> accu + +let fold_right f opt accu = + match opt with + | Some x -> f x accu + | None -> accu + +let join = function + | Some (Some a) -> Some a + | _ -> None + +let of_exception f = + try Some (f ()) + with _ -> None + diff --git a/lib/opt.mli b/lib/opt.mli new file mode 100644 index 00000000000..16ac7e59d5b --- /dev/null +++ b/lib/opt.mli @@ -0,0 +1,27 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module Monad : sig include Monad.M1.MONAD with type 'a m = 'a option end +val iter : ('a -> unit) -> 'a option -> unit +val map : ('a -> 'b) -> 'a option -> 'b option +val default : 'a -> 'a option -> 'a +val unbox : 'a option -> 'a +val is_boxed : 'a option -> bool +val is_some : 'a option -> bool +val is_none : 'a option -> bool +val to_list : 'a option -> 'a list +val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b option -> 'a +val fold_right : ('a -> 'b -> 'b) -> 'a option -> 'b -> 'b +val join : ('a option) option -> 'a option +val of_exception : (unit -> 'a) -> 'a option diff --git a/lib/pervasiveext.ml b/lib/pervasiveext.ml new file mode 100644 index 00000000000..4c1dadf3660 --- /dev/null +++ b/lib/pervasiveext.ml @@ -0,0 +1,64 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +(** apply the clean_f function after fct function has been called. + * Even if fct raises an exception, clean_f is applied + *) + +let exnhook = ref None + +let finally fct clean_f = + let result = try + fct (); + with + exn -> + (match !exnhook with None -> () | Some f -> f exn); + clean_f (); raise exn in + clean_f (); + result + +(* Those should go into the Opt module: *) + +let maybe_with_default d f v = + match v with None -> d | Some x -> f x + +(** if v is not none, apply f on it and return some value else return none. *) +let may f v = maybe_with_default None (fun x -> Some (f x)) v + +(** default value to d if v is none. *) +let default d v = maybe_with_default d (fun x -> x) v + +(** apply f on v if not none *) +let maybe f v = maybe_with_default () f v + +(** if bool is false then we intercept and quiten any exception *) +let reraise_if bool fct = + try fct () with exn -> if bool then raise exn else () + +(** execute fct ignoring exceptions *) +let ignore_exn fct = try fct () with _ -> () + +(* non polymorphic ignore function *) +let ignore_int v = let (_: int) = v in () +let ignore_int64 v = let (_: int64) = v in () +let ignore_int32 v = let (_: int32) = v in () +let ignore_string v = let (_: string) = v in () +let ignore_float v = let (_: float) = v in () +let ignore_bool v = let (_: bool) = v in () + +(* To avoid some parens: *) +(* composition of functions: *) +let (++) f g x = Fun.comp f g x + +(* and application *) +let ($) f a = f a diff --git a/lib/pervasiveext.mli b/lib/pervasiveext.mli new file mode 100644 index 00000000000..49a734e7766 --- /dev/null +++ b/lib/pervasiveext.mli @@ -0,0 +1,30 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +val exnhook : (exn -> unit) option ref +val finally : (unit -> 'a) -> (unit -> 'b) -> 'a +val maybe_with_default : 'b -> ('a -> 'b) -> 'a option -> 'b +val may : ('a -> 'b) -> 'a option -> 'b option +val default : 'a -> 'a option -> 'a +val maybe : ('a -> unit) -> 'a option -> unit +val reraise_if : bool -> (unit -> unit) -> unit +val ignore_exn : (unit -> unit) -> unit +val ignore_int : int -> unit +val ignore_int32 : int32 -> unit +val ignore_int64 : int64 -> unit +val ignore_string : string -> unit +val ignore_float : float -> unit +val ignore_bool : bool -> unit + +val (++) : ('b -> 'c) -> ('a -> 'b) -> ('a -> 'c) +val ($) : ('a -> 'b) -> 'a -> 'b diff --git a/lib/qring.ml b/lib/qring.ml new file mode 100644 index 00000000000..84c55b909fe --- /dev/null +++ b/lib/qring.ml @@ -0,0 +1,141 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +type t = { + sz: int; + data: string; + mutable prod: int; + mutable cons: int; + mutable pwrap: bool; +} + +exception Data_limit +exception Full + +let make sz = { sz = sz; data = String.create sz; prod = 0; cons = 0; pwrap = false } + +let to_consume ring = + if ring.pwrap then + ring.sz - (ring.cons - ring.prod) + else + ring.prod - ring.cons + +let to_fill ring = + if ring.pwrap then + ring.cons - ring.prod + else + ring.cons + (ring.sz - ring.prod) + +let is_full ring = ring.pwrap && ring.prod = ring.cons +let is_empty ring = not ring.pwrap && ring.prod = ring.cons + +let adv_cons ring i = + ring.cons <- ring.cons + i; + if ring.cons >= ring.sz then ( + ring.cons <- ring.cons - ring.sz; + ring.pwrap <- false; + ) + +let adv_prod ring i = + ring.prod <- ring.prod + i; + if ring.prod >= ring.sz then ( + ring.prod <- ring.prod - ring.sz; + ring.pwrap <- true; + ) + +let consume ring sz = + let max = to_consume ring in + let sz = + if sz > 0 then + if sz > max then max else sz + else + if max + sz > 0 then max + sz else 0 + in + let out = String.create sz in + if ring.pwrap then ( + let left_end = ring.sz - ring.cons in + if sz > left_end then ( + String.blit ring.data ring.cons out 0 left_end; + String.blit ring.data 0 out left_end (sz - left_end); + ) else + String.blit ring.data ring.cons out 0 sz; + ) else + String.blit ring.data ring.cons out 0 sz; + adv_cons ring sz; + out + +let consume_all ring = consume ring (max_int) + +let skip ring n = + let max = to_consume ring in + let n = if n > max then max else n in + adv_cons ring n + +let feed_data ring data = + let len = String.length data in + let max = to_fill ring in + if len > max then + raise Data_limit; + if ring.prod + len > ring.sz then ( + let firstblitsz = ring.sz - ring.prod in + String.blit data 0 ring.data ring.prod firstblitsz; + String.blit data firstblitsz ring.data 0 (len - firstblitsz); + ) else + String.blit data 0 ring.data ring.prod len; + adv_prod ring len; + () + +(* read and search directly to the qring. + * since we have give a continuous buffer, we limit our read length to the + * maximum continous length instead of the full length of the qring left. + * after the read, piggyback into the new data. + *) +let read_search ring fread fsearch len = + let prod = ring.prod in + let maxlen = + if ring.pwrap + then ring.cons - ring.prod + else ring.sz - ring.prod + in + if maxlen = 0 then + raise Full; + let len = if maxlen < len then maxlen else len in + let n = fread ring.data prod len in + if n > 0 then ( + adv_prod ring n; + fsearch ring.data prod n + ); + n + +let search ring c = + let search_from_to f t = + let found = ref false in + let i = ref f in + while not !found && !i < t + do + if ring.data.[!i] = c then + found := true + else + incr i + done; + if not !found then + raise Not_found; + !i - f + in + if is_empty ring then + raise Not_found; + if ring.pwrap then ( + try search_from_to ring.cons ring.sz + with Not_found -> search_from_to 0 ring.prod + ) else + search_from_to ring.cons ring.prod diff --git a/lib/qring.mli b/lib/qring.mli new file mode 100644 index 00000000000..7708d85b056 --- /dev/null +++ b/lib/qring.mli @@ -0,0 +1,41 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +type t = { + sz: int; + data: string; + mutable prod: int; + mutable cons: int; + mutable pwrap: bool; +} + +exception Data_limit +exception Full + +val make : int -> t + +val to_consume : t -> int +val to_fill : t -> int + +val is_full : t -> bool +val is_empty : t -> bool + +val consume : t -> int -> string +val consume_all : t -> string +val skip : t -> int -> unit + +val feed_data : t -> string -> unit +val read_search : t -> (string -> int -> int -> int) + -> (string -> int -> int -> unit) -> int + -> int +val search : t -> char -> int diff --git a/lib/range.ml b/lib/range.ml new file mode 100644 index 00000000000..5b362951b22 --- /dev/null +++ b/lib/range.ml @@ -0,0 +1,44 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +type t = { l : int; u : int } + +let make l u = + if l <= u then { l = l; u = u } else invalid_arg "Range.make" + +let get r = r.l, r.u + +let mem i r = r.l <= i && i < r.u + +let rec fold_left_aux f accu l u = + if l < u then + fold_left_aux f (f accu l) (l + 1) u + else accu + +let fold_left f accu r = fold_left_aux f accu r.l r.u + +let rec fold_right_aux f l u accu = + if l < u then + let u = u - 1 in + fold_right_aux f l u (f u accu) + else + accu + +let fold_right f r accu = fold_right_aux f r.l r.u accu + +let string_of_range r = + "[" ^ string_of_int r.l ^ ", " ^ string_of_int r.u ^ ")" + +let to_list r = + fold_right (fun x y -> x :: y) r [] + diff --git a/lib/range.mli b/lib/range.mli new file mode 100644 index 00000000000..0b78d6444eb --- /dev/null +++ b/lib/range.mli @@ -0,0 +1,33 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +type t + +(** Make a range. *) +val make : int -> int -> t + +(** Extract the start and end of the given range. *) +val get : t -> int * int + +(** Test the given int for membership in the given range. *) +val mem : int -> t -> bool + +(** Fold over a range, starting at the smallest int. *) +val fold_left : ('a -> int -> 'a) -> 'a -> t -> 'a + +(** Fold over a range, starting at the largest int. *) +val fold_right : (int -> 'a -> 'a) -> t -> 'a -> 'a + +(** Convert a range to a list of ascending integers *) +val to_list : t -> int list + diff --git a/lib/ring.ml b/lib/ring.ml new file mode 100644 index 00000000000..3fb032c56a9 --- /dev/null +++ b/lib/ring.ml @@ -0,0 +1,72 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +type 'a t = { size: int; mutable current: int; data: 'a array; } + +(** create a ring structure with size record. records inited to initval *) +let make size initval = + { size = size; current = size - 1; data = Array.create size initval; } + +(** length of the ring *) +let length ring = ring.size + +(** push into the ring one element *) +let push ring e = + ring.current <- ring.current + 1; + if ring.current = ring.size then + ring.current <- 0; + ring.data.(ring.current) <- e + +(** get the ith old element from the ring *) +let peek ring i = + if i >= ring.size then + raise (Invalid_argument "peek: index"); + let index = + let offset = ring.current - i in + if offset >= 0 then offset else ring.size + offset in + ring.data.(index) + +(** get the top element of the ring *) +let top ring = ring.data.(ring.current) + +(** iterate over nb element of the ring, starting from the top *) +let iter_nb ring f nb = + if nb > ring.size then + raise (Invalid_argument "iter_nb: nb"); + (* FIXME: OPTIMIZE ME with 2 Array.iter ? *) + for i = 0 to nb - 1 + do + f (peek ring i) + done + +(** iter directly on all element without using the index *) +let raw_iter ring f = + Array.iter f ring.data + +(** iterate over all element of the ring, starting from the top *) +let iter ring f = iter_nb ring f (ring.size) + +(** get array of latest nb value *) +let get_nb ring nb = + if nb > ring.size then + raise (Invalid_argument "get_nb: nb"); + let a = Array.create nb (top ring) in + for i = 1 to nb - 1 + do + (* FIXME: OPTIMIZE ME with 2 Array.blit *) + a.(i) <- peek ring i + done; + a + +let get ring = get_nb ring (ring.size) diff --git a/lib/ring.mli b/lib/ring.mli new file mode 100644 index 00000000000..95afdd1a048 --- /dev/null +++ b/lib/ring.mli @@ -0,0 +1,24 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +type 'a t = { size : int; mutable current : int; data : 'a array; } +val make : int -> 'a -> 'a t +val length : 'a t -> int +val push : 'a t -> 'a -> unit +val peek : 'a t -> int -> 'a +val top : 'a t -> 'a +val iter_nb : 'a t -> ('a -> 'b) -> int -> unit +val raw_iter : 'a t -> ('a -> unit) -> unit +val iter : 'a t -> ('a -> 'b) -> unit +val get_nb : 'a t -> int -> 'a array +val get : 'a t -> 'a array diff --git a/lib/set_test.ml b/lib/set_test.ml new file mode 100644 index 00000000000..dd46c7ed2b0 --- /dev/null +++ b/lib/set_test.ml @@ -0,0 +1,31 @@ +module type Set = sig + type t + val (+): t -> t -> t (* union *) + val (^): t -> t -> t (* intersection *) + val (-): t -> t -> t (* difference *) + val not: t -> t (* complement *) + val (=): t -> t -> bool + + val to_string: t -> string +end + +module SetEqualities(S: Set) = struct + open S + + let w txt f a b c = + if Pervasives.not(f a b c) + then failwith (Printf.sprintf "%s a=%s b=%s c=%s" txt (S.to_string a) (S.to_string b) (S.to_string c)) + + let all = [ + w "commutative_1" (fun a b _ -> a + b = b + a); + w "commutative_2" (fun a b _ -> a ^ b = b ^ a); + w "associative_1" (fun a b c -> (a + b) + c = a + (b + c)); + w "associative_2" (fun a b c -> (a ^ b) ^ c = a ^ (b ^ c)); + w "distributive_1" (fun a b c -> a + (b ^ c) = (a + b) ^ (a + c)); + w "distributive_2" (fun a b c -> a ^ (b + c) = (a ^ b) + (a ^ c)); + w "complement_1" (fun a _ _ -> not (not a) = a); + w "demorgan_1" (fun a b _ -> not (a + b) = (not a) ^ (not b)); + w "demorgan_2" (fun a b _ -> not (a ^ b) = (not a) + (not b)); + ] +end + diff --git a/lib/set_test.mli b/lib/set_test.mli new file mode 100644 index 00000000000..aef45f9c3a5 --- /dev/null +++ b/lib/set_test.mli @@ -0,0 +1,15 @@ +module type Set = + sig + type t + val ( + ) : t -> t -> t + val ( ^ ) : t -> t -> t + val ( - ) : t -> t -> t + val not : t -> t + val ( = ) : t -> t -> bool + val to_string : t -> string + end +module SetEqualities : + functor (S : Set) -> + sig + val all : (S.t -> S.t -> S.t -> unit) list + end diff --git a/lib/sha1sum.ml b/lib/sha1sum.ml new file mode 100644 index 00000000000..5b1f1ee7b4d --- /dev/null +++ b/lib/sha1sum.ml @@ -0,0 +1,64 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** Path to the sha1sum binary (used in the new import/export code to append checksums *) +let sha1sum = "/usr/bin/sha1sum" + +open Pervasiveext +open Stringext + +(** Helper function to prevent double-closes of file descriptors *) +let close to_close fd = + if List.mem fd !to_close then Unix.close fd; + to_close := List.filter (fun x -> fd <> x) !to_close + +(** Fork a slave sha1sum process, execute a function with the input file descriptor + and return the result of sha1sum, guaranteeing to reap the process. *) +let sha1sum f = + let input_out, input_in = Unix.pipe () in + let result_out, result_in = Unix.pipe () in + + Unix.set_close_on_exec result_out; + Unix.set_close_on_exec input_in; + + let to_close = ref [ input_out; input_in; result_out; result_in ] in + let close = close to_close in + + finally + (fun () -> + let args = [] in + let pid = Forkhelpers.safe_close_and_exec (Some input_out) (Some result_in) None [] sha1sum args in + + close result_in; + close input_out; + + finally + (fun () -> + finally + (fun () -> f input_in) + (fun () -> close input_in); + let buffer = String.make 1024 '\000' in + let n = Unix.read result_out buffer 0 (String.length buffer) in + let raw = String.sub buffer 0 n in + let result = match String.split ' ' raw with + | result :: _ -> result + | _ -> failwith (Printf.sprintf "Unable to parse sha1sum output: %s" raw) in + close result_out; + result) + (fun () -> + Forkhelpers.waitpid_fail_if_bad_exit pid + ) + ) (fun () -> List.iter close !to_close) + + diff --git a/lib/sha1sum.mli b/lib/sha1sum.mli new file mode 100644 index 00000000000..3c549fb2614 --- /dev/null +++ b/lib/sha1sum.mli @@ -0,0 +1,17 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** Takes a function which is supplied with an fd representing the input to the + sha1sum and returns the checksum as a string *) +val sha1sum: (Unix.file_descr -> unit) -> string diff --git a/lib/stdext.mllib b/lib/stdext.mllib new file mode 100644 index 00000000000..c27f8dffe03 --- /dev/null +++ b/lib/stdext.mllib @@ -0,0 +1,35 @@ +# OASIS_START +# DO NOT EDIT (digest: 27fb733ba22844f22e886085490e8e05) +Arrayext +Backtrace +Base64 +Bigbuffer +Config +Date +Either +Encodings +ExtentlistSet +Filenameext +Fring +Fun +Gzip +Hashtblext +Int64ext +LazyList +Listext +Mapext +Monad +Opt +Pervasiveext +Qring +Range +Ring +Sha1sum +Stringext +Tar +Threadext +Trie +Unixext +VIO +Zerocheck +# OASIS_STOP diff --git a/lib/stringext.ml b/lib/stringext.ml new file mode 100644 index 00000000000..8c743d559f8 --- /dev/null +++ b/lib/stringext.ml @@ -0,0 +1,217 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +module String = struct include String + +let of_char c = String.make 1 c + +let init n f = + let string = make n (f 0) in + for i=1 to n-1 do + string.[i] <- f i; + done; + string + +let map f string = + init (length string) (fun i -> f string.[i]) + +let rev_map f string = + let n = length string in + init n (fun i -> f string.[n - i - 1]) + +let rev_iter f string = + for i = length string - 1 downto 0 do + f (string.[i]) + done + +let fold_left f accu string = + let accu = ref accu in + for i = 0 to length string - 1 do + accu := f !accu string.[i] + done; + !accu + +let iteri f string = + for i = 0 to length string - 1 do + f i string.[i] + done + +let fold_right f string accu = + let accu = ref accu in + for i = length string - 1 downto 0 do + accu := f string.[i] !accu + done; + !accu + +let explode string = + fold_right (fun h t -> h :: t) string [] + +let implode list = + concat "" (List.map of_char list) + +(** True if string 'x' ends with suffix 'suffix' *) +let endswith suffix x = + let x_l = String.length x and suffix_l = String.length suffix in + suffix_l <= x_l && String.sub x (x_l - suffix_l) suffix_l = suffix + +(** True if string 'x' starts with prefix 'prefix' *) +let startswith prefix x = + let x_l = String.length x and prefix_l = String.length prefix in + prefix_l <= x_l && String.sub x 0 prefix_l = prefix + +(** Returns true for whitespace characters, false otherwise *) +let isspace = function + | ' ' | '\n' | '\r' | '\t' -> true + | _ -> false + +(** Removes all the characters from the ends of a string for which the predicate is true *) +let strip predicate string = + let rec remove = function + | [] -> [] + | c :: cs -> if predicate c then remove cs else c :: cs in + implode (List.rev (remove (List.rev (remove (explode string))))) + +let escaped ?rules string = match rules with + | None -> String.escaped string + | Some rules -> + let aux h t = (try List.assoc h rules + with Not_found -> of_char h) :: t in + concat "" (fold_right aux string []) + +(** Take a predicate and a string, return a list of strings separated by +runs of characters where the predicate was true (excluding those characters from the result) *) +let split_f p str = + let not_p = fun x -> not (p x) in + let rec split_one p acc = function + | [] -> List.rev acc, [] + | c :: cs -> if p c then split_one p (c :: acc) cs else List.rev acc, c :: cs in + + let rec alternate acc drop chars = + if chars = [] then acc else + begin + let a, b = split_one (if drop then p else not_p) [] chars in + alternate (if drop then acc else a :: acc) (not drop) b + end in + List.rev (List.map implode (alternate [] true (explode str))) + +let rec split ?limit:(limit=(-1)) c s = + let i = try String.index s c with Not_found -> -1 in + let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in + if i = -1 || nlimit = 0 then + [ s ] + else + let a = String.sub s 0 i + and b = String.sub s (i + 1) (String.length s - i - 1) in + a :: (split ~limit: nlimit c b) + +let rtrim s = + let n = String.length s in + if n > 0 && String.get s (n - 1) = '\n' then + String.sub s 0 (n - 1) + else + s + +(** has_substr str sub returns true if sub is a substring of str. Simple, naive, slow. *) +let has_substr str sub = + if String.length sub > String.length str then false else + begin + let result=ref false in + for start = 0 to (String.length str) - (String.length sub) do + if String.sub str start (String.length sub) = sub then result := true + done; + !result + end + +(** find all occurences of needle in haystack and return all their respective index *) +let find_all needle haystack = + let m = String.length needle and n = String.length haystack in + + if m > n then + [] + else ( + let i = ref 0 and found = ref [] in + while !i < (n - m + 1) + do + if (String.sub haystack !i m) = needle then ( + found := !i :: !found; + i := !i + m + ) else ( + incr i + ) + done; + List.rev !found + ) + +(* replace all @f substring in @s by @t *) +let replace f t s = + let indexes = find_all f s in + let n = List.length indexes in + if n > 0 then ( + let len_f = String.length f and len_t = String.length t in + let new_len = String.length s + (n * len_t) - (n * len_f) in + let new_s = String.make new_len '\000' in + let orig_offset = ref 0 and dest_offset = ref 0 in + List.iter (fun h -> + let len = h - !orig_offset in + String.blit s !orig_offset new_s !dest_offset len; + String.blit t 0 new_s (!dest_offset + len) len_t; + orig_offset := !orig_offset + len + len_f; + dest_offset := !dest_offset + len + len_t; + ) indexes; + String.blit s !orig_offset new_s !dest_offset (String.length s - !orig_offset); + new_s + ) else + s + +let filter_chars s valid = + let badchars = ref false in + let buf = Buffer.create 0 in + for i = 0 to String.length s - 1 + do + if !badchars then ( + if valid s.[i] then + Buffer.add_char buf s.[i] + ) else ( + if not (valid s.[i]) then ( + Buffer.add_substring buf s 0 i; + badchars := true + ) + ) + done; + if !badchars then Buffer.contents buf else s + +let map_unlikely s f = + let changed = ref false in + let m = ref 0 in + let buf = Buffer.create 0 in + for i = 0 to String.length s - 1 + do + match f s.[i] with + | None -> () + | Some n -> + changed := true; + Buffer.add_substring buf s !m (i - !m); + Buffer.add_string buf n; + m := i + 1 + done; + if !changed then ( + Buffer.add_substring buf s !m (String.length s - !m); + Buffer.contents buf + ) else + s + +let sub_to_end s start = + let length = String.length s in + String.sub s start (length - start) + +end diff --git a/lib/stringext.mli b/lib/stringext.mli new file mode 100644 index 00000000000..3cbe245b27a --- /dev/null +++ b/lib/stringext.mli @@ -0,0 +1,123 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +module String : + sig + external length : string -> int = "%string_length" + (** blabla *) + external get : string -> int -> char = "%string_safe_get" + external set : string -> int -> char -> unit = "%string_safe_set" + external create : int -> string = "caml_create_string" + val make : int -> char -> string + val copy : string -> string + val sub : string -> int -> int -> string + val fill : string -> int -> int -> char -> unit + val blit : string -> int -> string -> int -> int -> unit + val concat : string -> string list -> string + val iter : (char -> unit) -> string -> unit + val index : string -> char -> int + val rindex : string -> char -> int + val index_from : string -> int -> char -> int + val rindex_from : string -> int -> char -> int + val contains : string -> char -> bool + val contains_from : string -> int -> char -> bool + val rcontains_from : string -> int -> char -> bool + val uppercase : string -> string + val lowercase : string -> string + val capitalize : string -> string + val uncapitalize : string -> string + type t = string + val compare : t -> t -> int + external unsafe_get : string -> int -> char = "%string_unsafe_get" + external unsafe_set : string -> int -> char -> unit + = "%string_unsafe_set" + external unsafe_blit : string -> int -> string -> int -> int -> unit + = "caml_blit_string" "noalloc" + external unsafe_fill : string -> int -> int -> char -> unit + = "caml_fill_string" "noalloc" + val of_char : char -> string + + (** Make a string of the given length with characters generated by the + given function. *) + val init : int -> (int -> char) -> string + + (** Map a string to a string. *) + val map : (char -> char) -> string -> string + + (** Map a string to a string, applying the given function in reverse + order. *) + val rev_map : (char -> char) -> string -> string + + (** Iterate over the characters in a string in reverse order. *) + val rev_iter : (char -> 'a) -> string -> unit + + (** Fold over the characters in a string. *) + val fold_left : ('a -> char -> 'a) -> 'a -> string -> 'a + + (** Iterate over the characters with the character index in argument *) + val iteri : (int -> char -> 'a) -> string -> unit + + (** Iterate over the characters in a string in reverse order. *) + val fold_right : (char -> 'a -> 'a) -> string -> 'a -> 'a + + (** Split a string into a list of characters. *) + val explode : string -> char list + + (** Concatenate a list of characters into a string. *) + val implode : char list -> string + + (** True if string 'x' ends with suffix 'suffix' *) + val endswith : string -> string -> bool + + (** True if string 'x' starts with prefix 'prefix' *) + val startswith : string -> string -> bool + + (** True if the character is whitespace *) + val isspace : char -> bool + + (** Removes all the characters from the ends of a string for which the predicate is true *) + val strip : (char -> bool) -> string -> string + + (** Backward-compatible string escaping, defaulting to the built-in + OCaml string escaping but allowing an arbitrary mapping from characters + to strings. *) + val escaped : ?rules:(char * string) list -> string -> string + + (** Take a predicate and a string, return a list of strings separated by + runs of characters where the predicate was true *) + val split_f : (char -> bool) -> string -> string list + + (** split a string on a single char *) + val split : ?limit:int -> char -> string -> string list + + (** FIXME document me|remove me if similar to strip *) + val rtrim : string -> string + + (** True if sub is a substr of str *) + val has_substr : string -> string -> bool + +(** find all occurences of needle in haystack and return all their respective index *) + val find_all : string -> string -> int list + + (** replace all [f] substring in [s] by [t] *) + val replace : string -> string -> string -> string + + (** filter chars from a string *) + val filter_chars : string -> (char -> bool) -> string + + (** map a string trying to fill the buffer by chunk *) + val map_unlikely : string -> (char -> string option) -> string + + (** a substring from the specified position to the end of the string *) + val sub_to_end : string -> int -> string + end diff --git a/lib/tar.ml b/lib/tar.ml new file mode 100644 index 00000000000..fd4dac552c8 --- /dev/null +++ b/lib/tar.ml @@ -0,0 +1,376 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +open Stringext +open Unixext + +(** Process and create tar file headers *) +module Header = struct + (** Map of field name -> (start offset, length) taken from wikipedia: + http://en.wikipedia.org/w/index.php?title=Tar_%28file_format%29&oldid=83554041 *) + + let offset_size_table = [ "file_name", (0, 100); + "file_mode", (100, 8); + "user_id", (108, 8); + "group_id", (116, 8); + "file_size", (124, 12); + "mod_time", (136, 12); + "chksum", (148, 8); + "link", (156, 1); + "link_name", (157, 100); ] + + (** Extract the raw string corresponding to field named 'name' *) + let getfield (x: string) (name: string) = + if not(List.mem_assoc name offset_size_table) + then failwith (Printf.sprintf "Unknown tar header field: %s" name); + let start, length = List.assoc name offset_size_table in + String.sub x start length + + (** Set the raw data corresponding to the field named 'name' *) + let setfield (x: string) (name: string) (data: string) = + if not(List.mem_assoc name offset_size_table) + then failwith (Printf.sprintf "Unknown tar header field: %s" name); + let start, length = List.assoc name offset_size_table in + if String.length data > length + then failwith (Printf.sprintf "Data for field %s too large" name); + String.blit data 0 x start (String.length data) + + (** Return the size of the field named 'name' *) + let fieldsize (name: string) = + if not(List.mem_assoc name offset_size_table) + then failwith (Printf.sprintf "Unknown tar header field: %s" name); + snd(List.assoc name offset_size_table) + + (** Represents a standard (non-USTAR) archive (note checksum not stored) *) + type t = { file_name: string; + file_mode: int; + user_id: int; + group_id: int; + file_size: int64; + mod_time: int64; + link: bool; + link_name: int; + } + + (** Helper function to make a simple header *) + let make ?(file_mode=0) ?(user_id=0) ?(group_id=0) ?(mod_time=0L) ?(link=false) ?(link_name=0) file_name file_size = + { file_name = file_name; + file_mode = file_mode; + user_id = user_id; + group_id = group_id; + file_size = file_size; + mod_time = mod_time; + link = link; + link_name = link_name } + + (** Length of a header block *) + let length = 512 + + (** A blank header block (two of these in series mark the end of the tar) *) + let zero_block = String.make length '\000' + + (** Return a string containing 'x' padded out to 'n' bytes by adding 'c' to the LHS *) + let pad_left (x: string) (n: int) (c: char) = + if String.length x >= n then x + else let buffer = String.make n c in + String.blit x 0 buffer (n - (String.length x)) (String.length x); + buffer + + (** Return a string containing 'x' padded out to 'n' bytes by adding 'c' to the RHS *) + let pad_right (x: string) (n: int) (c: char) = + if String.length x >= n then x + else let buffer = String.make n c in + String.blit x 0 buffer 0 (String.length x); + buffer + + (** Pretty-print the header record *) + let to_detailed_string (x: t) = + let table = [ "file_name", x.file_name; + "file_mode", string_of_int x.file_mode; + "user_id", string_of_int x.user_id; + "group_id", string_of_int x.group_id; + "file_size", Int64.to_string x.file_size; + "mod_time", Int64.to_string x.mod_time; + "link", string_of_bool x.link; + "link_name", string_of_int x.link_name ] in + "{\n" ^ (String.concat "\n\t" (List.map (fun (k, v) -> k ^ ": " ^ v) table)) ^ "}" + + (** Make a single line summary which looks like the output of tar -tv *) + let to_summary_string (x: t) = + (* -rw-r--r-- *) + let mode = Printf.sprintf "%010d" x.file_mode in + (* root/root *) + let usergroup = Printf.sprintf "%d/%d" x.user_id x.group_id in + let size = pad_right (Int64.to_string x.file_size) 8 ' ' in + let time = Unix.gmtime (Int64.to_float x.mod_time) in + let time = Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d" + (time.Unix.tm_year + 1900) (time.Unix.tm_mon + 1) time.Unix.tm_mday + time.Unix.tm_hour time.Unix.tm_min time.Unix.tm_sec in + Printf.sprintf "%s %s %s %s %s" mode usergroup size time x.file_name + + (** For debugging: pretty-print a string as hex *) + let to_hex (x: string) : string = + let chars = List.map (Printf.sprintf "%02x") (List.map int_of_char (String.explode x)) in + String.concat " " chars + + (** Marshal an integer field of size 'n' *) + let marshal_int (x: int) (n: int) = + let octal = Printf.sprintf "%o" x in + let result = pad_left octal (n-1) '0' in + result ^ "\000" (* space or NULL allowed *) + + (** Marshal an int64 field of size 'n' *) + let marshal_int64 (x: int64) (n: int) = + let octal = Printf.sprintf "%Lo" x in + let result = pad_left octal (n-1) '0' in + result ^ "\000" (* space or NULL allowed *) + + (** Marshal an string field of size 'n' *) + let marshal_string (x: string) (n: int) = x + + (** Return the first part of a field, before the predicate is true *) + let trim (p: char -> bool) (x: string) : string = match String.split_f p x with + | [] -> "" + | first::_ -> first + + (** Return the first part of a numerical field, before any spaces or NULLs *) + let trim_numerical (x: string) : string = trim (fun c -> c = '\000' || c = ' ') x + (** Return the first part of a string field, before any NULLs *) + let trim_string (x: string) : string = trim (fun c -> c = '\000') x + + (** Unmarshal an integer field (stored as 0-padded octal) *) + let unmarshal_int (x: string) : int = + let tmp = "0o0" ^ (trim_numerical x) in + try + int_of_string tmp + with Failure "int_of_string" as e -> + Printf.eprintf "Failed to parse integer [%s] == %s\n" tmp (to_hex tmp); + raise e + + (** Unmarshal an int64 field (stored as 0-padded octal) *) + let unmarshal_int64 (x: string) : int64 = + let tmp = "0o0" ^ (trim_numerical x) in + Int64.of_string tmp + + (** Unmarshal a string *) + let unmarshal_string (x: string) : string = trim_string x + + (** Thrown when unmarshalling a header if the checksums don't match *) + exception Checksum_mismatch + + (** From an already-marshalled block, compute what the checksum should be *) + let checksum (x: string) : int64 = + (* Sum of all the byte values of the header with the checksum field taken + as 8 ' ' (spaces) *) + let x' = String.copy x in + let start, length = List.assoc "chksum" offset_size_table in + for i = start to start + length - 1 do + x'.[i] <- ' ' + done; + List.fold_left Int64.add 0L (List.map (fun x -> Int64.of_int (int_of_char x)) (String.explode x')) + + (** Unmarshal a header block, returning None if it's all zeroes *) + let unmarshal (x: string) : t option = + (* Check if the string is full of zeros *) + if x = zero_block then None + else + let chksum = unmarshal_int64 (getfield x "chksum") in + if checksum x <> chksum then raise Checksum_mismatch + else Some { file_name = unmarshal_string (getfield x "file_name"); + file_mode = unmarshal_int (getfield x "file_mode"); + user_id = unmarshal_int (getfield x "user_id"); + group_id = unmarshal_int (getfield x "group_id"); + file_size = unmarshal_int64 (getfield x "file_size"); + mod_time = unmarshal_int64 (getfield x "mod_time"); + link = getfield x "link" = "1"; + link_name = unmarshal_int (getfield x "link_name"); + } + + (** Marshal a header block, computing and inserting the checksum *) + let marshal (x: t) : string = + let buffer = String.make length '\000' in + setfield buffer "file_name" x.file_name; + setfield buffer "file_mode" (marshal_int x.file_mode (fieldsize "file_mode")); + setfield buffer "user_id" (marshal_int x.user_id (fieldsize "user_id")); + setfield buffer "group_id" (marshal_int x.group_id (fieldsize "group_id")); + setfield buffer "file_size" (marshal_int64 x.file_size (fieldsize "file_size")); + setfield buffer "mod_time" (marshal_int64 x.mod_time (fieldsize "mod_time")); + (* leave out link, link_name (zero-filled = unused) *) + (* Finally, compute the checksum *) + let chksum = checksum buffer in + setfield buffer "chksum" (marshal_int64 chksum (fieldsize "chksum")); + buffer + + (** Thrown if we detect the end of the tar (at least two zero blocks in sequence) *) + exception End_of_stream + + (** Returns the next header block or throws End_of_stream if two consecutive + zero-filled blocks are discovered. Assumes stream is positioned at the + possible start of a header block. Unix.End_of_file is thrown if the stream + unexpectedly fails *) + let get_next_header (ifd: Unix.file_descr) : t = + let next () = + let buffer = String.make length '\000' in + really_read ifd buffer 0 length; + unmarshal buffer + in + match next () with + | Some x -> x + | None -> + begin match next () with + | Some x -> x + | None -> raise End_of_stream + end + + (** Compute the amount of zero-padding required to round up the file size + to a whole number of blocks *) + let compute_zero_padding_length (x: t) : int = + (* round up to next whole number of block lengths *) + let length = Int64.of_int length in + let lenm1 = Int64.sub length Int64.one in + let next_block_length = (Int64.mul length (Int64.div (Int64.add x.file_size lenm1) length)) in + Int64.to_int (Int64.sub next_block_length x.file_size) + + (** Return the required zero-padding as a string *) + let zero_padding (x: t) : string = + let zero_padding_len = compute_zero_padding_length x in + String.make zero_padding_len '\000' + + (** Return the header needed for a particular file on disk *) + let of_file (file: string) : t = + let stat = Unix.stat file in + let size = Int64.of_int stat.Unix.st_size in + { file_name = file; + file_mode = stat.Unix.st_perm; + user_id = stat.Unix.st_uid; + group_id = stat.Unix.st_gid; + file_size = size; + mod_time = Int64.of_float stat.Unix.st_mtime; + link = false; + link_name = 0 } +end + + +let write_string fd str = + let written = Unix.write fd str 0 (String.length str) in + if str <> "" && String.length str > written then failwith "Truncated write" + +let write_bigbuffer fd buf = + Bigbuffer.to_fct buf (write_string fd) + +let write_block (header: Header.t) (body: Unix.file_descr -> unit) (fd : Unix.file_descr) = + write_string fd (Header.marshal header); + body fd; + write_string fd (Header.zero_padding header) + +let write_end (fd: Unix.file_descr) = + write_string fd Header.zero_block; + write_string fd Header.zero_block + +(** Utility functions for operating over whole tar archives *) +module Archive = struct + + (** Skip 'n' bytes from input channel 'ifd' *) + let skip (ifd: Unix.file_descr) (n: int) = + let buffer = String.make 4096 '\000' in + let rec loop (n: int) = + if n <= 0 then () + else + let amount = min n (String.length buffer) in + let m = Unix.read ifd buffer 0 amount in + if m = 0 then raise End_of_file; + loop (n - m) in + loop n + + (** Read the next header, apply the function 'f' to the fd and the header. The function + should leave the fd positioned immediately after the datablock. Finally the function + skips past the zero padding to the next header *) + let with_next_file (fd: Unix.file_descr) (f: Unix.file_descr -> Header.t -> 'a) = + let hdr = Header.get_next_header fd in + (* NB if the function 'f' fails we're boned *) + Pervasiveext.finally (fun () -> f fd hdr) + (fun () -> skip fd (Header.compute_zero_padding_length hdr)) + + + (** Multicast 'n' bytes from input fd 'ifd' to output fds 'ofds'. NB if one deadlocks + they all stop.*) + let multicast_n ?(buffer_size=1024*1024) (ifd: Unix.file_descr) (ofds: Unix.file_descr list) (n: int64) = + let buffer = String.make buffer_size '\000' in + let rec loop (n: int64) = + if n <= 0L then () + else + let amount = Int64.to_int (min n (Int64.of_int(String.length buffer))) in + let read = Unix.read ifd buffer 0 amount in + if read = 0 then raise End_of_file; + List.iter (fun ofd -> ignore(Unix.write ofd buffer 0 read)) ofds; + loop (Int64.sub n (Int64.of_int read)) in + loop n + + let multicast_n_string buffer ofds n = + List.iter (fun ofd -> ignore(Unix.write ofd buffer 0 n)) ofds + + (** Copy 'n' bytes from input fd 'ifd' to output fd 'ofd' *) + let copy_n ifd ofd n = multicast_n ifd [ ofd ] n + + (** List the contents of a tar to stdout *) + let list fd = + try + while true do + let hdr = Header.get_next_header fd in + print_endline (Header.to_summary_string hdr); + skip fd (Int64.to_int hdr.Header.file_size); + skip fd (Header.compute_zero_padding_length hdr) + done + with + | End_of_file -> + print_endline "Unexpected end of file while reading stream" + | Header.End_of_stream -> () + + (** Extract the contents of a tar to directory 'dest' *) + let extract dest ifd = + try + while true do + let hdr = Header.get_next_header ifd in + let filename = dest ^ "/" ^ hdr.Header.file_name in + print_endline filename; + let ofd = Unix.openfile filename [Unix.O_WRONLY] 0644 in + copy_n ifd ofd hdr.Header.file_size; + skip ifd (Header.compute_zero_padding_length hdr) + done + with + | End_of_file -> + print_endline "Unexpected end of file while reading stream" + | Header.End_of_stream -> () + + (** Create a tar on file descriptor fd from the filename list 'files' *) + let create files ofd = + let file filename = + let stat = Unix.stat filename in + if stat.Unix.st_kind <> Unix.S_REG + then Printf.eprintf "Skipping %s: not a regular file\n" filename + else + let hdr = Header.of_file filename in + write_block hdr (fun ofd -> + let ifd = Unix.openfile filename [Unix.O_RDONLY] 0644 in + copy_n ifd ofd hdr.Header.file_size) ofd; + in + List.iter file files; + (* Add two empty blocks *) + write_end ofd + + +end + + + diff --git a/lib/tar.mli b/lib/tar.mli new file mode 100644 index 00000000000..225f20c2afb --- /dev/null +++ b/lib/tar.mli @@ -0,0 +1,112 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** Tar utilities *) + +module Header : sig + (** Process and create tar file headers *) + + (** Represents a standard (non-USTAR) archive (note checksum not stored) *) + type t = { + file_name : string; + file_mode: int; + user_id: int; + group_id: int; + file_size: int64; + mod_time: int64; + link: bool; + link_name: int; + } + + (** Helper function to make a simple header *) + val make : ?file_mode:int -> ?user_id:int -> ?group_id:int -> ?mod_time:int64 -> ?link:bool -> ?link_name:int -> string -> int64 -> t + + (** Length of a header block *) + val length : int + + (** A blank header block (two of these in series mark the end of the tar) *) + val zero_block : string + + (** Pretty-print the header record *) + val to_detailed_string : t -> string + + (** Make a single line summary which looks like the output of tar -tv *) + val to_summary_string : t -> string + + (** For debugging: pretty-print a string as hex *) + val to_hex : string -> string + + (** Thrown when unmarshalling a header if the checksums don't match *) + exception Checksum_mismatch + + (** Thrown if we detect the end of the tar (at least two zero blocks in sequence) *) + exception End_of_stream + + (** Unmarshal a header block, returning None if it's all zeroes *) + val unmarshal : string -> t option + + (** Marshal a header block, computing and inserting the checksum *) + val marshal : t -> string + + (** Returns the next header block or throws End_of_stream if two consecutive + zero-filled blocks are discovered. Assumes stream is positioned at the + possible start of a header block. Unix.End_of_file is thrown if the stream + unexpectedly fails *) + val get_next_header : Unix.file_descr -> t + + (** Compute the amount of zero-padding required to round up the file size + to a whole number of blocks *) + val compute_zero_padding_length : t -> int + + (** Return the required zero-padding as a string *) + val zero_padding : t -> string + + (** Return the header needed for a particular file on disk *) + val of_file : string -> t +end + +val write_string : Unix.file_descr -> string -> unit +val write_bigbuffer : Unix.file_descr -> Bigbuffer.t -> unit +val write_block : Header.t -> (Unix.file_descr -> unit) -> Unix.file_descr -> unit +val write_end : Unix.file_descr -> unit + +module Archive : sig + (** Utility functions for operating over whole tar archives *) + + (** Skip 'n' bytes from input channel 'ifd' *) + val skip : Unix.file_descr -> int -> unit + + (** Read the next header, apply the function 'f' to the fd and the header. The function + should leave the fd positioned immediately after the datablock. Finally the function + skips past the zero padding to the next header *) + val with_next_file : Unix.file_descr -> (Unix.file_descr -> Header.t -> 'a) -> 'a + + (** Multicast 'n' bytes from input fd 'ifd' to output fds 'ofds'. NB if one deadlocks + they all stop.*) + val multicast_n : ?buffer_size:int -> Unix.file_descr -> Unix.file_descr list -> int64 -> unit + + val multicast_n_string : string -> Unix.file_descr list -> int -> unit + + (** Copy 'n' bytes from input fd 'ifd' to output fd 'ofd' *) + val copy_n : Unix.file_descr -> Unix.file_descr -> int64 -> unit + + (** List the contents of a tar to stdout *) + val list : Unix.file_descr -> unit + + (** Extract the contents of a tar to directory 'dest' *) + val extract : string -> Unix.file_descr -> unit + + (** Create a tar on file descriptor fd from the filename list 'files' *) + val create : string list -> Unix.file_descr -> unit +end diff --git a/lib/threadext.ml b/lib/threadext.ml new file mode 100644 index 00000000000..b66312384a2 --- /dev/null +++ b/lib/threadext.ml @@ -0,0 +1,411 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module Mutex = struct + include Mutex + (** execute the function f with the mutex hold *) + let execute lock f = + Mutex.lock lock; + let r = begin try f () with exn -> Mutex.unlock lock; raise exn end; in + Mutex.unlock lock; + r +end + + +module Alarm = struct + + type t = + { token: Mutex.t ; + mutable queue: (float * (unit -> unit)) list ; + mutable notifier: (Unix.file_descr * Unix.file_descr) option ; + } + + let create () = + { token = Mutex.create () ; + queue = [] ; + notifier = None ; + } + + let global_alarm = create () + + let rec watch alarm = + match alarm.notifier with + | None -> assert false + | Some (pipe_in, pipe_out) -> + while Thread.wait_timed_read pipe_in 0. do + ignore (Unix.read pipe_in " " 0 1) + done; + let next = Mutex.execute alarm.token + (fun () -> + let now = Unix.time () in + let nqueue = List.filter + (fun (clock, callback) -> + (* Create helper thread in case callback could block us *) + clock > now || (let _ = Thread.create callback () in false)) + alarm.queue in + alarm.queue <- nqueue; + match nqueue with + | [] -> + Unix.close pipe_out; + Unix.close pipe_in; + alarm.notifier <- None; + None + | (c, _) :: _ -> + Some c) in + match next with + | None -> Thread.exit () + | Some c -> + let now = Unix.time () in + if c > now then ignore (Thread.wait_timed_read pipe_in (c -. now)); + watch alarm + + let register ?(alarm = global_alarm) time callback = + Mutex.execute alarm.token + (fun () -> + let nqueue = (time, callback) :: alarm.queue in + alarm.queue <- List.sort (fun x1 x2 -> compare (fst x1) (fst x2)) nqueue; + match alarm.notifier with + | Some (_, pipe_out) -> + ignore (Unix.write pipe_out "X" 0 1) + | None -> + let pipe_in, pipe_out = Unix.pipe () in + alarm.notifier <- Some (pipe_in, pipe_out); + ignore (Thread.create watch alarm)) +end + +module Thread = struct + + type t = + | Running of Thread.t + | Pending of pthread + and pthread = float * int * Thread.t lazy_t + + type schedule = Now | Timeout of float | Indefinite + + type policy = + | AlwaysRun + | MaxCapacity of int * float option + | WaitCondition of (unit -> schedule) + + let count = ref 0 + + module PQueue = Set.Make(struct type t = pthread let compare = compare end) + + let running = ref 0 + + let pqueue = ref PQueue.empty + + (* This info can be deduced from pqueue, but having a specific int val allow + us to inspect it with lower cost and be lock free *) + let pending = ref 0 + + let running_threads () = !running + + let pending_threads () = !pending + + let scheduler_token = Mutex.create () + + let policy = ref AlwaysRun + + (* Should be protected by scheduler_token *) + let run_thread ((_, _, pt) as t) = + (* Might have run by other scheduling policy *) + if PQueue.mem t !pqueue then + (pqueue := PQueue.remove t !pqueue; decr pending); + if not (Lazy.lazy_is_val pt) then + let _ = Lazy.force pt in + incr running + + let fake_pivot = max_float, 0, lazy (Thread.create ignore ()) + let pivot = ref fake_pivot + let pre_pivot = ref max_int + + (* Should be protected by scheduler_token, this could be triggered either + because a thread finishes running and hence possibly provide an running + slot, or the scheduling policy has been updated hence more oppotunities + appear. *) + let rec run_pendings () = + if not (PQueue.is_empty !pqueue) then + let now = Unix.time() in + let (c, _, _) as t = PQueue.min_elt !pqueue in + (* Just in case policy has been changed *) + let to_run = match !policy with + | AlwaysRun -> true + | MaxCapacity (max_threads, _) -> c <= now || !running < max_threads + | WaitCondition f -> f () = Now in + if to_run then (run_thread t; run_pendings ()) + else (* extra logic to avoid starvation or wrongly programmed deadlock *) + let timeouts, exist, indefs = PQueue.split !pivot !pqueue in + if not exist || (PQueue.cardinal timeouts >= !pre_pivot + && (run_thread !pivot; true)) then + pivot := + if PQueue.is_empty indefs then fake_pivot + else PQueue.min_elt indefs; + pre_pivot := PQueue.cardinal timeouts + + let exit () = + Mutex.execute scheduler_token + (fun () -> decr running; run_pendings ()); + Thread.exit () + + let set_policy p = + Mutex.execute scheduler_token + (fun () -> + policy := p; + run_pendings ()) + + let create ?(schedule=Indefinite) f x = + let f' x = + Pervasiveext.finally + (fun () -> f x) + exit in + Mutex.execute scheduler_token + (fun () -> + run_pendings (); + let timeout = match schedule with + | Now -> 0. + | Timeout t -> t + | Indefinite -> max_float in + let timeout = + if timeout = 0. then 0. else + match !policy with + | AlwaysRun -> 0. + | MaxCapacity (max_threads, max_wait_opt) -> + if !running < max_threads && PQueue.is_empty !pqueue then 0. + else begin match max_wait_opt with + | None -> timeout + | Some t -> min timeout t end + | WaitCondition f -> match f () with + | Now -> 0. + | Timeout t -> min t timeout + | Indefinite -> timeout in + if timeout <= 0. then + let t = Thread.create f' x in + incr running; + Running t + else + let deadline = + if timeout < max_float then timeout +. Unix.time() + else max_float in + let pt = lazy (Thread.create f' x) in + incr count; + if !count = max_int then count := 0; + let t = (deadline, !count, pt) in + pqueue := PQueue.add t !pqueue; + incr pending; + if deadline < max_float then + Alarm.register deadline + (fun () -> Mutex.execute scheduler_token + (fun () -> run_thread t)); + (* It's fine that a pended thread might get scheduled later on so + that the information held in 't' becomes meaningless. This is + comparable to the case that a Thread.t finishes running and its + thread id still exits. + *) + Pending t) + + let self () = + (* When we get here, the thread must be running *) + Running (Thread.self ()) + + let id = function + | Running t -> Thread.id t + | Pending (_, id, _) -> + (* Pending thread have a negative id to avoid overlapping with running + thread id *) + -id + + let rec join = function + | Running t -> Thread.join t + | Pending ((_, _, pt) as t) -> + if not (Lazy.lazy_is_val pt) then begin + (* Give priority to those to be joined *) + Mutex.execute scheduler_token (fun () -> run_thread t); + assert (Lazy.lazy_is_val pt); + end; + Thread.join (Lazy.force pt) + + let kill = function + | Running t -> + (* Not implemented in stdlib *) + Thread.kill t + | Pending ((_, _, pt) as t) -> + if Lazy.lazy_is_val pt then + Thread.kill (Lazy.force pt) + else + Mutex.execute scheduler_token + (fun () -> + (* Just in case something happens before we grab the lock *) + if Lazy.lazy_is_val pt then Thread.kill (Lazy.force pt) + else (pqueue := PQueue.remove t !pqueue; decr pending)) + + let delay = Thread.delay + let exit = Thread.exit + let wait_read = Thread.wait_read + let wait_write = Thread.wait_write + let wait_timed_read = Thread.wait_timed_read + let wait_timed_write = Thread.wait_timed_write + let wait_pid = Thread.wait_pid + let select = Thread.select + let yield = Thread.yield + let sigmask = Thread.sigmask + let wait_signal = Thread.wait_signal +end + + +(** create thread loops which periodically applies a function *) +module Thread_loop + : functor (Tr : sig type t val delay : unit -> float end) -> + sig + val start : Tr.t -> (unit -> unit) -> unit + val stop : Tr.t -> unit + val update : Tr.t -> (unit -> unit) -> unit + end + = functor (Tr: sig type t val delay : unit -> float end) -> struct + + exception Done_loop + let ref_table : ((Tr.t,(Mutex.t * Thread.t * bool ref)) Hashtbl.t) = + Hashtbl.create 1 + + (** Create a thread which periodically applies a function to the + reference specified, and exits cleanly when removed *) + let start xref fn = + let mut = Mutex.create () in + let exit_var = ref false in + (* create thread which periodically applies the function *) + let tid = Thread.create (fun () -> + try while true do + Thread.delay (Tr.delay ()); + Mutex.execute mut (fun () -> + if !exit_var then + raise Done_loop; + let () = fn () in () + ); + done; with Done_loop -> (); + ) () in + (* create thread to manage the reference table and clean it up + safely once the delay thread is removed *) + let _ = Thread.create (fun () -> + Hashtbl.add ref_table xref (mut,tid,exit_var); + Thread.join tid; + List.iter (fun (_,t,_) -> + if tid = t then Hashtbl.remove ref_table xref + ) (Hashtbl.find_all ref_table xref) + ) () in () + + (** Remove a reference from the thread table *) + let stop xref = + try let mut,_,exit_ref = Hashtbl.find ref_table xref in + Mutex.execute mut (fun () -> exit_ref := true) + with Not_found -> () + + (** Replace a thread with another one *) + let update xref fn = + stop xref; + start xref fn +end + +(** Parallel List.iter. Remembers all exceptions and returns an association list mapping input x to an exception. + Applications of x which succeed will be missing from the returned list. *) +let thread_iter_all_exns f xs = + let exns = ref [] in + let m = Mutex.create () in + List.iter + Thread.join + (List.map + (fun x -> + Thread.create + (fun () -> + try + f x + with e -> Mutex.execute m (fun () -> exns := (x, e) :: !exns) + ) + () + ) xs); + !exns + +(** Parallel List.iter. Remembers one exception (at random) and throws it in the + error case. *) +let thread_iter f xs = match thread_iter_all_exns f xs with + | [] -> () + | (_, e) :: _ -> raise e + +module Delay = struct + (* Concrete type is the ends of a pipe *) + type t = { + (* A pipe is used to wake up a thread blocked in wait: *) + mutable pipe_out: Unix.file_descr option; + mutable pipe_in: Unix.file_descr option; + (* Indicates that a signal arrived before a wait: *) + mutable signalled: bool; + m: Mutex.t + } + + let make () = + { pipe_out = None; + pipe_in = None; + signalled = false; + m = Mutex.create () } + + exception Pre_signalled + + let wait (x: t) (seconds: float) = + let to_close = ref [ ] in + let close' fd = + if List.mem fd !to_close then Unix.close fd; + to_close := List.filter (fun x -> fd <> x) !to_close in + Pervasiveext.finally + (fun () -> + try + let pipe_out = Mutex.execute x.m + (fun () -> + if x.signalled then begin + x.signalled <- false; + raise Pre_signalled; + end; + let pipe_out, pipe_in = Unix.pipe () in + (* these will be unconditionally closed on exit *) + to_close := [ pipe_out; pipe_in ]; + x.pipe_out <- Some pipe_out; + x.pipe_in <- Some pipe_in; + x.signalled <- false; + pipe_out) in + let r, _, _ = Unix.select [ pipe_out ] [] [] seconds in + (* flush the single byte from the pipe *) + if r <> [] then ignore(Unix.read pipe_out (String.create 1) 0 1); + (* return true if we waited the full length of time, false if we were woken *) + r = [] + with Pre_signalled -> false + ) + (fun () -> + Mutex.execute x.m + (fun () -> + x.pipe_out <- None; + x.pipe_in <- None; + List.iter close' !to_close) + ) + + let signal (x: t) = + Mutex.execute x.m + (fun () -> + match x.pipe_in with + | Some fd -> ignore(Unix.write fd "X" 0 1) + | None -> x.signalled <- true (* If the wait hasn't happened yet then store up the signal *) + ) +end + +let keep_alive () = + while true do + Thread.delay 20000. + done diff --git a/lib/threadext.mli b/lib/threadext.mli new file mode 100644 index 00000000000..e10d1dfe3bb --- /dev/null +++ b/lib/threadext.mli @@ -0,0 +1,93 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +module Mutex : + sig + type t = Mutex.t + val create : unit -> t + val lock : t -> unit + val try_lock : t -> bool + val unlock : t -> unit + val execute : Mutex.t -> (unit -> 'a) -> 'a + end + +module Alarm : +sig + type t + val create: unit -> t + val register: ?alarm:t -> float -> (unit -> unit) -> unit +end + +module Thread : +sig + type t + + (* Global policy on deciding whether threads should start immediately, can + be refined by specific thread creation function with the schedule + parameter. *) + type policy = + | AlwaysRun (* always start the threads immediately *) + | MaxCapacity of int * float option + (* Static configuration on the largest number of active threads, and + optionally max wait time for queued threads *) + | WaitCondition of (unit -> schedule) + (* Dynamic configuration to be tested whnever creating a new thread, + None means do not wait, Some t means wait at most t seconds. *) + + (* Schedule policy on each particular thread. This will get considered together + with the global policy, taking whichever earlier among the two. *) + and schedule = + | Now (* Run the threads right now *) + | Timeout of float (* Run the threads at latest x seconds *) + | Indefinite (* Don't care, i.e. timeout = forever *) + + val scheduler_token: Mutex.t + + val running_threads: unit -> int + + val pending_threads: unit -> int + + (* Default policy is AlwaysRun, the same as standard thread semantics *) + val set_policy: policy -> unit + + include module type of Thread with type t := t + + (* The default schedule is Indefinite, i.e. to let the global policy in control *) + val create: ?schedule:schedule -> ('a -> 'b) -> 'a -> t +end + +module Thread_loop : + functor (Tr : sig type t val delay : unit -> float end) -> + sig + val start : Tr.t -> (unit -> unit) -> unit + val stop : Tr.t -> unit + val update : Tr.t -> (unit -> unit) -> unit + end +val thread_iter_all_exns: ('a -> unit) -> 'a list -> ('a * exn) list +val thread_iter: ('a -> unit) -> 'a list -> unit + +module Delay : + sig + type t + val make : unit -> t + (** Blocks the calling thread for a given period of time with the option of + returning early if someone calls 'signal'. Returns true if the full time + period elapsed and false if signalled. Note that multple 'signals' are + coalesced; 'signals' sent before 'wait' is called are not lost. *) + val wait : t -> float -> bool + (** Sends a signal to a waiting thread. See 'wait' *) + val signal : t -> unit + end + +(** Keeps a thread alive without doing anything. Used e.g. in XML/RPC daemons. *) +val keep_alive: unit -> unit diff --git a/lib/trie.ml b/lib/trie.ml new file mode 100644 index 00000000000..d0d26e5f9c5 --- /dev/null +++ b/lib/trie.ml @@ -0,0 +1,180 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +module Node = +struct + type ('a,'b) t = { + key: 'a; + value: 'b option; + children: ('a,'b) t list; + } + + let create key value = { + key = key; + value = Some value; + children = []; + } + + let empty key = { + key = key; + value = None; + children = [] + } + + let get_key node = node.key + let get_value node = + match node.value with + | None -> raise Not_found + | Some value -> value + + let get_children node = node.children + + let set_value node value = + { node with value = Some value } + let set_children node children = + { node with children = children } + + let add_child node child = + { node with children = child :: node.children } +end + +type ('a,'b) t = ('a,'b) Node.t list + +let mem_node nodes key = + List.exists (fun n -> n.Node.key = key) nodes + +let find_node nodes key = + List.find (fun n -> n.Node.key = key) nodes + +let replace_node nodes key node = + let rec aux = function + | [] -> [] + | h :: tl when h.Node.key = key -> node :: tl + | h :: tl -> h :: aux tl + in + aux nodes + +let remove_node nodes key = + let rec aux = function + | [] -> raise Not_found + | h :: tl when h.Node.key = key -> tl + | h :: tl -> h :: aux tl + in + aux nodes + +let create () = [] + +let rec iter f tree = + let rec aux node = + f node.Node.key node.Node.value; + iter f node.Node.children + in + List.iter aux tree + +let rec map f tree = + let rec aux node = + let value = + match node.Node.value with + | None -> None + | Some value -> f value + in + { node with Node.value = value; Node.children = map f node.Node.children } + in + List.filter (fun n -> n.Node.value <> None || n.Node.children <> []) (List.map aux tree) + +let rec fold f tree acc = + let rec aux accu node = + fold f node.Node.children (f node.Node.key node.Node.value accu) + in + List.fold_left aux acc tree + +(* return a sub-trie *) +let rec sub_node tree = function + | [] -> raise Not_found + | h::t -> + if mem_node tree h + then begin + let node = find_node tree h in + if t = [] + then node + else sub_node node.Node.children t + end else + raise Not_found + +let sub tree path = + try (sub_node tree path).Node.children + with Not_found -> [] + +let find tree path = + Node.get_value (sub_node tree path) + +(* return false if the node doesn't exists or if it is not associated to any value *) +let rec mem tree = function + | [] -> false + | h::t -> + mem_node tree h + && (let node = find_node tree h in + if t = [] + then node.Node.value <> None + else mem node.Node.children t) + +(* Iterate over the longest valid prefix *) +let rec iter_path f tree = function + | [] -> () + | h::l -> + if mem_node tree h + then begin + let node = find_node tree h in + f node.Node.key node.Node.value; + iter_path f node.Node.children l + end + +let rec set_node node path value = + if path = [] + then Node.set_value node value + else begin + let children = set node.Node.children path value in + Node.set_children node children + end + +and set tree path value = + match path with + | [] -> raise Not_found + | h::t -> + if mem_node tree h + then begin + let node = find_node tree h in + replace_node tree h (set_node node t value) + end else begin + let node = Node.empty h in + set_node node t value :: tree + end + +let rec unset tree = function + | [] -> tree + | h::t -> + if mem_node tree h + then begin + let node = find_node tree h in + let children = unset node.Node.children t in + let new_node = + if t = [] + then Node.set_children (Node.empty h) children + else Node.set_children node children + in + if children = [] && new_node.Node.value = None + then remove_node tree h + else replace_node tree h new_node + end else + raise Not_found + diff --git a/lib/trie.mli b/lib/trie.mli new file mode 100644 index 00000000000..efc17971512 --- /dev/null +++ b/lib/trie.mli @@ -0,0 +1,58 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +(** Basic Implementation of polymorphic tries (ie. prefix trees) *) + +type ('a, 'b) t +(** The type of tries. ['a list] is the type of keys, ['b] the type of values. + Internally, a trie is represented as a labeled tree, where node contains values + of type ['a * 'b option]. *) + +val create : unit -> ('a,'b) t +(** Creates an empty trie. *) + +val mem : ('a,'b) t -> 'a list -> bool +(** [mem t k] returns true if a value is associated with the key [k] in the trie [t]. + Otherwise, it returns false. *) + +val find : ('a, 'b) t -> 'a list -> 'b +(** [find t k] returns the value associated with the key [k] in the trie [t]. + Returns [Not_found] if no values are associated with [k] in [t]. *) + +val set : ('a, 'b) t -> 'a list -> 'b -> ('a, 'b) t +(** [set t k v] associates the value [v] with the key [k] in the trie [t]. *) + +val unset : ('a, 'b) t -> 'a list -> ('a, 'b) t +(** [unset k v] removes the association of value [v] with the key [k] in the trie [t]. + Moreover, it automatically clean the trie, ie. it removes recursively + every nodes of [t] containing no values and having no chil. *) + +val iter : ('a -> 'b option -> unit) -> ('a, 'b) t -> unit +(** [iter f t] applies the function [f] to every node of the trie [t]. + As nodes of the trie [t] do not necessary contains a value, the second argument of + [f] is an option type. *) + +val iter_path : ('a -> 'b option -> unit) -> ('a, 'b) t -> 'a list -> unit +(** [iter_path f t p] iterates [f] over nodes associated with the path [p] in the trie [t]. + If [p] is not a valid path of [t], it iterates on the longest valid prefix of [p]. *) + +val fold : ('a -> 'b option -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c +(** [fold f t x] fold [f] over every nodes of [t], with [x] as initial value. *) + +val map : ('b -> 'c option) -> ('a,'b) t -> ('a,'c) t +(** [map f t] maps [f] over every values stored in [t]. The return value of [f] is of type 'c option + as one may wants to remove value associated to a key. This function is not tail-recursive. *) + +val sub : ('a, 'b) t -> 'a list -> ('a,'b) t +(** [sub t p] returns the sub-trie associated with the path [p] in the trie [t]. + If [p] is not a valid path of [t], it returns an empty trie. *) diff --git a/lib/unixext.ml b/lib/unixext.ml new file mode 100644 index 00000000000..830dfe58a08 --- /dev/null +++ b/lib/unixext.ml @@ -0,0 +1,703 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +open Pervasiveext + +exception Unix_error of int + +external _exit : int -> unit = "unix_exit" + +(** remove a file, but doesn't raise an exception if the file is already removed *) +let unlink_safe file = + try Unix.unlink file with (* Unix.Unix_error (Unix.ENOENT, _ , _)*) _ -> () + +(** create a directory but doesn't raise an exception if the directory already exist *) +let mkdir_safe dir perm = + try Unix.mkdir dir perm with Unix.Unix_error (Unix.EEXIST, _, _) -> () + +(** create a directory, and create parent if doesn't exist *) +let mkdir_rec dir perm = + let rec p_mkdir dir = + let p_name = Filename.dirname dir in + if p_name <> "/" && p_name <> "." + then p_mkdir p_name; + mkdir_safe dir perm in + p_mkdir dir + +(** write a pidfile file *) +let pidfile_write filename = + let fd = Unix.openfile filename + [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ] + 0o640 in + finally + (fun () -> + let pid = Unix.getpid () in + let buf = string_of_int pid ^ "\n" in + let len = String.length buf in + if Unix.write fd buf 0 len <> len + then failwith "pidfile_write failed"; + ) + (fun () -> Unix.close fd) + +(** read a pidfile file, return either Some pid or None *) +let pidfile_read filename = + let fd = Unix.openfile filename [ Unix.O_RDONLY ] 0o640 in + finally + (fun () -> + try + let buf = String.create 80 in + let rd = Unix.read fd buf 0 (String.length buf) in + if rd = 0 then + failwith "pidfile_read failed"; + Scanf.sscanf (String.sub buf 0 rd) "%d" (fun i -> Some i) + with exn -> None) + (fun () -> Unix.close fd) + +(** daemonize a process *) +(* !! Must call this before spawning any threads !! *) +let daemonize () = + match Unix.fork () with + | 0 -> + if Unix.setsid () == -1 then + failwith "Unix.setsid failed"; + + begin match Unix.fork () with + | 0 -> + let nullfd = Unix.openfile "/dev/null" [ Unix.O_WRONLY ] 0 in + begin try + Unix.close Unix.stdin; + Unix.dup2 nullfd Unix.stdout; + Unix.dup2 nullfd Unix.stderr; + with exn -> Unix.close nullfd; raise exn + end; + Unix.close nullfd + | _ -> exit 0 + end + | _ -> exit 0 + +exception Break + +let lines_fold f start input = + let accumulator = ref start in + let running = ref true in + while !running do + let line = + try Some (input_line input) + with End_of_file -> None + in + match line with + | Some line -> + begin + try accumulator := (f !accumulator line) + with Break -> running := false + end + | None -> + running := false + done; + !accumulator + +let lines_iter f = lines_fold (fun () line -> ignore(f line)) () + +(** open a file, and make sure the close is always done *) +let with_input_channel file f = + let input = open_in file in + finally + (fun () -> f input) + (fun () -> close_in input) + +(** open a file, and make sure the close is always done *) +let with_file file mode perms f = + let fd = Unix.openfile file mode perms in + let r = + try f fd + with exn -> Unix.close fd; raise exn + in + Unix.close fd; + r + +let file_lines_fold f start file_path = with_input_channel file_path (lines_fold f start) + +let read_lines ~(path : string) : string list = + List.rev (file_lines_fold (fun acc line -> line::acc) [] path) + +let file_lines_iter f = file_lines_fold (fun () line -> ignore(f line)) () + +let readfile_line = file_lines_iter + + +(** [fd_blocks_fold block_size f start fd] folds [f] over blocks (strings) + from the fd [fd] with initial value [start] *) +let fd_blocks_fold block_size f start fd = + let block = String.create block_size in + let rec fold acc = + let n = Unix.read fd block 0 block_size in + (* Consider making the interface explicitly use Substrings *) + let s = if n = block_size then block else String.sub block 0 n in + if n = 0 then acc else fold (f acc s) in + fold start + +let with_directory dir f = + let dh = Unix.opendir dir in + let r = + try f dh + with exn -> Unix.closedir dh; raise exn + in + Unix.closedir dh; + r + +let buffer_of_fd fd = + fd_blocks_fold 1024 (fun b s -> Buffer.add_string b s; b) (Buffer.create 1024) fd + +let bigbuffer_of_fd fd = + fd_blocks_fold 1024 (fun b s -> Bigbuffer.append_string b s; b) (Bigbuffer.make ()) fd + +let string_of_fd fd = Buffer.contents (buffer_of_fd fd) + +let buffer_of_file file_path = with_file file_path [ Unix.O_RDONLY ] 0 buffer_of_fd + +let bigbuffer_of_file file_path = with_file file_path [ Unix.O_RDONLY ] 0 bigbuffer_of_fd + +let string_of_file file_path = Buffer.contents (buffer_of_file file_path) + +(** Opens a temp file, applies the fd to the function, when the function completes, renames the file + as required. *) +let atomic_write_to_file fname perms f = + let tmp = Filenameext.temp_file_in_dir fname in + Unix.chmod tmp perms; + Pervasiveext.finally + (fun () -> + let fd = Unix.openfile tmp [Unix.O_WRONLY; Unix.O_CREAT] perms (* ignored since the file exists *) in + let result = Pervasiveext.finally + (fun () -> f fd) + (fun () -> Unix.close fd) in + Unix.rename tmp fname; (* Nb this only happens if an exception wasn't raised in the application of f *) + result) + (fun () -> unlink_safe tmp) + + +(** Atomically write a string to a file *) +let write_string_to_file fname s = + atomic_write_to_file fname 0o644 (fun fd -> + let len = String.length s in + let written = Unix.write fd s 0 len in + if written <> len then (failwith "Short write occured!")) + + +let execv_get_output cmd args = + let (pipe_exit, pipe_entrance) = Unix.pipe () in + let r = try Unix.set_close_on_exec pipe_exit; true with _ -> false in + match Unix.fork () with + | 0 -> + Unix.dup2 pipe_entrance Unix.stdout; + Unix.close pipe_entrance; + if not r then + Unix.close pipe_exit; + begin try Unix.execv cmd args with _ -> exit 127 end + | pid -> + Unix.close pipe_entrance; + pid, pipe_exit + +let copy_file_internal ?limit reader writer = + let buffer = String.make 65536 '\000' in + let buffer_len = Int64.of_int (String.length buffer) in + let finished = ref false in + let total_bytes = ref 0L in + let limit = ref limit in + while not(!finished) do + let requested = min (Opt.default buffer_len !limit) buffer_len in + let num = reader buffer 0 (Int64.to_int requested) in + let num64 = Int64.of_int num in + + limit := Opt.map (fun x -> Int64.sub x num64) !limit; + ignore_int (writer buffer 0 num); + total_bytes := Int64.add !total_bytes num64; + finished := num = 0 || !limit = Some 0L; + done; + !total_bytes + +let copy_file ?limit ifd ofd = copy_file_internal ?limit (Unix.read ifd) (Unix.write ofd) + +let file_exists file_path = + try Unix.access file_path [Unix.F_OK]; true + with _ -> false + +let touch_file file_path = + let fd = Unix.openfile file_path + [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_NOCTTY; Unix.O_NONBLOCK] 0o666 in + Unix.close fd; + Unix.utimes file_path 0.0 0.0 + +let is_empty_file file_path = + try + let stats = Unix.stat file_path in + stats.Unix.st_size = 0 + with Unix.Unix_error (Unix.ENOENT, _, _) -> + false + +let delete_empty_file file_path = + if is_empty_file file_path + then (Sys.remove file_path; true) + else (false) + +(** Create a new file descriptor, connect it to host:port and return it *) +exception Host_not_found of string +let open_connection_fd host port = + let s = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + try + let he = + try + Unix.gethostbyname host + with + Not_found -> raise (Host_not_found host) in + if Array.length he.Unix.h_addr_list = 0 + then failwith (Printf.sprintf "Couldn't resolve hostname: %s" host); + let ip = he.Unix.h_addr_list.(0) in + let addr = Unix.ADDR_INET(ip, port) in + Unix.connect s addr; + s + with e -> Unix.close s; raise e + + +let open_connection_unix_fd filename = + let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + try + let addr = Unix.ADDR_UNIX(filename) in + Unix.connect s addr; + s + with e -> Unix.close s; raise e + +module CBuf = struct + (** A circular buffer constructed from a string *) + type t = { + mutable buffer: string; + mutable len: int; (** bytes of valid data in [buffer] *) + mutable start: int; (** index of first valid byte in [buffer] *) + mutable r_closed: bool; (** true if no more data can be read due to EOF *) + mutable w_closed: bool; (** true if no more data can be written due to EOF *) + } + + let empty length = { + buffer = String.create length; + len = 0; + start = 0; + r_closed = false; + w_closed = false; + } + + let drop (x: t) n = + if n > x.len then failwith (Printf.sprintf "drop %d > %d" n x.len); + x.start <- (x.start + n) mod (String.length x.buffer); + x.len <- x.len - n + + let should_read (x: t) = + not x.r_closed && (x.len < (String.length x.buffer - 1)) + let should_write (x: t) = + not x.w_closed && (x.len > 0) + + let end_of_reads (x: t) = x.r_closed && x.len = 0 + let end_of_writes (x: t) = x.w_closed + + let write (x: t) fd = + (* Offset of the character after the substring *) + let next = min (String.length x.buffer) (x.start + x.len) in + let len = next - x.start in + let written = try Unix.single_write fd x.buffer x.start len with e -> x.w_closed <- true; len in + drop x written + + let read (x: t) fd = + (* Offset of the next empty character *) + let next = (x.start + x.len) mod (String.length x.buffer) in + let len = min (String.length x.buffer - next) (String.length x.buffer - x.len) in + let read = Unix.read fd x.buffer next len in + if read = 0 then x.r_closed <- true; + x.len <- x.len + read + +end + +exception Process_still_alive + +let kill_and_wait ?(signal = Sys.sigterm) ?(timeout=10.) pid = + let proc_entry_exists pid = + try Unix.access (Printf.sprintf "/proc/%d" pid) [ Unix.F_OK ]; true + with _ -> false + in + if pid > 0 && proc_entry_exists pid then ( + let loop_time_waiting = 0.03 in + let left = ref timeout in + let readcmdline pid = + try string_of_file (Printf.sprintf "/proc/%d/cmdline" pid) + with _ -> "" + in + let reference = readcmdline pid and quit = ref false in + Unix.kill pid signal; + + (* We cannot do a waitpid here, since we might not be parent of + the process, so instead we are waiting for the /proc/%d to go + away. Also we verify that the cmdline stay the same if it's still here + to prevent the very very unlikely event that the pid get reused before + we notice it's gone *) + while proc_entry_exists pid && not !quit && !left > 0. + do + let cmdline = readcmdline pid in + if cmdline = reference then ( + (* still up, let's sleep a bit *) + ignore (Unix.select [] [] [] loop_time_waiting); + left := !left -. loop_time_waiting + ) else ( + (* not the same, it's gone ! *) + quit := true + ) + done; + if !left <= 0. then + raise Process_still_alive; + ) + +let string_of_signal x = + let table = [ + Sys.sigabrt, "SIGABRT"; + Sys.sigalrm, "SIGALRM"; + Sys.sigfpe, "SIGFPE"; + Sys.sighup, "SIGHUP"; + Sys.sigill, "SIGILL"; + Sys.sigint, "SIGINT"; + Sys.sigkill, "SIGKILL"; + Sys.sigpipe, "SIGPIPE"; + Sys.sigquit, "SIGQUIT"; + Sys.sigsegv, "SIGSEGV"; + Sys.sigterm, "SIGTERM"; + Sys.sigusr1, "SIGUSR1"; + Sys.sigusr2, "SIGUSR2"; + Sys.sigchld, "SIGCHLD"; + Sys.sigcont, "SIGCONT"; + Sys.sigstop, "SIGSTOP"; + Sys.sigttin, "SIGTTIN"; + Sys.sigttou, "SIGTTOU"; + Sys.sigvtalrm, "SIGVTALRM"; + Sys.sigprof, "SIGPROF"; + ] in + if List.mem_assoc x table + then List.assoc x table + else (Printf.sprintf "(ocaml signal %d with an unknown name)" x) + +let proxy (a: Unix.file_descr) (b: Unix.file_descr) = + let size = 64 * 1024 in + (* [a'] is read from [a] and will be written to [b] *) + (* [b'] is read from [b] and will be written to [a] *) + let a' = CBuf.empty size and b' = CBuf.empty size in + Unix.set_nonblock a; + Unix.set_nonblock b; + + try + while true do + let r = (if CBuf.should_read a' then [ a ] else []) @ (if CBuf.should_read b' then [ b ] else []) in + let w = (if CBuf.should_write a' then [ b ] else []) @ (if CBuf.should_write b' then [ a ] else []) in + + (* If we can't make any progress (because fds have been closed), then stop *) + if r = [] && w = [] then raise End_of_file; + + let r, w, _ = Unix.select r w [] (-1.0) in + (* Do the writing before the reading *) + List.iter (fun fd -> if a = fd then CBuf.write b' a else CBuf.write a' b) w; + List.iter (fun fd -> if a = fd then CBuf.read a' a else CBuf.read b' b) r; + (* If there's nothing else to read or write then signal the other end *) + List.iter + (fun (buf, fd) -> + if CBuf.end_of_reads buf then Unix.shutdown fd Unix.SHUTDOWN_SEND; + if CBuf.end_of_writes buf then Unix.shutdown fd Unix.SHUTDOWN_RECEIVE + ) [ a', b; b', a ] + done + with _ -> + (try Unix.clear_nonblock a with _ -> ()); + (try Unix.clear_nonblock b with _ -> ()); + (try Unix.close a with _ -> ()); + (try Unix.close b with _ -> ()) + +let rec really_read fd string off n = + if n=0 then () else + let m = Unix.read fd string off n in + if m = 0 then raise End_of_file; + really_read fd string (off+m) (n-m) + +let really_read_string fd length = + let buf = String.make length '\000' in + really_read fd buf 0 length; + buf + +let try_read_string ?limit fd = + let buf = Buffer.create 0 in + let chunk = match limit with None -> 4096 | Some x -> x in + let cache = String.make chunk '\000' in + let finished = ref false in + while not !finished do + let to_read = match limit with + | Some x -> min (x - (Buffer.length buf)) chunk + | None -> chunk in + let read_bytes = Unix.read fd cache 0 to_read in + Buffer.add_substring buf cache 0 read_bytes; + if read_bytes = 0 then finished := true + done; + Buffer.contents buf + +let really_read_bigbuffer fd bigbuf n = + let chunk = 4096 in + let s = String.make chunk '\000' in + let written = ref 0L in + while !written < n do + let remaining = Int64.sub n !written in + let to_write = min remaining (Int64.of_int chunk) in + really_read fd s 0 (Int64.to_int to_write); + Bigbuffer.append_substring bigbuf s 0 (Int64.to_int to_write); + written := Int64.add !written to_write; + done + +let really_write fd string off n = + let written = ref 0 in + while !written < n + do + let wr = Unix.write fd string (off + !written) (n - !written) in + written := wr + !written + done + +(* Ideally, really_write would be implemented with optional arguments ?(off=0) ?(len=String.length string) *) +let really_write_string fd string = + really_write fd string 0 (String.length string) + +(* --------------------------------------------------------------------------------------- *) +(* Functions to read and write to/from a file descriptor with a given latest response time *) + +exception Timeout + +(* Write as many bytes to a file descriptor as possible from data before a given clock time. *) +(* Raises Timeout exception if the number of bytes written is less than the specified length. *) +(* Writes into the file descriptor at the current cursor position. *) +let time_limited_write filedesc length data target_response_time = + let total_bytes_to_write = length in + let bytes_written = ref 0 in + let now = ref (Unix.gettimeofday()) in + while !bytes_written < total_bytes_to_write && !now < target_response_time do + let remaining_time = target_response_time -. !now in + let (_, ready_to_write, _) = Unix.select [] [filedesc] [] remaining_time in (* Note: there is a possibility that the storage could go away after the select and before the write, so the write would block. *) + if List.mem filedesc ready_to_write then begin + let bytes_to_write = total_bytes_to_write - !bytes_written in + let bytes = (try Unix.write filedesc data !bytes_written bytes_to_write with Unix.Unix_error(Unix.EAGAIN,_,_) | Unix.Unix_error(Unix.EWOULDBLOCK,_,_) -> 0) in (* write from buffer=data from offset=bytes_written, length=bytes_to_write *) + bytes_written := bytes + !bytes_written; + end; + now := Unix.gettimeofday() + done; + if !bytes_written = total_bytes_to_write then () else (* we ran out of time *) raise Timeout + +(* Read as many bytes to a file descriptor as possible before a given clock time. *) +(* Raises Timeout exception if the number of bytes read is less than the desired number. *) +(* Reads from the file descriptor at the current cursor position. *) +let time_limited_read filedesc length target_response_time = + let total_bytes_to_read = length in + let bytes_read = ref 0 in + let buf = String.make total_bytes_to_read '\000' in + let now = ref (Unix.gettimeofday()) in + while !bytes_read < total_bytes_to_read && !now < target_response_time do + let remaining_time = target_response_time -. !now in + let (ready_to_read, _, _) = Unix.select [filedesc] [] [] remaining_time in + if List.mem filedesc ready_to_read then begin + let bytes_to_read = total_bytes_to_read - !bytes_read in + let bytes = (try Unix.read filedesc buf !bytes_read bytes_to_read with Unix.Unix_error(Unix.EAGAIN,_,_) | Unix.Unix_error(Unix.EWOULDBLOCK,_,_) -> 0) in (* read into buffer=buf from offset=bytes_read, length=bytes_to_read *) + if bytes = 0 then raise End_of_file (* End of file has been reached *) + else bytes_read := bytes + !bytes_read + end; + now := Unix.gettimeofday() + done; + if !bytes_read = total_bytes_to_read then buf else (* we ran out of time *) raise Timeout + +(* --------------------------------------------------------------------------------------- *) + +(* Read a given number of bytes of data from the fd, or stop at EOF, whichever comes first. *) +(* A negative ~max_bytes indicates that all the data should be read from the fd until EOF. This is the default. *) +let read_data_in_chunks (f : string -> int -> unit) ?(block_size = 1024) ?(max_bytes = -1) from_fd = + let buf = String.make block_size '\000' in + let rec do_read acc = + let remaining_bytes = max_bytes - acc in + if remaining_bytes = 0 then acc (* we've read the amount requested *) + else begin + let bytes_to_read = (if max_bytes < 0 || remaining_bytes > block_size then block_size else remaining_bytes) in + let bytes_read = Unix.read from_fd buf 0 bytes_to_read in + if bytes_read = 0 then acc (* we reached EOF *) + else begin + f (String.sub buf 0 bytes_read) bytes_read; + do_read (acc + bytes_read) + end + end in + do_read 0 + +let spawnvp ?(pid_callback=(fun _ -> ())) cmd args = + match Unix.fork () with + | 0 -> + Unix.execvp cmd args + | pid -> + begin try pid_callback pid with _ -> () end; + snd (Unix.waitpid [] pid) + +let double_fork f = + match Unix.fork () with + | 0 -> + begin match Unix.fork () with + (* NB: use _exit (calls C lib _exit directly) to avoid + calling at_exit handlers and flushing output channels + which wouild cause intermittent deadlocks if we + forked from a threaded program *) + | 0 -> (try f () with _ -> ()); _exit 0 + | _ -> _exit 0 + end + | pid -> ignore(Unix.waitpid [] pid) + +external set_tcp_nodelay : Unix.file_descr -> bool -> unit = "stub_unixext_set_tcp_nodelay" + +external fsync : Unix.file_descr -> unit = "stub_unixext_fsync" +external blkgetsize64 : Unix.file_descr -> int64 = "stub_unixext_blkgetsize64" + +external get_max_fd : unit -> int = "stub_unixext_get_max_fd" + +let int_of_file_descr (x: Unix.file_descr) : int = Obj.magic x +let file_descr_of_int (x: int) : Unix.file_descr = Obj.magic x + +(** Forcibly closes all open file descriptors except those explicitly passed in as arguments. + Useful to avoid accidentally passing a file descriptor opened in another thread to a + process being concurrently fork()ed (there's a race between open/set_close_on_exec). + NB this assumes that 'type Unix.file_descr = int' +*) +let close_all_fds_except (fds: Unix.file_descr list) = + (* get at the file descriptor within *) + let fds' = List.map int_of_file_descr fds in + let close' (x: int) = + try Unix.close(file_descr_of_int x) with _ -> () in + + let highest_to_keep = List.fold_left max (-1) fds' in + (* close all the fds higher than the one we want to keep *) + for i = highest_to_keep + 1 to get_max_fd () do close' i done; + (* close all the rest *) + for i = 0 to highest_to_keep - 1 do + if not(List.mem i fds') then close' i + done + + +(** Remove "." and ".." from paths (NB doesn't attempt to resolve symlinks) *) +let resolve_dot_and_dotdot (path: string) : string = + let of_string (x: string): string list = + let rec rev_split path = + let basename = Filename.basename path + and dirname = Filename.dirname path in + let rest = if Filename.dirname dirname = dirname then [] else rev_split dirname in + basename :: rest in + let abs_path path = + if Filename.is_relative path + then Filename.concat "/" path (* no notion of a cwd *) + else path in + rev_split (abs_path x) in + + let to_string (x: string list) = List.fold_left Filename.concat "/" (List.rev x) in + + (* Process all "." and ".." references *) + let rec remove_dots (n: int) (x: string list) = + match x, n with + | [], _ -> [] + | "." :: rest, _ -> remove_dots n rest (* throw away ".", don't count as parent for ".." *) + | ".." :: rest, _ -> remove_dots (n + 1) rest (* note the number of ".." *) + | x :: rest, 0 -> x :: (remove_dots 0 rest) + | x :: rest, n -> remove_dots (n - 1) rest (* munch *) in + to_string (remove_dots 0 (of_string path)) + +(** Seek to an absolute offset within a file descriptor *) +let seek_to fd pos = + Unix.lseek fd pos Unix.SEEK_SET + +(** Seek to an offset within a file descriptor, relative to the current cursor position *) +let seek_rel fd diff = + Unix.lseek fd diff Unix.SEEK_CUR + +(** Return the current cursor position within a file descriptor *) +let current_cursor_pos fd = + (* 'seek' to the current position, exploiting the return value from Unix.lseek as the new cursor position *) + Unix.lseek fd 0 Unix.SEEK_CUR + +module Fdset = struct + type t + external of_list : Unix.file_descr list -> t = "stub_fdset_of_list" + external is_set : t -> Unix.file_descr -> bool = "stub_fdset_is_set" + external is_set_and_clear : t -> Unix.file_descr -> bool = "stub_fdset_is_set_and_clear" + external is_empty : t -> bool = "stub_fdset_is_empty" + external set : t -> Unix.file_descr -> unit = "stub_fdset_set" + external clear : t -> Unix.file_descr -> unit = "stub_fdset_clear" + external _select : t -> t -> t -> float -> t * t * t = "stub_fdset_select" + external _select_ro : t -> float -> t = "stub_fdset_select_ro" + external _select_wo : t -> float -> t = "stub_fdset_select_wo" + let select r w e t = _select r w e t + let select_ro r t = _select_ro r t + let select_wo w t = _select_wo w t +end + +let wait_for_path path delay timeout = + let rec inner ttl = + if ttl=0 then failwith "No path!"; + try + ignore(Unix.stat path) + with _ -> + delay 0.5; + inner (ttl - 1) + in + inner (timeout * 2) + + +let _ = Callback.register_exception "unixext.unix_error" (Unix_error (0)) + +external send_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> Unix.file_descr -> int = "stub_unix_send_fd_bytecode" "stub_unix_send_fd" +external recv_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr * Unix.file_descr = "stub_unix_recv_fd" + + +type statvfs_t = { + f_bsize : int64; + f_frsize : int64; + f_blocks : int64; + f_bfree : int64; + f_bavail : int64; + f_files : int64; + f_ffree : int64; + f_favail : int64; + f_fsid : int64; + f_flag : int64; + f_namemax : int64; +} + +external statvfs : string -> statvfs_t = "stub_statvfs" + +module Direct = struct + type t = Unix.file_descr + + external openfile : string -> Unix.open_flag list -> Unix.file_perm -> t = "stub_stdext_unix_open_direct" + + let close = Unix.close + + let with_openfile path flags perms f = + let t = openfile path flags perms in + finally (fun () -> f t) (fun () -> close t) + + external unsafe_write : t -> string -> int -> int -> int = "stub_stdext_unix_write" + + let write fd buf ofs len = + if ofs < 0 || len < 0 || ofs > String.length buf - len + then invalid_arg "Unix.write" + else unsafe_write fd buf ofs len + + let copy_from_fd ?limit socket fd = copy_file_internal ?limit (Unix.read socket) (write fd) + + let fsync x = fsync x + + let lseek fd x cmd = Unix.LargeFile.lseek fd x cmd +end diff --git a/lib/unixext.mli b/lib/unixext.mli new file mode 100644 index 00000000000..ac3f508eece --- /dev/null +++ b/lib/unixext.mli @@ -0,0 +1,196 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +(** A collection of extensions to the [Unix] module. *) + +external _exit : int -> unit = "unix_exit" +val unlink_safe : string -> unit +val mkdir_safe : string -> Unix.file_perm -> unit +val mkdir_rec : string -> Unix.file_perm -> unit +val pidfile_write : string -> unit +val pidfile_read : string -> int option +val daemonize : unit -> unit +val with_file : string -> Unix.open_flag list -> Unix.file_perm -> (Unix.file_descr -> 'a) -> 'a +val with_input_channel : string -> (in_channel -> 'a) -> 'a +val with_directory : string -> (Unix.dir_handle -> 'a) -> 'a + +(** Exception to be raised in function to break out of [file_lines_fold]. *) +exception Break + +(** Folds function [f] over every line in the input channel *) +val lines_fold : ('a -> string -> 'a) -> 'a -> in_channel -> 'a + +(** Applies function [f] to every line in the input channel *) +val lines_iter : (string -> unit) -> in_channel -> unit + +(** Folds function [f] over every line in the file at [file_path] using the +starting value [start]. *) +val file_lines_fold : ('a -> string -> 'a) -> 'a -> string -> 'a + +(** [read_lines path] returns a list of lines in the file at [path]. *) +val read_lines : path:string -> string list + +(** Applies function [f] to every line in the file at [file_path]. *) +val file_lines_iter : (string -> unit) -> string -> unit + +(** [fd_blocks_fold block_size f start fd] folds [f] over blocks (strings) + from the fd [fd] with initial value [start] *) +val fd_blocks_fold: int -> ('a -> string -> 'a) -> 'a -> Unix.file_descr -> 'a + +(** Alias for function [file_lines_iter]. *) +val readfile_line : (string -> 'a) -> string -> unit + +(** [buffer_of_fd fd] returns a Buffer.t containing all data read from [fd] up to EOF *) +val buffer_of_fd : Unix.file_descr -> Buffer.t + +(** [bigbuffer_of_fd fd] returns a Bigbuffer.t containing all data read from [fd] up +to EOF *) +val bigbuffer_of_fd : Unix.file_descr -> Bigbuffer.t + +(** [string_of_fd fd] returns a string containing all data read from [fd] up to EOF *) +val string_of_fd : Unix.file_descr -> string + +(** [buffer_of_file file] returns a Buffer.t containing the contents of [file] *) +val buffer_of_file : string -> Buffer.t + +(** [bigbuffer_of_file file] returns a Bigbuffer.t containing the contents of [file] *) +val bigbuffer_of_file : string -> Bigbuffer.t + +(** [string_of_file file] returns a string containing the contents of [file] *) +val string_of_file : string -> string + +val atomic_write_to_file : string -> Unix.file_perm -> (Unix.file_descr -> 'a) -> 'a +val write_string_to_file : string -> string -> unit +val execv_get_output : string -> string array -> int * Unix.file_descr +val copy_file : ?limit:int64 -> Unix.file_descr -> Unix.file_descr -> int64 + +(** Returns true if and only if a file exists at the given path. *) +val file_exists : string -> bool + +(** Sets both the access and modification times of the file *) +(** at the given path to the current time. Creates an empty *) +(** file at the given path if no such file already exists. *) +val touch_file : string -> unit + +(** Returns true if and only if an empty file exists at the given path. *) +val is_empty_file : string -> bool + +(** Safely deletes a file at the given path if (and only if) the *) +(** file exists and is empty. Returns true if a file was deleted. *) +val delete_empty_file : string -> bool + +exception Host_not_found of string +val open_connection_fd : string -> int -> Unix.file_descr +val open_connection_unix_fd : string -> Unix.file_descr + + +exception Process_still_alive +val kill_and_wait : ?signal:int -> ?timeout:float -> int -> unit + +(** [string_of_signal x] translates an ocaml signal number into + a string suitable for logging. *) +val string_of_signal : int -> string + +val proxy : Unix.file_descr -> Unix.file_descr -> unit +val really_read : Unix.file_descr -> string -> int -> int -> unit +val really_read_string : Unix.file_descr -> int -> string +val really_read_bigbuffer : Unix.file_descr -> Bigbuffer.t -> int64 -> unit +val really_write : Unix.file_descr -> string -> int -> int -> unit +val really_write_string : Unix.file_descr -> string -> unit +val try_read_string : ?limit: int -> Unix.file_descr -> string +exception Timeout +val time_limited_write : Unix.file_descr -> int -> string -> float -> unit +val time_limited_read : Unix.file_descr -> int -> float -> string +val read_data_in_chunks : (string -> int -> unit) -> ?block_size:int -> ?max_bytes:int -> Unix.file_descr -> int +val spawnvp : + ?pid_callback:(int -> unit) -> + string -> string array -> Unix.process_status +val double_fork : (unit -> unit) -> unit +external set_tcp_nodelay : Unix.file_descr -> bool -> unit + = "stub_unixext_set_tcp_nodelay" +external fsync : Unix.file_descr -> unit = "stub_unixext_fsync" +external get_max_fd : unit -> int = "stub_unixext_get_max_fd" +external blkgetsize64 : Unix.file_descr -> int64 = "stub_unixext_blkgetsize64" + +val int_of_file_descr : Unix.file_descr -> int +val file_descr_of_int : int -> Unix.file_descr +val close_all_fds_except : Unix.file_descr list -> unit +val resolve_dot_and_dotdot : string -> string + +val seek_to : Unix.file_descr -> int -> int +val seek_rel : Unix.file_descr -> int -> int +val current_cursor_pos : Unix.file_descr -> int + +module Fdset : sig + type t + external of_list : Unix.file_descr list -> t = "stub_fdset_of_list" + external is_set : t -> Unix.file_descr -> bool = "stub_fdset_is_set" + external is_set_and_clear : t -> Unix.file_descr -> bool = "stub_fdset_is_set_and_clear" + external is_empty : t -> bool = "stub_fdset_is_empty" + external set : t -> Unix.file_descr -> unit = "stub_fdset_set" + external clear : t -> Unix.file_descr -> unit = "stub_fdset_clear" + + val select : t -> t -> t -> float -> t * t * t + val select_ro : t -> float -> t + val select_wo : t -> float -> t +end + +val wait_for_path : string -> (float -> unit) -> int -> unit + +external send_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> Unix.file_descr -> int = "stub_unix_send_fd_bytecode" "stub_unix_send_fd" +external recv_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr * Unix.file_descr = "stub_unix_recv_fd" + +type statvfs_t = { + f_bsize : int64; + f_frsize : int64; + f_blocks : int64; + f_bfree : int64; + f_bavail : int64; + f_files : int64; + f_ffree : int64; + f_favail : int64; + f_fsid : int64; + f_flag : int64; + f_namemax : int64; +} + +val statvfs : string -> statvfs_t + +module Direct : sig + (** Perform I/O in O_DIRECT mode using 4KiB page-aligned buffers *) + + type t + (** represents a file open in O_DIRECT mode *) + + val openfile : string -> Unix.open_flag list -> Unix.file_perm -> t + (** [openfile name flags perm] behaves the same as [Unix.openfile] but includes the O_DIRECT flag *) + + val close : t -> unit + (** [close t] closes [t], a file open in O_DIRECT mode *) + + val with_openfile : string -> Unix.open_flag list -> Unix.file_perm -> (t -> 'a) -> 'a + (** [with_openfile name flags perm f] opens [name], applies the result to [f] and closes *) + + val write : t -> string -> int -> int -> int + (** [write t buf ofs len] writes [len] bytes at offset [ofs] from buffer [buf] to + [t] using page-aligned buffers. *) + + val copy_from_fd : ?limit:int64 -> Unix.file_descr -> t -> int64 + (** [copy_from_fd ?limit fd t] copies from [fd] to [t] up to [limit] *) + + val fsync : t -> unit + (** [fsync t] commits all outstanding writes, throwing an error if necessary. *) + + val lseek : t -> int64 -> Unix.seek_command -> int64 + (** [lseek t offset command]: see Unix.LargeFile.lseek *) +end diff --git a/lib/unixext_open_stubs.c b/lib/unixext_open_stubs.c new file mode 100644 index 00000000000..3b6cce4dd85 --- /dev/null +++ b/lib/unixext_open_stubs.c @@ -0,0 +1,60 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id: open.c 9547 2010-01-22 12:48:24Z doligez $ */ + +#define _GNU_SOURCE /* O_DIRECT */ + +#include +#include +#include +#include +#include +#include +#include + +#ifndef O_NONBLOCK +#define O_NONBLOCK O_NDELAY +#endif +#ifndef O_DSYNC +#define O_DSYNC 0 +#endif +#ifndef O_SYNC +#define O_SYNC 0 +#endif +#ifndef O_RSYNC +#define O_RSYNC 0 +#endif + +static int open_flag_table[] = { + O_RDONLY, O_WRONLY, O_RDWR, O_NONBLOCK, O_APPEND, O_CREAT, O_TRUNC, O_EXCL, + O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC +}; + +CAMLprim value stub_stdext_unix_open_direct(value path, value flags, value perm) +{ + CAMLparam3(path, flags, perm); + int ret, cv_flags; + char * p; + + cv_flags = convert_flag_list(flags, open_flag_table) | O_DIRECT; + p = stat_alloc(string_length(path) + 1); + strcpy(p, String_val(path)); + /* open on a named FIFO can block (PR#1533) */ + enter_blocking_section(); + ret = open(p, cv_flags, Int_val(perm)); + leave_blocking_section(); + stat_free(p); + if (ret == -1) uerror("open", path); + CAMLreturn (Val_int(ret)); +} diff --git a/lib/unixext_stubs.c b/lib/unixext_stubs.c new file mode 100644 index 00000000000..bbac3b67826 --- /dev/null +++ b/lib/unixext_stubs.c @@ -0,0 +1,445 @@ +/* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + */ +#include +#include +#include +#include +#include +#include +#include +#include /* needed for _SC_OPEN_MAX */ +#include /* snprintf */ +#include +#include +#include + +#include +#include +#include +#include +#include +#include +#include +#include + +/* Set the TCP_NODELAY flag on a Unix.file_descr */ +CAMLprim value stub_unixext_set_tcp_nodelay (value fd, value bool) +{ + CAMLparam2 (fd, bool); + int c_fd = Int_val(fd); + int opt = (Bool_val(bool)) ? 1 : 0; + if (setsockopt(c_fd, IPPROTO_TCP, TCP_NODELAY, (void *)&opt, sizeof(opt)) != 0){ + uerror("setsockopt", Nothing); + } + CAMLreturn(Val_unit); +} + +CAMLprim value stub_unixext_fsync (value fd) +{ + CAMLparam1(fd); + int c_fd = Int_val(fd); + if (fsync(c_fd) != 0) uerror("fsync", Nothing); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_unixext_blkgetsize64(value fd) +{ + CAMLparam1(fd); + uint64_t size; + int c_fd = Int_val(fd); + if(ioctl(c_fd,BLKGETSIZE64,&size)) { + uerror("ioctl(BLKGETSIZE64)", Nothing); + } + CAMLreturn(caml_copy_int64(size)); +} + +CAMLprim value stub_unixext_get_max_fd (value unit) +{ + CAMLparam1 (unit); + long maxfd; + maxfd = sysconf(_SC_OPEN_MAX); + CAMLreturn(Val_int(maxfd)); +} + +#define FDSET_OF_VALUE(v) (&(((struct fdset_t *) v)->fds)) +#define MAXFD_OF_VALUE(v) (((struct fdset_t *) v)->max) +struct fdset_t { fd_set fds; int max; }; + +CAMLprim value stub_fdset_of_list(value l) +{ + CAMLparam1(l); + CAMLlocal1(set); + + set = caml_alloc(sizeof(struct fdset_t), Abstract_tag); + FD_ZERO(FDSET_OF_VALUE(set)); + MAXFD_OF_VALUE(set) = -1; + while (l != Val_int(0)) { + int fd; + fd = Int_val(Field(l, 0)); + FD_SET(fd, FDSET_OF_VALUE(set)); + if (fd > MAXFD_OF_VALUE(set)) + MAXFD_OF_VALUE(set) = fd; + l = Field(l, 1); + } + CAMLreturn(set); +} + +CAMLprim value stub_fdset_is_set(value set, value fd) +{ + CAMLparam2(set, fd); + CAMLreturn(Val_bool(FD_ISSET(Int_val(fd), FDSET_OF_VALUE(set)))); +} + +CAMLprim value stub_fdset_set(value set, value fd) +{ + CAMLparam2(set, fd); + FD_SET(Int_val(fd), FDSET_OF_VALUE(set)); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_fdset_clear(value set, value fd) +{ + CAMLparam2(set, fd); + FD_CLR(Int_val(fd), FDSET_OF_VALUE(set)); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_fdset_is_set_and_clear(value set, value fd) +{ + CAMLparam2(set, fd); + int r, c_fd; + fd_set *c_set; + + c_fd = Int_val(fd); + c_set = FDSET_OF_VALUE(set); + r = FD_ISSET(c_fd, c_set); + if (r) + FD_CLR(c_fd, c_set); + CAMLreturn(Val_bool(r)); +} + +void unixext_error(int code) +{ + static value *exn = NULL; + + if (!exn) { + exn = caml_named_value("unixext.unix_error"); + if (!exn) + caml_invalid_argument("unixext.unix_error not initialiazed"); + } + caml_raise_with_arg(*exn, Val_int(code)); +} + +CAMLprim value stub_fdset_select(value rset, value wset, value eset, value t) +{ + CAMLparam4(rset, wset, eset, t); + CAMLlocal4(ret, nrset, nwset, neset); + fd_set r, w, e; + int maxfd; + double tm; + struct timeval tv; + struct timeval *tvp; + int v; + + memcpy(&r, FDSET_OF_VALUE(rset), sizeof(fd_set)); + memcpy(&w, FDSET_OF_VALUE(wset), sizeof(fd_set)); + memcpy(&e, FDSET_OF_VALUE(eset), sizeof(fd_set)); + + maxfd = (MAXFD_OF_VALUE(rset) > MAXFD_OF_VALUE(wset)) + ? MAXFD_OF_VALUE(rset) + : MAXFD_OF_VALUE(wset); + maxfd = (maxfd > MAXFD_OF_VALUE(eset)) ? maxfd : MAXFD_OF_VALUE(eset); + + tm = Double_val(t); + if (tm < 0.0) + tvp = NULL; + else { + tv.tv_sec = (int) tm; + tv.tv_usec = (int) (1e6 * (tm - tv.tv_sec)); + tvp = &tv; + } + + caml_enter_blocking_section(); + v = select(maxfd + 1, &r, &w, &e, tvp); + caml_leave_blocking_section(); + if (v == -1) + unixext_error(errno); + + nrset = caml_alloc(sizeof(struct fdset_t), Abstract_tag); + nwset = caml_alloc(sizeof(struct fdset_t), Abstract_tag); + neset = caml_alloc(sizeof(struct fdset_t), Abstract_tag); + + memcpy(FDSET_OF_VALUE(nrset), &r, sizeof(fd_set)); + memcpy(FDSET_OF_VALUE(nwset), &w, sizeof(fd_set)); + memcpy(FDSET_OF_VALUE(neset), &e, sizeof(fd_set)); + + ret = caml_alloc_small(3, 0); + Field(ret, 0) = nrset; + Field(ret, 1) = nwset; + Field(ret, 2) = neset; + + CAMLreturn(ret); +} + +CAMLprim value stub_fdset_select_ro(value rset, value t) +{ + CAMLparam2(rset, t); + CAMLlocal1(ret); + fd_set r; + int maxfd; + double tm; + struct timeval tv; + struct timeval *tvp; + int v; + + memcpy(&r, FDSET_OF_VALUE(rset), sizeof(fd_set)); + maxfd = MAXFD_OF_VALUE(rset); + + tm = Double_val(t); + if (tm < 0.0) + tvp = NULL; + else { + tv.tv_sec = (int) tm; + tv.tv_usec = (int) (1e6 * (tm - tv.tv_sec)); + tvp = &tv; + } + + caml_enter_blocking_section(); + v = select(maxfd + 1, &r, NULL, NULL, tvp); + caml_leave_blocking_section(); + if (v == -1) + unixext_error(errno); + + ret = caml_alloc(sizeof(struct fdset_t), Abstract_tag); + memcpy(FDSET_OF_VALUE(ret), &r, sizeof(fd_set)); + + CAMLreturn(ret); +} + +CAMLprim value stub_fdset_select_wo(value wset, value t) +{ + CAMLparam2(wset, t); + CAMLlocal1(ret); + fd_set w; + int maxfd; + double tm; + struct timeval tv; + struct timeval *tvp; + int v; + + memcpy(&w, FDSET_OF_VALUE(wset), sizeof(fd_set)); + maxfd = MAXFD_OF_VALUE(wset); + + tm = Double_val(t); + if (tm < 0.0) + tvp = NULL; + else { + tv.tv_sec = (int) tm; + tv.tv_usec = (int) (1e6 * (tm - tv.tv_sec)); + tvp = &tv; + } + + caml_enter_blocking_section(); + v = select(maxfd + 1, NULL, &w, NULL, tvp); + caml_leave_blocking_section(); + if (v == -1) + unixext_error(errno); + + ret = caml_alloc(sizeof(struct fdset_t), Abstract_tag); + memcpy(FDSET_OF_VALUE(ret), &w, sizeof(fd_set)); + + CAMLreturn(ret); +} + +CAMLprim value stub_fdset_is_empty(value set) +{ + CAMLparam1(set); + fd_set x; + int ret; + FD_ZERO(&x); + ret = memcmp(&x, FDSET_OF_VALUE(set), sizeof(fd_set)); + + CAMLreturn(Bool_val(ret == 0)); +} + +static int msg_flag_table[] = { + MSG_OOB, MSG_DONTROUTE, MSG_PEEK +}; + +#define UNIX_BUFFER_SIZE 16384 + +CAMLprim value stub_unix_send_fd(value sock, value buff, value ofs, value len, value flags, value fd) +{ + CAMLparam5(sock,buff,ofs,len,flags); + CAMLxparam1(fd); + int ret, cv_flags, cfd; + long numbytes; + char iobuf[UNIX_BUFFER_SIZE]; + char buf[CMSG_SPACE(sizeof(cfd))]; + + cfd = Int_val(fd); + + cv_flags = convert_flag_list(flags,msg_flag_table); + + numbytes = Long_val(len); + if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; + memmove(iobuf, &Byte(buff, Long_val(ofs)), numbytes); + + /* Set up sockaddr */ + + struct msghdr msg; + struct iovec vec; + struct cmsghdr *cmsg; + + msg.msg_name = NULL; + msg.msg_namelen = 0; + vec.iov_base=iobuf; + vec.iov_len=numbytes; + msg.msg_iov=&vec; + msg.msg_iovlen=1; + + msg.msg_control = buf; + msg.msg_controllen = sizeof(buf); + cmsg = CMSG_FIRSTHDR(&msg); + cmsg->cmsg_level = SOL_SOCKET; + cmsg->cmsg_type = SCM_RIGHTS; + cmsg->cmsg_len = CMSG_LEN(sizeof(cfd)); + *(int*)CMSG_DATA(cmsg) = cfd; + msg.msg_controllen = cmsg->cmsg_len; + + msg.msg_flags = 0; + + caml_enter_blocking_section(); + ret=sendmsg(Int_val(sock), &msg, cv_flags); + caml_leave_blocking_section(); + + if(ret == -1) + unixext_error(errno); + + CAMLreturn(Val_int(ret)); +} + +CAMLprim value stub_unix_send_fd_bytecode(value *argv, int argn) +{ + return stub_unix_send_fd(argv[0],argv[1],argv[2],argv[3], + argv[4], argv[5]); +} + +CAMLprim value stub_unix_recv_fd(value sock, value buff, value ofs, value len, value flags) +{ + CAMLparam5(sock,buff,ofs,len,flags); + CAMLlocal2(res,addr); + int ret, cv_flags, fd; + long numbytes; + char iobuf[UNIX_BUFFER_SIZE]; + char buf[CMSG_SPACE(sizeof(fd))]; + struct sockaddr_un unix_socket_name; + + cv_flags = convert_flag_list(flags,msg_flag_table); + + struct msghdr msg; + struct iovec vec; + struct cmsghdr *cmsg; + + numbytes = Long_val(len); + if(numbytes > UNIX_BUFFER_SIZE) + numbytes = UNIX_BUFFER_SIZE; + + msg.msg_name=&unix_socket_name; + msg.msg_namelen=sizeof(unix_socket_name); + vec.iov_base=iobuf; + vec.iov_len=numbytes; + msg.msg_iov=&vec; + + msg.msg_iovlen=1; + + msg.msg_control = buf; + msg.msg_controllen = sizeof(buf); + + caml_enter_blocking_section(); + ret=recvmsg(Int_val(sock), &msg, cv_flags); + caml_leave_blocking_section(); + + if(ret == -1) + unixext_error(errno); + + if(ret>0 && msg.msg_controllen>0) { + cmsg = CMSG_FIRSTHDR(&msg); + if(cmsg->cmsg_level == SOL_SOCKET && (cmsg->cmsg_type == SCM_RIGHTS)) { + fd=Val_int(*(int*)CMSG_DATA(cmsg)); + } else { + failwith("Failed to receive an fd!"); + } + } else { + fd=Val_int(-1); + } + + if(ret0) { + Field(addr,0) = copy_string(unix_socket_name.sun_path); + } else { + Field(addr,0) = copy_string("nothing"); + } + + res=alloc_small(3,0); + Field(res,0) = Val_int(ret); + Field(res,1) = addr; + Field(res,2) = fd; + + CAMLreturn(res); +} + +CAMLprim value stub_statvfs(value filename) +{ + CAMLparam1(filename); + CAMLlocal2(v,tmp); + int ret; + int i; + struct statvfs buf; + + ret = statvfs(String_val(filename), &buf); + + if(ret == -1) uerror("statvfs", Nothing); + + tmp=caml_copy_int64(0); + + /* Allocate the thing to return and ensure each of the + fields is set to something valid before attempting + any further allocations */ + v=alloc_small(11,0); + for(i=0; i<11; i++) { + Field(v,i)=tmp; + } + + Field(v,0)=caml_copy_int64(buf.f_bsize); + Field(v,1)=caml_copy_int64(buf.f_frsize); + Field(v,2)=caml_copy_int64(buf.f_blocks); + Field(v,3)=caml_copy_int64(buf.f_bfree); + Field(v,4)=caml_copy_int64(buf.f_bavail); + Field(v,5)=caml_copy_int64(buf.f_files); + Field(v,6)=caml_copy_int64(buf.f_ffree); + Field(v,7)=caml_copy_int64(buf.f_favail); + Field(v,8)=caml_copy_int64(buf.f_fsid); + Field(v,9)=caml_copy_int64(buf.f_flag); + Field(v,10)=caml_copy_int64(buf.f_namemax); + + CAMLreturn(v); +} diff --git a/lib/unixext_write_stubs.c b/lib/unixext_write_stubs.c new file mode 100644 index 00000000000..db98172db0f --- /dev/null +++ b/lib/unixext_write_stubs.c @@ -0,0 +1,65 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id: write.c 9547 2010-01-22 12:48:24Z doligez $ */ + +#include +#include +#include +#include +#include +#include + +#define PAGE_SIZE 4096 + +#ifndef EAGAIN +#define EAGAIN (-1) +#endif +#ifndef EWOULDBLOCK +#define EWOULDBLOCK (-1) +#endif + +CAMLprim value stub_stdext_unix_write(value fd, value buf, value vofs, value vlen) +{ + long ofs, len, written; + int numbytes, ret; + void *iobuf = NULL; + + Begin_root (buf); + ofs = Long_val(vofs); + len = Long_val(vlen); + written = 0; + while (len > 0) { + numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len; + ret = posix_memalign(&iobuf, PAGE_SIZE, numbytes); + if (ret != 0) + uerror("write/posix_memalign", Nothing); + + memmove (iobuf, &Byte(buf, ofs), numbytes); + enter_blocking_section(); + ret = write(Int_val(fd), iobuf, numbytes); + leave_blocking_section(); + free(iobuf); + + if (ret == -1) { + if ((errno == EAGAIN || errno == EWOULDBLOCK) && written > 0) break; + uerror("write", Nothing); + } + written += ret; + ofs += ret; + len -= ret; + } + End_roots(); + return Val_long(written); +} + diff --git a/lib/vIO.ml b/lib/vIO.ml new file mode 100644 index 00000000000..6e512285f58 --- /dev/null +++ b/lib/vIO.ml @@ -0,0 +1,107 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +exception End_of_file +exception Timeout + +type t = { + read: string -> int -> int -> int; + write: string -> int -> int -> int; + input_line: (?timeout: float option -> unit -> string) option; + flush: unit -> unit; + close: unit -> unit; + is_raw: bool; + selectable: Unix.file_descr option; +} + +let do_rw_io f buf index len = + let left = ref len in + let index = ref index in + let end_of_file = ref false in + while !left > 0 && not !end_of_file + do + let ret = f buf !index !left in + if ret = 0 then + end_of_file := true + else if ret > 0 then ( + left := !left - ret; + index := !index + ret; + ) + done; + len - !left + +let do_rw_io_timeout fd is_write f buf index len timeout = + let fdset = Unixext.Fdset.of_list [ fd ] in + let select = if is_write then Unixext.Fdset.select_wo else Unixext.Fdset.select_ro in + + let left = ref len in + let index = ref index in + let end_of_file = ref false in + while !left > 0 && not !end_of_file + do + let set = select fdset timeout in + if Unixext.Fdset.is_empty set then + raise Timeout; + let ret = f buf !index !left in + if ret = 0 then + end_of_file := true + else if ret > 0 then ( + left := !left - ret; + index := !index + ret; + ) + done; + len - !left + +let read ?(timeout=None) con buf index len = + match timeout, con.selectable with + | _, None | None, Some _ -> do_rw_io con.read buf index len + | Some timeout, Some fd -> do_rw_io_timeout fd false con.read buf index len timeout + +let write ?(timeout=None) con buf index len = + match timeout, con.selectable with + | _, None | None, Some _ -> do_rw_io con.write buf index len + | Some timeout, Some fd -> do_rw_io_timeout fd true con.write buf index len timeout + +let read_string ?timeout con len = + let s = String.create len in + let ret = read ?timeout con s 0 len in + if ret < len then + raise End_of_file; + s + +let write_string ?timeout con s = + let len = String.length s in + if write ?timeout con s 0 len < len then + raise End_of_file; + () + +let input_line ?timeout con = + match con.input_line with + | None -> + let buffer = Buffer.create 80 in + let newline = ref false in + while not !newline + do + let s = " " in + let ret = read ?timeout con s 0 1 in + if ret = 0 then + raise End_of_file; + if s.[0] = '\n' then newline := true else Buffer.add_char buffer s.[0] + done; + Buffer.contents buffer + | Some f -> + f ?timeout () + +let flush con = con.flush () +let close con = con.close () diff --git a/lib/vIO.mli b/lib/vIO.mli new file mode 100644 index 00000000000..a313b0074e7 --- /dev/null +++ b/lib/vIO.mli @@ -0,0 +1,33 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +exception End_of_file +exception Timeout + +type t = { + read : string -> int -> int -> int; + write : string -> int -> int -> int; + input_line : (?timeout: float option -> unit -> string) option; + flush : unit -> unit; + close : unit -> unit; + is_raw : bool; + selectable : Unix.file_descr option; +} + +val read : ?timeout: float option -> t -> string -> int -> int -> int +val write : ?timeout: float option -> t -> string -> int -> int -> int +val read_string : ?timeout: float option -> t -> int -> string +val write_string : ?timeout: float option -> t -> string -> unit +val input_line : ?timeout: float option -> t -> string +val flush : t -> unit +val close : t -> unit diff --git a/lib/zerocheck.ml b/lib/zerocheck.ml new file mode 100644 index 00000000000..1adedc61a4e --- /dev/null +++ b/lib/zerocheck.ml @@ -0,0 +1,48 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +external is_all_zeros : string -> int -> bool = "is_all_zeros" + +external _find_a_nonzero : string -> int -> int -> int = "find_a_nonzero" +external _find_a_zero : string -> int -> int -> int = "find_a_zero" + +let wrap f x len offset = + let remaining = len - offset in + if remaining <= 0 then raise (Invalid_argument "offset > length"); + let result = f x offset remaining in + if result = remaining then None else Some (result + offset) + +let find_a_nonzero = wrap _find_a_nonzero +let find_a_zero = wrap _find_a_zero + +type substring = { + buf: string; + offset: int; + len: int +} + +let fold_over_nonzeros x len rounddown roundup f initial = + let rec inner acc offset = + if offset = len then acc + else + match find_a_nonzero x len offset with + | None -> acc (* no more *) + | Some s -> + let e = match find_a_zero x len s with + | None -> len + | Some e -> e in + let e = min len (roundup e) in + let s = max 0 (rounddown s) in + inner (f acc { buf = x; offset = s; len = e - s }) e in + inner initial 0 + diff --git a/lib/zerocheck.mli b/lib/zerocheck.mli new file mode 100644 index 00000000000..0d92539e0a4 --- /dev/null +++ b/lib/zerocheck.mli @@ -0,0 +1,41 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** [is_all_zeroes x len] returns true if the substring is all zeroes *) +external is_all_zeros : string -> int -> bool = "is_all_zeros" + +(** [find_a_zero x len offset] returns the offset in [x] of a zero + character after [offset], or None if no zero was detected. + Note this function is approximate and is not guaranteed to find + strictly the first zero. *) +val find_a_zero: string -> int -> int -> int option + +(** [find_a_nonzero x len offset] returns the offset in [x] of a + nonzero character after [offset], or None if none could be detected. + Note this function is approximate and is not guaranteed to find + strictly the first nonzero. *) +val find_a_nonzero: string -> int -> int -> int option + +type substring = { + buf: string; + offset: int; + len: int +} + +(** [fold_over_nonzeros buf len rounddown roundup f initial] folds [f] over all + (start, length) pairs of non-zero data in string [buf] up to [len]. + The start of each pair is rounded down with [rounddown] and + the end offset of each pair is rounded up with [roundup] (e.g. to + potential block boudaries. *) +val fold_over_nonzeros: string -> int -> (int -> int) -> (int -> int) -> ('a -> substring -> 'a) -> 'a -> 'a diff --git a/lib/zerocheck_stub.c b/lib/zerocheck_stub.c new file mode 100644 index 00000000000..76f0e221d0d --- /dev/null +++ b/lib/zerocheck_stub.c @@ -0,0 +1,127 @@ +/* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + */ + +#define CAML_NAME_SPACE +#include +#include +#include +#include + +#define OFFSET(s) (((unsigned int)s) & (sizeof(unsigned int) - 1)) + + +/* Return the offset of the next non-zero byte (possibly rounded down a bit). + The value 'remaining' is returned if there is no non-zero byte found. */ +value find_a_nonzero(value string, value offset, value remaining) +{ + CAMLparam3(string, offset, remaining); + int c_offset = Int_val(offset); + int c_remaining = Int_val(remaining); + int c_origremaining = c_remaining; + char *c_string = String_val(string); + char *s = c_string + c_offset; + + /* Go character by character until we hit an unsigned int boundary */ + while ((OFFSET(s) != 0) && (c_remaining > 0)){ + if (*s != '\000') goto finish; + s++; c_remaining--; + } + /* Go word by word. Note we don't need to determine the exact position + of the nonzero, it suffices to return the index of the word containing + the nonzero. */ + unsigned int *p = (unsigned int *)s; + while (c_remaining > 4){ + if (*p != 0) goto finish; + p++; c_remaining-=4; + } + /* Go character by character until the end of the string */ + s = (char*) p; + while (c_remaining > 0){ + if (*s != '\000') goto finish; + s++; c_remaining--; + } + /* c_remaining == 0 */ + finish: + /* If we didn't find a nonzero then we return c_origremaining. + If we did then we return the number of chars after the starting + offset where the word containing the nonzero was detected. */ + CAMLreturn(Val_int(c_origremaining - c_remaining)); + +} + +/* Return the offset of the next zero byte (possibly rounded up a bit). + The value 'remaining' is returned if there is no zero byte found. */ +value find_a_zero(value string, value offset, value remaining) +{ + CAMLparam3(string, offset, remaining); + int c_offset = Int_val(offset); + int c_remaining = Int_val(remaining); + int c_origremaining = c_remaining; + char *c_string = String_val(string); + char *s = c_string + c_offset; + + /* Go character by character until we hit an unsigned int boundary */ + while ((OFFSET(s) != 0) && (c_remaining > 0)){ + if (*s == '\000') goto finish; + s++; c_remaining--; + } + /* Go word by word. Note we don't need to determine the exact position + of the zero, it suffices to return the index of the word following + the zero. */ + unsigned int *p = (unsigned int *)s; + while (c_remaining > 4){ + if (*p == 0) goto finish; + p++; c_remaining-=4; + } + /* Go character by character until the end of the string */ + s = (char*) p; + while (c_remaining > 0){ + if (*s == '\000') goto finish; + s++; c_remaining--; + } + /* c_remaining == 0 */ + finish: + /* If we didn't find a zero then we return c_origremaining. + If we did then we return the number of chars after the starting + offset where the word containing the zero was detected. */ + CAMLreturn(Val_int(c_origremaining - c_remaining)); +} + + + +/* for better performance in all case, we should process the unalign data at + * the beginning until we reach a 32 bit align value, however since ocaml + * allocate the string and we don't use any offset in this string, the string + * is always correctly aligned. + */ +value is_all_zeros(value string, value length) +{ + CAMLparam2(string, length); + char *s = String_val(string); + unsigned int *p; + int len = Int_val(length); + int i; + + p = (unsigned int *) s; + for (i = len / 4; i > 0; i--) + if (*p++ != 0) + goto notallzero; + s = (unsigned char *) p; + for (i = 0; i < len % 4; i++) + if (s[i] != 0) + goto notallzero; + CAMLreturn(Val_true); +notallzero: + CAMLreturn(Val_false); +} diff --git a/myocamlbuild.ml b/myocamlbuild.ml new file mode 100644 index 00000000000..feb891ebf7c --- /dev/null +++ b/myocamlbuild.ml @@ -0,0 +1,491 @@ +(* OASIS_START *) +(* DO NOT EDIT (digest: 1389f6cf16dbf6f02d2859c3cde5d291) *) +module OASISGettext = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) + + let ns_ str = + str + + let s_ str = + str + + let f_ (str : ('a, 'b, 'c, 'd) format4) = + str + + let fn_ fmt1 fmt2 n = + if n = 1 then + fmt1^^"" + else + fmt2^^"" + + let init = + [] + +end + +module OASISExpr = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) + + + + open OASISGettext + + type test = string + + type flag = string + + type t = + | EBool of bool + | ENot of t + | EAnd of t * t + | EOr of t * t + | EFlag of flag + | ETest of test * string + + + type 'a choices = (t * 'a) list + + let eval var_get t = + let rec eval' = + function + | EBool b -> + b + + | ENot e -> + not (eval' e) + + | EAnd (e1, e2) -> + (eval' e1) && (eval' e2) + + | EOr (e1, e2) -> + (eval' e1) || (eval' e2) + + | EFlag nm -> + let v = + var_get nm + in + assert(v = "true" || v = "false"); + (v = "true") + + | ETest (nm, vl) -> + let v = + var_get nm + in + (v = vl) + in + eval' t + + let choose ?printer ?name var_get lst = + let rec choose_aux = + function + | (cond, vl) :: tl -> + if eval var_get cond then + vl + else + choose_aux tl + | [] -> + let str_lst = + if lst = [] then + s_ "" + else + String.concat + (s_ ", ") + (List.map + (fun (cond, vl) -> + match printer with + | Some p -> p vl + | None -> s_ "") + lst) + in + match name with + | Some nm -> + failwith + (Printf.sprintf + (f_ "No result for the choice list '%s': %s") + nm str_lst) + | None -> + failwith + (Printf.sprintf + (f_ "No result for a choice list: %s") + str_lst) + in + choose_aux (List.rev lst) + +end + + +# 117 "myocamlbuild.ml" +module BaseEnvLight = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) + + module MapString = Map.Make(String) + + type t = string MapString.t + + let default_filename = + Filename.concat + (Sys.getcwd ()) + "setup.data" + + let load ?(allow_empty=false) ?(filename=default_filename) () = + if Sys.file_exists filename then + begin + let chn = + open_in_bin filename + in + let st = + Stream.of_channel chn + in + let line = + ref 1 + in + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + let lexer = + Genlex.make_lexer ["="] st_line + in + let rec read_file mp = + match Stream.npeek 3 lexer with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lexer; + Stream.junk lexer; + Stream.junk lexer; + read_file (MapString.add nm value mp) + | [] -> + mp + | _ -> + failwith + (Printf.sprintf + "Malformed data file '%s' line %d" + filename !line) + in + let mp = + read_file MapString.empty + in + close_in chn; + mp + end + else if allow_empty then + begin + MapString.empty + end + else + begin + failwith + (Printf.sprintf + "Unable to load environment, the file '%s' doesn't exist." + filename) + end + + let var_get name env = + let rec var_expand str = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + in + var_expand (MapString.find name env) + + let var_choose lst env = + OASISExpr.choose + (fun nm -> var_get nm env) + lst +end + + +# 215 "myocamlbuild.ml" +module MyOCamlbuildFindlib = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) + + (** OCamlbuild extension, copied from + * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild + * by N. Pouillard and others + * + * Updated on 2009/02/28 + * + * Modified by Sylvain Le Gall + *) + open Ocamlbuild_plugin + + (* these functions are not really officially exported *) + let run_and_read = + Ocamlbuild_pack.My_unix.run_and_read + + let blank_sep_strings = + Ocamlbuild_pack.Lexers.blank_sep_strings + + let split s ch = + let x = + ref [] + in + let rec go s = + let pos = + String.index s ch + in + x := (String.before s pos)::!x; + go (String.after s (pos + 1)) + in + try + go s + with Not_found -> !x + + let split_nl s = split s '\n' + + let before_space s = + try + String.before s (String.index s ' ') + with Not_found -> s + + (* this lists all supported packages *) + let find_packages () = + List.map before_space (split_nl & run_and_read "ocamlfind list") + + (* this is supposed to list available syntaxes, but I don't know how to do it. *) + let find_syntaxes () = ["camlp4o"; "camlp4r"] + + (* ocamlfind command *) + let ocamlfind x = S[A"ocamlfind"; x] + + let dispatch = + function + | Before_options -> + (* by using Before_options one let command line options have an higher priority *) + (* on the contrary using After_options will guarantee to have the higher priority *) + (* override default commands by ocamlfind ones *) + Options.ocamlc := ocamlfind & A"ocamlc"; + Options.ocamlopt := ocamlfind & A"ocamlopt"; + Options.ocamldep := ocamlfind & A"ocamldep"; + Options.ocamldoc := ocamlfind & A"ocamldoc"; + Options.ocamlmktop := ocamlfind & A"ocamlmktop" + + | After_rules -> + + (* When one link an OCaml library/binary/package, one should use -linkpkg *) + flag ["ocaml"; "link"; "program"] & A"-linkpkg"; + + (* For each ocamlfind package one inject the -package option when + * compiling, computing dependencies, generating documentation and + * linking. *) + List.iter + begin fun pkg -> + flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; + flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; + flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; + flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; + flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg]; + end + (find_packages ()); + + (* Like -package but for extensions syntax. Morover -syntax is useless + * when linking. *) + List.iter begin fun syntax -> + flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + end (find_syntaxes ()); + + (* The default "thread" tag is not compatible with ocamlfind. + * Indeed, the default rules add the "threads.cma" or "threads.cmxa" + * options when using this tag. When using the "-linkpkg" option with + * ocamlfind, this module will then be added twice on the command line. + * + * To solve this, one approach is to add the "-thread" option when using + * the "threads" package using the previous plugin. + *) + flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); + flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]) + + | _ -> + () + +end + +module MyOCamlbuildBase = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + + (** Base functions for writing myocamlbuild.ml + @author Sylvain Le Gall + *) + + + + open Ocamlbuild_plugin + module OC = Ocamlbuild_pack.Ocaml_compiler + + type dir = string + type file = string + type name = string + type tag = string + +(* # 56 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + + type t = + { + lib_ocaml: (name * dir list) list; + lib_c: (name * dir * file list) list; + flags: (tag list * (spec OASISExpr.choices)) list; + (* Replace the 'dir: include' from _tags by a precise interdepends in + * directory. + *) + includes: (dir * dir list) list; + } + + let env_filename = + Pathname.basename + BaseEnvLight.default_filename + + let dispatch_combine lst = + fun e -> + List.iter + (fun dispatch -> dispatch e) + lst + + let tag_libstubs nm = + "use_lib"^nm^"_stubs" + + let nm_libstubs nm = + nm^"_stubs" + + let dispatch t e = + let env = + BaseEnvLight.load + ~filename:env_filename + ~allow_empty:true + () + in + match e with + | Before_options -> + let no_trailing_dot s = + if String.length s >= 1 && s.[0] = '.' then + String.sub s 1 ((String.length s) - 1) + else + s + in + List.iter + (fun (opt, var) -> + try + opt := no_trailing_dot (BaseEnvLight.var_get var env) + with Not_found -> + Printf.eprintf "W: Cannot get variable %s" var) + [ + Options.ext_obj, "ext_obj"; + Options.ext_lib, "ext_lib"; + Options.ext_dll, "ext_dll"; + ] + + | After_rules -> + (* Declare OCaml libraries *) + List.iter + (function + | nm, [] -> + ocaml_lib nm + | nm, dir :: tl -> + ocaml_lib ~dir:dir (dir^"/"^nm); + List.iter + (fun dir -> + List.iter + (fun str -> + flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) + ["compile"; "infer_interface"; "doc"]) + tl) + t.lib_ocaml; + + (* Declare directories dependencies, replace "include" in _tags. *) + List.iter + (fun (dir, include_dirs) -> + Pathname.define_context dir include_dirs) + t.includes; + + (* Declare C libraries *) + List.iter + (fun (lib, dir, headers) -> + (* Handle C part of library *) + flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] + (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; + A("-l"^(nm_libstubs lib))]); + + flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] + (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); + + flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] + (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); + + (* When ocaml link something that use the C library, then one + need that file to be up to date. + *) + dep ["link"; "ocaml"; "program"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + + dep ["compile"; "ocaml"; "program"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + + (* TODO: be more specific about what depends on headers *) + (* Depends on .h files *) + dep ["compile"; "c"] + headers; + + (* Setup search path for lib *) + flag ["link"; "ocaml"; "use_"^lib] + (S[A"-I"; P(dir)]); + ) + t.lib_c; + + (* Add flags *) + List.iter + (fun (tags, cond_specs) -> + let spec = + BaseEnvLight.var_choose cond_specs env + in + flag tags & spec) + t.flags + | _ -> + () + + let dispatch_default t = + dispatch_combine + [ + dispatch t; + MyOCamlbuildFindlib.dispatch; + ] + +end + + +# 476 "myocamlbuild.ml" +open Ocamlbuild_plugin;; +let package_default = + { + MyOCamlbuildBase.lib_ocaml = [("stdext", ["lib"])]; + lib_c = [("stdext", "lib", [])]; + flags = []; + includes = []; + } + ;; + +let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; + +# 490 "myocamlbuild.ml" +(* OASIS_STOP *) +Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/setup.ml b/setup.ml new file mode 100644 index 00000000000..76632845543 --- /dev/null +++ b/setup.ml @@ -0,0 +1,5728 @@ +(* setup.ml generated for the first time by OASIS v0.3.0 *) + +(* OASIS_START *) +(* DO NOT EDIT (digest: 2180d6551e8c5a28ba9cb94865fadb47) *) +(* + Regenerated by OASIS v0.3.0 + Visit http://oasis.forge.ocamlcore.org for more information and + documentation about functions used in this file. +*) +module OASISGettext = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) + + let ns_ str = + str + + let s_ str = + str + + let f_ (str : ('a, 'b, 'c, 'd) format4) = + str + + let fn_ fmt1 fmt2 n = + if n = 1 then + fmt1^^"" + else + fmt2^^"" + + let init = + [] + +end + +module OASISContext = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISContext.ml" *) + + open OASISGettext + + type level = + [ `Debug + | `Info + | `Warning + | `Error] + + type t = + { + quiet: bool; + info: bool; + debug: bool; + ignore_plugins: bool; + ignore_unknown_fields: bool; + printf: level -> string -> unit; + } + + let printf lvl str = + let beg = + match lvl with + | `Error -> s_ "E: " + | `Warning -> s_ "W: " + | `Info -> s_ "I: " + | `Debug -> s_ "D: " + in + prerr_endline (beg^str) + + let default = + ref + { + quiet = false; + info = false; + debug = false; + ignore_plugins = false; + ignore_unknown_fields = false; + printf = printf; + } + + let quiet = + {!default with quiet = true} + + + let args () = + ["-quiet", + Arg.Unit (fun () -> default := {!default with quiet = true}), + (s_ " Run quietly"); + + "-info", + Arg.Unit (fun () -> default := {!default with info = true}), + (s_ " Display information message"); + + + "-debug", + Arg.Unit (fun () -> default := {!default with debug = true}), + (s_ " Output debug message")] +end + +module OASISString = struct +(* # 1 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISString.ml" *) + + + + (** Various string utilities. + + Mostly inspired by extlib and batteries ExtString and BatString libraries. + + @author Sylvain Le Gall + *) + + let nsplitf str f = + if str = "" then + [] + else + let buf = Buffer.create 13 in + let lst = ref [] in + let push () = + lst := Buffer.contents buf :: !lst; + Buffer.clear buf + in + let str_len = String.length str in + for i = 0 to str_len - 1 do + if f str.[i] then + push () + else + Buffer.add_char buf str.[i] + done; + push (); + List.rev !lst + + (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the + separator. + *) + let nsplit str c = + nsplitf str ((=) c) + + let find ~what ?(offset=0) str = + let what_idx = ref 0 in + let str_idx = ref offset in + while !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx + else + what_idx := 0; + incr str_idx + done; + if !what_idx <> String.length what then + raise Not_found + else + !str_idx - !what_idx + + let sub_start str len = + let str_len = String.length str in + if len >= str_len then + "" + else + String.sub str len (str_len - len) + + let sub_end ?(offset=0) str len = + let str_len = String.length str in + if len >= str_len then + "" + else + String.sub str 0 (str_len - len) + + let starts_with ~what ?(offset=0) str = + let what_idx = ref 0 in + let str_idx = ref offset in + let ok = ref true in + while !ok && + !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx + else + ok := false; + incr str_idx + done; + if !what_idx = String.length what then + true + else + false + + let strip_starts_with ~what str = + if starts_with ~what str then + sub_start str (String.length what) + else + raise Not_found + + let ends_with ~what ?(offset=0) str = + let what_idx = ref ((String.length what) - 1) in + let str_idx = ref ((String.length str) - 1) in + let ok = ref true in + while !ok && + offset <= !str_idx && + 0 <= !what_idx do + if str.[!str_idx] = what.[!what_idx] then + decr what_idx + else + ok := false; + decr str_idx + done; + if !what_idx = -1 then + true + else + false + + let strip_ends_with ~what str = + if ends_with ~what str then + sub_end str (String.length what) + else + raise Not_found + + let replace_chars f s = + let buf = String.make (String.length s) 'X' in + for i = 0 to String.length s - 1 do + buf.[i] <- f s.[i] + done; + buf + +end + +module OASISUtils = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISUtils.ml" *) + + open OASISGettext + + module MapString = Map.Make(String) + + let map_string_of_assoc assoc = + List.fold_left + (fun acc (k, v) -> MapString.add k v acc) + MapString.empty + assoc + + module SetString = Set.Make(String) + + let set_string_add_list st lst = + List.fold_left + (fun acc e -> SetString.add e acc) + st + lst + + let set_string_of_list = + set_string_add_list + SetString.empty + + + let compare_csl s1 s2 = + String.compare (String.lowercase s1) (String.lowercase s2) + + module HashStringCsl = + Hashtbl.Make + (struct + type t = string + + let equal s1 s2 = + (String.lowercase s1) = (String.lowercase s2) + + let hash s = + Hashtbl.hash (String.lowercase s) + end) + + let varname_of_string ?(hyphen='_') s = + if String.length s = 0 then + begin + invalid_arg "varname_of_string" + end + else + begin + let buf = + OASISString.replace_chars + (fun c -> + if ('a' <= c && c <= 'z') + || + ('A' <= c && c <= 'Z') + || + ('0' <= c && c <= '9') then + c + else + hyphen) + s; + in + let buf = + (* Start with a _ if digit *) + if '0' <= s.[0] && s.[0] <= '9' then + "_"^buf + else + buf + in + String.lowercase buf + end + + let varname_concat ?(hyphen='_') p s = + let what = String.make 1 hyphen in + let p = + try + OASISString.strip_ends_with ~what p + with Not_found -> + p + in + let s = + try + OASISString.strip_starts_with ~what s + with Not_found -> + s + in + p^what^s + + + let is_varname str = + str = varname_of_string str + + let failwithf fmt = Printf.ksprintf failwith fmt + +end + +module PropList = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/PropList.ml" *) + + open OASISGettext + + type name = string + + exception Not_set of name * string option + exception No_printer of name + exception Unknown_field of name * name + + let () = + Printexc.register_printer + (function + | Not_set (nm, Some rsn) -> + Some + (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) + | Not_set (nm, None) -> + Some + (Printf.sprintf (f_ "Field '%s' is not set") nm) + | No_printer nm -> + Some + (Printf.sprintf (f_ "No default printer for value %s") nm) + | Unknown_field (nm, schm) -> + Some + (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm) + | _ -> + None) + + module Data = + struct + + type t = + (name, unit -> unit) Hashtbl.t + + let create () = + Hashtbl.create 13 + + let clear t = + Hashtbl.clear t + +(* # 71 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/PropList.ml" *) + end + + module Schema = + struct + + type ('ctxt, 'extra) value = + { + get: Data.t -> string; + set: Data.t -> ?context:'ctxt -> string -> unit; + help: (unit -> string) option; + extra: 'extra; + } + + type ('ctxt, 'extra) t = + { + name: name; + fields: (name, ('ctxt, 'extra) value) Hashtbl.t; + order: name Queue.t; + name_norm: string -> string; + } + + let create ?(case_insensitive=false) nm = + { + name = nm; + fields = Hashtbl.create 13; + order = Queue.create (); + name_norm = + (if case_insensitive then + String.lowercase + else + fun s -> s); + } + + let add t nm set get extra help = + let key = + t.name_norm nm + in + + if Hashtbl.mem t.fields key then + failwith + (Printf.sprintf + (f_ "Field '%s' is already defined in schema '%s'") + nm t.name); + Hashtbl.add + t.fields + key + { + set = set; + get = get; + help = help; + extra = extra; + }; + Queue.add nm t.order + + let mem t nm = + Hashtbl.mem t.fields nm + + let find t nm = + try + Hashtbl.find t.fields (t.name_norm nm) + with Not_found -> + raise (Unknown_field (nm, t.name)) + + let get t data nm = + (find t nm).get data + + let set t data nm ?context x = + (find t nm).set + data + ?context + x + + let fold f acc t = + Queue.fold + (fun acc k -> + let v = + find t k + in + f acc k v.extra v.help) + acc + t.order + + let iter f t = + fold + (fun () -> f) + () + t + + let name t = + t.name + end + + module Field = + struct + + type ('ctxt, 'value, 'extra) t = + { + set: Data.t -> ?context:'ctxt -> 'value -> unit; + get: Data.t -> 'value; + sets: Data.t -> ?context:'ctxt -> string -> unit; + gets: Data.t -> string; + help: (unit -> string) option; + extra: 'extra; + } + + let new_id = + let last_id = + ref 0 + in + fun () -> incr last_id; !last_id + + let create ?schema ?name ?parse ?print ?default ?update ?help extra = + (* Default value container *) + let v = + ref None + in + + (* If name is not given, create unique one *) + let nm = + match name with + | Some s -> s + | None -> Printf.sprintf "_anon_%d" (new_id ()) + in + + (* Last chance to get a value: the default *) + let default () = + match default with + | Some d -> d + | None -> raise (Not_set (nm, Some (s_ "no default value"))) + in + + (* Get data *) + let get data = + (* Get value *) + try + (Hashtbl.find data nm) (); + match !v with + | Some x -> x + | None -> default () + with Not_found -> + default () + in + + (* Set data *) + let set data ?context x = + let x = + match update with + | Some f -> + begin + try + f ?context (get data) x + with Not_set _ -> + x + end + | None -> + x + in + Hashtbl.replace + data + nm + (fun () -> v := Some x) + in + + (* Parse string value, if possible *) + let parse = + match parse with + | Some f -> + f + | None -> + fun ?context s -> + failwith + (Printf.sprintf + (f_ "Cannot parse field '%s' when setting value %S") + nm + s) + in + + (* Set data, from string *) + let sets data ?context s = + set ?context data (parse ?context s) + in + + (* Output value as string, if possible *) + let print = + match print with + | Some f -> + f + | None -> + fun _ -> raise (No_printer nm) + in + + (* Get data, as a string *) + let gets data = + print (get data) + in + + begin + match schema with + | Some t -> + Schema.add t nm sets gets extra help + | None -> + () + end; + + { + set = set; + get = get; + sets = sets; + gets = gets; + help = help; + extra = extra; + } + + let fset data t ?context x = + t.set data ?context x + + let fget data t = + t.get data + + let fsets data t ?context s = + t.sets data ?context s + + let fgets data t = + t.gets data + + end + + module FieldRO = + struct + + let create ?schema ?name ?parse ?print ?default ?update ?help extra = + let fld = + Field.create ?schema ?name ?parse ?print ?default ?update ?help extra + in + fun data -> Field.fget data fld + + end +end + +module OASISMessage = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISMessage.ml" *) + + + open OASISGettext + open OASISContext + + let generic_message ~ctxt lvl fmt = + let cond = + if ctxt.quiet then + false + else + match lvl with + | `Debug -> ctxt.debug + | `Info -> ctxt.info + | _ -> true + in + Printf.ksprintf + (fun str -> + if cond then + begin + ctxt.printf lvl str + end) + fmt + + let debug ~ctxt fmt = + generic_message ~ctxt `Debug fmt + + let info ~ctxt fmt = + generic_message ~ctxt `Info fmt + + let warning ~ctxt fmt = + generic_message ~ctxt `Warning fmt + + let error ~ctxt fmt = + generic_message ~ctxt `Error fmt + +end + +module OASISVersion = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISVersion.ml" *) + + open OASISGettext + + + + type s = string + + type t = string + + type comparator = + | VGreater of t + | VGreaterEqual of t + | VEqual of t + | VLesser of t + | VLesserEqual of t + | VOr of comparator * comparator + | VAnd of comparator * comparator + + + (* Range of allowed characters *) + let is_digit c = + '0' <= c && c <= '9' + + let is_alpha c = + ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') + + let is_special = + function + | '.' | '+' | '-' | '~' -> true + | _ -> false + + let rec version_compare v1 v2 = + if v1 <> "" || v2 <> "" then + begin + (* Compare ascii string, using special meaning for version + * related char + *) + let val_ascii c = + if c = '~' then -1 + else if is_digit c then 0 + else if c = '\000' then 0 + else if is_alpha c then Char.code c + else (Char.code c) + 256 + in + + let len1 = String.length v1 in + let len2 = String.length v2 in + + let p = ref 0 in + + (** Compare ascii part *) + let compare_vascii () = + let cmp = ref 0 in + while !cmp = 0 && + !p < len1 && !p < len2 && + not (is_digit v1.[!p] && is_digit v2.[!p]) do + cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); + incr p + done; + if !cmp = 0 && !p < len1 && !p = len2 then + val_ascii v1.[!p] + else if !cmp = 0 && !p = len1 && !p < len2 then + - (val_ascii v2.[!p]) + else + !cmp + in + + (** Compare digit part *) + let compare_digit () = + let extract_int v p = + let start_p = !p in + while !p < String.length v && is_digit v.[!p] do + incr p + done; + let substr = + String.sub v !p ((String.length v) - !p) + in + let res = + match String.sub v start_p (!p - start_p) with + | "" -> 0 + | s -> int_of_string s + in + res, substr + in + let i1, tl1 = extract_int v1 (ref !p) in + let i2, tl2 = extract_int v2 (ref !p) in + i1 - i2, tl1, tl2 + in + + match compare_vascii () with + | 0 -> + begin + match compare_digit () with + | 0, tl1, tl2 -> + if tl1 <> "" && is_digit tl1.[0] then + 1 + else if tl2 <> "" && is_digit tl2.[0] then + -1 + else + version_compare tl1 tl2 + | n, _, _ -> + n + end + | n -> + n + end + else + begin + 0 + end + + + let version_of_string str = str + + let string_of_version t = t + + let chop t = + try + let pos = + String.rindex t '.' + in + String.sub t 0 pos + with Not_found -> + t + + let rec comparator_apply v op = + match op with + | VGreater cv -> + (version_compare v cv) > 0 + | VGreaterEqual cv -> + (version_compare v cv) >= 0 + | VLesser cv -> + (version_compare v cv) < 0 + | VLesserEqual cv -> + (version_compare v cv) <= 0 + | VEqual cv -> + (version_compare v cv) = 0 + | VOr (op1, op2) -> + (comparator_apply v op1) || (comparator_apply v op2) + | VAnd (op1, op2) -> + (comparator_apply v op1) && (comparator_apply v op2) + + let rec string_of_comparator = + function + | VGreater v -> "> "^(string_of_version v) + | VEqual v -> "= "^(string_of_version v) + | VLesser v -> "< "^(string_of_version v) + | VGreaterEqual v -> ">= "^(string_of_version v) + | VLesserEqual v -> "<= "^(string_of_version v) + | VOr (c1, c2) -> + (string_of_comparator c1)^" || "^(string_of_comparator c2) + | VAnd (c1, c2) -> + (string_of_comparator c1)^" && "^(string_of_comparator c2) + + let rec varname_of_comparator = + let concat p v = + OASISUtils.varname_concat + p + (OASISUtils.varname_of_string + (string_of_version v)) + in + function + | VGreater v -> concat "gt" v + | VLesser v -> concat "lt" v + | VEqual v -> concat "eq" v + | VGreaterEqual v -> concat "ge" v + | VLesserEqual v -> concat "le" v + | VOr (c1, c2) -> + (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) + | VAnd (c1, c2) -> + (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) + + let version_0_3_or_after t = + comparator_apply t (VGreaterEqual (string_of_version "0.3")) + +end + +module OASISLicense = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISLicense.ml" *) + + (** License for _oasis fields + @author Sylvain Le Gall + *) + + + + type license = string + + type license_exception = string + + type license_version = + | Version of OASISVersion.t + | VersionOrLater of OASISVersion.t + | NoVersion + + + type license_dep_5_unit = + { + license: license; + excption: license_exception option; + version: license_version; + } + + + type license_dep_5 = + | DEP5Unit of license_dep_5_unit + | DEP5Or of license_dep_5 list + | DEP5And of license_dep_5 list + + + type t = + | DEP5License of license_dep_5 + | OtherLicense of string (* URL *) + + +end + +module OASISExpr = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) + + + + open OASISGettext + + type test = string + + type flag = string + + type t = + | EBool of bool + | ENot of t + | EAnd of t * t + | EOr of t * t + | EFlag of flag + | ETest of test * string + + + type 'a choices = (t * 'a) list + + let eval var_get t = + let rec eval' = + function + | EBool b -> + b + + | ENot e -> + not (eval' e) + + | EAnd (e1, e2) -> + (eval' e1) && (eval' e2) + + | EOr (e1, e2) -> + (eval' e1) || (eval' e2) + + | EFlag nm -> + let v = + var_get nm + in + assert(v = "true" || v = "false"); + (v = "true") + + | ETest (nm, vl) -> + let v = + var_get nm + in + (v = vl) + in + eval' t + + let choose ?printer ?name var_get lst = + let rec choose_aux = + function + | (cond, vl) :: tl -> + if eval var_get cond then + vl + else + choose_aux tl + | [] -> + let str_lst = + if lst = [] then + s_ "" + else + String.concat + (s_ ", ") + (List.map + (fun (cond, vl) -> + match printer with + | Some p -> p vl + | None -> s_ "") + lst) + in + match name with + | Some nm -> + failwith + (Printf.sprintf + (f_ "No result for the choice list '%s': %s") + nm str_lst) + | None -> + failwith + (Printf.sprintf + (f_ "No result for a choice list: %s") + str_lst) + in + choose_aux (List.rev lst) + +end + +module OASISTypes = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) + + + + + type name = string + type package_name = string + type url = string + type unix_dirname = string + type unix_filename = string + type host_dirname = string + type host_filename = string + type prog = string + type arg = string + type args = string list + type command_line = (prog * arg list) + + type findlib_name = string + type findlib_full = string + + type compiled_object = + | Byte + | Native + | Best + + + type dependency = + | FindlibPackage of findlib_full * OASISVersion.comparator option + | InternalLibrary of name + + + type tool = + | ExternalTool of name + | InternalExecutable of name + + + type vcs = + | Darcs + | Git + | Svn + | Cvs + | Hg + | Bzr + | Arch + | Monotone + | OtherVCS of url + + + type plugin_kind = + [ `Configure + | `Build + | `Doc + | `Test + | `Install + | `Extra + ] + + type plugin_data_purpose = + [ `Configure + | `Build + | `Install + | `Clean + | `Distclean + | `Install + | `Uninstall + | `Test + | `Doc + | `Extra + | `Other of string + ] + + type 'a plugin = 'a * name * OASISVersion.t option + + type all_plugin = plugin_kind plugin + + type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list + +(* # 102 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) + + type 'a conditional = 'a OASISExpr.choices + + type custom = + { + pre_command: (command_line option) conditional; + post_command: (command_line option) conditional; + } + + + type common_section = + { + cs_name: name; + cs_data: PropList.Data.t; + cs_plugin_data: plugin_data; + } + + + type build_section = + { + bs_build: bool conditional; + bs_install: bool conditional; + bs_path: unix_dirname; + bs_compiled_object: compiled_object; + bs_build_depends: dependency list; + bs_build_tools: tool list; + bs_c_sources: unix_filename list; + bs_data_files: (unix_filename * unix_filename option) list; + bs_ccopt: args conditional; + bs_cclib: args conditional; + bs_dlllib: args conditional; + bs_dllpath: args conditional; + bs_byteopt: args conditional; + bs_nativeopt: args conditional; + } + + + type library = + { + lib_modules: string list; + lib_pack: bool; + lib_internal_modules: string list; + lib_findlib_parent: findlib_name option; + lib_findlib_name: findlib_name option; + lib_findlib_containers: findlib_name list; + } + + type executable = + { + exec_custom: bool; + exec_main_is: unix_filename; + } + + type flag = + { + flag_description: string option; + flag_default: bool conditional; + } + + type source_repository = + { + src_repo_type: vcs; + src_repo_location: url; + src_repo_browser: url option; + src_repo_module: string option; + src_repo_branch: string option; + src_repo_tag: string option; + src_repo_subdir: unix_filename option; + } + + type test = + { + test_type: [`Test] plugin; + test_command: command_line conditional; + test_custom: custom; + test_working_directory: unix_filename option; + test_run: bool conditional; + test_tools: tool list; + } + + type doc_format = + | HTML of unix_filename + | DocText + | PDF + | PostScript + | Info of unix_filename + | DVI + | OtherDoc + + + type doc = + { + doc_type: [`Doc] plugin; + doc_custom: custom; + doc_build: bool conditional; + doc_install: bool conditional; + doc_install_dir: unix_filename; + doc_title: string; + doc_authors: string list; + doc_abstract: string option; + doc_format: doc_format; + doc_data_files: (unix_filename * unix_filename option) list; + doc_build_tools: tool list; + } + + type section = + | Library of common_section * build_section * library + | Executable of common_section * build_section * executable + | Flag of common_section * flag + | SrcRepo of common_section * source_repository + | Test of common_section * test + | Doc of common_section * doc + + + type section_kind = + [ `Library | `Executable | `Flag | `SrcRepo | `Test | `Doc ] + + type package = + { + oasis_version: OASISVersion.t; + ocaml_version: OASISVersion.comparator option; + findlib_version: OASISVersion.comparator option; + name: package_name; + version: OASISVersion.t; + license: OASISLicense.t; + license_file: unix_filename option; + copyrights: string list; + maintainers: string list; + authors: string list; + homepage: url option; + synopsis: string; + description: string option; + categories: url list; + + conf_type: [`Configure] plugin; + conf_custom: custom; + + build_type: [`Build] plugin; + build_custom: custom; + + install_type: [`Install] plugin; + install_custom: custom; + uninstall_custom: custom; + + clean_custom: custom; + distclean_custom: custom; + + files_ab: unix_filename list; + sections: section list; + plugins: [`Extra] plugin list; + schema_data: PropList.Data.t; + plugin_data: plugin_data; + } + +end + +module OASISUnixPath = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" *) + + type unix_filename = string + type unix_dirname = string + + type host_filename = string + type host_dirname = string + + let current_dir_name = "." + + let parent_dir_name = ".." + + let is_current_dir fn = + fn = current_dir_name || fn = "" + + let concat f1 f2 = + if is_current_dir f1 then + f2 + else + let f1' = + try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 + in + f1'^"/"^f2 + + let make = + function + | hd :: tl -> + List.fold_left + (fun f p -> concat f p) + hd + tl + | [] -> + invalid_arg "OASISUnixPath.make" + + let dirname f = + try + String.sub f 0 (String.rindex f '/') + with Not_found -> + current_dir_name + + let basename f = + try + let pos_start = + (String.rindex f '/') + 1 + in + String.sub f pos_start ((String.length f) - pos_start) + with Not_found -> + f + + let chop_extension f = + try + let last_dot = + String.rindex f '.' + in + let sub = + String.sub f 0 last_dot + in + try + let last_slash = + String.rindex f '/' + in + if last_slash < last_dot then + sub + else + f + with Not_found -> + sub + + with Not_found -> + f + + let capitalize_file f = + let dir = dirname f in + let base = basename f in + concat dir (String.capitalize base) + + let uncapitalize_file f = + let dir = dirname f in + let base = basename f in + concat dir (String.uncapitalize base) + +end + +module OASISHostPath = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" *) + + + open Filename + + module Unix = OASISUnixPath + + let make = + function + | [] -> + invalid_arg "OASISHostPath.make" + | hd :: tl -> + List.fold_left Filename.concat hd tl + + let of_unix ufn = + if Sys.os_type = "Unix" then + ufn + else + make + (List.map + (fun p -> + if p = Unix.current_dir_name then + current_dir_name + else if p = Unix.parent_dir_name then + parent_dir_name + else + p) + (OASISString.nsplit ufn '/')) + + +end + +module OASISSection = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISSection.ml" *) + + open OASISTypes + + let section_kind_common = + function + | Library (cs, _, _) -> + `Library, cs + | Executable (cs, _, _) -> + `Executable, cs + | Flag (cs, _) -> + `Flag, cs + | SrcRepo (cs, _) -> + `SrcRepo, cs + | Test (cs, _) -> + `Test, cs + | Doc (cs, _) -> + `Doc, cs + + let section_common sct = + snd (section_kind_common sct) + + let section_common_set cs = + function + | Library (_, bs, lib) -> Library (cs, bs, lib) + | Executable (_, bs, exec) -> Executable (cs, bs, exec) + | Flag (_, flg) -> Flag (cs, flg) + | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) + | Test (_, tst) -> Test (cs, tst) + | Doc (_, doc) -> Doc (cs, doc) + + (** Key used to identify section + *) + let section_id sct = + let k, cs = + section_kind_common sct + in + k, cs.cs_name + + let string_of_section sct = + let k, nm = + section_id sct + in + (match k with + | `Library -> "library" + | `Executable -> "executable" + | `Flag -> "flag" + | `SrcRepo -> "src repository" + | `Test -> "test" + | `Doc -> "doc") + ^" "^nm + + let section_find id scts = + List.find + (fun sct -> id = section_id sct) + scts + + module CSection = + struct + type t = section + + let id = section_id + + let compare t1 t2 = + compare (id t1) (id t2) + + let equal t1 t2 = + (id t1) = (id t2) + + let hash t = + Hashtbl.hash (id t) + end + + module MapSection = Map.Make(CSection) + module SetSection = Set.Make(CSection) + +end + +module OASISBuildSection = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" *) + +end + +module OASISExecutable = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" *) + + open OASISTypes + + let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = + let dir = + OASISUnixPath.concat + bs.bs_path + (OASISUnixPath.dirname exec.exec_main_is) + in + let is_native_exec = + match bs.bs_compiled_object with + | Native -> true + | Best -> is_native () + | Byte -> false + in + + OASISUnixPath.concat + dir + (cs.cs_name^(suffix_program ())), + + if not is_native_exec && + not exec.exec_custom && + bs.bs_c_sources <> [] then + Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) + else + None + +end + +module OASISLibrary = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" *) + + open OASISTypes + open OASISUtils + open OASISGettext + open OASISSection + + type library_name = name + type findlib_part_name = name + type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t + + exception InternalLibraryNotFound of library_name + exception FindlibPackageNotFound of findlib_name + + type group_t = + | Container of findlib_name * group_t list + | Package of (findlib_name * + common_section * + build_section * + library * + group_t list) + + (* Look for a module file, considering capitalization or not. *) + let find_module source_file_exists (cs, bs, lib) modul = + let possible_base_fn = + List.map + (OASISUnixPath.concat bs.bs_path) + [modul; + OASISUnixPath.uncapitalize_file modul; + OASISUnixPath.capitalize_file modul] + in + (* TODO: we should be able to be able to determine the source for every + * files. Hence we should introduce a Module(source: fn) for the fields + * Modules and InternalModules + *) + List.fold_left + (fun acc base_fn -> + match acc with + | `No_sources _ -> + begin + let file_found = + List.fold_left + (fun acc ext -> + if source_file_exists (base_fn^ext) then + (base_fn^ext) :: acc + else + acc) + [] + [".ml"; ".mli"; ".mll"; ".mly"] + in + match file_found with + | [] -> + acc + | lst -> + `Sources (base_fn, lst) + end + | `Sources _ -> + acc) + (`No_sources possible_base_fn) + possible_base_fn + + let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = + List.fold_left + (fun acc modul -> + match find_module source_file_exists (cs, bs, lib) modul with + | `Sources (base_fn, lst) -> + (base_fn, lst) :: acc + | `No_sources _ -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in library %s") + modul cs.cs_name; + acc) + [] + (lib.lib_modules @ lib.lib_internal_modules) + + let generated_unix_files + ~ctxt + ~is_native + ~has_native_dynlink + ~ext_lib + ~ext_dll + ~source_file_exists + (cs, bs, lib) = + + let find_modules lst ext = + let find_module modul = + match find_module source_file_exists (cs, bs, lib) modul with + | `Sources (base_fn, _) -> + [base_fn] + | `No_sources lst -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in library %s") + modul cs.cs_name; + lst + in + List.map + (fun nm -> + List.map + (fun base_fn -> base_fn ^"."^ext) + (find_module nm)) + lst + in + + (* The headers that should be compiled along *) + let headers = + if lib.lib_pack then + [] + else + find_modules + lib.lib_modules + "cmi" + in + + (* The .cmx that be compiled along *) + let cmxs = + let should_be_built = + (not lib.lib_pack) && (* Do not install .cmx packed submodules *) + match bs.bs_compiled_object with + | Native -> true + | Best -> is_native + | Byte -> false + in + if should_be_built then + find_modules + (lib.lib_modules @ lib.lib_internal_modules) + "cmx" + else + [] + in + + let acc_nopath = + [] + in + + (* Compute what libraries should be built *) + let acc_nopath = + (* Add the packed header file if required *) + let add_pack_header acc = + if lib.lib_pack then + [cs.cs_name^".cmi"] :: acc + else + acc + in + let byte acc = + add_pack_header ([cs.cs_name^".cma"] :: acc) + in + let native acc = + let acc = + add_pack_header + (if has_native_dynlink then + [cs.cs_name^".cmxs"] :: acc + else acc) + in + [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc + in + match bs.bs_compiled_object with + | Native -> + byte (native acc_nopath) + | Best when is_native -> + byte (native acc_nopath) + | Byte | Best -> + byte acc_nopath + in + + (* Add C library to be built *) + let acc_nopath = + if bs.bs_c_sources <> [] then + begin + ["lib"^cs.cs_name^"_stubs"^ext_lib] + :: + ["dll"^cs.cs_name^"_stubs"^ext_dll] + :: + acc_nopath + end + else + acc_nopath + in + + (* All the files generated *) + List.rev_append + (List.rev_map + (List.rev_map + (OASISUnixPath.concat bs.bs_path)) + acc_nopath) + (headers @ cmxs) + + type data = common_section * build_section * library + type tree = + | Node of (data option) * (tree MapString.t) + | Leaf of data + + let findlib_mapping pkg = + (* Map from library name to either full findlib name or parts + parent. *) + let fndlb_parts_of_lib_name = + let fndlb_parts cs lib = + let name = + match lib.lib_findlib_name with + | Some nm -> nm + | None -> cs.cs_name + in + let name = + String.concat "." (lib.lib_findlib_containers @ [name]) + in + name + in + List.fold_left + (fun mp -> + function + | Library (cs, _, lib) -> + begin + let lib_name = cs.cs_name in + let fndlb_parts = fndlb_parts cs lib in + if MapString.mem lib_name mp then + failwithf + (f_ "The library name '%s' is used more than once.") + lib_name; + match lib.lib_findlib_parent with + | Some lib_name_parent -> + MapString.add + lib_name + (`Unsolved (lib_name_parent, fndlb_parts)) + mp + | None -> + MapString.add + lib_name + (`Solved fndlb_parts) + mp + end + + | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> + mp) + MapString.empty + pkg.sections + in + + (* Solve the above graph to be only library name to full findlib name. *) + let fndlb_name_of_lib_name = + let rec solve visited mp lib_name lib_name_child = + if SetString.mem lib_name visited then + failwithf + (f_ "Library '%s' is involved in a cycle \ + with regard to findlib naming.") + lib_name; + let visited = SetString.add lib_name visited in + try + match MapString.find lib_name mp with + | `Solved fndlb_nm -> + fndlb_nm, mp + | `Unsolved (lib_nm_parent, post_fndlb_nm) -> + let pre_fndlb_nm, mp = + solve visited mp lib_nm_parent lib_name + in + let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in + fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp + with Not_found -> + failwithf + (f_ "Library '%s', which is defined as the findlib parent of \ + library '%s', doesn't exist.") + lib_name lib_name_child + in + let mp = + MapString.fold + (fun lib_name status mp -> + match status with + | `Solved _ -> + (* Solved initialy, no need to go further *) + mp + | `Unsolved _ -> + let _, mp = solve SetString.empty mp lib_name "" in + mp) + fndlb_parts_of_lib_name + fndlb_parts_of_lib_name + in + MapString.map + (function + | `Solved fndlb_nm -> fndlb_nm + | `Unsolved _ -> assert false) + mp + in + + (* Convert an internal library name to a findlib name. *) + let findlib_name_of_library_name lib_nm = + try + MapString.find lib_nm fndlb_name_of_lib_name + with Not_found -> + raise (InternalLibraryNotFound lib_nm) + in + + (* Add a library to the tree. + *) + let add sct mp = + let fndlb_fullname = + let cs, _, _ = sct in + let lib_name = cs.cs_name in + findlib_name_of_library_name lib_name + in + let rec add_children nm_lst (children : tree MapString.t) = + match nm_lst with + | (hd :: tl) -> + begin + let node = + try + add_node tl (MapString.find hd children) + with Not_found -> + (* New node *) + new_node tl + in + MapString.add hd node children + end + | [] -> + (* Should not have a nameless library. *) + assert false + and add_node tl node = + if tl = [] then + begin + match node with + | Node (None, children) -> + Node (Some sct, children) + | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> + (* TODO: allow to merge Package, i.e. + * archive(byte) = "foo.cma foo_init.cmo" + *) + let cs, _, _ = sct in + failwithf + (f_ "Library '%s' and '%s' have the same findlib name '%s'") + cs.cs_name cs'.cs_name fndlb_fullname + end + else + begin + match node with + | Leaf data -> + Node (Some data, add_children tl MapString.empty) + | Node (data_opt, children) -> + Node (data_opt, add_children tl children) + end + and new_node = + function + | [] -> + Leaf sct + | hd :: tl -> + Node (None, MapString.add hd (new_node tl) MapString.empty) + in + add_children (OASISString.nsplit fndlb_fullname '.') mp + in + + let rec group_of_tree mp = + MapString.fold + (fun nm node acc -> + let cur = + match node with + | Node (Some (cs, bs, lib), children) -> + Package (nm, cs, bs, lib, group_of_tree children) + | Node (None, children) -> + Container (nm, group_of_tree children) + | Leaf (cs, bs, lib) -> + Package (nm, cs, bs, lib, []) + in + cur :: acc) + mp [] + in + + let group_mp = + List.fold_left + (fun mp -> + function + | Library (cs, bs, lib) -> + add (cs, bs, lib) mp + | _ -> + mp) + MapString.empty + pkg.sections + in + + let groups = + group_of_tree group_mp + in + + let library_name_of_findlib_name = + Lazy.lazy_from_fun + (fun () -> + (* Revert findlib_name_of_library_name. *) + MapString.fold + (fun k v mp -> MapString.add v k mp) + fndlb_name_of_lib_name + MapString.empty) + in + let library_name_of_findlib_name fndlb_nm = + try + MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) + with Not_found -> + raise (FindlibPackageNotFound fndlb_nm) + in + + groups, + findlib_name_of_library_name, + library_name_of_findlib_name + + let findlib_of_group = + function + | Container (fndlb_nm, _) + | Package (fndlb_nm, _, _, _, _) -> fndlb_nm + + let root_of_group grp = + let rec root_lib_aux = + (* We do a DFS in the group. *) + function + | Container (_, children) -> + List.fold_left + (fun res grp -> + if res = None then + root_lib_aux grp + else + res) + None + children + | Package (_, cs, bs, lib, _) -> + Some (cs, bs, lib) + in + match root_lib_aux grp with + | Some res -> + res + | None -> + failwithf + (f_ "Unable to determine root library of findlib library '%s'") + (findlib_of_group grp) + +end + +module OASISFlag = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISFlag.ml" *) + +end + +module OASISPackage = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISPackage.ml" *) + +end + +module OASISSourceRepository = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" *) + +end + +module OASISTest = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISTest.ml" *) + +end + +module OASISDocument = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISDocument.ml" *) + +end + +module OASISExec = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISExec.ml" *) + + open OASISGettext + open OASISUtils + open OASISMessage + + (* TODO: I don't like this quote, it is there because $(rm) foo expands to + * 'rm -f' foo... + *) + let run ~ctxt ?f_exit_code ?(quote=true) cmd args = + let cmd = + if quote then + if Sys.os_type = "Win32" then + if String.contains cmd ' ' then + (* Double the 1st double quote... win32... sigh *) + "\""^(Filename.quote cmd) + else + cmd + else + Filename.quote cmd + else + cmd + in + let cmdline = + String.concat " " (cmd :: args) + in + info ~ctxt (f_ "Running command '%s'") cmdline; + match f_exit_code, Sys.command cmdline with + | None, 0 -> () + | None, i -> + failwithf + (f_ "Command '%s' terminated with error code %d") + cmdline i + | Some f, i -> + f i + + let run_read_output ~ctxt ?f_exit_code cmd args = + let fn = + Filename.temp_file "oasis-" ".txt" + in + try + begin + let () = + run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) + in + let chn = + open_in fn + in + let routput = + ref [] + in + begin + try + while true do + routput := (input_line chn) :: !routput + done + with End_of_file -> + () + end; + close_in chn; + Sys.remove fn; + List.rev !routput + end + with e -> + (try Sys.remove fn with _ -> ()); + raise e + + let run_read_one_line ~ctxt ?f_exit_code cmd args = + match run_read_output ~ctxt ?f_exit_code cmd args with + | [fst] -> + fst + | lst -> + failwithf + (f_ "Command return unexpected output %S") + (String.concat "\n" lst) +end + +module OASISFileUtil = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" *) + + open OASISGettext + + let file_exists_case fn = + let dirname = Filename.dirname fn in + let basename = Filename.basename fn in + if Sys.file_exists dirname then + if basename = Filename.current_dir_name then + true + else + List.mem + basename + (Array.to_list (Sys.readdir dirname)) + else + false + + let find_file ?(case_sensitive=true) paths exts = + + (* Cardinal product of two list *) + let ( * ) lst1 lst2 = + List.flatten + (List.map + (fun a -> + List.map + (fun b -> a,b) + lst2) + lst1) + in + + let rec combined_paths lst = + match lst with + | p1 :: p2 :: tl -> + let acc = + (List.map + (fun (a,b) -> Filename.concat a b) + (p1 * p2)) + in + combined_paths (acc :: tl) + | [e] -> + e + | [] -> + [] + in + + let alternatives = + List.map + (fun (p,e) -> + if String.length e > 0 && e.[0] <> '.' then + p ^ "." ^ e + else + p ^ e) + ((combined_paths paths) * exts) + in + List.find + (if case_sensitive then + file_exists_case + else + Sys.file_exists) + alternatives + + let which ~ctxt prg = + let path_sep = + match Sys.os_type with + | "Win32" -> + ';' + | _ -> + ':' + in + let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in + let exec_ext = + match Sys.os_type with + | "Win32" -> + "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) + | _ -> + [""] + in + find_file ~case_sensitive:false [path_lst; [prg]] exec_ext + + (**/**) + let rec fix_dir dn = + (* Windows hack because Sys.file_exists "src\\" = false when + * Sys.file_exists "src" = true + *) + let ln = + String.length dn + in + if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then + fix_dir (String.sub dn 0 (ln - 1)) + else + dn + + let q = Filename.quote + (**/**) + + let cp ~ctxt ?(recurse=false) src tgt = + if recurse then + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt + "xcopy" [q src; q tgt; "/E"] + | _ -> + OASISExec.run ~ctxt + "cp" ["-r"; q src; q tgt] + else + OASISExec.run ~ctxt + (match Sys.os_type with + | "Win32" -> "copy" + | _ -> "cp") + [q src; q tgt] + + let mkdir ~ctxt tgt = + OASISExec.run ~ctxt + (match Sys.os_type with + | "Win32" -> "md" + | _ -> "mkdir") + [q tgt] + + let rec mkdir_parent ~ctxt f tgt = + let tgt = + fix_dir tgt + in + if Sys.file_exists tgt then + begin + if not (Sys.is_directory tgt) then + OASISUtils.failwithf + (f_ "Cannot create directory '%s', a file of the same name already \ + exists") + tgt + end + else + begin + mkdir_parent ~ctxt f (Filename.dirname tgt); + if not (Sys.file_exists tgt) then + begin + f tgt; + mkdir ~ctxt tgt + end + end + + let rmdir ~ctxt tgt = + if Sys.readdir tgt = [||] then + begin + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt "rd" [q tgt] + | _ -> + OASISExec.run ~ctxt "rm" ["-r"; q tgt] + end + + let glob ~ctxt fn = + let basename = + Filename.basename fn + in + if String.length basename >= 2 && + basename.[0] = '*' && + basename.[1] = '.' then + begin + let ext_len = + (String.length basename) - 2 + in + let ext = + String.sub basename 2 ext_len + in + let dirname = + Filename.dirname fn + in + Array.fold_left + (fun acc fn -> + try + let fn_ext = + String.sub + fn + ((String.length fn) - ext_len) + ext_len + in + if fn_ext = ext then + (Filename.concat dirname fn) :: acc + else + acc + with Invalid_argument _ -> + acc) + [] + (Sys.readdir dirname) + end + else + begin + if file_exists_case fn then + [fn] + else + [] + end +end + + +# 2142 "setup.ml" +module BaseEnvLight = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) + + module MapString = Map.Make(String) + + type t = string MapString.t + + let default_filename = + Filename.concat + (Sys.getcwd ()) + "setup.data" + + let load ?(allow_empty=false) ?(filename=default_filename) () = + if Sys.file_exists filename then + begin + let chn = + open_in_bin filename + in + let st = + Stream.of_channel chn + in + let line = + ref 1 + in + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + let lexer = + Genlex.make_lexer ["="] st_line + in + let rec read_file mp = + match Stream.npeek 3 lexer with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lexer; + Stream.junk lexer; + Stream.junk lexer; + read_file (MapString.add nm value mp) + | [] -> + mp + | _ -> + failwith + (Printf.sprintf + "Malformed data file '%s' line %d" + filename !line) + in + let mp = + read_file MapString.empty + in + close_in chn; + mp + end + else if allow_empty then + begin + MapString.empty + end + else + begin + failwith + (Printf.sprintf + "Unable to load environment, the file '%s' doesn't exist." + filename) + end + + let var_get name env = + let rec var_expand str = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + in + var_expand (MapString.find name env) + + let var_choose lst env = + OASISExpr.choose + (fun nm -> var_get nm env) + lst +end + + +# 2240 "setup.ml" +module BaseContext = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseContext.ml" *) + + open OASISContext + + let args = args + + let default = default + +end + +module BaseMessage = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseMessage.ml" *) + + (** Message to user, overrid for Base + @author Sylvain Le Gall + *) + open OASISMessage + open BaseContext + + let debug fmt = debug ~ctxt:!default fmt + + let info fmt = info ~ctxt:!default fmt + + let warning fmt = warning ~ctxt:!default fmt + + let error fmt = error ~ctxt:!default fmt + +end + +module BaseEnv = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseEnv.ml" *) + + open OASISGettext + open OASISUtils + open PropList + + module MapString = BaseEnvLight.MapString + + type origin_t = + | ODefault + | OGetEnv + | OFileLoad + | OCommandLine + + type cli_handle_t = + | CLINone + | CLIAuto + | CLIWith + | CLIEnable + | CLIUser of (Arg.key * Arg.spec * Arg.doc) list + + type definition_t = + { + hide: bool; + dump: bool; + cli: cli_handle_t; + arg_help: string option; + group: string option; + } + + let schema = + Schema.create "environment" + + (* Environment data *) + let env = + Data.create () + + (* Environment data from file *) + let env_from_file = + ref MapString.empty + + (* Lexer for var *) + let var_lxr = + Genlex.make_lexer [] + + let rec var_expand str = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + (* TODO: this is a quick hack to allow calling Test.Command + * without defining executable name really. I.e. if there is + * an exec Executable toto, then $(toto) should be replace + * by its real name. It is however useful to have this function + * for other variable that depend on the host and should be + * written better than that. + *) + let st = + var_lxr (Stream.of_string var) + in + match Stream.npeek 3 st with + | [Genlex.Ident "utoh"; Genlex.Ident nm] -> + OASISHostPath.of_unix (var_get nm) + | [Genlex.Ident "utoh"; Genlex.String s] -> + OASISHostPath.of_unix s + | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> + String.escaped (var_get nm) + | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> + String.escaped s + | [Genlex.Ident nm] -> + var_get nm + | _ -> + failwithf + (f_ "Unknown expression '%s' in variable expansion of %s.") + var + str + with + | Unknown_field (_, _) -> + failwithf + (f_ "No variable %s defined when trying to expand %S.") + var + str + | Stream.Error e -> + failwithf + (f_ "Syntax error when parsing '%s' when trying to \ + expand %S: %s") + var + str + e) + str; + Buffer.contents buff + + and var_get name = + let vl = + try + Schema.get schema env name + with Unknown_field _ as e -> + begin + try + MapString.find name !env_from_file + with Not_found -> + raise e + end + in + var_expand vl + + let var_choose ?printer ?name lst = + OASISExpr.choose + ?printer + ?name + var_get + lst + + let var_protect vl = + let buff = + Buffer.create (String.length vl) + in + String.iter + (function + | '$' -> Buffer.add_string buff "\\$" + | c -> Buffer.add_char buff c) + vl; + Buffer.contents buff + + let var_define + ?(hide=false) + ?(dump=true) + ?short_desc + ?(cli=CLINone) + ?arg_help + ?group + name (* TODO: type constraint on the fact that name must be a valid OCaml + id *) + dflt = + + let default = + [ + OFileLoad, (fun () -> MapString.find name !env_from_file); + ODefault, dflt; + OGetEnv, (fun () -> Sys.getenv name); + ] + in + + let extra = + { + hide = hide; + dump = dump; + cli = cli; + arg_help = arg_help; + group = group; + } + in + + (* Try to find a value that can be defined + *) + let var_get_low lst = + let errors, res = + List.fold_left + (fun (errors, res) (o, v) -> + if res = None then + begin + try + errors, Some (v ()) + with + | Not_found -> + errors, res + | Failure rsn -> + (rsn :: errors), res + | e -> + (Printexc.to_string e) :: errors, res + end + else + errors, res) + ([], None) + (List.sort + (fun (o1, _) (o2, _) -> + Pervasives.compare o2 o1) + lst) + in + match res, errors with + | Some v, _ -> + v + | None, [] -> + raise (Not_set (name, None)) + | None, lst -> + raise (Not_set (name, Some (String.concat (s_ ", ") lst))) + in + + let help = + match short_desc with + | Some fs -> Some fs + | None -> None + in + + let var_get_lst = + FieldRO.create + ~schema + ~name + ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) + ~print:var_get_low + ~default + ~update:(fun ?context x old_x -> x @ old_x) + ?help + extra + in + + fun () -> + var_expand (var_get_low (var_get_lst env)) + + let var_redefine + ?hide + ?dump + ?short_desc + ?cli + ?arg_help + ?group + name + dflt = + if Schema.mem schema name then + begin + (* TODO: look suspsicious, we want to memorize dflt not dflt () *) + Schema.set schema env ~context:ODefault name (dflt ()); + fun () -> var_get name + end + else + begin + var_define + ?hide + ?dump + ?short_desc + ?cli + ?arg_help + ?group + name + dflt + end + + let var_ignore (e : unit -> string) = + () + + let print_hidden = + var_define + ~hide:true + ~dump:false + ~cli:CLIAuto + ~arg_help:"Print even non-printable variable. (debug)" + "print_hidden" + (fun () -> "false") + + let var_all () = + List.rev + (Schema.fold + (fun acc nm def _ -> + if not def.hide || bool_of_string (print_hidden ()) then + nm :: acc + else + acc) + [] + schema) + + let default_filename = + BaseEnvLight.default_filename + + let load ?allow_empty ?filename () = + env_from_file := BaseEnvLight.load ?allow_empty ?filename () + + let unload () = + env_from_file := MapString.empty; + Data.clear env + + let dump ?(filename=default_filename) () = + let chn = + open_out_bin filename + in + let output nm value = + Printf.fprintf chn "%s=%S\n" nm value + in + let mp_todo = + (* Dump data from schema *) + Schema.fold + (fun mp_todo nm def _ -> + if def.dump then + begin + try + let value = + Schema.get + schema + env + nm + in + output nm value + with Not_set _ -> + () + end; + MapString.remove nm mp_todo) + !env_from_file + schema + in + (* Dump data defined outside of schema *) + MapString.iter output mp_todo; + + (* End of the dump *) + close_out chn + + let print () = + let printable_vars = + Schema.fold + (fun acc nm def short_descr_opt -> + if not def.hide || bool_of_string (print_hidden ()) then + begin + try + let value = + Schema.get + schema + env + nm + in + let txt = + match short_descr_opt with + | Some s -> s () + | None -> nm + in + (txt, value) :: acc + with Not_set _ -> + acc + end + else + acc) + [] + schema + in + let max_length = + List.fold_left max 0 + (List.rev_map String.length + (List.rev_map fst printable_vars)) + in + let dot_pad str = + String.make ((max_length - (String.length str)) + 3) '.' + in + + Printf.printf "\nConfiguration: \n"; + List.iter + (fun (name,value) -> + Printf.printf "%s: %s %s\n" name (dot_pad name) value) + (List.rev printable_vars); + Printf.printf "\n%!" + + let args () = + let arg_concat = + OASISUtils.varname_concat ~hyphen:'-' + in + [ + "--override", + Arg.Tuple + ( + let rvr = ref "" + in + let rvl = ref "" + in + [ + Arg.Set_string rvr; + Arg.Set_string rvl; + Arg.Unit + (fun () -> + Schema.set + schema + env + ~context:OCommandLine + !rvr + !rvl) + ] + ), + "var+val Override any configuration variable."; + + ] + @ + List.flatten + (Schema.fold + (fun acc name def short_descr_opt -> + let var_set s = + Schema.set + schema + env + ~context:OCommandLine + name + s + in + + let arg_name = + OASISUtils.varname_of_string ~hyphen:'-' name + in + + let hlp = + match short_descr_opt with + | Some txt -> txt () + | None -> "" + in + + let arg_hlp = + match def.arg_help with + | Some s -> s + | None -> "str" + in + + let default_value = + try + Printf.sprintf + (f_ " [%s]") + (Schema.get + schema + env + name) + with Not_set _ -> + "" + in + + let args = + match def.cli with + | CLINone -> + [] + | CLIAuto -> + [ + arg_concat "--" arg_name, + Arg.String var_set, + Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value + ] + | CLIWith -> + [ + arg_concat "--with-" arg_name, + Arg.String var_set, + Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value + ] + | CLIEnable -> + let dflt = + if default_value = " [true]" then + s_ " [default: enabled]" + else + s_ " [default: disabled]" + in + [ + arg_concat "--enable-" arg_name, + Arg.Unit (fun () -> var_set "true"), + Printf.sprintf (f_ " %s%s") hlp dflt; + + arg_concat "--disable-" arg_name, + Arg.Unit (fun () -> var_set "false"), + Printf.sprintf (f_ " %s%s") hlp dflt + ] + | CLIUser lst -> + lst + in + args :: acc) + [] + schema) +end + +module BaseArgExt = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseArgExt.ml" *) + + open OASISUtils + open OASISGettext + + let parse argv args = + (* Simulate command line for Arg *) + let current = + ref 0 + in + + try + Arg.parse_argv + ~current:current + (Array.concat [[|"none"|]; argv]) + (Arg.align args) + (failwithf (f_ "Don't know what to do with arguments: '%s'")) + (s_ "configure options:") + with + | Arg.Help txt -> + print_endline txt; + exit 0 + | Arg.Bad txt -> + prerr_endline txt; + exit 1 +end + +module BaseCheck = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseCheck.ml" *) + + open BaseEnv + open BaseMessage + open OASISUtils + open OASISGettext + + let prog_best prg prg_lst = + var_redefine + prg + (fun () -> + let alternate = + List.fold_left + (fun res e -> + match res with + | Some _ -> + res + | None -> + try + Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) + with Not_found -> + None) + None + prg_lst + in + match alternate with + | Some prg -> prg + | None -> raise Not_found) + + let prog prg = + prog_best prg [prg] + + let prog_opt prg = + prog_best prg [prg^".opt"; prg] + + let ocamlfind = + prog "ocamlfind" + + let version + var_prefix + cmp + fversion + () = + (* Really compare version provided *) + let var = + var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) + in + var_redefine + ~hide:true + var + (fun () -> + let version_str = + match fversion () with + | "[Distributed with OCaml]" -> + begin + try + (var_get "ocaml_version") + with Not_found -> + warning + (f_ "Variable ocaml_version not defined, fallback \ + to default"); + Sys.ocaml_version + end + | res -> + res + in + let version = + OASISVersion.version_of_string version_str + in + if OASISVersion.comparator_apply version cmp then + version_str + else + failwithf + (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") + var_prefix + (OASISVersion.string_of_comparator cmp) + version_str) + () + + let package_version pkg = + OASISExec.run_read_one_line ~ctxt:!BaseContext.default + (ocamlfind ()) + ["query"; "-format"; "%v"; pkg] + + let package ?version_comparator pkg () = + let var = + OASISUtils.varname_concat + "pkg_" + (OASISUtils.varname_of_string pkg) + in + let findlib_dir pkg = + let dir = + OASISExec.run_read_one_line ~ctxt:!BaseContext.default + (ocamlfind ()) + ["query"; "-format"; "%d"; pkg] + in + if Sys.file_exists dir && Sys.is_directory dir then + dir + else + failwithf + (f_ "When looking for findlib package %s, \ + directory %s return doesn't exist") + pkg dir + in + let vl = + var_redefine + var + (fun () -> findlib_dir pkg) + () + in + ( + match version_comparator with + | Some ver_cmp -> + ignore + (version + var + ver_cmp + (fun _ -> package_version pkg) + ()) + | None -> + () + ); + vl +end + +module BaseOCamlcConfig = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" *) + + + open BaseEnv + open OASISUtils + open OASISGettext + + module SMap = Map.Make(String) + + let ocamlc = + BaseCheck.prog_opt "ocamlc" + + let ocamlc_config_map = + (* Map name to value for ocamlc -config output + (name ^": "^value) + *) + let rec split_field mp lst = + match lst with + | line :: tl -> + let mp = + try + let pos_semicolon = + String.index line ':' + in + if pos_semicolon > 1 then + ( + let name = + String.sub line 0 pos_semicolon + in + let linelen = + String.length line + in + let value = + if linelen > pos_semicolon + 2 then + String.sub + line + (pos_semicolon + 2) + (linelen - pos_semicolon - 2) + else + "" + in + SMap.add name value mp + ) + else + ( + mp + ) + with Not_found -> + ( + mp + ) + in + split_field mp tl + | [] -> + mp + in + + let cache = + lazy + (var_protect + (Marshal.to_string + (split_field + SMap.empty + (OASISExec.run_read_output + ~ctxt:!BaseContext.default + (ocamlc ()) ["-config"])) + [])) + in + var_redefine + "ocamlc_config_map" + ~hide:true + ~dump:false + (fun () -> + (* TODO: update if ocamlc change !!! *) + Lazy.force cache) + + let var_define nm = + (* Extract data from ocamlc -config *) + let avlbl_config_get () = + Marshal.from_string + (ocamlc_config_map ()) + 0 + in + let chop_version_suffix s = + try + String.sub s 0 (String.index s '+') + with _ -> + s + in + + let nm_config, value_config = + match nm with + | "ocaml_version" -> + "version", chop_version_suffix + | _ -> nm, (fun x -> x) + in + var_redefine + nm + (fun () -> + try + let map = + avlbl_config_get () + in + let value = + SMap.find nm_config map + in + value_config value + with Not_found -> + failwithf + (f_ "Cannot find field '%s' in '%s -config' output") + nm + (ocamlc ())) + +end + +module BaseStandardVar = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseStandardVar.ml" *) + + + open OASISGettext + open OASISTypes + open OASISExpr + open BaseCheck + open BaseEnv + + let ocamlfind = BaseCheck.ocamlfind + let ocamlc = BaseOCamlcConfig.ocamlc + let ocamlopt = prog_opt "ocamlopt" + let ocamlbuild = prog "ocamlbuild" + + + (**/**) + let rpkg = + ref None + + let pkg_get () = + match !rpkg with + | Some pkg -> pkg + | None -> failwith (s_ "OASIS Package is not set") + + let var_cond = ref [] + + let var_define_cond ~since_version f dflt = + let holder = ref (fun () -> dflt) in + let since_version = + OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) + in + var_cond := + (fun ver -> + if OASISVersion.comparator_apply ver since_version then + holder := f ()) :: !var_cond; + fun () -> !holder () + + (**/**) + + let pkg_name = + var_define + ~short_desc:(fun () -> s_ "Package name") + "pkg_name" + (fun () -> (pkg_get ()).name) + + let pkg_version = + var_define + ~short_desc:(fun () -> s_ "Package version") + "pkg_version" + (fun () -> + (OASISVersion.string_of_version (pkg_get ()).version)) + + let c = BaseOCamlcConfig.var_define + + let os_type = c "os_type" + let system = c "system" + let architecture = c "architecture" + let ccomp_type = c "ccomp_type" + let ocaml_version = c "ocaml_version" + + (* TODO: Check standard variable presence at runtime *) + + let standard_library_default = c "standard_library_default" + let standard_library = c "standard_library" + let standard_runtime = c "standard_runtime" + let bytecomp_c_compiler = c "bytecomp_c_compiler" + let native_c_compiler = c "native_c_compiler" + let model = c "model" + let ext_obj = c "ext_obj" + let ext_asm = c "ext_asm" + let ext_lib = c "ext_lib" + let ext_dll = c "ext_dll" + let default_executable_name = c "default_executable_name" + let systhread_supported = c "systhread_supported" + + let flexlink = + BaseCheck.prog "flexlink" + + let flexdll_version = + var_define + ~short_desc:(fun () -> "FlexDLL version (Win32)") + "flexdll_version" + (fun () -> + let lst = + OASISExec.run_read_output ~ctxt:!BaseContext.default + (flexlink ()) ["-help"] + in + match lst with + | line :: _ -> + Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) + | [] -> + raise Not_found) + + (**/**) + let p name hlp dflt = + var_define + ~short_desc:hlp + ~cli:CLIAuto + ~arg_help:"dir" + name + dflt + + let (/) a b = + if os_type () = Sys.os_type then + Filename.concat a b + else if os_type () = "Unix" then + OASISUnixPath.concat a b + else + OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") + (os_type ()) + (**/**) + + let prefix = + p "prefix" + (fun () -> s_ "Install architecture-independent files dir") + (fun () -> + match os_type () with + | "Win32" -> + let program_files = + Sys.getenv "PROGRAMFILES" + in + program_files/(pkg_name ()) + | _ -> + "/usr/local") + + let exec_prefix = + p "exec_prefix" + (fun () -> s_ "Install architecture-dependent files in dir") + (fun () -> "$prefix") + + let bindir = + p "bindir" + (fun () -> s_ "User executables") + (fun () -> "$exec_prefix"/"bin") + + let sbindir = + p "sbindir" + (fun () -> s_ "System admin executables") + (fun () -> "$exec_prefix"/"sbin") + + let libexecdir = + p "libexecdir" + (fun () -> s_ "Program executables") + (fun () -> "$exec_prefix"/"libexec") + + let sysconfdir = + p "sysconfdir" + (fun () -> s_ "Read-only single-machine data") + (fun () -> "$prefix"/"etc") + + let sharedstatedir = + p "sharedstatedir" + (fun () -> s_ "Modifiable architecture-independent data") + (fun () -> "$prefix"/"com") + + let localstatedir = + p "localstatedir" + (fun () -> s_ "Modifiable single-machine data") + (fun () -> "$prefix"/"var") + + let libdir = + p "libdir" + (fun () -> s_ "Object code libraries") + (fun () -> "$exec_prefix"/"lib") + + let datarootdir = + p "datarootdir" + (fun () -> s_ "Read-only arch-independent data root") + (fun () -> "$prefix"/"share") + + let datadir = + p "datadir" + (fun () -> s_ "Read-only architecture-independent data") + (fun () -> "$datarootdir") + + let infodir = + p "infodir" + (fun () -> s_ "Info documentation") + (fun () -> "$datarootdir"/"info") + + let localedir = + p "localedir" + (fun () -> s_ "Locale-dependent data") + (fun () -> "$datarootdir"/"locale") + + let mandir = + p "mandir" + (fun () -> s_ "Man documentation") + (fun () -> "$datarootdir"/"man") + + let docdir = + p "docdir" + (fun () -> s_ "Documentation root") + (fun () -> "$datarootdir"/"doc"/"$pkg_name") + + let htmldir = + p "htmldir" + (fun () -> s_ "HTML documentation") + (fun () -> "$docdir") + + let dvidir = + p "dvidir" + (fun () -> s_ "DVI documentation") + (fun () -> "$docdir") + + let pdfdir = + p "pdfdir" + (fun () -> s_ "PDF documentation") + (fun () -> "$docdir") + + let psdir = + p "psdir" + (fun () -> s_ "PS documentation") + (fun () -> "$docdir") + + let destdir = + p "destdir" + (fun () -> s_ "Prepend a path when installing package") + (fun () -> + raise + (PropList.Not_set + ("destdir", + Some (s_ "undefined by construct")))) + + let findlib_version = + var_define + "findlib_version" + (fun () -> + BaseCheck.package_version "findlib") + + let is_native = + var_define + "is_native" + (fun () -> + try + let _s : string = + ocamlopt () + in + "true" + with PropList.Not_set _ -> + let _s : string = + ocamlc () + in + "false") + + let ext_program = + var_define + "suffix_program" + (fun () -> + match os_type () with + | "Win32" -> ".exe" + | _ -> "") + + let rm = + var_define + ~short_desc:(fun () -> s_ "Remove a file.") + "rm" + (fun () -> + match os_type () with + | "Win32" -> "del" + | _ -> "rm -f") + + let rmdir = + var_define + ~short_desc:(fun () -> s_ "Remove a directory.") + "rmdir" + (fun () -> + match os_type () with + | "Win32" -> "rd" + | _ -> "rm -rf") + + let debug = + var_define + ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") + ~cli:CLIEnable + "debug" + (fun () -> "true") + + let profile = + var_define + ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") + ~cli:CLIEnable + "profile" + (fun () -> "false") + + let tests = + var_define_cond ~since_version:"0.3" + (fun () -> + var_define + ~short_desc:(fun () -> + s_ "Compile tests executable and library and run them") + ~cli:CLIEnable + "tests" + (fun () -> "false")) + "true" + + let docs = + var_define_cond ~since_version:"0.3" + (fun () -> + var_define + ~short_desc:(fun () -> s_ "Create documentations") + ~cli:CLIEnable + "docs" + (fun () -> "true")) + "true" + + let native_dynlink = + var_define + ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") + ~cli:CLINone + "native_dynlink" + (fun () -> + let res = + let ocaml_lt_312 () = + OASISVersion.comparator_apply + (OASISVersion.version_of_string (ocaml_version ())) + (OASISVersion.VLesser + (OASISVersion.version_of_string "3.12.0")) + in + let flexdll_lt_030 () = + OASISVersion.comparator_apply + (OASISVersion.version_of_string (flexdll_version ())) + (OASISVersion.VLesser + (OASISVersion.version_of_string "0.30")) + in + let has_native_dynlink = + let ocamlfind = ocamlfind () in + try + let fn = + OASISExec.run_read_one_line + ~ctxt:!BaseContext.default + ocamlfind + ["query"; "-predicates"; "native"; "dynlink"; + "-format"; "%d/%a"] + in + Sys.file_exists fn + with _ -> + false + in + if not has_native_dynlink then + false + else if ocaml_lt_312 () then + false + else if (os_type () = "Win32" || os_type () = "Cygwin") + && flexdll_lt_030 () then + begin + BaseMessage.warning + (f_ ".cmxs generation disabled because FlexDLL needs to be \ + at least 0.30. Please upgrade FlexDLL from %s to 0.30.") + (flexdll_version ()); + false + end + else + true + in + string_of_bool res) + + let init pkg = + rpkg := Some pkg; + List.iter (fun f -> f pkg.oasis_version) !var_cond + +end + +module BaseFileAB = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseFileAB.ml" *) + + open BaseEnv + open OASISGettext + open BaseMessage + + let to_filename fn = + let fn = + OASISHostPath.of_unix fn + in + if not (Filename.check_suffix fn ".ab") then + warning + (f_ "File '%s' doesn't have '.ab' extension") + fn; + Filename.chop_extension fn + + let replace fn_lst = + let buff = + Buffer.create 13 + in + List.iter + (fun fn -> + let fn = + OASISHostPath.of_unix fn + in + let chn_in = + open_in fn + in + let chn_out = + open_out (to_filename fn) + in + ( + try + while true do + Buffer.add_string buff (var_expand (input_line chn_in)); + Buffer.add_char buff '\n' + done + with End_of_file -> + () + ); + Buffer.output_buffer chn_out buff; + Buffer.clear buff; + close_in chn_in; + close_out chn_out) + fn_lst +end + +module BaseLog = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseLog.ml" *) + + open OASISUtils + + let default_filename = + Filename.concat + (Filename.dirname BaseEnv.default_filename) + "setup.log" + + module SetTupleString = + Set.Make + (struct + type t = string * string + let compare (s11, s12) (s21, s22) = + match String.compare s11 s21 with + | 0 -> String.compare s12 s22 + | n -> n + end) + + let load () = + if Sys.file_exists default_filename then + begin + let chn = + open_in default_filename + in + let scbuf = + Scanf.Scanning.from_file default_filename + in + let rec read_aux (st, lst) = + if not (Scanf.Scanning.end_of_input scbuf) then + begin + let acc = + try + Scanf.bscanf scbuf "%S %S\n" + (fun e d -> + let t = + e, d + in + if SetTupleString.mem t st then + st, lst + else + SetTupleString.add t st, + t :: lst) + with Scanf.Scan_failure _ -> + failwith + (Scanf.bscanf scbuf + "%l" + (fun line -> + Printf.sprintf + "Malformed log file '%s' at line %d" + default_filename + line)) + in + read_aux acc + end + else + begin + close_in chn; + List.rev lst + end + in + read_aux (SetTupleString.empty, []) + end + else + begin + [] + end + + let register event data = + let chn_out = + open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename + in + Printf.fprintf chn_out "%S %S\n" event data; + close_out chn_out + + let unregister event data = + if Sys.file_exists default_filename then + begin + let lst = + load () + in + let chn_out = + open_out default_filename + in + let write_something = + ref false + in + List.iter + (fun (e, d) -> + if e <> event || d <> data then + begin + write_something := true; + Printf.fprintf chn_out "%S %S\n" e d + end) + lst; + close_out chn_out; + if not !write_something then + Sys.remove default_filename + end + + let filter events = + let st_events = + List.fold_left + (fun st e -> + SetString.add e st) + SetString.empty + events + in + List.filter + (fun (e, _) -> SetString.mem e st_events) + (load ()) + + let exists event data = + List.exists + (fun v -> (event, data) = v) + (load ()) +end + +module BaseBuilt = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseBuilt.ml" *) + + open OASISTypes + open OASISGettext + open BaseStandardVar + open BaseMessage + + type t = + | BExec (* Executable *) + | BExecLib (* Library coming with executable *) + | BLib (* Library *) + | BDoc (* Document *) + + let to_log_event_file t nm = + "built_"^ + (match t with + | BExec -> "exec" + | BExecLib -> "exec_lib" + | BLib -> "lib" + | BDoc -> "doc")^ + "_"^nm + + let to_log_event_done t nm = + "is_"^(to_log_event_file t nm) + + let register t nm lst = + BaseLog.register + (to_log_event_done t nm) + "true"; + List.iter + (fun alt -> + let registered = + List.fold_left + (fun registered fn -> + if OASISFileUtil.file_exists_case fn then + begin + BaseLog.register + (to_log_event_file t nm) + (if Filename.is_relative fn then + Filename.concat (Sys.getcwd ()) fn + else + fn); + true + end + else + registered) + false + alt + in + if not registered then + warning + (f_ "Cannot find an existing alternative files among: %s") + (String.concat (s_ ", ") alt)) + lst + + let unregister t nm = + List.iter + (fun (e, d) -> + BaseLog.unregister e d) + (BaseLog.filter + [to_log_event_file t nm; + to_log_event_done t nm]) + + let fold t nm f acc = + List.fold_left + (fun acc (_, fn) -> + if OASISFileUtil.file_exists_case fn then + begin + f acc fn + end + else + begin + warning + (f_ "File '%s' has been marked as built \ + for %s but doesn't exist") + fn + (Printf.sprintf + (match t with + | BExec | BExecLib -> + (f_ "executable %s") + | BLib -> + (f_ "library %s") + | BDoc -> + (f_ "documentation %s")) + nm); + acc + end) + acc + (BaseLog.filter + [to_log_event_file t nm]) + + let is_built t nm = + List.fold_left + (fun is_built (_, d) -> + (try + bool_of_string d + with _ -> + false)) + false + (BaseLog.filter + [to_log_event_done t nm]) + + let of_executable ffn (cs, bs, exec) = + let unix_exec_is, unix_dll_opt = + OASISExecutable.unix_exec_is + (cs, bs, exec) + (fun () -> + bool_of_string + (is_native ())) + ext_dll + ext_program + in + let evs = + (BExec, cs.cs_name, [[ffn unix_exec_is]]) + :: + (match unix_dll_opt with + | Some fn -> + [BExecLib, cs.cs_name, [[ffn fn]]] + | None -> + []) + in + evs, + unix_exec_is, + unix_dll_opt + + let of_library ffn (cs, bs, lib) = + let unix_lst = + OASISLibrary.generated_unix_files + ~ctxt:!BaseContext.default + ~source_file_exists:(fun fn -> + OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) + ~is_native:(bool_of_string (is_native ())) + ~has_native_dynlink:(bool_of_string (native_dynlink ())) + ~ext_lib:(ext_lib ()) + ~ext_dll:(ext_dll ()) + (cs, bs, lib) + in + let evs = + [BLib, + cs.cs_name, + List.map (List.map ffn) unix_lst] + in + evs, unix_lst + +end + +module BaseCustom = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseCustom.ml" *) + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISGettext + + let run cmd args extra_args = + OASISExec.run ~ctxt:!BaseContext.default ~quote:false + (var_expand cmd) + (List.map + var_expand + (args @ (Array.to_list extra_args))) + + let hook ?(failsafe=false) cstm f e = + let optional_command lst = + let printer = + function + | Some (cmd, args) -> String.concat " " (cmd :: args) + | None -> s_ "No command" + in + match + var_choose + ~name:(s_ "Pre/Post Command") + ~printer + lst with + | Some (cmd, args) -> + begin + try + run cmd args [||] + with e when failsafe -> + warning + (f_ "Command '%s' fail with error: %s") + (String.concat " " (cmd :: args)) + (match e with + | Failure msg -> msg + | e -> Printexc.to_string e) + end + | None -> + () + in + let res = + optional_command cstm.pre_command; + f e + in + optional_command cstm.post_command; + res +end + +module BaseDynVar = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseDynVar.ml" *) + + + open OASISTypes + open OASISGettext + open BaseEnv + open BaseBuilt + + let init pkg = + (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) + (* TODO: provide compile option for library libary_byte_args_VARNAME... *) + List.iter + (function + | Executable (cs, bs, exec) -> + if var_choose bs.bs_build then + var_ignore + (var_redefine + (* We don't save this variable *) + ~dump:false + ~short_desc:(fun () -> + Printf.sprintf + (f_ "Filename of executable '%s'") + cs.cs_name) + (OASISUtils.varname_of_string cs.cs_name) + (fun () -> + let fn_opt = + fold + BExec cs.cs_name + (fun _ fn -> Some fn) + None + in + match fn_opt with + | Some fn -> fn + | None -> + raise + (PropList.Not_set + (cs.cs_name, + Some (Printf.sprintf + (f_ "Executable '%s' not yet built.") + cs.cs_name))))) + + | Library _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> + ()) + pkg.sections +end + +module BaseTest = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseTest.ml" *) + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISExpr + open OASISGettext + + let test lst pkg extra_args = + + let one_test (failure, n) (test_plugin, cs, test) = + if var_choose + ~name:(Printf.sprintf + (f_ "test %s run") + cs.cs_name) + ~printer:string_of_bool + test.test_run then + begin + let () = + info (f_ "Running test '%s'") cs.cs_name + in + let back_cwd = + match test.test_working_directory with + | Some dir -> + let cwd = + Sys.getcwd () + in + let chdir d = + info (f_ "Changing directory to '%s'") d; + Sys.chdir d + in + chdir dir; + fun () -> chdir cwd + + | None -> + fun () -> () + in + try + let failure_percent = + BaseCustom.hook + test.test_custom + (test_plugin pkg (cs, test)) + extra_args + in + back_cwd (); + (failure_percent +. failure, n + 1) + with e -> + begin + back_cwd (); + raise e + end + end + else + begin + info (f_ "Skipping test '%s'") cs.cs_name; + (failure, n) + end + in + let (failed, n) = + List.fold_left + one_test + (0.0, 0) + lst + in + let failure_percent = + if n = 0 then + 0.0 + else + failed /. (float_of_int n) + in + let msg = + Printf.sprintf + (f_ "Tests had a %.2f%% failure rate") + (100. *. failure_percent) + in + if failure_percent > 0.0 then + failwith msg + else + info "%s" msg; + + (* Possible explanation why the tests where not run. *) + if OASISVersion.version_0_3_or_after pkg.oasis_version && + not (bool_of_string (BaseStandardVar.tests ())) && + lst <> [] then + BaseMessage.warning + "Tests are turned off, consider enabling with \ + 'ocaml setup.ml -configure --enable-tests'" +end + +module BaseDoc = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseDoc.ml" *) + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISGettext + + let doc lst pkg extra_args = + + let one_doc (doc_plugin, cs, doc) = + if var_choose + ~name:(Printf.sprintf + (f_ "documentation %s build") + cs.cs_name) + ~printer:string_of_bool + doc.doc_build then + begin + info (f_ "Building documentation '%s'") cs.cs_name; + BaseCustom.hook + doc.doc_custom + (doc_plugin pkg (cs, doc)) + extra_args + end + in + List.iter one_doc lst; + + if OASISVersion.version_0_3_or_after pkg.oasis_version && + not (bool_of_string (BaseStandardVar.docs ())) && + lst <> [] then + BaseMessage.warning + "Docs are turned off, consider enabling with \ + 'ocaml setup.ml -configure --enable-docs'" +end + +module BaseSetup = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseSetup.ml" *) + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISSection + open OASISGettext + open OASISUtils + + type std_args_fun = + package -> string array -> unit + + type ('a, 'b) section_args_fun = + name * (package -> (common_section * 'a) -> string array -> 'b) + + type t = + { + configure: std_args_fun; + build: std_args_fun; + doc: ((doc, unit) section_args_fun) list; + test: ((test, float) section_args_fun) list; + install: std_args_fun; + uninstall: std_args_fun; + clean: std_args_fun list; + clean_doc: (doc, unit) section_args_fun list; + clean_test: (test, unit) section_args_fun list; + distclean: std_args_fun list; + distclean_doc: (doc, unit) section_args_fun list; + distclean_test: (test, unit) section_args_fun list; + package: package; + oasis_fn: string option; + oasis_version: string; + oasis_digest: Digest.t option; + oasis_exec: string option; + oasis_setup_args: string list; + setup_update: bool; + } + + (* Associate a plugin function with data from package *) + let join_plugin_sections filter_map lst = + List.rev + (List.fold_left + (fun acc sct -> + match filter_map sct with + | Some e -> + e :: acc + | None -> + acc) + [] + lst) + + (* Search for plugin data associated with a section name *) + let lookup_plugin_section plugin action nm lst = + try + List.assoc nm lst + with Not_found -> + failwithf + (f_ "Cannot find plugin %s matching section %s for %s action") + plugin + nm + action + + let configure t args = + (* Run configure *) + BaseCustom.hook + t.package.conf_custom + (fun () -> + (* Reload if preconf has changed it *) + begin + try + unload (); + load (); + with _ -> + () + end; + + (* Run plugin's configure *) + t.configure t.package args; + + (* Dump to allow postconf to change it *) + dump ()) + (); + + (* Reload environment *) + unload (); + load (); + + (* Save environment *) + print (); + + (* Replace data in file *) + BaseFileAB.replace t.package.files_ab + + let build t args = + BaseCustom.hook + t.package.build_custom + (t.build t.package) + args + + let doc t args = + BaseDoc.doc + (join_plugin_sections + (function + | Doc (cs, e) -> + Some + (lookup_plugin_section + "documentation" + (s_ "build") + cs.cs_name + t.doc, + cs, + e) + | _ -> + None) + t.package.sections) + t.package + args + + let test t args = + BaseTest.test + (join_plugin_sections + (function + | Test (cs, e) -> + Some + (lookup_plugin_section + "test" + (s_ "run") + cs.cs_name + t.test, + cs, + e) + | _ -> + None) + t.package.sections) + t.package + args + + let all t args = + let rno_doc = + ref false + in + let rno_test = + ref false + in + Arg.parse_argv + ~current:(ref 0) + (Array.of_list + ((Sys.executable_name^" all") :: + (Array.to_list args))) + [ + "-no-doc", + Arg.Set rno_doc, + s_ "Don't run doc target"; + + "-no-test", + Arg.Set rno_test, + s_ "Don't run test target"; + ] + (failwithf (f_ "Don't know what to do with '%s'")) + ""; + + info "Running configure step"; + configure t [||]; + + info "Running build step"; + build t [||]; + + (* Load setup.log dynamic variables *) + BaseDynVar.init t.package; + + if not !rno_doc then + begin + info "Running doc step"; + doc t [||]; + end + else + begin + info "Skipping doc step" + end; + + if not !rno_test then + begin + info "Running test step"; + test t [||] + end + else + begin + info "Skipping test step" + end + + let install t args = + BaseCustom.hook + t.package.install_custom + (t.install t.package) + args + + let uninstall t args = + BaseCustom.hook + t.package.uninstall_custom + (t.uninstall t.package) + args + + let reinstall t args = + uninstall t args; + install t args + + let clean, distclean = + let failsafe f a = + try + f a + with e -> + warning + (f_ "Action fail with error: %s") + (match e with + | Failure msg -> msg + | e -> Printexc.to_string e) + in + + let generic_clean t cstm mains docs tests args = + BaseCustom.hook + ~failsafe:true + cstm + (fun () -> + (* Clean section *) + List.iter + (function + | Test (cs, test) -> + let f = + try + List.assoc cs.cs_name tests + with Not_found -> + fun _ _ _ -> () + in + failsafe + (f t.package (cs, test)) + args + | Doc (cs, doc) -> + let f = + try + List.assoc cs.cs_name docs + with Not_found -> + fun _ _ _ -> () + in + failsafe + (f t.package (cs, doc)) + args + | Library _ + | Executable _ + | Flag _ + | SrcRepo _ -> + ()) + t.package.sections; + (* Clean whole package *) + List.iter + (fun f -> + failsafe + (f t.package) + args) + mains) + () + in + + let clean t args = + generic_clean + t + t.package.clean_custom + t.clean + t.clean_doc + t.clean_test + args + in + + let distclean t args = + (* Call clean *) + clean t args; + + (* Call distclean code *) + generic_clean + t + t.package.distclean_custom + t.distclean + t.distclean_doc + t.distclean_test + args; + + (* Remove generated file *) + List.iter + (fun fn -> + if Sys.file_exists fn then + begin + info (f_ "Remove '%s'") fn; + Sys.remove fn + end) + (BaseEnv.default_filename + :: + BaseLog.default_filename + :: + (List.rev_map BaseFileAB.to_filename t.package.files_ab)) + in + + clean, distclean + + let version t _ = + print_endline t.oasis_version + + let update_setup_ml, no_update_setup_ml_cli = + let b = ref true in + b, + ("-no-update-setup-ml", + Arg.Clear b, + s_ " Don't try to update setup.ml, even if _oasis has changed.") + + let update_setup_ml t = + let oasis_fn = + match t.oasis_fn with + | Some fn -> fn + | None -> "_oasis" + in + let oasis_exec = + match t.oasis_exec with + | Some fn -> fn + | None -> "oasis" + in + let ocaml = + Sys.executable_name + in + let setup_ml, args = + match Array.to_list Sys.argv with + | setup_ml :: args -> + setup_ml, args + | [] -> + failwith + (s_ "Expecting non-empty command line arguments.") + in + let ocaml, setup_ml = + if Sys.executable_name = Sys.argv.(0) then + (* We are not running in standard mode, probably the script + * is precompiled. + *) + "ocaml", "setup.ml" + else + ocaml, setup_ml + in + let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in + let do_update () = + let oasis_exec_version = + OASISExec.run_read_one_line + ~ctxt:!BaseContext.default + ~f_exit_code: + (function + | 0 -> + () + | 1 -> + failwithf + (f_ "Executable '%s' is probably an old version \ + of oasis (< 0.3.0), please update to version \ + v%s.") + oasis_exec t.oasis_version + | 127 -> + failwithf + (f_ "Cannot find executable '%s', please install \ + oasis v%s.") + oasis_exec t.oasis_version + | n -> + failwithf + (f_ "Command '%s version' exited with code %d.") + oasis_exec n) + oasis_exec ["version"] + in + if OASISVersion.comparator_apply + (OASISVersion.version_of_string oasis_exec_version) + (OASISVersion.VGreaterEqual + (OASISVersion.version_of_string t.oasis_version)) then + begin + (* We have a version >= for the executable oasis, proceed with + * update. + *) + (* TODO: delegate this check to 'oasis setup'. *) + if Sys.os_type = "Win32" then + failwithf + (f_ "It is not possible to update the running script \ + setup.ml on Windows. Please update setup.ml by \ + running '%s'.") + (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) + else + begin + OASISExec.run + ~ctxt:!BaseContext.default + ~f_exit_code: + (function + | 0 -> + () + | n -> + failwithf + (f_ "Unable to update setup.ml using '%s', \ + please fix the problem and retry.") + oasis_exec) + oasis_exec ("setup" :: t.oasis_setup_args); + OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) + end + end + else + failwithf + (f_ "The version of '%s' (v%s) doesn't match the version of \ + oasis used to generate the %s file. Please install at \ + least oasis v%s.") + oasis_exec oasis_exec_version setup_ml t.oasis_version + in + + if !update_setup_ml then + begin + try + match t.oasis_digest with + | Some dgst -> + if Sys.file_exists oasis_fn && dgst <> Digest.file "_oasis" then + begin + do_update (); + true + end + else + false + | None -> + false + with e -> + error + (f_ "Error when updating setup.ml. If you want to avoid this error, \ + you can bypass the update of %s by running '%s %s %s %s'") + setup_ml ocaml setup_ml no_update_setup_ml_cli + (String.concat " " args); + raise e + end + else + false + + let setup t = + let catch_exn = + ref true + in + try + let act_ref = + ref (fun _ -> + failwithf + (f_ "No action defined, run '%s %s -help'") + Sys.executable_name + Sys.argv.(0)) + + in + let extra_args_ref = + ref [] + in + let allow_empty_env_ref = + ref false + in + let arg_handle ?(allow_empty_env=false) act = + Arg.Tuple + [ + Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); + + Arg.Unit + (fun () -> + allow_empty_env_ref := allow_empty_env; + act_ref := act); + ] + in + + Arg.parse + (Arg.align + ([ + "-configure", + arg_handle ~allow_empty_env:true configure, + s_ "[options*] Configure the whole build process."; + + "-build", + arg_handle build, + s_ "[options*] Build executables and libraries."; + + "-doc", + arg_handle doc, + s_ "[options*] Build documents."; + + "-test", + arg_handle test, + s_ "[options*] Run tests."; + + "-all", + arg_handle ~allow_empty_env:true all, + s_ "[options*] Run configure, build, doc and test targets."; + + "-install", + arg_handle install, + s_ "[options*] Install libraries, data, executables \ + and documents."; + + "-uninstall", + arg_handle uninstall, + s_ "[options*] Uninstall libraries, data, executables \ + and documents."; + + "-reinstall", + arg_handle reinstall, + s_ "[options*] Uninstall and install libraries, data, \ + executables and documents."; + + "-clean", + arg_handle ~allow_empty_env:true clean, + s_ "[options*] Clean files generated by a build."; + + "-distclean", + arg_handle ~allow_empty_env:true distclean, + s_ "[options*] Clean files generated by a build and configure."; + + "-version", + arg_handle ~allow_empty_env:true version, + s_ " Display version of OASIS used to generate this setup.ml."; + + "-no-catch-exn", + Arg.Clear catch_exn, + s_ " Don't catch exception, useful for debugging."; + ] + @ + (if t.setup_update then + [no_update_setup_ml_cli] + else + []) + @ (BaseContext.args ()))) + (failwithf (f_ "Don't know what to do with '%s'")) + (s_ "Setup and run build process current package\n"); + + (* Build initial environment *) + load ~allow_empty:!allow_empty_env_ref (); + + (** Initialize flags *) + List.iter + (function + | Flag (cs, {flag_description = hlp; + flag_default = choices}) -> + begin + let apply ?short_desc () = + var_ignore + (var_define + ~cli:CLIEnable + ?short_desc + (OASISUtils.varname_of_string cs.cs_name) + (fun () -> + string_of_bool + (var_choose + ~name:(Printf.sprintf + (f_ "default value of flag %s") + cs.cs_name) + ~printer:string_of_bool + choices))) + in + match hlp with + | Some hlp -> + apply ~short_desc:(fun () -> hlp) () + | None -> + apply () + end + | _ -> + ()) + t.package.sections; + + BaseStandardVar.init t.package; + + BaseDynVar.init t.package; + + if t.setup_update && update_setup_ml t then + () + else + !act_ref t (Array.of_list (List.rev !extra_args_ref)) + + with e when !catch_exn -> + error "%s" (Printexc.to_string e); + exit 1 + +end + + +# 4480 "setup.ml" +module InternalConfigurePlugin = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" *) + + (** Configure using internal scheme + @author Sylvain Le Gall + *) + + open BaseEnv + open OASISTypes + open OASISUtils + open OASISGettext + open BaseMessage + + (** Configure build using provided series of check to be done + * and then output corresponding file. + *) + let configure pkg argv = + let var_ignore_eval var = + let _s : string = + var () + in + () + in + + let errors = + ref SetString.empty + in + + let buff = + Buffer.create 13 + in + + let add_errors fmt = + Printf.kbprintf + (fun b -> + errors := SetString.add (Buffer.contents b) !errors; + Buffer.clear b) + buff + fmt + in + + let warn_exception e = + warning "%s" (Printexc.to_string e) + in + + (* Check tools *) + let check_tools lst = + List.iter + (function + | ExternalTool tool -> + begin + try + var_ignore_eval (BaseCheck.prog tool) + with e -> + warn_exception e; + add_errors (f_ "Cannot find external tool '%s'") tool + end + | InternalExecutable nm1 -> + (* Check that matching tool is built *) + List.iter + (function + | Executable ({cs_name = nm2}, + {bs_build = build}, + _) when nm1 = nm2 -> + if not (var_choose build) then + add_errors + (f_ "Cannot find buildable internal executable \ + '%s' when checking build depends") + nm1 + | _ -> + ()) + pkg.sections) + lst + in + + let build_checks sct bs = + if var_choose bs.bs_build then + begin + if bs.bs_compiled_object = Native then + begin + try + var_ignore_eval BaseStandardVar.ocamlopt + with e -> + warn_exception e; + add_errors + (f_ "Section %s requires native compilation") + (OASISSection.string_of_section sct) + end; + + (* Check tools *) + check_tools bs.bs_build_tools; + + (* Check depends *) + List.iter + (function + | FindlibPackage (findlib_pkg, version_comparator) -> + begin + try + var_ignore_eval + (BaseCheck.package ?version_comparator findlib_pkg) + with e -> + warn_exception e; + match version_comparator with + | None -> + add_errors + (f_ "Cannot find findlib package %s") + findlib_pkg + | Some ver_cmp -> + add_errors + (f_ "Cannot find findlib package %s (%s)") + findlib_pkg + (OASISVersion.string_of_comparator ver_cmp) + end + | InternalLibrary nm1 -> + (* Check that matching library is built *) + List.iter + (function + | Library ({cs_name = nm2}, + {bs_build = build}, + _) when nm1 = nm2 -> + if not (var_choose build) then + add_errors + (f_ "Cannot find buildable internal library \ + '%s' when checking build depends") + nm1 + | _ -> + ()) + pkg.sections) + bs.bs_build_depends + end + in + + (* Parse command line *) + BaseArgExt.parse argv (BaseEnv.args ()); + + (* OCaml version *) + begin + match pkg.ocaml_version with + | Some ver_cmp -> + begin + try + var_ignore_eval + (BaseCheck.version + "ocaml" + ver_cmp + BaseStandardVar.ocaml_version) + with e -> + warn_exception e; + add_errors + (f_ "OCaml version %s doesn't match version constraint %s") + (BaseStandardVar.ocaml_version ()) + (OASISVersion.string_of_comparator ver_cmp) + end + | None -> + () + end; + + (* Findlib version *) + begin + match pkg.findlib_version with + | Some ver_cmp -> + begin + try + var_ignore_eval + (BaseCheck.version + "findlib" + ver_cmp + BaseStandardVar.findlib_version) + with e -> + warn_exception e; + add_errors + (f_ "Findlib version %s doesn't match version constraint %s") + (BaseStandardVar.findlib_version ()) + (OASISVersion.string_of_comparator ver_cmp) + end + | None -> + () + end; + + (* FlexDLL *) + if BaseStandardVar.os_type () = "Win32" || + BaseStandardVar.os_type () = "Cygwin" then + begin + try + var_ignore_eval BaseStandardVar.flexlink + with e -> + warn_exception e; + add_errors (f_ "Cannot find 'flexlink'") + end; + + (* Check build depends *) + List.iter + (function + | Executable (_, bs, _) + | Library (_, bs, _) as sct -> + build_checks sct bs + | Doc (_, doc) -> + if var_choose doc.doc_build then + check_tools doc.doc_build_tools + | Test (_, test) -> + if var_choose test.test_run then + check_tools test.test_tools + | _ -> + ()) + pkg.sections; + + (* Check if we need native dynlink (presence of libraries that compile to + * native) + *) + begin + let has_cmxa = + List.exists + (function + | Library (_, bs, _) -> + var_choose bs.bs_build && + (bs.bs_compiled_object = Native || + (bs.bs_compiled_object = Best && + bool_of_string (BaseStandardVar.is_native ()))) + | _ -> + false) + pkg.sections + in + if has_cmxa then + var_ignore_eval BaseStandardVar.native_dynlink + end; + + (* Check errors *) + if SetString.empty != !errors then + begin + List.iter + (fun e -> error "%s" e) + (SetString.elements !errors); + failwithf + (fn_ + "%d configuration error" + "%d configuration errors" + (SetString.cardinal !errors)) + (SetString.cardinal !errors) + end + +end + +module InternalInstallPlugin = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" *) + + (** Install using internal scheme + @author Sylvain Le Gall + *) + + open BaseEnv + open BaseStandardVar + open BaseMessage + open OASISTypes + open OASISLibrary + open OASISGettext + open OASISUtils + + let exec_hook = + ref (fun (cs, bs, exec) -> cs, bs, exec) + + let lib_hook = + ref (fun (cs, bs, lib) -> cs, bs, lib, []) + + let doc_hook = + ref (fun (cs, doc) -> cs, doc) + + let install_file_ev = + "install-file" + + let install_dir_ev = + "install-dir" + + let install_findlib_ev = + "install-findlib" + + let win32_max_command_line_length = 8000 + + let split_install_command ocamlfind findlib_name meta files = + if Sys.os_type = "Win32" then + (* Arguments for the first command: *) + let first_args = ["install"; findlib_name; meta] in + (* Arguments for remaining commands: *) + let other_args = ["install"; findlib_name; "-add"] in + (* Extract as much files as possible from [files], [len] is + the current command line length: *) + let rec get_files len acc files = + match files with + | [] -> + (List.rev acc, []) + | file :: rest -> + let len = len + 1 + String.length file in + if len > win32_max_command_line_length then + (List.rev acc, files) + else + get_files len (file :: acc) rest + in + (* Split the command into several commands. *) + let rec split args files = + match files with + | [] -> + [] + | _ -> + (* Length of "ocamlfind install [META|-add]" *) + let len = + List.fold_left + (fun len arg -> + len + 1 (* for the space *) + String.length arg) + (String.length ocamlfind) + args + in + match get_files len [] files with + | ([], _) -> + failwith (s_ "Command line too long.") + | (firsts, others) -> + let cmd = args @ firsts in + (* Use -add for remaining commands: *) + let () = + let findlib_ge_132 = + OASISVersion.comparator_apply + (OASISVersion.version_of_string + (BaseStandardVar.findlib_version ())) + (OASISVersion.VGreaterEqual + (OASISVersion.version_of_string "1.3.2")) + in + if not findlib_ge_132 then + failwithf + (f_ "Installing the library %s require to use the flag \ + '-add' of ocamlfind because the command line is too \ + long. This flag is only available for findlib 1.3.2. \ + Please upgrade findlib from %s to 1.3.2") + findlib_name (BaseStandardVar.findlib_version ()) + in + let cmds = split other_args others in + cmd :: cmds + in + (* The first command does not use -add: *) + split first_args files + else + ["install" :: findlib_name :: meta :: files] + + let install pkg argv = + + let in_destdir = + try + let destdir = + destdir () + in + (* Practically speaking destdir is prepended + * at the beginning of the target filename + *) + fun fn -> destdir^fn + with PropList.Not_set _ -> + fun fn -> fn + in + + let install_file ?tgt_fn src_file envdir = + let tgt_dir = + in_destdir (envdir ()) + in + let tgt_file = + Filename.concat + tgt_dir + (match tgt_fn with + | Some fn -> + fn + | None -> + Filename.basename src_file) + in + (* Create target directory if needed *) + OASISFileUtil.mkdir_parent + ~ctxt:!BaseContext.default + (fun dn -> + info (f_ "Creating directory '%s'") dn; + BaseLog.register install_dir_ev dn) + tgt_dir; + + (* Really install files *) + info (f_ "Copying file '%s' to '%s'") src_file tgt_file; + OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; + BaseLog.register install_file_ev tgt_file + in + + (* Install data into defined directory *) + let install_data srcdir lst tgtdir = + let tgtdir = + OASISHostPath.of_unix (var_expand tgtdir) + in + List.iter + (fun (src, tgt_opt) -> + let real_srcs = + OASISFileUtil.glob + ~ctxt:!BaseContext.default + (Filename.concat srcdir src) + in + if real_srcs = [] then + failwithf + (f_ "Wildcard '%s' doesn't match any files") + src; + List.iter + (fun fn -> + install_file + fn + (fun () -> + match tgt_opt with + | Some s -> + OASISHostPath.of_unix (var_expand s) + | None -> + tgtdir)) + real_srcs) + lst + in + + (** Install all libraries *) + let install_libs pkg = + + let files_of_library (f_data, acc) data_lib = + let cs, bs, lib, lib_extra = + !lib_hook data_lib + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then + begin + let acc = + (* Start with acc + lib_extra *) + List.rev_append lib_extra acc + in + let acc = + (* Add uncompiled header from the source tree *) + let path = + OASISHostPath.of_unix bs.bs_path + in + List.fold_left + (fun acc modul -> + try + List.find + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + [modul^".mli"; + modul^".ml"; + String.uncapitalize modul^".mli"; + String.capitalize modul^".mli"; + String.uncapitalize modul^".ml"; + String.capitalize modul^".ml"]) + :: acc + with Not_found -> + begin + warning + (f_ "Cannot find source header for module %s \ + in library %s") + modul cs.cs_name; + acc + end) + acc + lib.lib_modules + in + + let acc = + (* Get generated files *) + BaseBuilt.fold + BaseBuilt.BLib + cs.cs_name + (fun acc fn -> fn :: acc) + acc + in + + let f_data () = + (* Install data associated with the library *) + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name); + f_data () + in + + (f_data, acc) + end + else + begin + (f_data, acc) + end + in + + (* Install one group of library *) + let install_group_lib grp = + (* Iterate through all group nodes *) + let rec install_group_lib_aux data_and_files grp = + let data_and_files, children = + match grp with + | Container (_, children) -> + data_and_files, children + | Package (_, cs, bs, lib, children) -> + files_of_library data_and_files (cs, bs, lib), children + in + List.fold_left + install_group_lib_aux + data_and_files + children + in + + (* Findlib name of the root library *) + let findlib_name = + findlib_of_group grp + in + + (* Determine root library *) + let root_lib = + root_of_group grp + in + + (* All files to install for this library *) + let f_data, files = + install_group_lib_aux (ignore, []) grp + in + + (* Really install, if there is something to install *) + if files = [] then + begin + warning + (f_ "Nothing to install for findlib library '%s'") + findlib_name + end + else + begin + let meta = + (* Search META file *) + let (_, bs, _) = + root_lib + in + let res = + Filename.concat bs.bs_path "META" + in + if not (OASISFileUtil.file_exists_case res) then + failwithf + (f_ "Cannot find file '%s' for findlib library %s") + res + findlib_name; + res + in + let files = + (* Make filename shorter to avoid hitting command max line length + * too early, esp. on Windows. + *) + let remove_prefix p n = + let plen = String.length p in + let nlen = String.length n in + if plen <= nlen && String.sub n 0 plen = p then + begin + let fn_sep = + if Sys.os_type = "Win32" then + '\\' + else + '/' + in + let cutpoint = plen + + (if plen < nlen && n.[plen] = fn_sep then + 1 + else + 0) + in + String.sub n cutpoint (nlen - cutpoint) + end + else + n + in + List.map (remove_prefix (Sys.getcwd ())) files + in + info + (f_ "Installing findlib library '%s'") + findlib_name; + let ocamlfind = ocamlfind () in + let commands = + split_install_command + ocamlfind + findlib_name + meta + files + in + List.iter + (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) + commands; + BaseLog.register install_findlib_ev findlib_name + end; + + (* Install data files *) + f_data (); + + in + + let group_libs, _, _ = + findlib_mapping pkg + in + + (* We install libraries in groups *) + List.iter install_group_lib group_libs + in + + let install_execs pkg = + let install_exec data_exec = + let (cs, bs, exec) = + !exec_hook data_exec + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then + begin + let exec_libdir () = + Filename.concat + (libdir ()) + pkg.name + in + BaseBuilt.fold + BaseBuilt.BExec + cs.cs_name + (fun () fn -> + install_file + ~tgt_fn:(cs.cs_name ^ ext_program ()) + fn + bindir) + (); + BaseBuilt.fold + BaseBuilt.BExecLib + cs.cs_name + (fun () fn -> + install_file + fn + exec_libdir) + (); + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name) + end + in + List.iter + (function + | Executable (cs, bs, exec)-> + install_exec (cs, bs, exec) + | _ -> + ()) + pkg.sections + in + + let install_docs pkg = + let install_doc data = + let (cs, doc) = + !doc_hook data + in + if var_choose doc.doc_install && + BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then + begin + let tgt_dir = + OASISHostPath.of_unix (var_expand doc.doc_install_dir) + in + BaseBuilt.fold + BaseBuilt.BDoc + cs.cs_name + (fun () fn -> + install_file + fn + (fun () -> tgt_dir)) + (); + install_data + Filename.current_dir_name + doc.doc_data_files + doc.doc_install_dir + end + in + List.iter + (function + | Doc (cs, doc) -> + install_doc (cs, doc) + | _ -> + ()) + pkg.sections + in + + install_libs pkg; + install_execs pkg; + install_docs pkg + + (* Uninstall already installed data *) + let uninstall _ argv = + List.iter + (fun (ev, data) -> + if ev = install_file_ev then + begin + if OASISFileUtil.file_exists_case data then + begin + info + (f_ "Removing file '%s'") + data; + Sys.remove data + end + else + begin + warning + (f_ "File '%s' doesn't exist anymore") + data + end + end + else if ev = install_dir_ev then + begin + if Sys.file_exists data && Sys.is_directory data then + begin + if Sys.readdir data = [||] then + begin + info + (f_ "Removing directory '%s'") + data; + OASISFileUtil.rmdir ~ctxt:!BaseContext.default data + end + else + begin + warning + (f_ "Directory '%s' is not empty (%s)") + data + (String.concat + ", " + (Array.to_list + (Sys.readdir data))) + end + end + else + begin + warning + (f_ "Directory '%s' doesn't exist anymore") + data + end + end + else if ev = install_findlib_ev then + begin + info (f_ "Removing findlib library '%s'") data; + OASISExec.run ~ctxt:!BaseContext.default + (ocamlfind ()) ["remove"; data] + end + else + failwithf (f_ "Unknown log event '%s'") ev; + BaseLog.unregister ev data) + (* We process event in reverse order *) + (List.rev + (BaseLog.filter + [install_file_ev; + install_dir_ev; + install_findlib_ev;])) + +end + + +# 5233 "setup.ml" +module OCamlbuildCommon = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) + + (** Functions common to OCamlbuild build and doc plugin + *) + + open OASISGettext + open BaseEnv + open BaseStandardVar + + let ocamlbuild_clean_ev = + "ocamlbuild-clean" + + let ocamlbuildflags = + var_define + ~short_desc:(fun () -> "OCamlbuild additional flags") + "ocamlbuildflags" + (fun () -> "") + + (** Fix special arguments depending on environment *) + let fix_args args extra_argv = + List.flatten + [ + if (os_type ()) = "Win32" then + [ + "-classic-display"; + "-no-log"; + "-no-links"; + "-install-lib-dir"; + (Filename.concat (standard_library ()) "ocamlbuild") + ] + else + []; + + if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then + [ + "-byte-plugin" + ] + else + []; + args; + + if bool_of_string (debug ()) then + ["-tag"; "debug"] + else + []; + + if bool_of_string (profile ()) then + ["-tag"; "profile"] + else + []; + + OASISString.nsplit (ocamlbuildflags ()) ' '; + + Array.to_list extra_argv; + ] + + (** Run 'ocamlbuild -clean' if not already done *) + let run_clean extra_argv = + let extra_cli = + String.concat " " (Array.to_list extra_argv) + in + (* Run if never called with these args *) + if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then + begin + OASISExec.run ~ctxt:!BaseContext.default + (ocamlbuild ()) (fix_args ["-clean"] extra_argv); + BaseLog.register ocamlbuild_clean_ev extra_cli; + at_exit + (fun () -> + try + BaseLog.unregister ocamlbuild_clean_ev extra_cli + with _ -> + ()) + end + + (** Run ocamlbuild, unregister all clean events *) + let run_ocamlbuild args extra_argv = + (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html + *) + OASISExec.run ~ctxt:!BaseContext.default + (ocamlbuild ()) (fix_args args extra_argv); + (* Remove any clean event, we must run it again *) + List.iter + (fun (e, d) -> BaseLog.unregister e d) + (BaseLog.filter [ocamlbuild_clean_ev]) + + (** Determine real build directory *) + let build_dir extra_argv = + let rec search_args dir = + function + | "-build-dir" :: dir :: tl -> + search_args dir tl + | _ :: tl -> + search_args dir tl + | [] -> + dir + in + search_args "_build" (fix_args [] extra_argv) + +end + +module OCamlbuildPlugin = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) + + (** Build using ocamlbuild + @author Sylvain Le Gall + *) + + open OASISTypes + open OASISGettext + open OASISUtils + open BaseEnv + open OCamlbuildCommon + open BaseStandardVar + open BaseMessage + + let cond_targets_hook = + ref (fun lst -> lst) + + let build pkg argv = + + (* Return the filename in build directory *) + let in_build_dir fn = + Filename.concat + (build_dir argv) + fn + in + + (* Return the unix filename in host build directory *) + let in_build_dir_of_unix fn = + in_build_dir (OASISHostPath.of_unix fn) + in + + let cond_targets = + List.fold_left + (fun acc -> + function + | Library (cs, bs, lib) when var_choose bs.bs_build -> + begin + let evs, unix_files = + BaseBuilt.of_library + in_build_dir_of_unix + (cs, bs, lib) + in + + let ends_with nd fn = + let nd_len = + String.length nd + in + (String.length fn >= nd_len) + && + (String.sub + fn + (String.length fn - nd_len) + nd_len) = nd + in + + let tgts = + List.flatten + (List.filter + (fun l -> l <> []) + (List.map + (List.filter + (fun fn -> + ends_with ".cma" fn + || ends_with ".cmxs" fn + || ends_with ".cmxa" fn + || ends_with (ext_lib ()) fn + || ends_with (ext_dll ()) fn)) + unix_files)) + in + + match tgts with + | _ :: _ -> + (evs, tgts) :: acc + | [] -> + failwithf + (f_ "No possible ocamlbuild targets for library %s") + cs.cs_name + end + + | Executable (cs, bs, exec) when var_choose bs.bs_build -> + begin + let evs, unix_exec_is, unix_dll_opt = + BaseBuilt.of_executable + in_build_dir_of_unix + (cs, bs, exec) + in + + let target ext = + let unix_tgt = + (OASISUnixPath.concat + bs.bs_path + (OASISUnixPath.chop_extension + exec.exec_main_is))^ext + in + let evs = + (* Fix evs, we want to use the unix_tgt, without copying *) + List.map + (function + | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> + BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]] + | ev -> + ev) + evs + in + evs, [unix_tgt] + in + + (* Add executable *) + let acc = + match bs.bs_compiled_object with + | Native -> + (target ".native") :: acc + | Best when bool_of_string (is_native ()) -> + (target ".native") :: acc + | Byte + | Best -> + (target ".byte") :: acc + in + acc + end + + | Library _ | Executable _ | Test _ + | SrcRepo _ | Flag _ | Doc _ -> + acc) + [] + (* Keep the pkg.sections ordered *) + (List.rev pkg.sections); + in + + (* Check and register built files *) + let check_and_register (bt, bnm, lst) = + List.iter + (fun fns -> + if not (List.exists OASISFileUtil.file_exists_case fns) then + failwithf + (f_ "No one of expected built files %s exists") + (String.concat (s_ ", ") (List.map (Printf.sprintf "'%s'") fns))) + lst; + (BaseBuilt.register bt bnm lst) + in + + let cond_targets = + (* Run the hook *) + !cond_targets_hook cond_targets + in + + (* Run a list of target... *) + run_ocamlbuild + (List.flatten + (List.map snd cond_targets)) + argv; + (* ... and register events *) + List.iter + check_and_register + (List.flatten (List.map fst cond_targets)) + + + let clean pkg extra_args = + run_clean extra_args; + List.iter + (function + | Library (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BLib cs.cs_name + | Executable (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; + BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name + | _ -> + ()) + pkg.sections + +end + +module OCamlbuildDocPlugin = struct +(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) + + (* Create documentation using ocamlbuild .odocl files + @author Sylvain Le Gall + *) + + open OASISTypes + open OASISGettext + open OASISMessage + open OCamlbuildCommon + open BaseStandardVar + + + + let doc_build path pkg (cs, doc) argv = + let index_html = + OASISUnixPath.make + [ + path; + cs.cs_name^".docdir"; + "index.html"; + ] + in + let tgt_dir = + OASISHostPath.make + [ + build_dir argv; + OASISHostPath.of_unix path; + cs.cs_name^".docdir"; + ] + in + run_ocamlbuild [index_html] argv; + List.iter + (fun glb -> + BaseBuilt.register + BaseBuilt.BDoc + cs.cs_name + [OASISFileUtil.glob ~ctxt:!BaseContext.default + (Filename.concat tgt_dir glb)]) + ["*.html"; "*.css"] + + let doc_clean t pkg (cs, doc) argv = + run_clean argv; + BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name + +end + + +# 5558 "setup.ml" +open OASISTypes;; + +let setup_t = + { + BaseSetup.configure = InternalConfigurePlugin.configure; + build = OCamlbuildPlugin.build; + test = []; + doc = []; + install = InternalInstallPlugin.install; + uninstall = InternalInstallPlugin.uninstall; + clean = [OCamlbuildPlugin.clean]; + clean_test = []; + clean_doc = []; + distclean = []; + distclean_test = []; + distclean_doc = []; + package = + { + oasis_version = "0.3"; + ocaml_version = None; + findlib_version = None; + name = "stdext"; + version = "0.1"; + license = + OASISLicense.DEP5License + (OASISLicense.DEP5Unit + { + OASISLicense.license = "LGPL"; + excption = Some "OCaml linking"; + version = OASISLicense.Version "2.1"; + }); + license_file = None; + copyrights = ["(C) 2012 Citrix"]; + maintainers = []; + authors = ["various"]; + homepage = None; + synopsis = "Standard extension library"; + description = None; + categories = []; + conf_type = (`Configure, "internal", Some "0.3"); + conf_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + build_type = (`Build, "ocamlbuild", Some "0.3"); + build_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + install_type = (`Install, "internal", Some "0.3"); + install_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + uninstall_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + clean_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + distclean_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + files_ab = []; + sections = + [ + Library + ({ + cs_name = "stdext"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "lib"; + bs_compiled_object = Best; + bs_build_depends = + [ + FindlibPackage ("threads", None); + FindlibPackage ("uuidm", None); + FindlibPackage ("forkexec", None); + FindlibPackage ("unix", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = + [ + "unixext_open_stubs.c"; + "unixext_stubs.c"; + "unixext_write_stubs.c"; + "zerocheck_stub.c" + ]; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = + [ + "Arrayext"; + "Backtrace"; + "Base64"; + "Bigbuffer"; + "Config"; + "Date"; + "Either"; + "Encodings"; + "ExtentlistSet"; + "Filenameext"; + "Fring"; + "Fun"; + "Gzip"; + "Hashtblext"; + "Int64ext"; + "LazyList"; + "Listext"; + "Mapext"; + "Monad"; + "Opt"; + "Pervasiveext"; + "Qring"; + "Range"; + "Ring"; + "Sha1sum"; + "Stringext"; + "Tar"; + "Threadext"; + "Trie"; + "Unixext"; + "VIO"; + "Zerocheck" + ]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = None; + lib_findlib_name = None; + lib_findlib_containers = []; + }) + ]; + plugins = + [(`Extra, "DevFiles", Some "0.3"); (`Extra, "META", Some "0.3")]; + schema_data = PropList.Data.create (); + plugin_data = []; + }; + oasis_fn = Some "_oasis"; + oasis_version = "0.3.0"; + oasis_digest = Some "\003'G\nm\2403\173L\190\134\155:q\1356"; + oasis_exec = None; + oasis_setup_args = []; + setup_update = false; + };; + +let setup () = BaseSetup.setup setup_t;; + +# 5727 "setup.ml" +(* OASIS_STOP *) +let () = setup ();; From bd79e3896fe7106800355ecc6324f4c442cd0673 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sat, 12 Jan 2013 11:02:54 +0000 Subject: [PATCH 002/199] Remove gzip and sha1sum: these depend on fork/exec, which makes it difficult for fork/exec to use stdext itself --- _oasis | 4 +-- lib/gzip.ml | 97 -------------------------------------------------- lib/sha1sum.ml | 64 --------------------------------- 3 files changed, 2 insertions(+), 163 deletions(-) delete mode 100644 lib/gzip.ml delete mode 100644 lib/sha1sum.ml diff --git a/_oasis b/_oasis index f9ea5b8038a..2c6795554ef 100644 --- a/_oasis +++ b/_oasis @@ -10,8 +10,8 @@ Plugins: DevFiles (0.3), META (0.3) Library stdext Path: lib - Modules: Arrayext, Backtrace, Base64, Bigbuffer, Config, Date, Either, Encodings, ExtentlistSet, Filenameext, Fring, Fun, Gzip, Hashtblext, Int64ext, LazyList, Listext, Mapext, Monad, Opt, Pervasiveext, Qring, Range, Ring, Sha1sum, Stringext, Tar, Threadext, Trie, Unixext, VIO, Zerocheck + Modules: Arrayext, Backtrace, Base64, Bigbuffer, Config, Date, Either, Encodings, ExtentlistSet, Filenameext, Fring, Fun, Hashtblext, Int64ext, LazyList, Listext, Mapext, Monad, Opt, Pervasiveext, Qring, Range, Ring, Stringext, Tar, Threadext, Trie, Unixext, VIO, Zerocheck CSources: unixext_open_stubs.c, unixext_stubs.c, unixext_write_stubs.c, zerocheck_stub.c - BuildDepends: threads, uuidm, forkexec, unix + BuildDepends: threads, uuidm, unix diff --git a/lib/gzip.ml b/lib/gzip.ml deleted file mode 100644 index 8e81b728361..00000000000 --- a/lib/gzip.ml +++ /dev/null @@ -1,97 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -open Pervasiveext - -(** Path to the gzip binary *) -let gzip = "/bin/gzip" - -(** Helper function to prevent double-closes of file descriptors *) -let close to_close fd = - if List.mem fd !to_close then Unix.close fd; - to_close := List.filter (fun x -> fd <> x) !to_close - -type zcat_mode = Compress | Decompress - -type input_type = - | Active (** we provide a function which writes into the compressor and a fd output *) - | Passive (** we provide an fd input and a function which reads from the compressor *) - -(* start cmd with lowest priority so that it doesn't - use up all cpu resources in dom0 -*) -let lower_priority cmd args = - let ionice="/usr/bin/ionice" in - let ionice_args=["-c";"3"] in (*io idle*) - let nice="/bin/nice" in - let nice_args=["-n";"19"] in (*lowest priority*) - let extra_args=nice_args@[ionice]@ionice_args in - let new_cmd=nice in - let new_args=extra_args@[cmd]@args in - (new_cmd,new_args) - -(** Runs a zcat process which is either: - i) a compressor; or (ii) a decompressor - and which has either - i) an active input (ie a function and a pipe) + passive output (fd); or - ii) a passive input (fd) + active output (ie a function and a pipe) -*) -let go (mode: zcat_mode) (input: input_type) fd f = - let zcat_out, zcat_in = Unix.pipe() in - - let to_close = ref [ zcat_in; zcat_out ] in - let close = close to_close in - - finally - (fun () -> - let args = if mode = Compress then [] else ["--decompress"] @ [ "--stdout"; "--force" ] in - - let stdin, stdout, close_now, close_later = match input with - | Active -> - Some zcat_out, (* input comes from the pipe+fn *) - Some fd, (* supplied fd is written to *) - zcat_out, (* we close this now *) - zcat_in (* close this before waitpid *) - | Passive -> - Some fd, (* supplied fd is read from *) - Some zcat_in, (* output goes into the pipe+fn *) - zcat_in, (* we close this now *) - zcat_out in (* close this before waitpid *) - let (gzip,args)=lower_priority gzip args in - let pid = Forkhelpers.safe_close_and_exec stdin stdout None [] gzip args in - close close_now; - finally - (fun () -> - f close_later - ) - (fun () -> - let failwith_error s = - let mode = if mode = Compress then "Compression" else "Decompression" in - let msg = Printf.sprintf "%s via zcat failed: %s" mode s in - Printf.eprintf "%s" msg; - failwith msg - in - close close_later; - match snd (Forkhelpers.waitpid pid) with - | Unix.WEXITED 0 -> (); - | Unix.WEXITED i -> failwith_error (Printf.sprintf "exit code %d" i) - | Unix.WSIGNALED i -> failwith_error (Printf.sprintf "killed by signal: %s" (Unixext.string_of_signal i)) - | Unix.WSTOPPED i -> failwith_error (Printf.sprintf "stopped by signal: %s" (Unixext.string_of_signal i)) - ) - ) (fun () -> List.iter close !to_close) - -let compress fd f = go Compress Active fd f -let decompress fd f = go Decompress Active fd f - -let decompress_passive fd f = go Decompress Passive fd f diff --git a/lib/sha1sum.ml b/lib/sha1sum.ml deleted file mode 100644 index 5b1f1ee7b4d..00000000000 --- a/lib/sha1sum.ml +++ /dev/null @@ -1,64 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -(** Path to the sha1sum binary (used in the new import/export code to append checksums *) -let sha1sum = "/usr/bin/sha1sum" - -open Pervasiveext -open Stringext - -(** Helper function to prevent double-closes of file descriptors *) -let close to_close fd = - if List.mem fd !to_close then Unix.close fd; - to_close := List.filter (fun x -> fd <> x) !to_close - -(** Fork a slave sha1sum process, execute a function with the input file descriptor - and return the result of sha1sum, guaranteeing to reap the process. *) -let sha1sum f = - let input_out, input_in = Unix.pipe () in - let result_out, result_in = Unix.pipe () in - - Unix.set_close_on_exec result_out; - Unix.set_close_on_exec input_in; - - let to_close = ref [ input_out; input_in; result_out; result_in ] in - let close = close to_close in - - finally - (fun () -> - let args = [] in - let pid = Forkhelpers.safe_close_and_exec (Some input_out) (Some result_in) None [] sha1sum args in - - close result_in; - close input_out; - - finally - (fun () -> - finally - (fun () -> f input_in) - (fun () -> close input_in); - let buffer = String.make 1024 '\000' in - let n = Unix.read result_out buffer 0 (String.length buffer) in - let raw = String.sub buffer 0 n in - let result = match String.split ' ' raw with - | result :: _ -> result - | _ -> failwith (Printf.sprintf "Unable to parse sha1sum output: %s" raw) in - close result_out; - result) - (fun () -> - Forkhelpers.waitpid_fail_if_bad_exit pid - ) - ) (fun () -> List.iter close !to_close) - - From 62f69e14904e343f505514e6bbce4553b7b10219 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sat, 12 Jan 2013 11:15:26 +0000 Subject: [PATCH 003/199] Update OASIS --- _tags | 7 +--- lib/META | 4 +- lib/stdext.mllib | 4 +- myocamlbuild.ml | 14 +++---- setup.ml | 102 +++++++++++++++++++++++------------------------ 5 files changed, 61 insertions(+), 70 deletions(-) diff --git a/_tags b/_tags index 14974f9b5a9..a484fa06399 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 7560e1cd1f3b4dabc60a9f8ebb35ba86) +# DO NOT EDIT (digest: f06032cfb796620abc9b67ecc56e8626) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -18,22 +18,17 @@ : use_libstdext_stubs : pkg_threads : pkg_uuidm -: pkg_forkexec : pkg_unix "lib/unixext_open_stubs.c": pkg_threads "lib/unixext_open_stubs.c": pkg_uuidm -"lib/unixext_open_stubs.c": pkg_forkexec "lib/unixext_open_stubs.c": pkg_unix "lib/unixext_stubs.c": pkg_threads "lib/unixext_stubs.c": pkg_uuidm -"lib/unixext_stubs.c": pkg_forkexec "lib/unixext_stubs.c": pkg_unix "lib/unixext_write_stubs.c": pkg_threads "lib/unixext_write_stubs.c": pkg_uuidm -"lib/unixext_write_stubs.c": pkg_forkexec "lib/unixext_write_stubs.c": pkg_unix "lib/zerocheck_stub.c": pkg_threads "lib/zerocheck_stub.c": pkg_uuidm -"lib/zerocheck_stub.c": pkg_forkexec "lib/zerocheck_stub.c": pkg_unix # OASIS_STOP diff --git a/lib/META b/lib/META index bc913638344..9ffc1840204 100644 --- a/lib/META +++ b/lib/META @@ -1,8 +1,8 @@ # OASIS_START -# DO NOT EDIT (digest: 7a78a259a7957a9cdde948237e0bf2d5) +# DO NOT EDIT (digest: fc0ac7d6d2798724ed50aead23c84438) version = "0.1" description = "Standard extension library" -requires = "threads uuidm forkexec unix" +requires = "threads uuidm unix" archive(byte) = "stdext.cma" archive(byte, plugin) = "stdext.cma" archive(native) = "stdext.cmxa" diff --git a/lib/stdext.mllib b/lib/stdext.mllib index c27f8dffe03..c21ebcf1a06 100644 --- a/lib/stdext.mllib +++ b/lib/stdext.mllib @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 27fb733ba22844f22e886085490e8e05) +# DO NOT EDIT (digest: c0d4900aa146cbadd2648012f63e1a0d) Arrayext Backtrace Base64 @@ -12,7 +12,6 @@ ExtentlistSet Filenameext Fring Fun -Gzip Hashtblext Int64ext LazyList @@ -24,7 +23,6 @@ Pervasiveext Qring Range Ring -Sha1sum Stringext Tar Threadext diff --git a/myocamlbuild.ml b/myocamlbuild.ml index feb891ebf7c..35bb1c820ea 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,7 +1,7 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 1389f6cf16dbf6f02d2859c3cde5d291) *) +(* DO NOT EDIT (digest: d37cf428d00d4bc8c152caa495aa597b) *) module OASISGettext = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -24,7 +24,7 @@ module OASISGettext = struct end module OASISExpr = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) @@ -116,7 +116,7 @@ end # 117 "myocamlbuild.ml" module BaseEnvLight = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -214,7 +214,7 @@ end # 215 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild @@ -323,7 +323,7 @@ module MyOCamlbuildFindlib = struct end module MyOCamlbuildBase = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -339,7 +339,7 @@ module MyOCamlbuildBase = struct type name = string type tag = string -(* # 56 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 56 "/home/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { diff --git a/setup.ml b/setup.ml index 76632845543..78a72155790 100644 --- a/setup.ml +++ b/setup.ml @@ -1,14 +1,14 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 2180d6551e8c5a28ba9cb94865fadb47) *) +(* DO NOT EDIT (digest: 82fa4ead04b1830b58629b038f33ebd3) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -31,7 +31,7 @@ module OASISGettext = struct end module OASISContext = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISContext.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISContext.ml" *) open OASISGettext @@ -92,7 +92,7 @@ module OASISContext = struct end module OASISString = struct -(* # 1 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISString.ml" *) +(* # 1 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISString.ml" *) @@ -217,7 +217,7 @@ module OASISString = struct end module OASISUtils = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISUtils.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISUtils.ml" *) open OASISGettext @@ -312,7 +312,7 @@ module OASISUtils = struct end module PropList = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/PropList.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/PropList.ml" *) open OASISGettext @@ -352,7 +352,7 @@ module PropList = struct let clear t = Hashtbl.clear t -(* # 71 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/PropList.ml" *) +(* # 71 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/PropList.ml" *) end module Schema = @@ -593,7 +593,7 @@ module PropList = struct end module OASISMessage = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISMessage.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISMessage.ml" *) open OASISGettext @@ -632,7 +632,7 @@ module OASISMessage = struct end module OASISVersion = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISVersion.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISVersion.ml" *) open OASISGettext @@ -811,7 +811,7 @@ module OASISVersion = struct end module OASISLicense = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISLicense.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall @@ -851,7 +851,7 @@ module OASISLicense = struct end module OASISExpr = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) @@ -941,7 +941,7 @@ module OASISExpr = struct end module OASISTypes = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) @@ -1018,7 +1018,7 @@ module OASISTypes = struct type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -(* # 102 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) +(* # 102 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices @@ -1176,7 +1176,7 @@ module OASISTypes = struct end module OASISUnixPath = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string @@ -1260,7 +1260,7 @@ module OASISUnixPath = struct end module OASISHostPath = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" *) open Filename @@ -1293,7 +1293,7 @@ module OASISHostPath = struct end module OASISSection = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISSection.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISSection.ml" *) open OASISTypes @@ -1372,12 +1372,12 @@ module OASISSection = struct end module OASISBuildSection = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" *) open OASISTypes @@ -1408,7 +1408,7 @@ module OASISExecutable = struct end module OASISLibrary = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils @@ -1841,32 +1841,32 @@ module OASISLibrary = struct end module OASISFlag = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISFlag.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISFlag.ml" *) end module OASISPackage = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISPackage.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISTest.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISTest.ml" *) end module OASISDocument = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISDocument.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISDocument.ml" *) end module OASISExec = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISExec.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils @@ -1944,7 +1944,7 @@ module OASISExec = struct end module OASISFileUtil = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" *) open OASISGettext @@ -2141,7 +2141,7 @@ end # 2142 "setup.ml" module BaseEnvLight = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -2239,7 +2239,7 @@ end # 2240 "setup.ml" module BaseContext = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseContext.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseContext.ml" *) open OASISContext @@ -2250,7 +2250,7 @@ module BaseContext = struct end module BaseMessage = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseMessage.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall @@ -2269,7 +2269,7 @@ module BaseMessage = struct end module BaseEnv = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseEnv.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils @@ -2729,7 +2729,7 @@ module BaseEnv = struct end module BaseArgExt = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseArgExt.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext @@ -2757,7 +2757,7 @@ module BaseArgExt = struct end module BaseCheck = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseCheck.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage @@ -2883,7 +2883,7 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" *) open BaseEnv @@ -2999,7 +2999,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseStandardVar.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseStandardVar.ml" *) open OASISGettext @@ -3363,7 +3363,7 @@ module BaseStandardVar = struct end module BaseFileAB = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseFileAB.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext @@ -3411,7 +3411,7 @@ module BaseFileAB = struct end module BaseLog = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseLog.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseLog.ml" *) open OASISUtils @@ -3530,7 +3530,7 @@ module BaseLog = struct end module BaseBuilt = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseBuilt.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext @@ -3677,7 +3677,7 @@ module BaseBuilt = struct end module BaseCustom = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseCustom.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage @@ -3727,7 +3727,7 @@ module BaseCustom = struct end module BaseDynVar = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseDynVar.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseDynVar.ml" *) open OASISTypes @@ -3774,7 +3774,7 @@ module BaseDynVar = struct end module BaseTest = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseTest.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseTest.ml" *) open BaseEnv open BaseMessage @@ -3864,7 +3864,7 @@ module BaseTest = struct end module BaseDoc = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseDoc.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage @@ -3899,7 +3899,7 @@ module BaseDoc = struct end module BaseSetup = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseSetup.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage @@ -4479,7 +4479,7 @@ end # 4480 "setup.ml" module InternalConfigurePlugin = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall @@ -4721,7 +4721,7 @@ module InternalConfigurePlugin = struct end module InternalInstallPlugin = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall @@ -5232,7 +5232,7 @@ end # 5233 "setup.ml" module OCamlbuildCommon = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) @@ -5334,7 +5334,7 @@ module OCamlbuildCommon = struct end module OCamlbuildPlugin = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall @@ -5507,7 +5507,7 @@ module OCamlbuildPlugin = struct end module OCamlbuildDocPlugin = struct -(* # 21 "/home/jludlam/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) +(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall @@ -5646,7 +5646,6 @@ let setup_t = [ FindlibPackage ("threads", None); FindlibPackage ("uuidm", None); - FindlibPackage ("forkexec", None); FindlibPackage ("unix", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; @@ -5680,7 +5679,6 @@ let setup_t = "Filenameext"; "Fring"; "Fun"; - "Gzip"; "Hashtblext"; "Int64ext"; "LazyList"; @@ -5692,7 +5690,6 @@ let setup_t = "Qring"; "Range"; "Ring"; - "Sha1sum"; "Stringext"; "Tar"; "Threadext"; @@ -5715,7 +5712,8 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.0"; - oasis_digest = Some "\003'G\nm\2403\173L\190\134\155:q\1356"; + oasis_digest = + Some " \197\005[\191\232\166:\2249\155\168\225\003\223\153"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -5723,6 +5721,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 5727 "setup.ml" +# 5725 "setup.ml" (* OASIS_STOP *) let () = setup ();; From e0a0d210d7ab8192dd2f3bd0c5eadb58713b16c6 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sat, 12 Jan 2013 12:22:25 +0000 Subject: [PATCH 004/199] Rely on {send,recv}_fd in the fd-send-recv package We need to remove the stubs to avoid linking errors in projects which are using both this transitional package and the new fd-send-recv one. We re-export the functions from here so no client code changes are required. Signed-off-by: David Scott --- _oasis | 2 +- lib/unixext.ml | 5 +- lib/unixext.mli | 4 +- lib/unixext_stubs.c | 128 -------------------------------------------- 4 files changed, 5 insertions(+), 134 deletions(-) diff --git a/_oasis b/_oasis index 2c6795554ef..b730b02001b 100644 --- a/_oasis +++ b/_oasis @@ -12,6 +12,6 @@ Library stdext Path: lib Modules: Arrayext, Backtrace, Base64, Bigbuffer, Config, Date, Either, Encodings, ExtentlistSet, Filenameext, Fring, Fun, Hashtblext, Int64ext, LazyList, Listext, Mapext, Monad, Opt, Pervasiveext, Qring, Range, Ring, Stringext, Tar, Threadext, Trie, Unixext, VIO, Zerocheck CSources: unixext_open_stubs.c, unixext_stubs.c, unixext_write_stubs.c, zerocheck_stub.c - BuildDepends: threads, uuidm, unix + BuildDepends: threads, uuidm, unix, fd-send-recv diff --git a/lib/unixext.ml b/lib/unixext.ml index 830dfe58a08..b5fbf822aaa 100644 --- a/lib/unixext.ml +++ b/lib/unixext.ml @@ -657,9 +657,8 @@ let wait_for_path path delay timeout = let _ = Callback.register_exception "unixext.unix_error" (Unix_error (0)) -external send_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> Unix.file_descr -> int = "stub_unix_send_fd_bytecode" "stub_unix_send_fd" -external recv_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr * Unix.file_descr = "stub_unix_recv_fd" - +let send_fd = Fd_send_recv.send_fd +let recv_fd = Fd_send_recv.recv_fd type statvfs_t = { f_bsize : int64; diff --git a/lib/unixext.mli b/lib/unixext.mli index ac3f508eece..2a6fd32a66e 100644 --- a/lib/unixext.mli +++ b/lib/unixext.mli @@ -147,8 +147,8 @@ end val wait_for_path : string -> (float -> unit) -> int -> unit -external send_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> Unix.file_descr -> int = "stub_unix_send_fd_bytecode" "stub_unix_send_fd" -external recv_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr * Unix.file_descr = "stub_unix_recv_fd" +val send_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> Unix.file_descr -> int +val recv_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr * Unix.file_descr type statvfs_t = { f_bsize : int64; diff --git a/lib/unixext_stubs.c b/lib/unixext_stubs.c index bbac3b67826..30285579d4d 100644 --- a/lib/unixext_stubs.c +++ b/lib/unixext_stubs.c @@ -279,134 +279,6 @@ static int msg_flag_table[] = { #define UNIX_BUFFER_SIZE 16384 -CAMLprim value stub_unix_send_fd(value sock, value buff, value ofs, value len, value flags, value fd) -{ - CAMLparam5(sock,buff,ofs,len,flags); - CAMLxparam1(fd); - int ret, cv_flags, cfd; - long numbytes; - char iobuf[UNIX_BUFFER_SIZE]; - char buf[CMSG_SPACE(sizeof(cfd))]; - - cfd = Int_val(fd); - - cv_flags = convert_flag_list(flags,msg_flag_table); - - numbytes = Long_val(len); - if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; - memmove(iobuf, &Byte(buff, Long_val(ofs)), numbytes); - - /* Set up sockaddr */ - - struct msghdr msg; - struct iovec vec; - struct cmsghdr *cmsg; - - msg.msg_name = NULL; - msg.msg_namelen = 0; - vec.iov_base=iobuf; - vec.iov_len=numbytes; - msg.msg_iov=&vec; - msg.msg_iovlen=1; - - msg.msg_control = buf; - msg.msg_controllen = sizeof(buf); - cmsg = CMSG_FIRSTHDR(&msg); - cmsg->cmsg_level = SOL_SOCKET; - cmsg->cmsg_type = SCM_RIGHTS; - cmsg->cmsg_len = CMSG_LEN(sizeof(cfd)); - *(int*)CMSG_DATA(cmsg) = cfd; - msg.msg_controllen = cmsg->cmsg_len; - - msg.msg_flags = 0; - - caml_enter_blocking_section(); - ret=sendmsg(Int_val(sock), &msg, cv_flags); - caml_leave_blocking_section(); - - if(ret == -1) - unixext_error(errno); - - CAMLreturn(Val_int(ret)); -} - -CAMLprim value stub_unix_send_fd_bytecode(value *argv, int argn) -{ - return stub_unix_send_fd(argv[0],argv[1],argv[2],argv[3], - argv[4], argv[5]); -} - -CAMLprim value stub_unix_recv_fd(value sock, value buff, value ofs, value len, value flags) -{ - CAMLparam5(sock,buff,ofs,len,flags); - CAMLlocal2(res,addr); - int ret, cv_flags, fd; - long numbytes; - char iobuf[UNIX_BUFFER_SIZE]; - char buf[CMSG_SPACE(sizeof(fd))]; - struct sockaddr_un unix_socket_name; - - cv_flags = convert_flag_list(flags,msg_flag_table); - - struct msghdr msg; - struct iovec vec; - struct cmsghdr *cmsg; - - numbytes = Long_val(len); - if(numbytes > UNIX_BUFFER_SIZE) - numbytes = UNIX_BUFFER_SIZE; - - msg.msg_name=&unix_socket_name; - msg.msg_namelen=sizeof(unix_socket_name); - vec.iov_base=iobuf; - vec.iov_len=numbytes; - msg.msg_iov=&vec; - - msg.msg_iovlen=1; - - msg.msg_control = buf; - msg.msg_controllen = sizeof(buf); - - caml_enter_blocking_section(); - ret=recvmsg(Int_val(sock), &msg, cv_flags); - caml_leave_blocking_section(); - - if(ret == -1) - unixext_error(errno); - - if(ret>0 && msg.msg_controllen>0) { - cmsg = CMSG_FIRSTHDR(&msg); - if(cmsg->cmsg_level == SOL_SOCKET && (cmsg->cmsg_type == SCM_RIGHTS)) { - fd=Val_int(*(int*)CMSG_DATA(cmsg)); - } else { - failwith("Failed to receive an fd!"); - } - } else { - fd=Val_int(-1); - } - - if(ret0) { - Field(addr,0) = copy_string(unix_socket_name.sun_path); - } else { - Field(addr,0) = copy_string("nothing"); - } - - res=alloc_small(3,0); - Field(res,0) = Val_int(ret); - Field(res,1) = addr; - Field(res,2) = fd; - - CAMLreturn(res); -} - CAMLprim value stub_statvfs(value filename) { CAMLparam1(filename); From 3ee1deba7cb12a2dc9d8e89f1a1d8a467d8093e7 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sat, 12 Jan 2013 12:23:56 +0000 Subject: [PATCH 005/199] Update OASIS autogenerated files Signed-off-by: David Scott --- _tags | 7 +++- lib/META | 4 +- myocamlbuild.ml | 14 +++---- setup.ml | 101 ++++++++++++++++++++++++------------------------ 4 files changed, 66 insertions(+), 60 deletions(-) diff --git a/_tags b/_tags index a484fa06399..65404c34466 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: f06032cfb796620abc9b67ecc56e8626) +# DO NOT EDIT (digest: e178c54bab8ac32d82fd0ed18f25dbfe) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -19,16 +19,21 @@ : pkg_threads : pkg_uuidm : pkg_unix +: pkg_fd-send-recv "lib/unixext_open_stubs.c": pkg_threads "lib/unixext_open_stubs.c": pkg_uuidm "lib/unixext_open_stubs.c": pkg_unix +"lib/unixext_open_stubs.c": pkg_fd-send-recv "lib/unixext_stubs.c": pkg_threads "lib/unixext_stubs.c": pkg_uuidm "lib/unixext_stubs.c": pkg_unix +"lib/unixext_stubs.c": pkg_fd-send-recv "lib/unixext_write_stubs.c": pkg_threads "lib/unixext_write_stubs.c": pkg_uuidm "lib/unixext_write_stubs.c": pkg_unix +"lib/unixext_write_stubs.c": pkg_fd-send-recv "lib/zerocheck_stub.c": pkg_threads "lib/zerocheck_stub.c": pkg_uuidm "lib/zerocheck_stub.c": pkg_unix +"lib/zerocheck_stub.c": pkg_fd-send-recv # OASIS_STOP diff --git a/lib/META b/lib/META index 9ffc1840204..951c6af00df 100644 --- a/lib/META +++ b/lib/META @@ -1,8 +1,8 @@ # OASIS_START -# DO NOT EDIT (digest: fc0ac7d6d2798724ed50aead23c84438) +# DO NOT EDIT (digest: 953ff1b692d5fb02d2f1208d433082b8) version = "0.1" description = "Standard extension library" -requires = "threads uuidm unix" +requires = "threads uuidm unix fd-send-recv" archive(byte) = "stdext.cma" archive(byte, plugin) = "stdext.cma" archive(native) = "stdext.cmxa" diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 35bb1c820ea..790eb797fe7 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,7 +1,7 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: d37cf428d00d4bc8c152caa495aa597b) *) +(* DO NOT EDIT (digest: 6a5abf2ab730fee592c5ebd08b3708e6) *) module OASISGettext = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -24,7 +24,7 @@ module OASISGettext = struct end module OASISExpr = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) @@ -116,7 +116,7 @@ end # 117 "myocamlbuild.ml" module BaseEnvLight = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -214,7 +214,7 @@ end # 215 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild @@ -323,7 +323,7 @@ module MyOCamlbuildFindlib = struct end module MyOCamlbuildBase = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -339,7 +339,7 @@ module MyOCamlbuildBase = struct type name = string type tag = string -(* # 56 "/home/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 56 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { diff --git a/setup.ml b/setup.ml index 78a72155790..a115d671215 100644 --- a/setup.ml +++ b/setup.ml @@ -1,14 +1,14 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 82fa4ead04b1830b58629b038f33ebd3) *) +(* DO NOT EDIT (digest: f8b140fda7b2597d608863c7c1d437c4) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -31,7 +31,7 @@ module OASISGettext = struct end module OASISContext = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISContext.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISContext.ml" *) open OASISGettext @@ -92,7 +92,7 @@ module OASISContext = struct end module OASISString = struct -(* # 1 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISString.ml" *) +(* # 1 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISString.ml" *) @@ -217,7 +217,7 @@ module OASISString = struct end module OASISUtils = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISUtils.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISUtils.ml" *) open OASISGettext @@ -312,7 +312,7 @@ module OASISUtils = struct end module PropList = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/PropList.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/PropList.ml" *) open OASISGettext @@ -352,7 +352,7 @@ module PropList = struct let clear t = Hashtbl.clear t -(* # 71 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/PropList.ml" *) +(* # 71 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/PropList.ml" *) end module Schema = @@ -593,7 +593,7 @@ module PropList = struct end module OASISMessage = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISMessage.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISMessage.ml" *) open OASISGettext @@ -632,7 +632,7 @@ module OASISMessage = struct end module OASISVersion = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISVersion.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISVersion.ml" *) open OASISGettext @@ -811,7 +811,7 @@ module OASISVersion = struct end module OASISLicense = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISLicense.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall @@ -851,7 +851,7 @@ module OASISLicense = struct end module OASISExpr = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) @@ -941,7 +941,7 @@ module OASISExpr = struct end module OASISTypes = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) @@ -1018,7 +1018,7 @@ module OASISTypes = struct type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -(* # 102 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) +(* # 102 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices @@ -1176,7 +1176,7 @@ module OASISTypes = struct end module OASISUnixPath = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string @@ -1260,7 +1260,7 @@ module OASISUnixPath = struct end module OASISHostPath = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" *) open Filename @@ -1293,7 +1293,7 @@ module OASISHostPath = struct end module OASISSection = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISSection.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISSection.ml" *) open OASISTypes @@ -1372,12 +1372,12 @@ module OASISSection = struct end module OASISBuildSection = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" *) open OASISTypes @@ -1408,7 +1408,7 @@ module OASISExecutable = struct end module OASISLibrary = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils @@ -1841,32 +1841,32 @@ module OASISLibrary = struct end module OASISFlag = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISFlag.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISFlag.ml" *) end module OASISPackage = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISPackage.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISTest.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISTest.ml" *) end module OASISDocument = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISDocument.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISDocument.ml" *) end module OASISExec = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISExec.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils @@ -1944,7 +1944,7 @@ module OASISExec = struct end module OASISFileUtil = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" *) open OASISGettext @@ -2141,7 +2141,7 @@ end # 2142 "setup.ml" module BaseEnvLight = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -2239,7 +2239,7 @@ end # 2240 "setup.ml" module BaseContext = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseContext.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseContext.ml" *) open OASISContext @@ -2250,7 +2250,7 @@ module BaseContext = struct end module BaseMessage = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseMessage.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall @@ -2269,7 +2269,7 @@ module BaseMessage = struct end module BaseEnv = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseEnv.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils @@ -2729,7 +2729,7 @@ module BaseEnv = struct end module BaseArgExt = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseArgExt.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext @@ -2757,7 +2757,7 @@ module BaseArgExt = struct end module BaseCheck = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseCheck.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage @@ -2883,7 +2883,7 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" *) open BaseEnv @@ -2999,7 +2999,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseStandardVar.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseStandardVar.ml" *) open OASISGettext @@ -3363,7 +3363,7 @@ module BaseStandardVar = struct end module BaseFileAB = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseFileAB.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext @@ -3411,7 +3411,7 @@ module BaseFileAB = struct end module BaseLog = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseLog.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseLog.ml" *) open OASISUtils @@ -3530,7 +3530,7 @@ module BaseLog = struct end module BaseBuilt = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseBuilt.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext @@ -3677,7 +3677,7 @@ module BaseBuilt = struct end module BaseCustom = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseCustom.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage @@ -3727,7 +3727,7 @@ module BaseCustom = struct end module BaseDynVar = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseDynVar.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseDynVar.ml" *) open OASISTypes @@ -3774,7 +3774,7 @@ module BaseDynVar = struct end module BaseTest = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseTest.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseTest.ml" *) open BaseEnv open BaseMessage @@ -3864,7 +3864,7 @@ module BaseTest = struct end module BaseDoc = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseDoc.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage @@ -3899,7 +3899,7 @@ module BaseDoc = struct end module BaseSetup = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/base/BaseSetup.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage @@ -4479,7 +4479,7 @@ end # 4480 "setup.ml" module InternalConfigurePlugin = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall @@ -4721,7 +4721,7 @@ module InternalConfigurePlugin = struct end module InternalInstallPlugin = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall @@ -5232,7 +5232,7 @@ end # 5233 "setup.ml" module OCamlbuildCommon = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) @@ -5334,7 +5334,7 @@ module OCamlbuildCommon = struct end module OCamlbuildPlugin = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall @@ -5507,7 +5507,7 @@ module OCamlbuildPlugin = struct end module OCamlbuildDocPlugin = struct -(* # 21 "/home/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) +(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall @@ -5646,7 +5646,8 @@ let setup_t = [ FindlibPackage ("threads", None); FindlibPackage ("uuidm", None); - FindlibPackage ("unix", None) + FindlibPackage ("unix", None); + FindlibPackage ("fd-send-recv", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = @@ -5713,7 +5714,7 @@ let setup_t = oasis_fn = Some "_oasis"; oasis_version = "0.3.0"; oasis_digest = - Some " \197\005[\191\232\166:\2249\155\168\225\003\223\153"; + Some "\160\251\247\026w~S\226\134\191\148\171\238\031\175\176"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -5721,6 +5722,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 5725 "setup.ml" +# 5726 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 6e6fb992a73dba3f1428fe74b159bf824f0cc358 Mon Sep 17 00:00:00 2001 From: David Scott Date: Tue, 29 Jan 2013 16:04:02 +0000 Subject: [PATCH 006/199] Import Debug, Syslog from xen-api-libs 6b42ec06ea2f14e989b41ca61623e53638692703 --- lib/debug.ml | 178 +++++++++++++++++++++++++++++++++++++++++++++ lib/debug.mli | 78 ++++++++++++++++++++ lib/syslog.ml | 49 +++++++++++++ lib/syslog.mli | 42 +++++++++++ lib/syslog_stubs.c | 77 ++++++++++++++++++++ 5 files changed, 424 insertions(+) create mode 100644 lib/debug.ml create mode 100644 lib/debug.mli create mode 100644 lib/syslog.ml create mode 100644 lib/syslog.mli create mode 100644 lib/syslog_stubs.c diff --git a/lib/debug.ml b/lib/debug.ml new file mode 100644 index 00000000000..454c3464cf7 --- /dev/null +++ b/lib/debug.ml @@ -0,0 +1,178 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +open Stringext +open Pervasiveext +open Threadext + +(** Associate a task with each active thread *) +let thread_tasks : (int, string) Hashtbl.t = Hashtbl.create 256 +let thread_tasks_m = Mutex.create () + +let get_thread_id () = + try Thread.id (Thread.self ()) with _ -> -1 + +let associate_thread_with_task task = + let id = get_thread_id () in + if id <> -1 + then begin + Mutex.execute thread_tasks_m (fun () -> Hashtbl.add thread_tasks id task); + end + +let get_task_from_thread () = + let id = get_thread_id () in + Mutex.execute thread_tasks_m + (fun () -> if Hashtbl.mem thread_tasks id then Some(Hashtbl.find thread_tasks id) else None) + +let dissociate_thread_from_task () = + let id = get_thread_id () in + if id <> -1 + then match get_task_from_thread () with + | Some _ -> + Mutex.execute thread_tasks_m (fun () -> Hashtbl.remove thread_tasks id) + | None -> + () + +let with_thread_associated task f x = + associate_thread_with_task task; + finally + (fun () -> f x) + dissociate_thread_from_task + +let threadnames = Hashtbl.create 256 +let tnmutex = Mutex.create () +module StringSet = Set.Make(struct type t=string let compare=Pervasives.compare end) +let debug_keys = ref StringSet.empty +let get_all_debug_keys () = + StringSet.fold (fun key keys -> key::keys) !debug_keys [] + +let dkmutex = Mutex.create () + +let _ = Hashtbl.add threadnames (-1) "no thread" + +let get_thread_id () = + try Thread.id (Thread.self ()) with _ -> -1 + +let name_thread name = + let id = get_thread_id () in + Mutex.execute tnmutex (fun () -> Hashtbl.add threadnames id name) + +let remove_thread_name () = + let id = get_thread_id () in + Mutex.execute tnmutex (fun () -> Hashtbl.remove threadnames id) + +module type BRAND = sig + val name: string +end + +let hostname_cache = ref None +let hostname_m = Mutex.create () +let get_hostname () = + match Mutex.execute hostname_m (fun () -> !hostname_cache) with + | Some h -> h + | None -> + let h = Unix.gethostname () in + Mutex.execute hostname_m (fun () -> hostname_cache := Some h); + h +let invalidate_hostname_cache () = Mutex.execute hostname_m (fun () -> hostname_cache := None) + +let facility = ref Syslog.Daemon +let facility_m = Mutex.create () +let set_facility f = Mutex.execute facility_m (fun () -> facility := f) +let get_facility () = Mutex.execute facility_m (fun () -> !facility) + +let logging_disabled_for = ref [] +let logging_disabled_for_m = Mutex.create () +let disable brand = + Mutex.execute logging_disabled_for_m + (fun () -> logging_disabled_for := brand :: !logging_disabled_for) +let enable brand = + Mutex.execute logging_disabled_for_m + (fun () -> logging_disabled_for := List.filter (fun x -> x <> brand) !logging_disabled_for) +let is_disabled brand = + Mutex.execute logging_disabled_for_m + (fun () -> List.mem brand !logging_disabled_for) + +let gettimestring () = + let time = Unix.gettimeofday () in + let tm = Unix.gmtime time in + let msec = time -. (floor time) in + Printf.sprintf "%d%.2d%.2dT%.2d:%.2d:%.2d.%.3dZ|" (1900 + tm.Unix.tm_year) + (tm.Unix.tm_mon + 1) tm.Unix.tm_mday + tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec + (int_of_float (1000.0 *. msec)) + +let print_debug = ref false +let log_to_stdout () = print_debug := true + +module Debugger = functor(Brand: BRAND) -> struct + let _ = + Mutex.execute dkmutex (fun () -> + debug_keys := StringSet.add Brand.name !debug_keys) + + let get_thread_name () = + let id = get_thread_id () in + Mutex.execute tnmutex + (fun () -> + try + Printf.sprintf "%d %s" id (Hashtbl.find threadnames id) + with _ -> + Printf.sprintf "%d" id) + + let get_task () = + default "" (may (fun s -> s) (get_task_from_thread ())) + + let make_log_message include_time brand priority message = + let extra = + Printf.sprintf "%s|%s|%s|%s" + (get_hostname ()) + (get_thread_name ()) + (get_task ()) + brand in + Printf.sprintf "[%s%.5s|%s] %s" (if include_time then gettimestring () else "") priority extra message + + + + let output level priority (fmt: ('a, unit, string, 'b) format4) = + Printf.kprintf + (fun s -> + if not(is_disabled Brand.name) then begin + let msg = make_log_message false Brand.name priority s in + + if !print_debug + then Printf.printf "%s\n%!" (make_log_message true Brand.name priority s); + + Syslog.log (get_facility ()) level msg + end + ) fmt + + let debug fmt = output Syslog.Debug "debug" fmt + let warn fmt = output Syslog.Warning "warn" fmt + let info fmt = output Syslog.Info "info" fmt + let error fmt = output Syslog.Err "error" fmt + let audit ?(raw=false) (fmt: ('a, unit, string, 'b) format4) = + Printf.kprintf + (fun s -> + let msg = if raw then s else make_log_message true Brand.name "audit" s in + Syslog.log Syslog.Local6 Syslog.Info msg; + msg + ) fmt + + let log_backtrace () = + let backtrace = Backtrace.get_backtrace () in + debug "%s" (String.escaped backtrace) + + let log_and_ignore_exn f = + try f () with _ -> log_backtrace () + +end diff --git a/lib/debug.mli b/lib/debug.mli new file mode 100644 index 00000000000..9075b7af474 --- /dev/null +++ b/lib/debug.mli @@ -0,0 +1,78 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** Debug utilities *) + +(** Throw away the cached hostname. The next log line will re-query the hostname *) +val invalidate_hostname_cache: unit -> unit + +(** {2 Associate a task to the current actions} *) + +(** Associate a task name to the current thread *) +val associate_thread_with_task : string -> unit + +(** Dissociate a task name to the current thread *) +val dissociate_thread_from_task : unit -> unit + +(** Do an action with a task name associated with the current thread *) +val with_thread_associated : string -> ('a -> 'b) -> 'a -> 'b + +(** {2 Associate a name to the current thread} *) + +val name_thread : string -> unit + +val remove_thread_name : unit -> unit + +val get_all_debug_keys : unit -> string list + +module type BRAND = sig val name : string end + +val gettimestring : unit -> string +(** The current time of day in a format suitable for logging *) + +val set_facility : Syslog.facility -> unit +(** Set the syslog facility that will be used by this program. *) + +val disable : string -> unit +(** [disable brand] Suppress all log output from the given [brand]. This function is idempotent. *) + +val enable : string -> unit +(** [enable brand] Enable all log output from the given [brand]. This function is idempotent. *) + +val log_to_stdout : unit -> unit +(** [log_to_stdout ()] will echo all log output to stdout (not the default) *) + +module Debugger : functor (Brand : BRAND) -> +sig + + (** Debug function *) + val debug : ('a, unit, string, unit) format4 -> 'a + + (** Warn function *) + val warn : ('a, unit, string, unit) format4 -> 'a + + (** Info function *) + val info : ('a, unit, string, unit) format4 -> 'a + + (** Error function *) + val error : ('a, unit, string, unit) format4 -> 'a + + (** Audit function *) + val audit : ?raw:bool -> ('a, unit, string, string) format4 -> 'a + + val log_backtrace : unit -> unit + + val log_and_ignore_exn : (unit -> unit) -> unit +end + diff --git a/lib/syslog.ml b/lib/syslog.ml new file mode 100644 index 00000000000..ee99da9ba0e --- /dev/null +++ b/lib/syslog.ml @@ -0,0 +1,49 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +type level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug +type options = Cons | Ndelay | Nowait | Odelay | Perror | Pid +type facility = Auth | Authpriv | Cron | Daemon | Ftp | Kern + | Local0 | Local1 | Local2 | Local3 + | Local4 | Local5 | Local6 | Local7 + | Lpr | Mail | News | Syslog | User | Uucp + +(* external init : string -> options list -> facility -> unit = "stub_openlog" *) +external log : facility -> level -> string -> unit = "stub_syslog" +external close : unit -> unit = "stub_closelog" + +exception Unknown_facility of string +let facility_of_string s = + match s with + |"auth"->Auth + |"authpriv"->Authpriv + |"cron"->Cron + |"daemon"->Daemon + |"ftp"->Ftp + |"kern"->Kern + |"local0"->Local0 + |"local1"->Local1 + |"local2"->Local2 + |"local3"->Local3 + |"local4"->Local4 + |"local5"->Local5 + |"local6"->Local6 + |"local7"->Local7 + |"lpr"->Lpr + |"mail"->Mail + |"news"->News + |"syslog"->Syslog + |"user"->User + |"uucp"->Uucp + |_-> raise (Unknown_facility s) diff --git a/lib/syslog.mli b/lib/syslog.mli new file mode 100644 index 00000000000..7ff2cda9c77 --- /dev/null +++ b/lib/syslog.mli @@ -0,0 +1,42 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +type level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug +type facility = + Auth + | Authpriv + | Cron + | Daemon + | Ftp + | Kern + | Local0 + | Local1 + | Local2 + | Local3 + | Local4 + | Local5 + | Local6 + | Local7 + | Lpr + | Mail + | News + | Syslog + | User + | Uucp + +external log : facility -> level -> string -> unit = "stub_syslog" +external close : unit -> unit = "stub_closelog" + + +val facility_of_string : string -> facility diff --git a/lib/syslog_stubs.c b/lib/syslog_stubs.c new file mode 100644 index 00000000000..408ecefe320 --- /dev/null +++ b/lib/syslog_stubs.c @@ -0,0 +1,77 @@ +/* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + */ + +#include +#include +#include +#include +#include +#include +#include + +static int __syslog_level_table[] = { + LOG_EMERG, LOG_ALERT, LOG_CRIT, LOG_ERR, LOG_WARNING, + LOG_NOTICE, LOG_INFO, LOG_DEBUG +}; + +static int __syslog_options_table[] = { + LOG_CONS, LOG_NDELAY, LOG_NOWAIT, LOG_ODELAY, LOG_PERROR, LOG_PID +}; + +static int __syslog_facility_table[] = { + LOG_AUTH, LOG_AUTHPRIV, LOG_CRON, LOG_DAEMON, LOG_FTP, LOG_KERN, + LOG_LOCAL0, LOG_LOCAL1, LOG_LOCAL2, LOG_LOCAL3, + LOG_LOCAL4, LOG_LOCAL5, LOG_LOCAL6, LOG_LOCAL7, + LOG_LPR | LOG_MAIL | LOG_NEWS | LOG_SYSLOG | LOG_USER | LOG_UUCP +}; + +/* According to the openlog manpage the 'openlog' call may take a reference + to the 'ident' string and keep it long-term. This means we cannot just pass in + an ocaml string which is under the control of the GC. Since we aren't actually + calling this function we can just comment it out for the time-being. */ +/* +value stub_openlog(value ident, value option, value facility) +{ + CAMLparam3(ident, option, facility); + int c_option; + int c_facility; + + c_option = caml_convert_flag_list(option, __syslog_options_table); + c_facility = __syslog_facility_table[Int_val(facility)]; + openlog(String_val(ident), c_option, c_facility); + CAMLreturn(Val_unit); +} +*/ + +value stub_syslog(value facility, value level, value msg) +{ + CAMLparam3(facility, level, msg); + const char *c_msg = strdup(String_val(msg)); + int c_facility = __syslog_facility_table[Int_val(facility)] + | __syslog_level_table[Int_val(level)]; + + caml_enter_blocking_section(); + syslog(c_facility, "%s", c_msg); + caml_leave_blocking_section(); + + free(c_msg); + CAMLreturn(Val_unit); +} + +value stub_closelog(value unit) +{ + CAMLparam1(unit); + closelog(); + CAMLreturn(Val_unit); +} From abc202c9b92e157dde43a9393e1e19337bf68bb9 Mon Sep 17 00:00:00 2001 From: David Scott Date: Tue, 29 Jan 2013 16:43:11 +0000 Subject: [PATCH 007/199] Revert "Import Debug, Syslog from xen-api-libs 6b42ec06ea2f14e989b41ca61623e53638692703" This reverts commit 6e6fb992a73dba3f1428fe74b159bf824f0cc358. This code was already in the xen-api-libs-transitional package --- lib/debug.ml | 178 --------------------------------------------- lib/debug.mli | 78 -------------------- lib/syslog.ml | 49 ------------- lib/syslog.mli | 42 ----------- lib/syslog_stubs.c | 77 -------------------- 5 files changed, 424 deletions(-) delete mode 100644 lib/debug.ml delete mode 100644 lib/debug.mli delete mode 100644 lib/syslog.ml delete mode 100644 lib/syslog.mli delete mode 100644 lib/syslog_stubs.c diff --git a/lib/debug.ml b/lib/debug.ml deleted file mode 100644 index 454c3464cf7..00000000000 --- a/lib/debug.ml +++ /dev/null @@ -1,178 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -open Stringext -open Pervasiveext -open Threadext - -(** Associate a task with each active thread *) -let thread_tasks : (int, string) Hashtbl.t = Hashtbl.create 256 -let thread_tasks_m = Mutex.create () - -let get_thread_id () = - try Thread.id (Thread.self ()) with _ -> -1 - -let associate_thread_with_task task = - let id = get_thread_id () in - if id <> -1 - then begin - Mutex.execute thread_tasks_m (fun () -> Hashtbl.add thread_tasks id task); - end - -let get_task_from_thread () = - let id = get_thread_id () in - Mutex.execute thread_tasks_m - (fun () -> if Hashtbl.mem thread_tasks id then Some(Hashtbl.find thread_tasks id) else None) - -let dissociate_thread_from_task () = - let id = get_thread_id () in - if id <> -1 - then match get_task_from_thread () with - | Some _ -> - Mutex.execute thread_tasks_m (fun () -> Hashtbl.remove thread_tasks id) - | None -> - () - -let with_thread_associated task f x = - associate_thread_with_task task; - finally - (fun () -> f x) - dissociate_thread_from_task - -let threadnames = Hashtbl.create 256 -let tnmutex = Mutex.create () -module StringSet = Set.Make(struct type t=string let compare=Pervasives.compare end) -let debug_keys = ref StringSet.empty -let get_all_debug_keys () = - StringSet.fold (fun key keys -> key::keys) !debug_keys [] - -let dkmutex = Mutex.create () - -let _ = Hashtbl.add threadnames (-1) "no thread" - -let get_thread_id () = - try Thread.id (Thread.self ()) with _ -> -1 - -let name_thread name = - let id = get_thread_id () in - Mutex.execute tnmutex (fun () -> Hashtbl.add threadnames id name) - -let remove_thread_name () = - let id = get_thread_id () in - Mutex.execute tnmutex (fun () -> Hashtbl.remove threadnames id) - -module type BRAND = sig - val name: string -end - -let hostname_cache = ref None -let hostname_m = Mutex.create () -let get_hostname () = - match Mutex.execute hostname_m (fun () -> !hostname_cache) with - | Some h -> h - | None -> - let h = Unix.gethostname () in - Mutex.execute hostname_m (fun () -> hostname_cache := Some h); - h -let invalidate_hostname_cache () = Mutex.execute hostname_m (fun () -> hostname_cache := None) - -let facility = ref Syslog.Daemon -let facility_m = Mutex.create () -let set_facility f = Mutex.execute facility_m (fun () -> facility := f) -let get_facility () = Mutex.execute facility_m (fun () -> !facility) - -let logging_disabled_for = ref [] -let logging_disabled_for_m = Mutex.create () -let disable brand = - Mutex.execute logging_disabled_for_m - (fun () -> logging_disabled_for := brand :: !logging_disabled_for) -let enable brand = - Mutex.execute logging_disabled_for_m - (fun () -> logging_disabled_for := List.filter (fun x -> x <> brand) !logging_disabled_for) -let is_disabled brand = - Mutex.execute logging_disabled_for_m - (fun () -> List.mem brand !logging_disabled_for) - -let gettimestring () = - let time = Unix.gettimeofday () in - let tm = Unix.gmtime time in - let msec = time -. (floor time) in - Printf.sprintf "%d%.2d%.2dT%.2d:%.2d:%.2d.%.3dZ|" (1900 + tm.Unix.tm_year) - (tm.Unix.tm_mon + 1) tm.Unix.tm_mday - tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec - (int_of_float (1000.0 *. msec)) - -let print_debug = ref false -let log_to_stdout () = print_debug := true - -module Debugger = functor(Brand: BRAND) -> struct - let _ = - Mutex.execute dkmutex (fun () -> - debug_keys := StringSet.add Brand.name !debug_keys) - - let get_thread_name () = - let id = get_thread_id () in - Mutex.execute tnmutex - (fun () -> - try - Printf.sprintf "%d %s" id (Hashtbl.find threadnames id) - with _ -> - Printf.sprintf "%d" id) - - let get_task () = - default "" (may (fun s -> s) (get_task_from_thread ())) - - let make_log_message include_time brand priority message = - let extra = - Printf.sprintf "%s|%s|%s|%s" - (get_hostname ()) - (get_thread_name ()) - (get_task ()) - brand in - Printf.sprintf "[%s%.5s|%s] %s" (if include_time then gettimestring () else "") priority extra message - - - - let output level priority (fmt: ('a, unit, string, 'b) format4) = - Printf.kprintf - (fun s -> - if not(is_disabled Brand.name) then begin - let msg = make_log_message false Brand.name priority s in - - if !print_debug - then Printf.printf "%s\n%!" (make_log_message true Brand.name priority s); - - Syslog.log (get_facility ()) level msg - end - ) fmt - - let debug fmt = output Syslog.Debug "debug" fmt - let warn fmt = output Syslog.Warning "warn" fmt - let info fmt = output Syslog.Info "info" fmt - let error fmt = output Syslog.Err "error" fmt - let audit ?(raw=false) (fmt: ('a, unit, string, 'b) format4) = - Printf.kprintf - (fun s -> - let msg = if raw then s else make_log_message true Brand.name "audit" s in - Syslog.log Syslog.Local6 Syslog.Info msg; - msg - ) fmt - - let log_backtrace () = - let backtrace = Backtrace.get_backtrace () in - debug "%s" (String.escaped backtrace) - - let log_and_ignore_exn f = - try f () with _ -> log_backtrace () - -end diff --git a/lib/debug.mli b/lib/debug.mli deleted file mode 100644 index 9075b7af474..00000000000 --- a/lib/debug.mli +++ /dev/null @@ -1,78 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -(** Debug utilities *) - -(** Throw away the cached hostname. The next log line will re-query the hostname *) -val invalidate_hostname_cache: unit -> unit - -(** {2 Associate a task to the current actions} *) - -(** Associate a task name to the current thread *) -val associate_thread_with_task : string -> unit - -(** Dissociate a task name to the current thread *) -val dissociate_thread_from_task : unit -> unit - -(** Do an action with a task name associated with the current thread *) -val with_thread_associated : string -> ('a -> 'b) -> 'a -> 'b - -(** {2 Associate a name to the current thread} *) - -val name_thread : string -> unit - -val remove_thread_name : unit -> unit - -val get_all_debug_keys : unit -> string list - -module type BRAND = sig val name : string end - -val gettimestring : unit -> string -(** The current time of day in a format suitable for logging *) - -val set_facility : Syslog.facility -> unit -(** Set the syslog facility that will be used by this program. *) - -val disable : string -> unit -(** [disable brand] Suppress all log output from the given [brand]. This function is idempotent. *) - -val enable : string -> unit -(** [enable brand] Enable all log output from the given [brand]. This function is idempotent. *) - -val log_to_stdout : unit -> unit -(** [log_to_stdout ()] will echo all log output to stdout (not the default) *) - -module Debugger : functor (Brand : BRAND) -> -sig - - (** Debug function *) - val debug : ('a, unit, string, unit) format4 -> 'a - - (** Warn function *) - val warn : ('a, unit, string, unit) format4 -> 'a - - (** Info function *) - val info : ('a, unit, string, unit) format4 -> 'a - - (** Error function *) - val error : ('a, unit, string, unit) format4 -> 'a - - (** Audit function *) - val audit : ?raw:bool -> ('a, unit, string, string) format4 -> 'a - - val log_backtrace : unit -> unit - - val log_and_ignore_exn : (unit -> unit) -> unit -end - diff --git a/lib/syslog.ml b/lib/syslog.ml deleted file mode 100644 index ee99da9ba0e..00000000000 --- a/lib/syslog.ml +++ /dev/null @@ -1,49 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -type level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug -type options = Cons | Ndelay | Nowait | Odelay | Perror | Pid -type facility = Auth | Authpriv | Cron | Daemon | Ftp | Kern - | Local0 | Local1 | Local2 | Local3 - | Local4 | Local5 | Local6 | Local7 - | Lpr | Mail | News | Syslog | User | Uucp - -(* external init : string -> options list -> facility -> unit = "stub_openlog" *) -external log : facility -> level -> string -> unit = "stub_syslog" -external close : unit -> unit = "stub_closelog" - -exception Unknown_facility of string -let facility_of_string s = - match s with - |"auth"->Auth - |"authpriv"->Authpriv - |"cron"->Cron - |"daemon"->Daemon - |"ftp"->Ftp - |"kern"->Kern - |"local0"->Local0 - |"local1"->Local1 - |"local2"->Local2 - |"local3"->Local3 - |"local4"->Local4 - |"local5"->Local5 - |"local6"->Local6 - |"local7"->Local7 - |"lpr"->Lpr - |"mail"->Mail - |"news"->News - |"syslog"->Syslog - |"user"->User - |"uucp"->Uucp - |_-> raise (Unknown_facility s) diff --git a/lib/syslog.mli b/lib/syslog.mli deleted file mode 100644 index 7ff2cda9c77..00000000000 --- a/lib/syslog.mli +++ /dev/null @@ -1,42 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -type level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug -type facility = - Auth - | Authpriv - | Cron - | Daemon - | Ftp - | Kern - | Local0 - | Local1 - | Local2 - | Local3 - | Local4 - | Local5 - | Local6 - | Local7 - | Lpr - | Mail - | News - | Syslog - | User - | Uucp - -external log : facility -> level -> string -> unit = "stub_syslog" -external close : unit -> unit = "stub_closelog" - - -val facility_of_string : string -> facility diff --git a/lib/syslog_stubs.c b/lib/syslog_stubs.c deleted file mode 100644 index 408ecefe320..00000000000 --- a/lib/syslog_stubs.c +++ /dev/null @@ -1,77 +0,0 @@ -/* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - */ - -#include -#include -#include -#include -#include -#include -#include - -static int __syslog_level_table[] = { - LOG_EMERG, LOG_ALERT, LOG_CRIT, LOG_ERR, LOG_WARNING, - LOG_NOTICE, LOG_INFO, LOG_DEBUG -}; - -static int __syslog_options_table[] = { - LOG_CONS, LOG_NDELAY, LOG_NOWAIT, LOG_ODELAY, LOG_PERROR, LOG_PID -}; - -static int __syslog_facility_table[] = { - LOG_AUTH, LOG_AUTHPRIV, LOG_CRON, LOG_DAEMON, LOG_FTP, LOG_KERN, - LOG_LOCAL0, LOG_LOCAL1, LOG_LOCAL2, LOG_LOCAL3, - LOG_LOCAL4, LOG_LOCAL5, LOG_LOCAL6, LOG_LOCAL7, - LOG_LPR | LOG_MAIL | LOG_NEWS | LOG_SYSLOG | LOG_USER | LOG_UUCP -}; - -/* According to the openlog manpage the 'openlog' call may take a reference - to the 'ident' string and keep it long-term. This means we cannot just pass in - an ocaml string which is under the control of the GC. Since we aren't actually - calling this function we can just comment it out for the time-being. */ -/* -value stub_openlog(value ident, value option, value facility) -{ - CAMLparam3(ident, option, facility); - int c_option; - int c_facility; - - c_option = caml_convert_flag_list(option, __syslog_options_table); - c_facility = __syslog_facility_table[Int_val(facility)]; - openlog(String_val(ident), c_option, c_facility); - CAMLreturn(Val_unit); -} -*/ - -value stub_syslog(value facility, value level, value msg) -{ - CAMLparam3(facility, level, msg); - const char *c_msg = strdup(String_val(msg)); - int c_facility = __syslog_facility_table[Int_val(facility)] - | __syslog_level_table[Int_val(level)]; - - caml_enter_blocking_section(); - syslog(c_facility, "%s", c_msg); - caml_leave_blocking_section(); - - free(c_msg); - CAMLreturn(Val_unit); -} - -value stub_closelog(value unit) -{ - CAMLparam1(unit); - closelog(); - CAMLreturn(Val_unit); -} From 6378d17e317afcee6e6d2ccfd0112fa093570e7a Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 30 Jan 2013 11:45:22 +0000 Subject: [PATCH 008/199] Fring depends on Bigarray --- _oasis | 2 +- _tags | 7 ++++++- lib/META | 4 ++-- setup.ml | 9 +++++---- 4 files changed, 14 insertions(+), 8 deletions(-) diff --git a/_oasis b/_oasis index b730b02001b..aaf54938fdd 100644 --- a/_oasis +++ b/_oasis @@ -12,6 +12,6 @@ Library stdext Path: lib Modules: Arrayext, Backtrace, Base64, Bigbuffer, Config, Date, Either, Encodings, ExtentlistSet, Filenameext, Fring, Fun, Hashtblext, Int64ext, LazyList, Listext, Mapext, Monad, Opt, Pervasiveext, Qring, Range, Ring, Stringext, Tar, Threadext, Trie, Unixext, VIO, Zerocheck CSources: unixext_open_stubs.c, unixext_stubs.c, unixext_write_stubs.c, zerocheck_stub.c - BuildDepends: threads, uuidm, unix, fd-send-recv + BuildDepends: threads, uuidm, unix, fd-send-recv, bigarray diff --git a/_tags b/_tags index 65404c34466..31e4d1deaf0 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: e178c54bab8ac32d82fd0ed18f25dbfe) +# DO NOT EDIT (digest: 68f404103d28eef0beaf97b7755a9c4d) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -20,20 +20,25 @@ : pkg_uuidm : pkg_unix : pkg_fd-send-recv +: pkg_bigarray "lib/unixext_open_stubs.c": pkg_threads "lib/unixext_open_stubs.c": pkg_uuidm "lib/unixext_open_stubs.c": pkg_unix "lib/unixext_open_stubs.c": pkg_fd-send-recv +"lib/unixext_open_stubs.c": pkg_bigarray "lib/unixext_stubs.c": pkg_threads "lib/unixext_stubs.c": pkg_uuidm "lib/unixext_stubs.c": pkg_unix "lib/unixext_stubs.c": pkg_fd-send-recv +"lib/unixext_stubs.c": pkg_bigarray "lib/unixext_write_stubs.c": pkg_threads "lib/unixext_write_stubs.c": pkg_uuidm "lib/unixext_write_stubs.c": pkg_unix "lib/unixext_write_stubs.c": pkg_fd-send-recv +"lib/unixext_write_stubs.c": pkg_bigarray "lib/zerocheck_stub.c": pkg_threads "lib/zerocheck_stub.c": pkg_uuidm "lib/zerocheck_stub.c": pkg_unix "lib/zerocheck_stub.c": pkg_fd-send-recv +"lib/zerocheck_stub.c": pkg_bigarray # OASIS_STOP diff --git a/lib/META b/lib/META index 951c6af00df..0abf849d752 100644 --- a/lib/META +++ b/lib/META @@ -1,8 +1,8 @@ # OASIS_START -# DO NOT EDIT (digest: 953ff1b692d5fb02d2f1208d433082b8) +# DO NOT EDIT (digest: fbffbf46bcb66bb27353943ffb241372) version = "0.1" description = "Standard extension library" -requires = "threads uuidm unix fd-send-recv" +requires = "threads uuidm unix fd-send-recv bigarray" archive(byte) = "stdext.cma" archive(byte, plugin) = "stdext.cma" archive(native) = "stdext.cmxa" diff --git a/setup.ml b/setup.ml index a115d671215..4ea979094d7 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: f8b140fda7b2597d608863c7c1d437c4) *) +(* DO NOT EDIT (digest: 6b4a3e7d91959c4b372799ff2a7294a2) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and @@ -5647,7 +5647,8 @@ let setup_t = FindlibPackage ("threads", None); FindlibPackage ("uuidm", None); FindlibPackage ("unix", None); - FindlibPackage ("fd-send-recv", None) + FindlibPackage ("fd-send-recv", None); + FindlibPackage ("bigarray", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = @@ -5714,7 +5715,7 @@ let setup_t = oasis_fn = Some "_oasis"; oasis_version = "0.3.0"; oasis_digest = - Some "\160\251\247\026w~S\226\134\191\148\171\238\031\175\176"; + Some "\223\166\188\196,\250\214\029\138\227~i\"\236\219\166"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -5722,6 +5723,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 5726 "setup.ml" +# 5727 "setup.ml" (* OASIS_STOP *) let () = setup ();; From fdb683a74eff019df455a96b102747ec5e26138f Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 30 Jan 2013 11:55:40 +0000 Subject: [PATCH 009/199] Hashtblext.fold_{keys,values} are not folds! --- lib/hashtblext.ml | 2 ++ lib/hashtblext.mli | 5 +++++ 2 files changed, 7 insertions(+) diff --git a/lib/hashtblext.ml b/lib/hashtblext.ml index c0065dfa513..eec1a82010e 100644 --- a/lib/hashtblext.ml +++ b/lib/hashtblext.ml @@ -15,9 +15,11 @@ let to_list tbl = Hashtbl.fold (fun k v acc -> (k, v) :: acc) tbl [] +(* this is not a fold ... *) let fold_keys tbl = Hashtbl.fold (fun k v acc -> k :: acc) tbl [] +(* ... neither is this *) let fold_values tbl = Hashtbl.fold (fun k v acc -> v :: acc) tbl [] diff --git a/lib/hashtblext.mli b/lib/hashtblext.mli index c1a25a850f0..0741741593b 100644 --- a/lib/hashtblext.mli +++ b/lib/hashtblext.mli @@ -12,8 +12,13 @@ * GNU Lesser General Public License for more details. *) val to_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list + +(* this is not a fold ... *) val fold_keys : ('a, 'b) Hashtbl.t -> 'a list + +(* ... neither is this *) val fold_values : ('a, 'b) Hashtbl.t -> 'b list + val add_empty : ('a, 'b) Hashtbl.t -> 'a -> 'b -> unit val add_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list -> unit val remove_other_keys : ('a, 'b) Hashtbl.t -> 'a list -> unit From d08cdea4b3342eb8e863e31b13471dd9ec7ae019 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Mon, 25 Feb 2013 22:32:46 +0000 Subject: [PATCH 010/199] CA-94829: Bindings to the TCP keepalive settings Imported from xen-api-libs. Signed-off-by: Jon Ludlam --- lib/unixext.ml | 2 +- lib/unixext.mli | 1 + lib/unixext_stubs.c | 26 ++++++++++++++++++++++++++ 3 files changed, 28 insertions(+), 1 deletion(-) diff --git a/lib/unixext.ml b/lib/unixext.ml index 830dfe58a08..484d9d86c53 100644 --- a/lib/unixext.ml +++ b/lib/unixext.ml @@ -559,7 +559,7 @@ let double_fork f = | pid -> ignore(Unix.waitpid [] pid) external set_tcp_nodelay : Unix.file_descr -> bool -> unit = "stub_unixext_set_tcp_nodelay" - +external set_sock_keepalives : Unix.file_descr -> int -> int -> int -> unit = "stub_unixext_set_sock_keepalives" external fsync : Unix.file_descr -> unit = "stub_unixext_fsync" external blkgetsize64 : Unix.file_descr -> int64 = "stub_unixext_blkgetsize64" diff --git a/lib/unixext.mli b/lib/unixext.mli index ac3f508eece..e721208d8d4 100644 --- a/lib/unixext.mli +++ b/lib/unixext.mli @@ -118,6 +118,7 @@ val spawnvp : val double_fork : (unit -> unit) -> unit external set_tcp_nodelay : Unix.file_descr -> bool -> unit = "stub_unixext_set_tcp_nodelay" +external set_sock_keepalives : Unix.file_descr -> int -> int -> int -> unit = "stub_unixext_set_sock_keepalives" external fsync : Unix.file_descr -> unit = "stub_unixext_fsync" external get_max_fd : unit -> int = "stub_unixext_get_max_fd" external blkgetsize64 : Unix.file_descr -> int64 = "stub_unixext_blkgetsize64" diff --git a/lib/unixext_stubs.c b/lib/unixext_stubs.c index bbac3b67826..db7799fc2b0 100644 --- a/lib/unixext_stubs.c +++ b/lib/unixext_stubs.c @@ -72,6 +72,32 @@ CAMLprim value stub_unixext_get_max_fd (value unit) CAMLreturn(Val_int(maxfd)); } +CAMLprim value stub_unixext_set_sock_keepalives(value fd, value count, value idle, value interval) +{ + CAMLparam4(fd, count, idle, interval); + + int c_fd = Int_val(fd); + int optval; + socklen_t optlen=sizeof(optval); + + optval = Int_val(count); + if(setsockopt(c_fd, SOL_TCP, TCP_KEEPCNT, &optval, optlen) < 0) { + uerror("setsockopt(TCP_KEEPCNT)", Nothing); + } + + optval = Int_val(idle); + if(setsockopt(c_fd, SOL_TCP, TCP_KEEPIDLE, &optval, optlen) < 0) { + uerror("setsockopt(TCP_KEEPIDLE)", Nothing); + } + + optval = Int_val(interval); + if(setsockopt(c_fd, SOL_TCP, TCP_KEEPINTVL, &optval, optlen) < 0) { + uerror("setsockopt(TCP_KEEPINTVL)", Nothing); + } + + CAMLreturn(Val_unit); +} + #define FDSET_OF_VALUE(v) (&(((struct fdset_t *) v)->fds)) #define MAXFD_OF_VALUE(v) (((struct fdset_t *) v)->max) struct fdset_t { fd_set fds; int max; }; From 2a3ffcbf5686e6a1e5ac3d17c1f98c874f641776 Mon Sep 17 00:00:00 2001 From: David Scott Date: Mon, 3 Jun 2013 13:16:31 +0000 Subject: [PATCH 011/199] Add standard files. Signed-off-by: David Scott --- ChangeLog | 3 + LICENSE | 521 ++++++++++++++++++++++++++++++++++++++++++++++++++++ MAINTAINERS | 12 ++ README.md | 10 + 4 files changed, 546 insertions(+) create mode 100644 ChangeLog create mode 100644 LICENSE create mode 100644 MAINTAINERS create mode 100644 README.md diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 00000000000..0932f97aaf4 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,3 @@ +0.9.0 (3-Jun-2013): +* first public release + diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000000..1b1ce97cb5c --- /dev/null +++ b/LICENSE @@ -0,0 +1,521 @@ +This repository is distributed under the terms of the GNU Lesser General +Public License version 2.1 (included below). + +As a special exception to the GNU Lesser General Public License, you +may link, statically or dynamically, a "work that uses the Library" +with a publicly distributed version of the Library to produce an +executable file containing portions of the Library, and distribute +that executable file under terms of your choice, without any of the +additional requirements listed in clause 6 of the GNU Lesser General +Public License. By "a publicly distributed version of the Library", +we mean either the unmodified Library as distributed, or a +modified version of the Library that is distributed under the +conditions defined in clause 3 of the GNU Library General Public +License. This exception does not however invalidate any other reasons +why the executable file might be covered by the GNU Lesser General +Public License. + +------------ + + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/MAINTAINERS b/MAINTAINERS new file mode 100644 index 00000000000..64869937605 --- /dev/null +++ b/MAINTAINERS @@ -0,0 +1,12 @@ +How to submit changes to this project +===================================== + +Please submit changes as pull requests to the repository on github. +Please ensure that all changes have descriptive commit comments and +include a Signed-off-by: line. + +Maintainers list +---------------- + +* David Scott +* Jonathan Ludlam diff --git a/README.md b/README.md new file mode 100644 index 00000000000..50a7fe27276 --- /dev/null +++ b/README.md @@ -0,0 +1,10 @@ +Deprecated misc utility functions +================================= + +These utility functions are used by several other services. Much of this +should be replaced with other libraries such as + * cohttp + * uri + * re + +Eventually this library should disappear. From be0b119c3eb71270df9283195ec7af2e5e125d6a Mon Sep 17 00:00:00 2001 From: David Scott Date: Mon, 3 Jun 2013 13:16:53 +0000 Subject: [PATCH 012/199] Bump version to 0.9.0 Signed-off-by: David Scott --- _oasis | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/_oasis b/_oasis index aaf54938fdd..60216656d8a 100644 --- a/_oasis +++ b/_oasis @@ -1,6 +1,6 @@ OASISFormat: 0.3 Name: stdext -Version: 0.1 +Version: 0.9.0 Synopsis: Standard extension library License: LGPL-2.1 with OCaml linking exception Authors: various From cec1ab112dfe2dfbbf7308ec19ee764f1c930f33 Mon Sep 17 00:00:00 2001 From: David Scott Date: Mon, 3 Jun 2013 13:17:10 +0000 Subject: [PATCH 013/199] Regnerate OASIS. --- lib/META | 4 +- myocamlbuild.ml | 14 +++---- setup.ml | 101 ++++++++++++++++++++++++------------------------ 3 files changed, 59 insertions(+), 60 deletions(-) diff --git a/lib/META b/lib/META index 0abf849d752..1c3d3b22987 100644 --- a/lib/META +++ b/lib/META @@ -1,6 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: fbffbf46bcb66bb27353943ffb241372) -version = "0.1" +# DO NOT EDIT (digest: acf5f6b945a4686f403083afb72255f2) +version = "0.9.0" description = "Standard extension library" requires = "threads uuidm unix fd-send-recv bigarray" archive(byte) = "stdext.cma" diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 790eb797fe7..b6fdaedb598 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,7 +1,7 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 6a5abf2ab730fee592c5ebd08b3708e6) *) +(* DO NOT EDIT (digest: a4ed19cd7f440af14f6663b57db31800) *) module OASISGettext = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -24,7 +24,7 @@ module OASISGettext = struct end module OASISExpr = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) @@ -116,7 +116,7 @@ end # 117 "myocamlbuild.ml" module BaseEnvLight = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -214,7 +214,7 @@ end # 215 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild @@ -323,7 +323,7 @@ module MyOCamlbuildFindlib = struct end module MyOCamlbuildBase = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -339,7 +339,7 @@ module MyOCamlbuildBase = struct type name = string type tag = string -(* # 56 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 56 "/root/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { diff --git a/setup.ml b/setup.ml index 4ea979094d7..cbe23ae1af7 100644 --- a/setup.ml +++ b/setup.ml @@ -1,14 +1,14 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 6b4a3e7d91959c4b372799ff2a7294a2) *) +(* DO NOT EDIT (digest: 0e16ea7fc326f39b1015b872831b2640) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -31,7 +31,7 @@ module OASISGettext = struct end module OASISContext = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISContext.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISContext.ml" *) open OASISGettext @@ -92,7 +92,7 @@ module OASISContext = struct end module OASISString = struct -(* # 1 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISString.ml" *) +(* # 1 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISString.ml" *) @@ -217,7 +217,7 @@ module OASISString = struct end module OASISUtils = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISUtils.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISUtils.ml" *) open OASISGettext @@ -312,7 +312,7 @@ module OASISUtils = struct end module PropList = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/PropList.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/PropList.ml" *) open OASISGettext @@ -352,7 +352,7 @@ module PropList = struct let clear t = Hashtbl.clear t -(* # 71 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/PropList.ml" *) +(* # 71 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/PropList.ml" *) end module Schema = @@ -593,7 +593,7 @@ module PropList = struct end module OASISMessage = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISMessage.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISMessage.ml" *) open OASISGettext @@ -632,7 +632,7 @@ module OASISMessage = struct end module OASISVersion = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISVersion.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISVersion.ml" *) open OASISGettext @@ -811,7 +811,7 @@ module OASISVersion = struct end module OASISLicense = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISLicense.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall @@ -851,7 +851,7 @@ module OASISLicense = struct end module OASISExpr = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) @@ -941,7 +941,7 @@ module OASISExpr = struct end module OASISTypes = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) @@ -1018,7 +1018,7 @@ module OASISTypes = struct type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -(* # 102 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) +(* # 102 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices @@ -1176,7 +1176,7 @@ module OASISTypes = struct end module OASISUnixPath = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string @@ -1260,7 +1260,7 @@ module OASISUnixPath = struct end module OASISHostPath = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" *) open Filename @@ -1293,7 +1293,7 @@ module OASISHostPath = struct end module OASISSection = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISSection.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISSection.ml" *) open OASISTypes @@ -1372,12 +1372,12 @@ module OASISSection = struct end module OASISBuildSection = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" *) open OASISTypes @@ -1408,7 +1408,7 @@ module OASISExecutable = struct end module OASISLibrary = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils @@ -1841,32 +1841,32 @@ module OASISLibrary = struct end module OASISFlag = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISFlag.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISFlag.ml" *) end module OASISPackage = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISPackage.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISTest.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISTest.ml" *) end module OASISDocument = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISDocument.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISDocument.ml" *) end module OASISExec = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISExec.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils @@ -1944,7 +1944,7 @@ module OASISExec = struct end module OASISFileUtil = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" *) open OASISGettext @@ -2141,7 +2141,7 @@ end # 2142 "setup.ml" module BaseEnvLight = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -2239,7 +2239,7 @@ end # 2240 "setup.ml" module BaseContext = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseContext.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseContext.ml" *) open OASISContext @@ -2250,7 +2250,7 @@ module BaseContext = struct end module BaseMessage = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseMessage.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall @@ -2269,7 +2269,7 @@ module BaseMessage = struct end module BaseEnv = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseEnv.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils @@ -2729,7 +2729,7 @@ module BaseEnv = struct end module BaseArgExt = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseArgExt.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext @@ -2757,7 +2757,7 @@ module BaseArgExt = struct end module BaseCheck = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseCheck.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage @@ -2883,7 +2883,7 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" *) open BaseEnv @@ -2999,7 +2999,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseStandardVar.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseStandardVar.ml" *) open OASISGettext @@ -3363,7 +3363,7 @@ module BaseStandardVar = struct end module BaseFileAB = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseFileAB.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext @@ -3411,7 +3411,7 @@ module BaseFileAB = struct end module BaseLog = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseLog.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseLog.ml" *) open OASISUtils @@ -3530,7 +3530,7 @@ module BaseLog = struct end module BaseBuilt = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseBuilt.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext @@ -3677,7 +3677,7 @@ module BaseBuilt = struct end module BaseCustom = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseCustom.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage @@ -3727,7 +3727,7 @@ module BaseCustom = struct end module BaseDynVar = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseDynVar.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseDynVar.ml" *) open OASISTypes @@ -3774,7 +3774,7 @@ module BaseDynVar = struct end module BaseTest = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseTest.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseTest.ml" *) open BaseEnv open BaseMessage @@ -3864,7 +3864,7 @@ module BaseTest = struct end module BaseDoc = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseDoc.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage @@ -3899,7 +3899,7 @@ module BaseDoc = struct end module BaseSetup = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/base/BaseSetup.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage @@ -4479,7 +4479,7 @@ end # 4480 "setup.ml" module InternalConfigurePlugin = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall @@ -4721,7 +4721,7 @@ module InternalConfigurePlugin = struct end module InternalInstallPlugin = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall @@ -5232,7 +5232,7 @@ end # 5233 "setup.ml" module OCamlbuildCommon = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) @@ -5334,7 +5334,7 @@ module OCamlbuildCommon = struct end module OCamlbuildPlugin = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall @@ -5507,7 +5507,7 @@ module OCamlbuildPlugin = struct end module OCamlbuildDocPlugin = struct -(* # 21 "/local/scratch/djs/.opam/system/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) +(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall @@ -5578,7 +5578,7 @@ let setup_t = ocaml_version = None; findlib_version = None; name = "stdext"; - version = "0.1"; + version = "0.9.0"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -5714,8 +5714,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.0"; - oasis_digest = - Some "\223\166\188\196,\250\214\029\138\227~i\"\236\219\166"; + oasis_digest = Some "2P\225w\137\b\181i\2368\024\171N\138E+"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -5723,6 +5722,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 5727 "setup.ml" +# 5726 "setup.ml" (* OASIS_STOP *) let () = setup ();; From c186e5e59751df3f21cc1dd80e5fa71074a9dce7 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Fri, 5 Jul 2013 23:27:18 +0100 Subject: [PATCH 014/199] Import patch 32fbe661230e6f8328b962559350efcc20a88b2d from xen-api-libs Originally from Euan Harris Signed-off-by: Jon Ludlam --- lib/stringext.ml | 6 ++++++ lib/stringext.mli | 6 ++++++ lib/unixext.ml | 35 ++++++++++++++++++++--------------- lib/unixext.mli | 3 +++ 4 files changed, 35 insertions(+), 15 deletions(-) diff --git a/lib/stringext.ml b/lib/stringext.ml index 8c743d559f8..c7de560e360 100644 --- a/lib/stringext.ml +++ b/lib/stringext.ml @@ -214,4 +214,10 @@ let sub_to_end s start = let length = String.length s in String.sub s start (length - start) +let sub_before c s = + String.sub s 0 (String.index s c) + +let sub_after c s = + sub_to_end s (String.index s c + 1) + end diff --git a/lib/stringext.mli b/lib/stringext.mli index 3cbe245b27a..09fdf9aa255 100644 --- a/lib/stringext.mli +++ b/lib/stringext.mli @@ -120,4 +120,10 @@ module String : (** a substring from the specified position to the end of the string *) val sub_to_end : string -> int -> string + + (** a substring from the start of the string to the first occurrence of a given character, excluding the character *) + val sub_before : char -> string -> string + + (** a substring from the first occurrence of a given character to the end of the string, excluding the character *) + val sub_after : char -> string -> string end diff --git a/lib/unixext.ml b/lib/unixext.ml index 9d6af7782a2..fa557488541 100644 --- a/lib/unixext.ml +++ b/lib/unixext.ml @@ -252,21 +252,19 @@ let delete_empty_file file_path = (** Create a new file descriptor, connect it to host:port and return it *) exception Host_not_found of string let open_connection_fd host port = - let s = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - try - let he = - try - Unix.gethostbyname host - with - Not_found -> raise (Host_not_found host) in - if Array.length he.Unix.h_addr_list = 0 - then failwith (Printf.sprintf "Couldn't resolve hostname: %s" host); - let ip = he.Unix.h_addr_list.(0) in - let addr = Unix.ADDR_INET(ip, port) in - Unix.connect s addr; - s - with e -> Unix.close s; raise e - + let open Unix in + let addrinfo = getaddrinfo host (string_of_int port) [AI_SOCKTYPE SOCK_STREAM] in + match addrinfo with + | [] -> + failwith (Printf.sprintf "Couldn't resolve hostname: %s" host) + | ai :: _ -> + let s = socket ai.ai_family ai.ai_socktype 0 in + try + connect s ai.ai_addr; + s + with e -> + close s; + raise e let open_connection_unix_fd filename = let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in @@ -676,6 +674,13 @@ type statvfs_t = { external statvfs : string -> statvfs_t = "stub_statvfs" +(** Returns Some Unix.PF_INET or Some Unix.PF_INET6 if passed a valid IP address, otherwise returns None. *) +let domain_of_addr str = + try + let addr = Unix.inet_addr_of_string str in + Some (Unix.domain_of_sockaddr (Unix.ADDR_INET (addr, 1))) + with _ -> None + module Direct = struct type t = Unix.file_descr diff --git a/lib/unixext.mli b/lib/unixext.mli index b8760fe8ac0..889182ae707 100644 --- a/lib/unixext.mli +++ b/lib/unixext.mli @@ -167,6 +167,9 @@ type statvfs_t = { val statvfs : string -> statvfs_t +(** Returns Some Unix.PF_INET or Some Unix.PF_INET6 if passed a valid IP address, otherwise returns None. *) +val domain_of_addr : string -> Unix.socket_domain option + module Direct : sig (** Perform I/O in O_DIRECT mode using 4KiB page-aligned buffers *) From 0f7483a3ad757200fe34022d297b8e77a43c81f5 Mon Sep 17 00:00:00 2001 From: David Scott Date: Tue, 10 Sep 2013 20:34:12 +0000 Subject: [PATCH 015/199] Release 0.9.1 Signed-off-by: David Scott --- ChangeLog | 4 ++++ _oasis | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 0932f97aaf4..c3977331908 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +0.9.1 (10-Sep-2013): +* Add Unixext.domain_of_addr +* Add String.sub_{before,after} + 0.9.0 (3-Jun-2013): * first public release diff --git a/_oasis b/_oasis index 60216656d8a..5c717af648e 100644 --- a/_oasis +++ b/_oasis @@ -1,6 +1,6 @@ OASISFormat: 0.3 Name: stdext -Version: 0.9.0 +Version: 0.9.1 Synopsis: Standard extension library License: LGPL-2.1 with OCaml linking exception Authors: various From 05f20dc07720d7e6042825e22a54f57ddfffbc46 Mon Sep 17 00:00:00 2001 From: David Scott Date: Tue, 10 Sep 2013 21:35:18 +0100 Subject: [PATCH 016/199] Regenerate OASIS Signed-off-by: David Scott --- lib/META | 4 +- myocamlbuild.ml | 14 +++---- setup.ml | 98 ++++++++++++++++++++++++------------------------- 3 files changed, 58 insertions(+), 58 deletions(-) diff --git a/lib/META b/lib/META index 1c3d3b22987..e71d8eafa6c 100644 --- a/lib/META +++ b/lib/META @@ -1,6 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: acf5f6b945a4686f403083afb72255f2) -version = "0.9.0" +# DO NOT EDIT (digest: 3ed2adb163391595a1dfeed7f6c4f8ba) +version = "0.9.1" description = "Standard extension library" requires = "threads uuidm unix fd-send-recv bigarray" archive(byte) = "stdext.cma" diff --git a/myocamlbuild.ml b/myocamlbuild.ml index b6fdaedb598..6195d316a4a 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,7 +1,7 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: a4ed19cd7f440af14f6663b57db31800) *) +(* DO NOT EDIT (digest: e139bd233288b32e42925ee1ab4c02d9) *) module OASISGettext = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) +(* # 21 "src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -24,7 +24,7 @@ module OASISGettext = struct end module OASISExpr = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) +(* # 21 "src/oasis/OASISExpr.ml" *) @@ -116,7 +116,7 @@ end # 117 "myocamlbuild.ml" module BaseEnvLight = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) +(* # 21 "src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -214,7 +214,7 @@ end # 215 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) +(* # 21 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild @@ -323,7 +323,7 @@ module MyOCamlbuildFindlib = struct end module MyOCamlbuildBase = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 21 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -339,7 +339,7 @@ module MyOCamlbuildBase = struct type name = string type tag = string -(* # 56 "/root/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 56 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { diff --git a/setup.ml b/setup.ml index cbe23ae1af7..28f38f6235c 100644 --- a/setup.ml +++ b/setup.ml @@ -1,14 +1,14 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 0e16ea7fc326f39b1015b872831b2640) *) +(* DO NOT EDIT (digest: 55f6d3d4128b148249f324dd06a2fd15) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISGettext.ml" *) +(* # 21 "src/oasis/OASISGettext.ml" *) let ns_ str = str @@ -31,7 +31,7 @@ module OASISGettext = struct end module OASISContext = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISContext.ml" *) +(* # 21 "src/oasis/OASISContext.ml" *) open OASISGettext @@ -92,7 +92,7 @@ module OASISContext = struct end module OASISString = struct -(* # 1 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISString.ml" *) +(* # 1 "src/oasis/OASISString.ml" *) @@ -217,7 +217,7 @@ module OASISString = struct end module OASISUtils = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISUtils.ml" *) +(* # 21 "src/oasis/OASISUtils.ml" *) open OASISGettext @@ -312,7 +312,7 @@ module OASISUtils = struct end module PropList = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/PropList.ml" *) +(* # 21 "src/oasis/PropList.ml" *) open OASISGettext @@ -352,7 +352,7 @@ module PropList = struct let clear t = Hashtbl.clear t -(* # 71 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/PropList.ml" *) +(* # 71 "src/oasis/PropList.ml" *) end module Schema = @@ -593,7 +593,7 @@ module PropList = struct end module OASISMessage = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISMessage.ml" *) +(* # 21 "src/oasis/OASISMessage.ml" *) open OASISGettext @@ -632,7 +632,7 @@ module OASISMessage = struct end module OASISVersion = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISVersion.ml" *) +(* # 21 "src/oasis/OASISVersion.ml" *) open OASISGettext @@ -811,7 +811,7 @@ module OASISVersion = struct end module OASISLicense = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISLicense.ml" *) +(* # 21 "src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall @@ -851,7 +851,7 @@ module OASISLicense = struct end module OASISExpr = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISExpr.ml" *) +(* # 21 "src/oasis/OASISExpr.ml" *) @@ -941,7 +941,7 @@ module OASISExpr = struct end module OASISTypes = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) +(* # 21 "src/oasis/OASISTypes.ml" *) @@ -1018,7 +1018,7 @@ module OASISTypes = struct type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -(* # 102 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISTypes.ml" *) +(* # 102 "src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices @@ -1176,7 +1176,7 @@ module OASISTypes = struct end module OASISUnixPath = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISUnixPath.ml" *) +(* # 21 "src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string @@ -1260,7 +1260,7 @@ module OASISUnixPath = struct end module OASISHostPath = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" *) +(* # 21 "src/oasis/OASISHostPath.ml" *) open Filename @@ -1293,7 +1293,7 @@ module OASISHostPath = struct end module OASISSection = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISSection.ml" *) +(* # 21 "src/oasis/OASISSection.ml" *) open OASISTypes @@ -1372,12 +1372,12 @@ module OASISSection = struct end module OASISBuildSection = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" *) +(* # 21 "src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISExecutable.ml" *) +(* # 21 "src/oasis/OASISExecutable.ml" *) open OASISTypes @@ -1408,7 +1408,7 @@ module OASISExecutable = struct end module OASISLibrary = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" *) +(* # 21 "src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils @@ -1841,32 +1841,32 @@ module OASISLibrary = struct end module OASISFlag = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISFlag.ml" *) +(* # 21 "src/oasis/OASISFlag.ml" *) end module OASISPackage = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISPackage.ml" *) +(* # 21 "src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" *) +(* # 21 "src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISTest.ml" *) +(* # 21 "src/oasis/OASISTest.ml" *) end module OASISDocument = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISDocument.ml" *) +(* # 21 "src/oasis/OASISDocument.ml" *) end module OASISExec = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISExec.ml" *) +(* # 21 "src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils @@ -1944,7 +1944,7 @@ module OASISExec = struct end module OASISFileUtil = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" *) +(* # 21 "src/oasis/OASISFileUtil.ml" *) open OASISGettext @@ -2141,7 +2141,7 @@ end # 2142 "setup.ml" module BaseEnvLight = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseEnvLight.ml" *) +(* # 21 "src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) @@ -2239,7 +2239,7 @@ end # 2240 "setup.ml" module BaseContext = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseContext.ml" *) +(* # 21 "src/base/BaseContext.ml" *) open OASISContext @@ -2250,7 +2250,7 @@ module BaseContext = struct end module BaseMessage = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseMessage.ml" *) +(* # 21 "src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall @@ -2269,7 +2269,7 @@ module BaseMessage = struct end module BaseEnv = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseEnv.ml" *) +(* # 21 "src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils @@ -2729,7 +2729,7 @@ module BaseEnv = struct end module BaseArgExt = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseArgExt.ml" *) +(* # 21 "src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext @@ -2757,7 +2757,7 @@ module BaseArgExt = struct end module BaseCheck = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseCheck.ml" *) +(* # 21 "src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage @@ -2883,7 +2883,7 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseOCamlcConfig.ml" *) +(* # 21 "src/base/BaseOCamlcConfig.ml" *) open BaseEnv @@ -2999,7 +2999,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseStandardVar.ml" *) +(* # 21 "src/base/BaseStandardVar.ml" *) open OASISGettext @@ -3363,7 +3363,7 @@ module BaseStandardVar = struct end module BaseFileAB = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseFileAB.ml" *) +(* # 21 "src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext @@ -3411,7 +3411,7 @@ module BaseFileAB = struct end module BaseLog = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseLog.ml" *) +(* # 21 "src/base/BaseLog.ml" *) open OASISUtils @@ -3530,7 +3530,7 @@ module BaseLog = struct end module BaseBuilt = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseBuilt.ml" *) +(* # 21 "src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext @@ -3677,7 +3677,7 @@ module BaseBuilt = struct end module BaseCustom = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseCustom.ml" *) +(* # 21 "src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage @@ -3727,7 +3727,7 @@ module BaseCustom = struct end module BaseDynVar = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseDynVar.ml" *) +(* # 21 "src/base/BaseDynVar.ml" *) open OASISTypes @@ -3774,7 +3774,7 @@ module BaseDynVar = struct end module BaseTest = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseTest.ml" *) +(* # 21 "src/base/BaseTest.ml" *) open BaseEnv open BaseMessage @@ -3864,7 +3864,7 @@ module BaseTest = struct end module BaseDoc = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseDoc.ml" *) +(* # 21 "src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage @@ -3899,7 +3899,7 @@ module BaseDoc = struct end module BaseSetup = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseSetup.ml" *) +(* # 21 "src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage @@ -4479,7 +4479,7 @@ end # 4480 "setup.ml" module InternalConfigurePlugin = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" *) +(* # 21 "src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall @@ -4721,7 +4721,7 @@ module InternalConfigurePlugin = struct end module InternalInstallPlugin = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/plugins/internal/InternalInstallPlugin.ml" *) +(* # 21 "src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall @@ -5232,7 +5232,7 @@ end # 5233 "setup.ml" module OCamlbuildCommon = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) +(* # 21 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) @@ -5334,7 +5334,7 @@ module OCamlbuildCommon = struct end module OCamlbuildPlugin = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) +(* # 21 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall @@ -5507,7 +5507,7 @@ module OCamlbuildPlugin = struct end module OCamlbuildDocPlugin = struct -(* # 21 "/root/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) +(* # 21 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall @@ -5578,7 +5578,7 @@ let setup_t = ocaml_version = None; findlib_version = None; name = "stdext"; - version = "0.9.0"; + version = "0.9.1"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -5714,7 +5714,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.0"; - oasis_digest = Some "2P\225w\137\b\181i\2368\024\171N\138E+"; + oasis_digest = Some "\207\020\127\000C[[\001T2\211)$\014\191."; oasis_exec = None; oasis_setup_args = []; setup_update = false; From 269961eab62866f2c1cbbd35e8447ab5dce1711d Mon Sep 17 00:00:00 2001 From: David Scott Date: Tue, 8 Oct 2013 09:56:49 +0100 Subject: [PATCH 017/199] Remove Tar We should use ocaml-tar instead. Signed-off-by: David Scott --- _oasis | 2 +- lib/stdext.mllib | 3 +- lib/tar.ml | 376 ----------------------------------------------- lib/tar.mli | 112 -------------- setup.ml | 7 +- 5 files changed, 5 insertions(+), 495 deletions(-) delete mode 100644 lib/tar.ml delete mode 100644 lib/tar.mli diff --git a/_oasis b/_oasis index 5c717af648e..8cf67b88a44 100644 --- a/_oasis +++ b/_oasis @@ -10,7 +10,7 @@ Plugins: DevFiles (0.3), META (0.3) Library stdext Path: lib - Modules: Arrayext, Backtrace, Base64, Bigbuffer, Config, Date, Either, Encodings, ExtentlistSet, Filenameext, Fring, Fun, Hashtblext, Int64ext, LazyList, Listext, Mapext, Monad, Opt, Pervasiveext, Qring, Range, Ring, Stringext, Tar, Threadext, Trie, Unixext, VIO, Zerocheck + Modules: Arrayext, Backtrace, Base64, Bigbuffer, Config, Date, Either, Encodings, ExtentlistSet, Filenameext, Fring, Fun, Hashtblext, Int64ext, LazyList, Listext, Mapext, Monad, Opt, Pervasiveext, Qring, Range, Ring, Stringext, Threadext, Trie, Unixext, VIO, Zerocheck CSources: unixext_open_stubs.c, unixext_stubs.c, unixext_write_stubs.c, zerocheck_stub.c BuildDepends: threads, uuidm, unix, fd-send-recv, bigarray diff --git a/lib/stdext.mllib b/lib/stdext.mllib index c21ebcf1a06..7777edc7e70 100644 --- a/lib/stdext.mllib +++ b/lib/stdext.mllib @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: c0d4900aa146cbadd2648012f63e1a0d) +# DO NOT EDIT (digest: 5624266dc569a5630eaf94478b6cbce9) Arrayext Backtrace Base64 @@ -24,7 +24,6 @@ Qring Range Ring Stringext -Tar Threadext Trie Unixext diff --git a/lib/tar.ml b/lib/tar.ml deleted file mode 100644 index fd4dac552c8..00000000000 --- a/lib/tar.ml +++ /dev/null @@ -1,376 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -open Stringext -open Unixext - -(** Process and create tar file headers *) -module Header = struct - (** Map of field name -> (start offset, length) taken from wikipedia: - http://en.wikipedia.org/w/index.php?title=Tar_%28file_format%29&oldid=83554041 *) - - let offset_size_table = [ "file_name", (0, 100); - "file_mode", (100, 8); - "user_id", (108, 8); - "group_id", (116, 8); - "file_size", (124, 12); - "mod_time", (136, 12); - "chksum", (148, 8); - "link", (156, 1); - "link_name", (157, 100); ] - - (** Extract the raw string corresponding to field named 'name' *) - let getfield (x: string) (name: string) = - if not(List.mem_assoc name offset_size_table) - then failwith (Printf.sprintf "Unknown tar header field: %s" name); - let start, length = List.assoc name offset_size_table in - String.sub x start length - - (** Set the raw data corresponding to the field named 'name' *) - let setfield (x: string) (name: string) (data: string) = - if not(List.mem_assoc name offset_size_table) - then failwith (Printf.sprintf "Unknown tar header field: %s" name); - let start, length = List.assoc name offset_size_table in - if String.length data > length - then failwith (Printf.sprintf "Data for field %s too large" name); - String.blit data 0 x start (String.length data) - - (** Return the size of the field named 'name' *) - let fieldsize (name: string) = - if not(List.mem_assoc name offset_size_table) - then failwith (Printf.sprintf "Unknown tar header field: %s" name); - snd(List.assoc name offset_size_table) - - (** Represents a standard (non-USTAR) archive (note checksum not stored) *) - type t = { file_name: string; - file_mode: int; - user_id: int; - group_id: int; - file_size: int64; - mod_time: int64; - link: bool; - link_name: int; - } - - (** Helper function to make a simple header *) - let make ?(file_mode=0) ?(user_id=0) ?(group_id=0) ?(mod_time=0L) ?(link=false) ?(link_name=0) file_name file_size = - { file_name = file_name; - file_mode = file_mode; - user_id = user_id; - group_id = group_id; - file_size = file_size; - mod_time = mod_time; - link = link; - link_name = link_name } - - (** Length of a header block *) - let length = 512 - - (** A blank header block (two of these in series mark the end of the tar) *) - let zero_block = String.make length '\000' - - (** Return a string containing 'x' padded out to 'n' bytes by adding 'c' to the LHS *) - let pad_left (x: string) (n: int) (c: char) = - if String.length x >= n then x - else let buffer = String.make n c in - String.blit x 0 buffer (n - (String.length x)) (String.length x); - buffer - - (** Return a string containing 'x' padded out to 'n' bytes by adding 'c' to the RHS *) - let pad_right (x: string) (n: int) (c: char) = - if String.length x >= n then x - else let buffer = String.make n c in - String.blit x 0 buffer 0 (String.length x); - buffer - - (** Pretty-print the header record *) - let to_detailed_string (x: t) = - let table = [ "file_name", x.file_name; - "file_mode", string_of_int x.file_mode; - "user_id", string_of_int x.user_id; - "group_id", string_of_int x.group_id; - "file_size", Int64.to_string x.file_size; - "mod_time", Int64.to_string x.mod_time; - "link", string_of_bool x.link; - "link_name", string_of_int x.link_name ] in - "{\n" ^ (String.concat "\n\t" (List.map (fun (k, v) -> k ^ ": " ^ v) table)) ^ "}" - - (** Make a single line summary which looks like the output of tar -tv *) - let to_summary_string (x: t) = - (* -rw-r--r-- *) - let mode = Printf.sprintf "%010d" x.file_mode in - (* root/root *) - let usergroup = Printf.sprintf "%d/%d" x.user_id x.group_id in - let size = pad_right (Int64.to_string x.file_size) 8 ' ' in - let time = Unix.gmtime (Int64.to_float x.mod_time) in - let time = Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d" - (time.Unix.tm_year + 1900) (time.Unix.tm_mon + 1) time.Unix.tm_mday - time.Unix.tm_hour time.Unix.tm_min time.Unix.tm_sec in - Printf.sprintf "%s %s %s %s %s" mode usergroup size time x.file_name - - (** For debugging: pretty-print a string as hex *) - let to_hex (x: string) : string = - let chars = List.map (Printf.sprintf "%02x") (List.map int_of_char (String.explode x)) in - String.concat " " chars - - (** Marshal an integer field of size 'n' *) - let marshal_int (x: int) (n: int) = - let octal = Printf.sprintf "%o" x in - let result = pad_left octal (n-1) '0' in - result ^ "\000" (* space or NULL allowed *) - - (** Marshal an int64 field of size 'n' *) - let marshal_int64 (x: int64) (n: int) = - let octal = Printf.sprintf "%Lo" x in - let result = pad_left octal (n-1) '0' in - result ^ "\000" (* space or NULL allowed *) - - (** Marshal an string field of size 'n' *) - let marshal_string (x: string) (n: int) = x - - (** Return the first part of a field, before the predicate is true *) - let trim (p: char -> bool) (x: string) : string = match String.split_f p x with - | [] -> "" - | first::_ -> first - - (** Return the first part of a numerical field, before any spaces or NULLs *) - let trim_numerical (x: string) : string = trim (fun c -> c = '\000' || c = ' ') x - (** Return the first part of a string field, before any NULLs *) - let trim_string (x: string) : string = trim (fun c -> c = '\000') x - - (** Unmarshal an integer field (stored as 0-padded octal) *) - let unmarshal_int (x: string) : int = - let tmp = "0o0" ^ (trim_numerical x) in - try - int_of_string tmp - with Failure "int_of_string" as e -> - Printf.eprintf "Failed to parse integer [%s] == %s\n" tmp (to_hex tmp); - raise e - - (** Unmarshal an int64 field (stored as 0-padded octal) *) - let unmarshal_int64 (x: string) : int64 = - let tmp = "0o0" ^ (trim_numerical x) in - Int64.of_string tmp - - (** Unmarshal a string *) - let unmarshal_string (x: string) : string = trim_string x - - (** Thrown when unmarshalling a header if the checksums don't match *) - exception Checksum_mismatch - - (** From an already-marshalled block, compute what the checksum should be *) - let checksum (x: string) : int64 = - (* Sum of all the byte values of the header with the checksum field taken - as 8 ' ' (spaces) *) - let x' = String.copy x in - let start, length = List.assoc "chksum" offset_size_table in - for i = start to start + length - 1 do - x'.[i] <- ' ' - done; - List.fold_left Int64.add 0L (List.map (fun x -> Int64.of_int (int_of_char x)) (String.explode x')) - - (** Unmarshal a header block, returning None if it's all zeroes *) - let unmarshal (x: string) : t option = - (* Check if the string is full of zeros *) - if x = zero_block then None - else - let chksum = unmarshal_int64 (getfield x "chksum") in - if checksum x <> chksum then raise Checksum_mismatch - else Some { file_name = unmarshal_string (getfield x "file_name"); - file_mode = unmarshal_int (getfield x "file_mode"); - user_id = unmarshal_int (getfield x "user_id"); - group_id = unmarshal_int (getfield x "group_id"); - file_size = unmarshal_int64 (getfield x "file_size"); - mod_time = unmarshal_int64 (getfield x "mod_time"); - link = getfield x "link" = "1"; - link_name = unmarshal_int (getfield x "link_name"); - } - - (** Marshal a header block, computing and inserting the checksum *) - let marshal (x: t) : string = - let buffer = String.make length '\000' in - setfield buffer "file_name" x.file_name; - setfield buffer "file_mode" (marshal_int x.file_mode (fieldsize "file_mode")); - setfield buffer "user_id" (marshal_int x.user_id (fieldsize "user_id")); - setfield buffer "group_id" (marshal_int x.group_id (fieldsize "group_id")); - setfield buffer "file_size" (marshal_int64 x.file_size (fieldsize "file_size")); - setfield buffer "mod_time" (marshal_int64 x.mod_time (fieldsize "mod_time")); - (* leave out link, link_name (zero-filled = unused) *) - (* Finally, compute the checksum *) - let chksum = checksum buffer in - setfield buffer "chksum" (marshal_int64 chksum (fieldsize "chksum")); - buffer - - (** Thrown if we detect the end of the tar (at least two zero blocks in sequence) *) - exception End_of_stream - - (** Returns the next header block or throws End_of_stream if two consecutive - zero-filled blocks are discovered. Assumes stream is positioned at the - possible start of a header block. Unix.End_of_file is thrown if the stream - unexpectedly fails *) - let get_next_header (ifd: Unix.file_descr) : t = - let next () = - let buffer = String.make length '\000' in - really_read ifd buffer 0 length; - unmarshal buffer - in - match next () with - | Some x -> x - | None -> - begin match next () with - | Some x -> x - | None -> raise End_of_stream - end - - (** Compute the amount of zero-padding required to round up the file size - to a whole number of blocks *) - let compute_zero_padding_length (x: t) : int = - (* round up to next whole number of block lengths *) - let length = Int64.of_int length in - let lenm1 = Int64.sub length Int64.one in - let next_block_length = (Int64.mul length (Int64.div (Int64.add x.file_size lenm1) length)) in - Int64.to_int (Int64.sub next_block_length x.file_size) - - (** Return the required zero-padding as a string *) - let zero_padding (x: t) : string = - let zero_padding_len = compute_zero_padding_length x in - String.make zero_padding_len '\000' - - (** Return the header needed for a particular file on disk *) - let of_file (file: string) : t = - let stat = Unix.stat file in - let size = Int64.of_int stat.Unix.st_size in - { file_name = file; - file_mode = stat.Unix.st_perm; - user_id = stat.Unix.st_uid; - group_id = stat.Unix.st_gid; - file_size = size; - mod_time = Int64.of_float stat.Unix.st_mtime; - link = false; - link_name = 0 } -end - - -let write_string fd str = - let written = Unix.write fd str 0 (String.length str) in - if str <> "" && String.length str > written then failwith "Truncated write" - -let write_bigbuffer fd buf = - Bigbuffer.to_fct buf (write_string fd) - -let write_block (header: Header.t) (body: Unix.file_descr -> unit) (fd : Unix.file_descr) = - write_string fd (Header.marshal header); - body fd; - write_string fd (Header.zero_padding header) - -let write_end (fd: Unix.file_descr) = - write_string fd Header.zero_block; - write_string fd Header.zero_block - -(** Utility functions for operating over whole tar archives *) -module Archive = struct - - (** Skip 'n' bytes from input channel 'ifd' *) - let skip (ifd: Unix.file_descr) (n: int) = - let buffer = String.make 4096 '\000' in - let rec loop (n: int) = - if n <= 0 then () - else - let amount = min n (String.length buffer) in - let m = Unix.read ifd buffer 0 amount in - if m = 0 then raise End_of_file; - loop (n - m) in - loop n - - (** Read the next header, apply the function 'f' to the fd and the header. The function - should leave the fd positioned immediately after the datablock. Finally the function - skips past the zero padding to the next header *) - let with_next_file (fd: Unix.file_descr) (f: Unix.file_descr -> Header.t -> 'a) = - let hdr = Header.get_next_header fd in - (* NB if the function 'f' fails we're boned *) - Pervasiveext.finally (fun () -> f fd hdr) - (fun () -> skip fd (Header.compute_zero_padding_length hdr)) - - - (** Multicast 'n' bytes from input fd 'ifd' to output fds 'ofds'. NB if one deadlocks - they all stop.*) - let multicast_n ?(buffer_size=1024*1024) (ifd: Unix.file_descr) (ofds: Unix.file_descr list) (n: int64) = - let buffer = String.make buffer_size '\000' in - let rec loop (n: int64) = - if n <= 0L then () - else - let amount = Int64.to_int (min n (Int64.of_int(String.length buffer))) in - let read = Unix.read ifd buffer 0 amount in - if read = 0 then raise End_of_file; - List.iter (fun ofd -> ignore(Unix.write ofd buffer 0 read)) ofds; - loop (Int64.sub n (Int64.of_int read)) in - loop n - - let multicast_n_string buffer ofds n = - List.iter (fun ofd -> ignore(Unix.write ofd buffer 0 n)) ofds - - (** Copy 'n' bytes from input fd 'ifd' to output fd 'ofd' *) - let copy_n ifd ofd n = multicast_n ifd [ ofd ] n - - (** List the contents of a tar to stdout *) - let list fd = - try - while true do - let hdr = Header.get_next_header fd in - print_endline (Header.to_summary_string hdr); - skip fd (Int64.to_int hdr.Header.file_size); - skip fd (Header.compute_zero_padding_length hdr) - done - with - | End_of_file -> - print_endline "Unexpected end of file while reading stream" - | Header.End_of_stream -> () - - (** Extract the contents of a tar to directory 'dest' *) - let extract dest ifd = - try - while true do - let hdr = Header.get_next_header ifd in - let filename = dest ^ "/" ^ hdr.Header.file_name in - print_endline filename; - let ofd = Unix.openfile filename [Unix.O_WRONLY] 0644 in - copy_n ifd ofd hdr.Header.file_size; - skip ifd (Header.compute_zero_padding_length hdr) - done - with - | End_of_file -> - print_endline "Unexpected end of file while reading stream" - | Header.End_of_stream -> () - - (** Create a tar on file descriptor fd from the filename list 'files' *) - let create files ofd = - let file filename = - let stat = Unix.stat filename in - if stat.Unix.st_kind <> Unix.S_REG - then Printf.eprintf "Skipping %s: not a regular file\n" filename - else - let hdr = Header.of_file filename in - write_block hdr (fun ofd -> - let ifd = Unix.openfile filename [Unix.O_RDONLY] 0644 in - copy_n ifd ofd hdr.Header.file_size) ofd; - in - List.iter file files; - (* Add two empty blocks *) - write_end ofd - - -end - - - diff --git a/lib/tar.mli b/lib/tar.mli deleted file mode 100644 index 225f20c2afb..00000000000 --- a/lib/tar.mli +++ /dev/null @@ -1,112 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -(** Tar utilities *) - -module Header : sig - (** Process and create tar file headers *) - - (** Represents a standard (non-USTAR) archive (note checksum not stored) *) - type t = { - file_name : string; - file_mode: int; - user_id: int; - group_id: int; - file_size: int64; - mod_time: int64; - link: bool; - link_name: int; - } - - (** Helper function to make a simple header *) - val make : ?file_mode:int -> ?user_id:int -> ?group_id:int -> ?mod_time:int64 -> ?link:bool -> ?link_name:int -> string -> int64 -> t - - (** Length of a header block *) - val length : int - - (** A blank header block (two of these in series mark the end of the tar) *) - val zero_block : string - - (** Pretty-print the header record *) - val to_detailed_string : t -> string - - (** Make a single line summary which looks like the output of tar -tv *) - val to_summary_string : t -> string - - (** For debugging: pretty-print a string as hex *) - val to_hex : string -> string - - (** Thrown when unmarshalling a header if the checksums don't match *) - exception Checksum_mismatch - - (** Thrown if we detect the end of the tar (at least two zero blocks in sequence) *) - exception End_of_stream - - (** Unmarshal a header block, returning None if it's all zeroes *) - val unmarshal : string -> t option - - (** Marshal a header block, computing and inserting the checksum *) - val marshal : t -> string - - (** Returns the next header block or throws End_of_stream if two consecutive - zero-filled blocks are discovered. Assumes stream is positioned at the - possible start of a header block. Unix.End_of_file is thrown if the stream - unexpectedly fails *) - val get_next_header : Unix.file_descr -> t - - (** Compute the amount of zero-padding required to round up the file size - to a whole number of blocks *) - val compute_zero_padding_length : t -> int - - (** Return the required zero-padding as a string *) - val zero_padding : t -> string - - (** Return the header needed for a particular file on disk *) - val of_file : string -> t -end - -val write_string : Unix.file_descr -> string -> unit -val write_bigbuffer : Unix.file_descr -> Bigbuffer.t -> unit -val write_block : Header.t -> (Unix.file_descr -> unit) -> Unix.file_descr -> unit -val write_end : Unix.file_descr -> unit - -module Archive : sig - (** Utility functions for operating over whole tar archives *) - - (** Skip 'n' bytes from input channel 'ifd' *) - val skip : Unix.file_descr -> int -> unit - - (** Read the next header, apply the function 'f' to the fd and the header. The function - should leave the fd positioned immediately after the datablock. Finally the function - skips past the zero padding to the next header *) - val with_next_file : Unix.file_descr -> (Unix.file_descr -> Header.t -> 'a) -> 'a - - (** Multicast 'n' bytes from input fd 'ifd' to output fds 'ofds'. NB if one deadlocks - they all stop.*) - val multicast_n : ?buffer_size:int -> Unix.file_descr -> Unix.file_descr list -> int64 -> unit - - val multicast_n_string : string -> Unix.file_descr list -> int -> unit - - (** Copy 'n' bytes from input fd 'ifd' to output fd 'ofd' *) - val copy_n : Unix.file_descr -> Unix.file_descr -> int64 -> unit - - (** List the contents of a tar to stdout *) - val list : Unix.file_descr -> unit - - (** Extract the contents of a tar to directory 'dest' *) - val extract : string -> Unix.file_descr -> unit - - (** Create a tar on file descriptor fd from the filename list 'files' *) - val create : string list -> Unix.file_descr -> unit -end diff --git a/setup.ml b/setup.ml index 28f38f6235c..f9c0f781089 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 55f6d3d4128b148249f324dd06a2fd15) *) +(* DO NOT EDIT (digest: e137a657ffb7e9f8b830a64b307fc3f4) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and @@ -5693,7 +5693,6 @@ let setup_t = "Range"; "Ring"; "Stringext"; - "Tar"; "Threadext"; "Trie"; "Unixext"; @@ -5714,7 +5713,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.0"; - oasis_digest = Some "\207\020\127\000C[[\001T2\211)$\014\191."; + oasis_digest = Some "\182W\177\022$V\021IF\016\234!w\138\156<"; oasis_exec = None; oasis_setup_args = []; setup_update = false; @@ -5722,6 +5721,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 5726 "setup.ml" +# 5725 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 456d079aa1f1b055c4cc48a102849e26859cc8c0 Mon Sep 17 00:00:00 2001 From: Thomas Sanders Date: Tue, 7 Jan 2014 11:03:13 +0000 Subject: [PATCH 018/199] Temporary change to give extra details when int_of_string fails. We hope this will help with diagnosing CA-120159 etc. Signed-off-by: Thomas Sanders --- lib/pervasiveext.ml | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/lib/pervasiveext.ml b/lib/pervasiveext.ml index 4c1dadf3660..2ca52fa5773 100644 --- a/lib/pervasiveext.ml +++ b/lib/pervasiveext.ml @@ -62,3 +62,17 @@ let (++) f g x = Fun.comp f g x (* and application *) let ($) f a = f a + +(** Temporary measure to help with debugging CA-120159: extra details in int_of_string excn. *) +let int_of_string s = + try + int_of_string s + with + | Failure "int_of_string" -> + (let b = Printexc.get_backtrace () in + raise (Failure ("int_of_string (" ^ s ^ ")\n" ^ b))) + | Failure msg when (String.length msg > 13) + && (String.sub msg 0 13 = "int_of_string") + -> + (let b = Printexc.get_backtrace () in + raise (Failure (msg ^ "\n" ^ b))) From 1933e8f641b541547cfe890f690596f68e295cc0 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Wed, 7 May 2014 12:13:53 +0100 Subject: [PATCH 019/199] s/Stringext/Xstringext/g Signed-off-by: Jon Ludlam --- Makefile | 11 +- _oasis | 2 +- _tags | 36 +- configure | 4 +- lib/backtrace.ml | 4 +- lib/base64.ml | 2 +- lib/stdext.mllib | 4 +- lib/{stringext.ml => xstringext.ml} | 0 lib/{stringext.mli => xstringext.mli} | 0 myocamlbuild.ml | 346 +++-- setup.ml | 1843 +++++++++++++++++++------ 11 files changed, 1717 insertions(+), 535 deletions(-) rename lib/{stringext.ml => xstringext.ml} (100%) rename lib/{stringext.mli => xstringext.mli} (100%) diff --git a/Makefile b/Makefile index 68f2e0e9a49..3639f14addb 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: bc1e05bfc8b39b664f29dae8dbd3ebbb) +# DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954) SETUP = ocaml setup.ml @@ -12,7 +12,7 @@ doc: setup.data build test: setup.data build $(SETUP) -test $(TESTFLAGS) -all: +all: $(SETUP) -all $(ALLFLAGS) install: setup.data @@ -24,15 +24,18 @@ uninstall: setup.data reinstall: setup.data $(SETUP) -reinstall $(REINSTALLFLAGS) -clean: +clean: $(SETUP) -clean $(CLEANFLAGS) -distclean: +distclean: $(SETUP) -distclean $(DISTCLEANFLAGS) setup.data: $(SETUP) -configure $(CONFIGUREFLAGS) +configure: + $(SETUP) -configure $(CONFIGUREFLAGS) + .PHONY: build doc test all install uninstall reinstall clean distclean configure # OASIS_STOP diff --git a/_oasis b/_oasis index 8cf67b88a44..d11d0934fb6 100644 --- a/_oasis +++ b/_oasis @@ -10,7 +10,7 @@ Plugins: DevFiles (0.3), META (0.3) Library stdext Path: lib - Modules: Arrayext, Backtrace, Base64, Bigbuffer, Config, Date, Either, Encodings, ExtentlistSet, Filenameext, Fring, Fun, Hashtblext, Int64ext, LazyList, Listext, Mapext, Monad, Opt, Pervasiveext, Qring, Range, Ring, Stringext, Threadext, Trie, Unixext, VIO, Zerocheck + Modules: Arrayext, Backtrace, Base64, Bigbuffer, Config, Date, Either, Encodings, ExtentlistSet, Filenameext, Fring, Fun, Hashtblext, Int64ext, LazyList, Listext, Mapext, Monad, Opt, Pervasiveext, Qring, Range, Ring, Xstringext, Threadext, Trie, Unixext, VIO, Zerocheck CSources: unixext_open_stubs.c, unixext_stubs.c, unixext_write_stubs.c, zerocheck_stub.c BuildDepends: threads, uuidm, unix, fd-send-recv, bigarray diff --git a/_tags b/_tags index 31e4d1deaf0..a1e0d13b480 100644 --- a/_tags +++ b/_tags @@ -1,7 +1,7 @@ # OASIS_START -# DO NOT EDIT (digest: 68f404103d28eef0beaf97b7755a9c4d) -# Ignore VCS directories, you can use the same kind of rule outside -# OASIS_START/STOP if you want to exclude directories that contains +# DO NOT EDIT (digest: 97b078caaf9aa5877a841adb67d7deb6) +# Ignore VCS directories, you can use the same kind of rule outside +# OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process <**/.svn>: -traverse <**/.svn>: not_hygienic @@ -16,29 +16,29 @@ # Library stdext "lib/stdext.cmxs": use_stdext : use_libstdext_stubs +: pkg_bigarray +: pkg_fd-send-recv : pkg_threads -: pkg_uuidm : pkg_unix -: pkg_fd-send-recv -: pkg_bigarray +: pkg_uuidm +"lib/unixext_open_stubs.c": pkg_bigarray +"lib/unixext_open_stubs.c": pkg_fd-send-recv "lib/unixext_open_stubs.c": pkg_threads -"lib/unixext_open_stubs.c": pkg_uuidm "lib/unixext_open_stubs.c": pkg_unix -"lib/unixext_open_stubs.c": pkg_fd-send-recv -"lib/unixext_open_stubs.c": pkg_bigarray +"lib/unixext_open_stubs.c": pkg_uuidm +"lib/unixext_stubs.c": pkg_bigarray +"lib/unixext_stubs.c": pkg_fd-send-recv "lib/unixext_stubs.c": pkg_threads -"lib/unixext_stubs.c": pkg_uuidm "lib/unixext_stubs.c": pkg_unix -"lib/unixext_stubs.c": pkg_fd-send-recv -"lib/unixext_stubs.c": pkg_bigarray +"lib/unixext_stubs.c": pkg_uuidm +"lib/unixext_write_stubs.c": pkg_bigarray +"lib/unixext_write_stubs.c": pkg_fd-send-recv "lib/unixext_write_stubs.c": pkg_threads -"lib/unixext_write_stubs.c": pkg_uuidm "lib/unixext_write_stubs.c": pkg_unix -"lib/unixext_write_stubs.c": pkg_fd-send-recv -"lib/unixext_write_stubs.c": pkg_bigarray +"lib/unixext_write_stubs.c": pkg_uuidm +"lib/zerocheck_stub.c": pkg_bigarray +"lib/zerocheck_stub.c": pkg_fd-send-recv "lib/zerocheck_stub.c": pkg_threads -"lib/zerocheck_stub.c": pkg_uuidm "lib/zerocheck_stub.c": pkg_unix -"lib/zerocheck_stub.c": pkg_fd-send-recv -"lib/zerocheck_stub.c": pkg_bigarray +"lib/zerocheck_stub.c": pkg_uuidm # OASIS_STOP diff --git a/configure b/configure index 97ed012e660..6acfaeb953f 100755 --- a/configure +++ b/configure @@ -1,11 +1,11 @@ #!/bin/sh # OASIS_START -# DO NOT EDIT (digest: 425187ed8bfdbdd207fd76392dd243a7) +# DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) set -e FST=true -for i in "$@"; do +for i in "$@"; do if $FST; then set -- FST=false diff --git a/lib/backtrace.ml b/lib/backtrace.ml index a0d55887255..0d5985b8a51 100644 --- a/lib/backtrace.ml +++ b/lib/backtrace.ml @@ -15,7 +15,7 @@ let get_backtrace () = let b = Printexc.get_backtrace () in let nicify_locator s = try - match Stringext.String.split ',' s with + match Xstringext.String.split ',' s with | file :: line :: character :: [] -> let i = String.index_from file 0 '"' + 1 in let i2 = String.index_from file i '"' in @@ -26,7 +26,7 @@ let get_backtrace () = with _ -> s in try - let list = Stringext.String.split '\n' b in + let list = Xstringext.String.split '\n' b in let list = List.filter ((<>) "") list in "Raised at " ^ (String.concat " -> " (List.map nicify_locator list)) with _ -> diff --git a/lib/base64.ml b/lib/base64.ml index 1713e804369..4de817877cd 100644 --- a/lib/base64.ml +++ b/lib/base64.ml @@ -11,7 +11,7 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -open Stringext +open Xstringext let code = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" let padding = '=' diff --git a/lib/stdext.mllib b/lib/stdext.mllib index 7777edc7e70..a6c9d9ccf43 100644 --- a/lib/stdext.mllib +++ b/lib/stdext.mllib @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 5624266dc569a5630eaf94478b6cbce9) +# DO NOT EDIT (digest: c978081ca056d24ca2e8600834c60c52) Arrayext Backtrace Base64 @@ -23,7 +23,7 @@ Pervasiveext Qring Range Ring -Stringext +Xstringext Threadext Trie Unixext diff --git a/lib/stringext.ml b/lib/xstringext.ml similarity index 100% rename from lib/stringext.ml rename to lib/xstringext.ml diff --git a/lib/stringext.mli b/lib/xstringext.mli similarity index 100% rename from lib/stringext.mli rename to lib/xstringext.mli diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 6195d316a4a..c64d730ff16 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,38 +1,49 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: e139bd233288b32e42925ee1ab4c02d9) *) +(* DO NOT EDIT (digest: b8faf3da52e902fb96e77b14b83140c9) *) module OASISGettext = struct -(* # 21 "src/oasis/OASISGettext.ml" *) +(* # 22 "src/oasis/OASISGettext.ml" *) + let ns_ str = str + let s_ str = str - let f_ (str : ('a, 'b, 'c, 'd) format4) = + + let f_ (str: ('a, 'b, 'c, 'd) format4) = str + let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" + let init = [] + end module OASISExpr = struct -(* # 21 "src/oasis/OASISExpr.ml" *) +(* # 22 "src/oasis/OASISExpr.ml" *) + + open OASISGettext - type test = string - type flag = string + type test = string + + + type flag = string + type t = | EBool of bool @@ -41,9 +52,11 @@ module OASISExpr = struct | EOr of t * t | EFlag of flag | ETest of test * string - - type 'a choices = (t * 'a) list + + + type 'a choices = (t * 'a) list + let eval var_get t = let rec eval' = @@ -75,6 +88,7 @@ module OASISExpr = struct in eval' t + let choose ?printer ?name var_get lst = let rec choose_aux = function @@ -111,22 +125,27 @@ module OASISExpr = struct in choose_aux (List.rev lst) + end -# 117 "myocamlbuild.ml" +# 132 "myocamlbuild.ml" module BaseEnvLight = struct -(* # 21 "src/base/BaseEnvLight.ml" *) +(* # 22 "src/base/BaseEnvLight.ml" *) + module MapString = Map.Make(String) + type t = string MapString.t + let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" + let load ?(allow_empty=false) ?(filename=default_filename) () = if Sys.file_exists filename then begin @@ -184,26 +203,29 @@ module BaseEnvLight = struct filename) end - let var_get name env = - let rec var_expand str = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff + + let rec var_expand str env = + let buff = + Buffer.create ((String.length str) * 2) in - var_expand (MapString.find name env) + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) env + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + + + let var_get name env = + var_expand (MapString.find name env) env + let var_choose lst env = OASISExpr.choose @@ -212,87 +234,153 @@ module BaseEnvLight = struct end -# 215 "myocamlbuild.ml" +# 237 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct -(* # 21 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) +(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) + - (** OCamlbuild extension, copied from + (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild * by N. Pouillard and others * * Updated on 2009/02/28 * - * Modified by Sylvain Le Gall + * Modified by Sylvain Le Gall *) open Ocamlbuild_plugin + (* these functions are not really officially exported *) - let run_and_read = + let run_and_read = Ocamlbuild_pack.My_unix.run_and_read - let blank_sep_strings = + + let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings - let split s ch = - let x = - ref [] + + let exec_from_conf exec = + let exec = + let env_filename = Pathname.basename BaseEnvLight.default_filename in + let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in + try + BaseEnvLight.var_get exec env + with Not_found -> + Printf.eprintf "W: Cannot get variable %s\n" exec; + exec + in + let fix_win32 str = + if Sys.os_type = "Win32" then begin + let buff = Buffer.create (String.length str) in + (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. + *) + String.iter + (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) + str; + Buffer.contents buff + end else begin + str + end in - let rec go s = - let pos = - String.index s ch - in - x := (String.before s pos)::!x; - go (String.after s (pos + 1)) + fix_win32 exec + + let split s ch = + let buf = Buffer.create 13 in + let x = ref [] in + let flush () = + x := (Buffer.contents buf) :: !x; + Buffer.clear buf in - try - go s - with Not_found -> !x + String.iter + (fun c -> + if c = ch then + flush () + else + Buffer.add_char buf c) + s; + flush (); + List.rev !x + let split_nl s = split s '\n' + let before_space s = try String.before s (String.index s ' ') with Not_found -> s - (* this lists all supported packages *) + (* ocamlfind command *) + let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] + + (* This lists all supported packages. *) let find_packages () = List.map before_space (split_nl & run_and_read "ocamlfind list") - (* this is supposed to list available syntaxes, but I don't know how to do it. *) + + (* Mock to list available syntaxes. *) let find_syntaxes () = ["camlp4o"; "camlp4r"] - (* ocamlfind command *) - let ocamlfind x = S[A"ocamlfind"; x] + + let well_known_syntax = [ + "camlp4.quotations.o"; + "camlp4.quotations.r"; + "camlp4.exceptiontracer"; + "camlp4.extend"; + "camlp4.foldgenerator"; + "camlp4.listcomprehension"; + "camlp4.locationstripper"; + "camlp4.macro"; + "camlp4.mapgenerator"; + "camlp4.metagenerator"; + "camlp4.profiler"; + "camlp4.tracer" + ] + let dispatch = function - | Before_options -> - (* by using Before_options one let command line options have an higher priority *) - (* on the contrary using After_options will guarantee to have the higher priority *) - (* override default commands by ocamlfind ones *) + | After_options -> + (* By using Before_options one let command line options have an higher + * priority on the contrary using After_options will guarantee to have + * the higher priority override default commands by ocamlfind ones *) Options.ocamlc := ocamlfind & A"ocamlc"; Options.ocamlopt := ocamlfind & A"ocamlopt"; Options.ocamldep := ocamlfind & A"ocamldep"; Options.ocamldoc := ocamlfind & A"ocamldoc"; - Options.ocamlmktop := ocamlfind & A"ocamlmktop" - + Options.ocamlmktop := ocamlfind & A"ocamlmktop"; + Options.ocamlmklib := ocamlfind & A"ocamlmklib" + | After_rules -> - - (* When one link an OCaml library/binary/package, one should use -linkpkg *) + + (* When one link an OCaml library/binary/package, one should use + * -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; - + (* For each ocamlfind package one inject the -package option when * compiling, computing dependencies, generating documentation and * linking. *) - List.iter + List.iter begin fun pkg -> - flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg]; - end + let base_args = [A"-package"; A pkg] in + (* TODO: consider how to really choose camlp4o or camlp4r. *) + let syn_args = [A"-syntax"; A "camlp4o"] in + let args = + (* Heuristic to identify syntax extensions: whether they end in + ".syntax"; some might not. + *) + if Filename.check_suffix pkg "syntax" || + List.mem pkg well_known_syntax then + syn_args @ base_args + else + base_args + in + flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; + flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; + flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; + flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; + flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; + end (find_packages ()); (* Like -package but for extensions syntax. Morover -syntax is useless @@ -301,29 +389,34 @@ module MyOCamlbuildFindlib = struct flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & + S[A"-syntax"; A syntax]; end (find_syntaxes ()); (* The default "thread" tag is not compatible with ocamlfind. * Indeed, the default rules add the "threads.cma" or "threads.cmxa" * options when using this tag. When using the "-linkpkg" option with * ocamlfind, this module will then be added twice on the command line. - * + * * To solve this, one approach is to add the "-thread" option when using * the "threads" package using the previous plugin. *) flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]) + flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); + flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); - | _ -> + | _ -> () - end module MyOCamlbuildBase = struct -(* # 21 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -331,51 +424,61 @@ module MyOCamlbuildBase = struct + + open Ocamlbuild_plugin module OC = Ocamlbuild_pack.Ocaml_compiler - type dir = string - type file = string - type name = string - type tag = string -(* # 56 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + type dir = string + type file = string + type name = string + type tag = string + + +(* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + type t = { - lib_ocaml: (name * dir list) list; - lib_c: (name * dir * file list) list; + lib_ocaml: (name * dir list * string list) list; + lib_c: (name * dir * file list) list; flags: (tag list * (spec OASISExpr.choices)) list; (* Replace the 'dir: include' from _tags by a precise interdepends in * directory. *) - includes: (dir * dir list) list; - } + includes: (dir * dir list) list; + } + let env_filename = - Pathname.basename + Pathname.basename BaseEnvLight.default_filename + let dispatch_combine lst = fun e -> - List.iter + List.iter (fun dispatch -> dispatch e) - lst + lst + let tag_libstubs nm = "use_lib"^nm^"_stubs" + let nm_libstubs nm = nm^"_stubs" - let dispatch t e = - let env = - BaseEnvLight.load - ~filename:env_filename + + let dispatch t e = + let env = + BaseEnvLight.load + ~filename:env_filename ~allow_empty:true () in - match e with + match e with | Before_options -> let no_trailing_dot s = if String.length s >= 1 && s.[0] = '.' then @@ -385,35 +488,44 @@ module MyOCamlbuildBase = struct in List.iter (fun (opt, var) -> - try + try opt := no_trailing_dot (BaseEnvLight.var_get var env) with Not_found -> - Printf.eprintf "W: Cannot get variable %s" var) + Printf.eprintf "W: Cannot get variable %s\n" var) [ Options.ext_obj, "ext_obj"; Options.ext_lib, "ext_lib"; Options.ext_dll, "ext_dll"; ] - | After_rules -> + | After_rules -> (* Declare OCaml libraries *) - List.iter + List.iter (function - | nm, [] -> - ocaml_lib nm - | nm, dir :: tl -> + | nm, [], intf_modules -> + ocaml_lib nm; + let cmis = + List.map (fun m -> (String.uncapitalize m) ^ ".cmi") + intf_modules in + dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis + | nm, dir :: tl, intf_modules -> ocaml_lib ~dir:dir (dir^"/"^nm); - List.iter - (fun dir -> + List.iter + (fun dir -> List.iter (fun str -> flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) ["compile"; "infer_interface"; "doc"]) - tl) + tl; + let cmis = + List.map (fun m -> dir^"/"^(String.uncapitalize m)^".cmi") + intf_modules in + dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] + cmis) t.lib_ocaml; (* Declare directories dependencies, replace "include" in _tags. *) - List.iter + List.iter (fun (dir, include_dirs) -> Pathname.define_context dir include_dirs) t.includes; @@ -428,7 +540,7 @@ module MyOCamlbuildBase = struct flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); - + flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); @@ -443,11 +555,11 @@ module MyOCamlbuildBase = struct (* TODO: be more specific about what depends on headers *) (* Depends on .h files *) - dep ["compile"; "c"] + dep ["compile"; "c"] headers; (* Setup search path for lib *) - flag ["link"; "ocaml"; "use_"^lib] + flag ["link"; "ocaml"; "use_"^lib] (S[A"-I"; P(dir)]); ) t.lib_c; @@ -455,37 +567,43 @@ module MyOCamlbuildBase = struct (* Add flags *) List.iter (fun (tags, cond_specs) -> - let spec = - BaseEnvLight.var_choose cond_specs env + let spec = BaseEnvLight.var_choose cond_specs env in + let rec eval_specs = + function + | S lst -> S (List.map eval_specs lst) + | A str -> A (BaseEnvLight.var_expand str env) + | spec -> spec in - flag tags & spec) + flag tags & (eval_specs spec)) t.flags - | _ -> + | _ -> () + let dispatch_default t = - dispatch_combine + dispatch_combine [ dispatch t; MyOCamlbuildFindlib.dispatch; ] + end -# 476 "myocamlbuild.ml" +# 594 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { - MyOCamlbuildBase.lib_ocaml = [("stdext", ["lib"])]; + MyOCamlbuildBase.lib_ocaml = [("stdext", ["lib"], [])]; lib_c = [("stdext", "lib", [])]; flags = []; - includes = []; - } + includes = [] + } ;; let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; -# 490 "myocamlbuild.ml" +# 608 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/setup.ml b/setup.ml index f9c0f781089..d5d098901ef 100644 --- a/setup.ml +++ b/setup.ml @@ -1,48 +1,58 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: e137a657ffb7e9f8b830a64b307fc3f4) *) +(* DO NOT EDIT (digest: b645ca291090034a33aada1d81713d4b) *) (* - Regenerated by OASIS v0.3.0 + Regenerated by OASIS v0.4.4 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -(* # 21 "src/oasis/OASISGettext.ml" *) +(* # 22 "src/oasis/OASISGettext.ml" *) + let ns_ str = str + let s_ str = str - let f_ (str : ('a, 'b, 'c, 'd) format4) = + + let f_ (str: ('a, 'b, 'c, 'd) format4) = str + let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" + let init = [] + end module OASISContext = struct -(* # 21 "src/oasis/OASISContext.ml" *) +(* # 22 "src/oasis/OASISContext.ml" *) + open OASISGettext + type level = [ `Debug | `Info | `Warning | `Error] + type t = { + (* TODO: replace this by a proplist. *) quiet: bool; info: bool; debug: bool; @@ -51,6 +61,7 @@ module OASISContext = struct printf: level -> string -> unit; } + let printf lvl str = let beg = match lvl with @@ -61,6 +72,7 @@ module OASISContext = struct in prerr_endline (beg^str) + let default = ref { @@ -72,37 +84,50 @@ module OASISContext = struct printf = printf; } + let quiet = {!default with quiet = true} - let args () = + let fspecs () = + (* TODO: don't act on default. *) + let ignore_plugins = ref false in ["-quiet", Arg.Unit (fun () -> default := {!default with quiet = true}), - (s_ " Run quietly"); + s_ " Run quietly"; "-info", Arg.Unit (fun () -> default := {!default with info = true}), - (s_ " Display information message"); + s_ " Display information message"; "-debug", Arg.Unit (fun () -> default := {!default with debug = true}), - (s_ " Output debug message")] + s_ " Output debug message"; + + "-ignore-plugins", + Arg.Set ignore_plugins, + s_ " Ignore plugin's field."; + + "-C", + (* TODO: remove this chdir. *) + Arg.String (fun str -> Sys.chdir str), + s_ "dir Change directory before running."], + fun () -> {!default with ignore_plugins = !ignore_plugins} end module OASISString = struct -(* # 1 "src/oasis/OASISString.ml" *) - +(* # 22 "src/oasis/OASISString.ml" *) (** Various string utilities. - + Mostly inspired by extlib and batteries ExtString and BatString libraries. @author Sylvain Le Gall *) + let nsplitf str f = if str = "" then [] @@ -123,16 +148,18 @@ module OASISString = struct push (); List.rev !lst + (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the separator. *) let nsplit str c = nsplitf str ((=) c) + let find ~what ?(offset=0) str = let what_idx = ref 0 in - let str_idx = ref offset in - while !str_idx < String.length str && + let str_idx = ref offset in + while !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx @@ -142,16 +169,18 @@ module OASISString = struct done; if !what_idx <> String.length what then raise Not_found - else + else !str_idx - !what_idx - let sub_start str len = + + let sub_start str len = let str_len = String.length str in if len >= str_len then "" else String.sub str len (str_len - len) + let sub_end ?(offset=0) str len = let str_len = String.length str in if len >= str_len then @@ -159,12 +188,13 @@ module OASISString = struct else String.sub str 0 (str_len - len) + let starts_with ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in let ok = ref true in while !ok && - !str_idx < String.length str && + !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx @@ -174,21 +204,23 @@ module OASISString = struct done; if !what_idx = String.length what then true - else + else false + let strip_starts_with ~what str = if starts_with ~what str then sub_start str (String.length what) else raise Not_found + let ends_with ~what ?(offset=0) str = let what_idx = ref ((String.length what) - 1) in let str_idx = ref ((String.length str) - 1) in let ok = ref true in while !ok && - offset <= !str_idx && + offset <= !str_idx && 0 <= !what_idx do if str.[!str_idx] = what.[!what_idx] then decr what_idx @@ -198,15 +230,17 @@ module OASISString = struct done; if !what_idx = -1 then true - else + else false + let strip_ends_with ~what str = if ends_with ~what str then sub_end str (String.length what) else raise Not_found + let replace_chars f s = let buf = String.make (String.length s) 'X' in for i = 0 to String.length s - 1 do @@ -214,37 +248,78 @@ module OASISString = struct done; buf + end module OASISUtils = struct -(* # 21 "src/oasis/OASISUtils.ml" *) +(* # 22 "src/oasis/OASISUtils.ml" *) + open OASISGettext - module MapString = Map.Make(String) - let map_string_of_assoc assoc = - List.fold_left - (fun acc (k, v) -> MapString.add k v acc) - MapString.empty - assoc + module MapExt = + struct + module type S = + sig + include Map.S + val add_list: 'a t -> (key * 'a) list -> 'a t + val of_list: (key * 'a) list -> 'a t + val to_list: 'a t -> (key * 'a) list + end + + module Make (Ord: Map.OrderedType) = + struct + include Map.Make(Ord) + + let rec add_list t = + function + | (k, v) :: tl -> add_list (add k v t) tl + | [] -> t - module SetString = Set.Make(String) + let of_list lst = add_list empty lst + + let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] + end + end + + + module MapString = MapExt.Make(String) + + + module SetExt = + struct + module type S = + sig + include Set.S + val add_list: t -> elt list -> t + val of_list: elt list -> t + val to_list: t -> elt list + end + + module Make (Ord: Set.OrderedType) = + struct + include Set.Make(Ord) + + let rec add_list t = + function + | e :: tl -> add_list (add e t) tl + | [] -> t + + let of_list lst = add_list empty lst + + let to_list = elements + end + end - let set_string_add_list st lst = - List.fold_left - (fun acc e -> SetString.add e acc) - st - lst - let set_string_of_list = - set_string_add_list - SetString.empty + module SetString = SetExt.Make(String) let compare_csl s1 s2 = String.compare (String.lowercase s1) (String.lowercase s2) + module HashStringCsl = Hashtbl.Make (struct @@ -257,6 +332,14 @@ module OASISUtils = struct Hashtbl.hash (String.lowercase s) end) + module SetStringCsl = + SetExt.Make + (struct + type t = string + let compare = compare_csl + end) + + let varname_of_string ?(hyphen='_') s = if String.length s = 0 then begin @@ -287,6 +370,7 @@ module OASISUtils = struct String.lowercase buf end + let varname_concat ?(hyphen='_') p s = let what = String.make 1 hyphen in let p = @@ -307,42 +391,49 @@ module OASISUtils = struct let is_varname str = str = varname_of_string str + let failwithf fmt = Printf.ksprintf failwith fmt + end module PropList = struct -(* # 21 "src/oasis/PropList.ml" *) +(* # 22 "src/oasis/PropList.ml" *) + open OASISGettext + type name = string + exception Not_set of name * string option exception No_printer of name exception Unknown_field of name * name + let () = Printexc.register_printer (function | Not_set (nm, Some rsn) -> - Some + Some (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) | Not_set (nm, None) -> - Some + Some (Printf.sprintf (f_ "Field '%s' is not set") nm) | No_printer nm -> Some (Printf.sprintf (f_ "No default printer for value %s") nm) | Unknown_field (nm, schm) -> - Some - (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm) + Some + (Printf.sprintf + (f_ "Field %s is not defined in schema %s") nm schm) | _ -> None) + module Data = struct - type t = (name, unit -> unit) Hashtbl.t @@ -352,12 +443,13 @@ module PropList = struct let clear t = Hashtbl.clear t -(* # 71 "src/oasis/PropList.ml" *) + +(* # 78 "src/oasis/PropList.ml" *) end + module Schema = struct - type ('ctxt, 'extra) value = { get: Data.t -> string; @@ -445,9 +537,9 @@ module PropList = struct t.name end + module Field = struct - type ('ctxt, 'value, 'extra) t = { set: Data.t -> ?context:'ctxt -> 'value -> unit; @@ -577,28 +669,27 @@ module PropList = struct let fgets data t = t.gets data - end + module FieldRO = struct - let create ?schema ?name ?parse ?print ?default ?update ?help extra = let fld = Field.create ?schema ?name ?parse ?print ?default ?update ?help extra in fun data -> Field.fget data fld - end end module OASISMessage = struct -(* # 21 "src/oasis/OASISMessage.ml" *) +(* # 22 "src/oasis/OASISMessage.ml" *) open OASISGettext open OASISContext + let generic_message ~ctxt lvl fmt = let cond = if ctxt.quiet then @@ -617,30 +708,39 @@ module OASISMessage = struct end) fmt + let debug ~ctxt fmt = generic_message ~ctxt `Debug fmt + let info ~ctxt fmt = generic_message ~ctxt `Info fmt + let warning ~ctxt fmt = generic_message ~ctxt `Warning fmt + let error ~ctxt fmt = generic_message ~ctxt `Error fmt end module OASISVersion = struct -(* # 21 "src/oasis/OASISVersion.ml" *) +(* # 22 "src/oasis/OASISVersion.ml" *) + open OASISGettext + + type s = string - type t = string + + type t = string + type comparator = | VGreater of t @@ -650,20 +750,24 @@ module OASISVersion = struct | VLesserEqual of t | VOr of comparator * comparator | VAnd of comparator * comparator - + + (* Range of allowed characters *) let is_digit c = '0' <= c && c <= '9' + let is_alpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') + let is_special = function | '.' | '+' | '-' | '~' -> true | _ -> false + let rec version_compare v1 v2 = if v1 <> "" || v2 <> "" then begin @@ -707,11 +811,11 @@ module OASISVersion = struct while !p < String.length v && is_digit v.[!p] do incr p done; - let substr = + let substr = String.sub v !p ((String.length v) - !p) - in - let res = - match String.sub v start_p (!p - start_p) with + in + let res = + match String.sub v start_p (!p - start_p) with | "" -> 0 | s -> int_of_string s in @@ -747,8 +851,14 @@ module OASISVersion = struct let version_of_string str = str + let string_of_version t = t + + let version_compare_string s1 s2 = + version_compare (version_of_string s1) (version_of_string s2) + + let chop t = try let pos = @@ -758,6 +868,7 @@ module OASISVersion = struct with Not_found -> t + let rec comparator_apply v op = match op with | VGreater cv -> @@ -775,6 +886,7 @@ module OASISVersion = struct | VAnd (op1, op2) -> (comparator_apply v op1) && (comparator_apply v op2) + let rec string_of_comparator = function | VGreater v -> "> "^(string_of_version v) @@ -787,6 +899,7 @@ module OASISVersion = struct | VAnd (c1, c2) -> (string_of_comparator c1)^" && "^(string_of_comparator c2) + let rec varname_of_comparator = let concat p v = OASISUtils.varname_concat @@ -805,13 +918,24 @@ module OASISVersion = struct | VAnd (c1, c2) -> (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) - let version_0_3_or_after t = - comparator_apply t (VGreaterEqual (string_of_version "0.3")) + + let rec comparator_ge v' = + let cmp v = version_compare v v' >= 0 in + function + | VEqual v + | VGreaterEqual v + | VGreater v -> cmp v + | VLesserEqual _ + | VLesser _ -> false + | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2 + | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2 + end module OASISLicense = struct -(* # 21 "src/oasis/OASISLicense.ml" *) +(* # 22 "src/oasis/OASISLicense.ml" *) + (** License for _oasis fields @author Sylvain Le Gall @@ -819,15 +943,20 @@ module OASISLicense = struct - type license = string - type license_exception = string + + type license = string + + + type license_exception = string + type license_version = | Version of OASISVersion.t | VersionOrLater of OASISVersion.t | NoVersion - + + type license_dep_5_unit = { @@ -835,31 +964,38 @@ module OASISLicense = struct excption: license_exception option; version: license_version; } - + + type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list | DEP5And of license_dep_5 list - + type t = | DEP5License of license_dep_5 | OtherLicense of string (* URL *) - + + end module OASISExpr = struct -(* # 21 "src/oasis/OASISExpr.ml" *) +(* # 22 "src/oasis/OASISExpr.ml" *) + + open OASISGettext - type test = string - type flag = string + type test = string + + + type flag = string + type t = | EBool of bool @@ -868,9 +1004,11 @@ module OASISExpr = struct | EOr of t * t | EFlag of flag | ETest of test * string - - type 'a choices = (t * 'a) list + + + type 'a choices = (t * 'a) list + let eval var_get t = let rec eval' = @@ -902,6 +1040,7 @@ module OASISExpr = struct in eval' t + let choose ?printer ?name var_get lst = let rec choose_aux = function @@ -938,44 +1077,66 @@ module OASISExpr = struct in choose_aux (List.rev lst) + +end + +module OASISText = struct +(* # 22 "src/oasis/OASISText.ml" *) + + + + type elt = + | Para of string + | Verbatim of string + | BlankLine + + + type t = elt list + end module OASISTypes = struct -(* # 21 "src/oasis/OASISTypes.ml" *) +(* # 22 "src/oasis/OASISTypes.ml" *) + + + type name = string + type package_name = string + type url = string + type unix_dirname = string + type unix_filename = string + type host_dirname = string + type host_filename = string + type prog = string + type arg = string + type args = string list + type command_line = (prog * arg list) - type name = string - type package_name = string - type url = string - type unix_dirname = string - type unix_filename = string - type host_dirname = string - type host_filename = string - type prog = string - type arg = string - type args = string list - type command_line = (prog * arg list) - type findlib_name = string - type findlib_full = string + type findlib_name = string + type findlib_full = string + type compiled_object = | Byte | Native | Best - + + type dependency = | FindlibPackage of findlib_full * OASISVersion.comparator option | InternalLibrary of name - + + type tool = | ExternalTool of name | InternalExecutable of name - + + type vcs = | Darcs @@ -987,7 +1148,8 @@ module OASISTypes = struct | Arch | Monotone | OtherVCS of url - + + type plugin_kind = [ `Configure @@ -998,6 +1160,7 @@ module OASISTypes = struct | `Extra ] + type plugin_data_purpose = [ `Configure | `Build @@ -1012,22 +1175,29 @@ module OASISTypes = struct | `Other of string ] - type 'a plugin = 'a * name * OASISVersion.t option + + type 'a plugin = 'a * name * OASISVersion.t option + type all_plugin = plugin_kind plugin + type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -(* # 102 "src/oasis/OASISTypes.ml" *) - type 'a conditional = 'a OASISExpr.choices +(* # 115 "src/oasis/OASISTypes.ml" *) + + + type 'a conditional = 'a OASISExpr.choices + type custom = { pre_command: (command_line option) conditional; post_command: (command_line option) conditional; } - + + type common_section = { @@ -1035,7 +1205,8 @@ module OASISTypes = struct cs_data: PropList.Data.t; cs_plugin_data: plugin_data; } - + + type build_section = { @@ -1054,7 +1225,8 @@ module OASISTypes = struct bs_byteopt: args conditional; bs_nativeopt: args conditional; } - + + type library = { @@ -1064,19 +1236,29 @@ module OASISTypes = struct lib_findlib_parent: findlib_name option; lib_findlib_name: findlib_name option; lib_findlib_containers: findlib_name list; - } + } + + + type object_ = + { + obj_modules: string list; + obj_findlib_fullname: findlib_name list option; + } + type executable = { exec_custom: bool; exec_main_is: unix_filename; - } + } + type flag = { flag_description: string option; flag_default: bool conditional; - } + } + type source_repository = { @@ -1087,7 +1269,8 @@ module OASISTypes = struct src_repo_branch: string option; src_repo_tag: string option; src_repo_subdir: unix_filename option; - } + } + type test = { @@ -1097,7 +1280,8 @@ module OASISTypes = struct test_working_directory: unix_filename option; test_run: bool conditional; test_tools: tool list; - } + } + type doc_format = | HTML of unix_filename @@ -1107,7 +1291,8 @@ module OASISTypes = struct | Info of unix_filename | DVI | OtherDoc - + + type doc = { @@ -1122,75 +1307,452 @@ module OASISTypes = struct doc_format: doc_format; doc_data_files: (unix_filename * unix_filename option) list; doc_build_tools: tool list; - } + } + type section = | Library of common_section * build_section * library + | Object of common_section * build_section * object_ | Executable of common_section * build_section * executable | Flag of common_section * flag | SrcRepo of common_section * source_repository | Test of common_section * test | Doc of common_section * doc - + + type section_kind = - [ `Library | `Executable | `Flag | `SrcRepo | `Test | `Doc ] + [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] + + + type package = + { + oasis_version: OASISVersion.t; + ocaml_version: OASISVersion.comparator option; + findlib_version: OASISVersion.comparator option; + alpha_features: string list; + beta_features: string list; + name: package_name; + version: OASISVersion.t; + license: OASISLicense.t; + license_file: unix_filename option; + copyrights: string list; + maintainers: string list; + authors: string list; + homepage: url option; + synopsis: string; + description: OASISText.t option; + categories: url list; + + conf_type: [`Configure] plugin; + conf_custom: custom; + + build_type: [`Build] plugin; + build_custom: custom; + + install_type: [`Install] plugin; + install_custom: custom; + uninstall_custom: custom; + + clean_custom: custom; + distclean_custom: custom; + + files_ab: unix_filename list; + sections: section list; + plugins: [`Extra] plugin list; + disable_oasis_section: unix_filename list; + schema_data: PropList.Data.t; + plugin_data: plugin_data; + } + + +end + +module OASISFeatures = struct +(* # 22 "src/oasis/OASISFeatures.ml" *) + + open OASISTypes + open OASISUtils + open OASISGettext + open OASISVersion + + module MapPlugin = + Map.Make + (struct + type t = plugin_kind * name + let compare = Pervasives.compare + end) + + module Data = + struct + type t = + { + oasis_version: OASISVersion.t; + plugin_versions: OASISVersion.t option MapPlugin.t; + alpha_features: string list; + beta_features: string list; + } + + let create oasis_version alpha_features beta_features = + { + oasis_version = oasis_version; + plugin_versions = MapPlugin.empty; + alpha_features = alpha_features; + beta_features = beta_features + } + + let of_package pkg = + create + pkg.OASISTypes.oasis_version + pkg.OASISTypes.alpha_features + pkg.OASISTypes.beta_features + + let add_plugin (plugin_kind, plugin_name, plugin_version) t = + {t with + plugin_versions = MapPlugin.add + (plugin_kind, plugin_name) + plugin_version + t.plugin_versions} + + let plugin_version plugin_kind plugin_name t = + MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions + + let to_string t = + Printf.sprintf + "oasis_version: %s; alpha_features: %s; beta_features: %s; \ + plugins_version: %s" + (OASISVersion.string_of_version t.oasis_version) + (String.concat ", " t.alpha_features) + (String.concat ", " t.beta_features) + (String.concat ", " + (MapPlugin.fold + (fun (_, plg) ver_opt acc -> + (plg^ + (match ver_opt with + | Some v -> + " "^(OASISVersion.string_of_version v) + | None -> "")) + :: acc) + t.plugin_versions [])) + end + + type origin = + | Field of string * string + | Section of string + | NoOrigin + + type stage = Alpha | Beta + + + let string_of_stage = + function + | Alpha -> "alpha" + | Beta -> "beta" + + + let field_of_stage = + function + | Alpha -> "AlphaFeatures" + | Beta -> "BetaFeatures" + + type publication = InDev of stage | SinceVersion of OASISVersion.t + + type t = + { + name: string; + plugin: all_plugin option; + publication: publication; + description: unit -> string; + } + + (* TODO: mutex protect this. *) + let all_features = Hashtbl.create 13 + + + let since_version ver_str = SinceVersion (version_of_string ver_str) + let alpha = InDev Alpha + let beta = InDev Beta + + + let to_string t = + Printf.sprintf + "feature: %s; plugin: %s; publication: %s" + t.name + (match t.plugin with + | None -> "" + | Some (_, nm, _) -> nm) + (match t.publication with + | InDev stage -> string_of_stage stage + | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) + + let data_check t data origin = + let no_message = "no message" in + + let check_feature features stage = + let has_feature = List.mem t.name features in + if not has_feature then + match origin with + | Field (fld, where) -> + Some + (Printf.sprintf + (f_ "Field %s in %s is only available when feature %s \ + is in field %s.") + fld where t.name (field_of_stage stage)) + | Section sct -> + Some + (Printf.sprintf + (f_ "Section %s is only available when features %s \ + is in field %s.") + sct t.name (field_of_stage stage)) + | NoOrigin -> + Some no_message + else + None + in + + let version_is_good ~min_version version fmt = + let version_is_good = + OASISVersion.comparator_apply + version (OASISVersion.VGreaterEqual min_version) + in + Printf.ksprintf + (fun str -> + if version_is_good then + None + else + Some str) + fmt + in + + match origin, t.plugin, t.publication with + | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha + | _, _, InDev Beta -> check_feature data.Data.beta_features Beta + | Field(fld, where), None, SinceVersion min_version -> + version_is_good ~min_version data.Data.oasis_version + (f_ "Field %s in %s is only valid since OASIS v%s, update \ + OASISFormat field from '%s' to '%s' after checking \ + OASIS changelog.") + fld where (string_of_version min_version) + (string_of_version data.Data.oasis_version) + (string_of_version min_version) + + | Field(fld, where), Some(plugin_knd, plugin_name, _), + SinceVersion min_version -> + begin + try + let plugin_version_current = + try + match Data.plugin_version plugin_knd plugin_name data with + | Some ver -> ver + | None -> + failwithf + (f_ "Field %s in %s is only valid for the OASIS \ + plugin %s since v%s, but no plugin version is \ + defined in the _oasis file, change '%s' to \ + '%s (%s)' in your _oasis file.") + fld where plugin_name (string_of_version min_version) + plugin_name + plugin_name (string_of_version min_version) + with Not_found -> + failwithf + (f_ "Field %s in %s is only valid when the OASIS plugin %s \ + is defined.") + fld where plugin_name + in + version_is_good ~min_version plugin_version_current + (f_ "Field %s in %s is only valid for the OASIS plugin %s \ + since v%s, update your plugin from '%s (%s)' to \ + '%s (%s)' after checking the plugin's changelog.") + fld where plugin_name (string_of_version min_version) + plugin_name (string_of_version plugin_version_current) + plugin_name (string_of_version min_version) + with Failure msg -> + Some msg + end + + | Section sct, None, SinceVersion min_version -> + version_is_good ~min_version data.Data.oasis_version + (f_ "Section %s is only valid for since OASIS v%s, update \ + OASISFormat field from '%s' to '%s' after checking OASIS \ + changelog.") + sct (string_of_version min_version) + (string_of_version data.Data.oasis_version) + (string_of_version min_version) + + | Section sct, Some(plugin_knd, plugin_name, _), + SinceVersion min_version -> + begin + try + let plugin_version_current = + try + match Data.plugin_version plugin_knd plugin_name data with + | Some ver -> ver + | None -> + failwithf + (f_ "Section %s is only valid for the OASIS \ + plugin %s since v%s, but no plugin version is \ + defined in the _oasis file, change '%s' to \ + '%s (%s)' in your _oasis file.") + sct plugin_name (string_of_version min_version) + plugin_name + plugin_name (string_of_version min_version) + with Not_found -> + failwithf + (f_ "Section %s is only valid when the OASIS plugin %s \ + is defined.") + sct plugin_name + in + version_is_good ~min_version plugin_version_current + (f_ "Section %s is only valid for the OASIS plugin %s \ + since v%s, update your plugin from '%s (%s)' to \ + '%s (%s)' after checking the plugin's changelog.") + sct plugin_name (string_of_version min_version) + plugin_name (string_of_version plugin_version_current) + plugin_name (string_of_version min_version) + with Failure msg -> + Some msg + end + + | NoOrigin, None, SinceVersion min_version -> + version_is_good ~min_version data.Data.oasis_version "%s" no_message + + | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> + begin + try + let plugin_version_current = + match Data.plugin_version plugin_knd plugin_name data with + | Some ver -> ver + | None -> raise Not_found + in + version_is_good ~min_version plugin_version_current + "%s" no_message + with Not_found -> + Some no_message + end + + + let data_assert t data origin = + match data_check t data origin with + | None -> () + | Some str -> failwith str - type package = + + let data_test t data = + match data_check t data NoOrigin with + | None -> true + | Some str -> false + + + let package_test t pkg = + data_test t (Data.of_package pkg) + + + let create ?plugin name publication description = + let () = + if Hashtbl.mem all_features name then + failwithf "Feature '%s' is already declared." name + in + let t = { - oasis_version: OASISVersion.t; - ocaml_version: OASISVersion.comparator option; - findlib_version: OASISVersion.comparator option; - name: package_name; - version: OASISVersion.t; - license: OASISLicense.t; - license_file: unix_filename option; - copyrights: string list; - maintainers: string list; - authors: string list; - homepage: url option; - synopsis: string; - description: string option; - categories: url list; - - conf_type: [`Configure] plugin; - conf_custom: custom; - - build_type: [`Build] plugin; - build_custom: custom; - - install_type: [`Install] plugin; - install_custom: custom; - uninstall_custom: custom; - - clean_custom: custom; - distclean_custom: custom; - - files_ab: unix_filename list; - sections: section list; - plugins: [`Extra] plugin list; - schema_data: PropList.Data.t; - plugin_data: plugin_data; - } + name = name; + plugin = plugin; + publication = publication; + description = description; + } + in + Hashtbl.add all_features name t; + t + + + let get_stage name = + try + (Hashtbl.find all_features name).publication + with Not_found -> + failwithf (f_ "Feature %s doesn't exist.") name + + + let list () = + Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] + + (* + * Real flags. + *) + + + let features = + create "features_fields" + (since_version "0.4") + (fun () -> + s_ "Enable to experiment not yet official features.") + + + let flag_docs = + create "flag_docs" + (since_version "0.3") + (fun () -> + s_ "Building docs require '-docs' flag at configure.") + + + let flag_tests = + create "flag_tests" + (since_version "0.3") + (fun () -> + s_ "Running tests require '-tests' flag at configure.") + + + let pack = + create "pack" + (since_version "0.3") + (fun () -> + s_ "Allow to create packed library.") + + + let section_object = + create "section_object" beta + (fun () -> + s_ "Implement an object section.") + + let dynrun_for_release = + create "dynrun_for_release" alpha + (fun () -> + s_ "Make '-setup-update dynamic' suitable for releasing project.") + + + let compiled_setup_ml = + create "compiled_setup_ml" alpha + (fun () -> + s_ "It compiles the setup.ml and speed-up actions done with it.") + + let disable_oasis_section = + create "disable_oasis_section" alpha + (fun () -> + s_ "Allows the OASIS section comments and digest to be omitted in \ + generated files.") end module OASISUnixPath = struct -(* # 21 "src/oasis/OASISUnixPath.ml" *) +(* # 22 "src/oasis/OASISUnixPath.ml" *) + type unix_filename = string type unix_dirname = string + type host_filename = string type host_dirname = string + let current_dir_name = "." + let parent_dir_name = ".." + let is_current_dir fn = fn = current_dir_name || fn = "" + let concat f1 f2 = if is_current_dir f1 then f2 @@ -1200,6 +1762,7 @@ module OASISUnixPath = struct in f1'^"/"^f2 + let make = function | hd :: tl -> @@ -1210,12 +1773,14 @@ module OASISUnixPath = struct | [] -> invalid_arg "OASISUnixPath.make" + let dirname f = try String.sub f 0 (String.rindex f '/') with Not_found -> current_dir_name + let basename f = try let pos_start = @@ -1225,6 +1790,7 @@ module OASISUnixPath = struct with Not_found -> f + let chop_extension f = try let last_dot = @@ -1247,26 +1813,31 @@ module OASISUnixPath = struct with Not_found -> f + let capitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.capitalize base) + let uncapitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.uncapitalize base) + end module OASISHostPath = struct -(* # 21 "src/oasis/OASISHostPath.ml" *) +(* # 22 "src/oasis/OASISHostPath.ml" *) open Filename + module Unix = OASISUnixPath + let make = function | [] -> @@ -1274,6 +1845,7 @@ module OASISHostPath = struct | hd :: tl -> List.fold_left Filename.concat hd tl + let of_unix ufn = if Sys.os_type = "Unix" then ufn @@ -1293,14 +1865,18 @@ module OASISHostPath = struct end module OASISSection = struct -(* # 21 "src/oasis/OASISSection.ml" *) +(* # 22 "src/oasis/OASISSection.ml" *) + open OASISTypes - let section_kind_common = + + let section_kind_common = function - | Library (cs, _, _) -> + | Library (cs, _, _) -> `Library, cs + | Object (cs, _, _) -> + `Object, cs | Executable (cs, _, _) -> `Executable, cs | Flag (cs, _) -> @@ -1312,32 +1888,38 @@ module OASISSection = struct | Doc (cs, _) -> `Doc, cs + let section_common sct = snd (section_kind_common sct) + let section_common_set cs = function | Library (_, bs, lib) -> Library (cs, bs, lib) + | Object (_, bs, obj) -> Object (cs, bs, obj) | Executable (_, bs, exec) -> Executable (cs, bs, exec) | Flag (_, flg) -> Flag (cs, flg) | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) | Test (_, tst) -> Test (cs, tst) | Doc (_, doc) -> Doc (cs, doc) + (** Key used to identify section *) - let section_id sct = - let k, cs = + let section_id sct = + let k, cs = section_kind_common sct in k, cs.cs_name + let string_of_section sct = let k, nm = section_id sct in (match k with - | `Library -> "library" + | `Library -> "library" + | `Object -> "object" | `Executable -> "executable" | `Flag -> "flag" | `SrcRepo -> "src repository" @@ -1345,20 +1927,22 @@ module OASISSection = struct | `Doc -> "doc") ^" "^nm + let section_find id scts = List.find (fun sct -> id = section_id sct) scts + module CSection = struct type t = section let id = section_id - let compare t1 t2 = + let compare t1 t2 = compare (id t1) (id t2) - + let equal t1 t2 = (id t1) = (id t2) @@ -1366,28 +1950,33 @@ module OASISSection = struct Hashtbl.hash (id t) end + module MapSection = Map.Make(CSection) module SetSection = Set.Make(CSection) + end module OASISBuildSection = struct -(* # 21 "src/oasis/OASISBuildSection.ml" *) +(* # 22 "src/oasis/OASISBuildSection.ml" *) + end module OASISExecutable = struct -(* # 21 "src/oasis/OASISExecutable.ml" *) +(* # 22 "src/oasis/OASISExecutable.ml" *) + open OASISTypes - let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = - let dir = + + let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = + let dir = OASISUnixPath.concat bs.bs_path (OASISUnixPath.dirname exec.exec_main_is) in - let is_native_exec = + let is_native_exec = match bs.bs_compiled_object with | Native -> true | Best -> is_native () @@ -1398,40 +1987,28 @@ module OASISExecutable = struct dir (cs.cs_name^(suffix_program ())), - if not is_native_exec && - not exec.exec_custom && + if not is_native_exec && + not exec.exec_custom && bs.bs_c_sources <> [] then Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) else None + end module OASISLibrary = struct -(* # 21 "src/oasis/OASISLibrary.ml" *) +(* # 22 "src/oasis/OASISLibrary.ml" *) + open OASISTypes open OASISUtils open OASISGettext open OASISSection - type library_name = name - type findlib_part_name = name - type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t - - exception InternalLibraryNotFound of library_name - exception FindlibPackageNotFound of findlib_name - - type group_t = - | Container of findlib_name * group_t list - | Package of (findlib_name * - common_section * - build_section * - library * - group_t list) (* Look for a module file, considering capitalization or not. *) - let find_module source_file_exists (cs, bs, lib) modul = + let find_module source_file_exists bs modul = let possible_base_fn = List.map (OASISUnixPath.concat bs.bs_path) @@ -1469,10 +2046,11 @@ module OASISLibrary = struct (`No_sources possible_base_fn) possible_base_fn + let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = List.fold_left (fun acc modul -> - match find_module source_file_exists (cs, bs, lib) modul with + match find_module source_file_exists bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> @@ -1485,6 +2063,7 @@ module OASISLibrary = struct [] (lib.lib_modules @ lib.lib_internal_modules) + let generated_unix_files ~ctxt ~is_native @@ -1494,24 +2073,29 @@ module OASISLibrary = struct ~source_file_exists (cs, bs, lib) = - let find_modules lst ext = + let find_modules lst ext = let find_module modul = - match find_module source_file_exists (cs, bs, lib) modul with + match find_module source_file_exists bs modul with + | `Sources (base_fn, [fn]) when ext <> "cmi" + && Filename.check_suffix fn ".mli" -> + None (* No implementation files for pure interface. *) | `Sources (base_fn, _) -> - [base_fn] + Some [base_fn] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; - lst + Some lst in - List.map - (fun nm -> - List.map - (fun base_fn -> base_fn ^"."^ext) - (find_module nm)) + List.fold_left + (fun acc nm -> + match find_module nm with + | None -> acc + | Some base_fns -> + List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) + [] lst in @@ -1528,16 +2112,20 @@ module OASISLibrary = struct (* The .cmx that be compiled along *) let cmxs = let should_be_built = - (not lib.lib_pack) && (* Do not install .cmx packed submodules *) match bs.bs_compiled_object with | Native -> true | Best -> is_native | Byte -> false in if should_be_built then - find_modules - (lib.lib_modules @ lib.lib_internal_modules) - "cmx" + if lib.lib_pack then + find_modules + [cs.cs_name] + "cmx" + else + find_modules + (lib.lib_modules @ lib.lib_internal_modules) + "cmx" else [] in @@ -1559,7 +2147,7 @@ module OASISLibrary = struct add_pack_header ([cs.cs_name^".cma"] :: acc) in let native acc = - let acc = + let acc = add_pack_header (if has_native_dynlink then [cs.cs_name^".cmxs"] :: acc @@ -1598,11 +2186,113 @@ module OASISLibrary = struct acc_nopath) (headers @ cmxs) - type data = common_section * build_section * library + +end + +module OASISObject = struct +(* # 22 "src/oasis/OASISObject.ml" *) + + + open OASISTypes + open OASISGettext + + + let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = + List.fold_left + (fun acc modul -> + match OASISLibrary.find_module source_file_exists bs modul with + | `Sources (base_fn, lst) -> + (base_fn, lst) :: acc + | `No_sources _ -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in object %s") + modul cs.cs_name; + acc) + [] + obj.obj_modules + + + let generated_unix_files + ~ctxt + ~is_native + ~source_file_exists + (cs, bs, obj) = + + let find_module ext modul = + match OASISLibrary.find_module source_file_exists bs modul with + | `Sources (base_fn, _) -> [base_fn ^ ext] + | `No_sources lst -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in object %s") + modul cs.cs_name ; + lst + in + + let header, byte, native, c_object, f = + match obj.obj_modules with + | [ m ] -> (find_module ".cmi" m, + find_module ".cmo" m, + find_module ".cmx" m, + find_module ".o" m, + fun x -> x) + | _ -> ([cs.cs_name ^ ".cmi"], + [cs.cs_name ^ ".cmo"], + [cs.cs_name ^ ".cmx"], + [cs.cs_name ^ ".o"], + OASISUnixPath.concat bs.bs_path) + in + List.map (List.map f) ( + match bs.bs_compiled_object with + | Native -> + native :: c_object :: byte :: header :: [] + | Best when is_native -> + native :: c_object :: byte :: header :: [] + | Byte | Best -> + byte :: header :: []) + + +end + +module OASISFindlib = struct +(* # 22 "src/oasis/OASISFindlib.ml" *) + + + open OASISTypes + open OASISUtils + open OASISGettext + open OASISSection + + + type library_name = name + type findlib_part_name = name + type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t + + + exception InternalLibraryNotFound of library_name + exception FindlibPackageNotFound of findlib_name + + + type group_t = + | Container of findlib_name * group_t list + | Package of (findlib_name * + common_section * + build_section * + [`Library of library | `Object of object_] * + group_t list) + + + type data = common_section * + build_section * + [`Library of library | `Object of object_] type tree = | Node of (data option) * (tree MapString.t) | Leaf of data + let findlib_mapping pkg = (* Map from library name to either full findlib name or parts + parent. *) let fndlb_parts_of_lib_name = @@ -1641,6 +2331,23 @@ module OASISLibrary = struct mp end + | Object (cs, _, obj) -> + begin + let obj_name = cs.cs_name in + if MapString.mem obj_name mp then + failwithf + (f_ "The object name '%s' is used more than once.") + obj_name; + let findlib_full_name = match obj.obj_findlib_fullname with + | Some ns -> String.concat "." ns + | None -> obj_name + in + MapString.add + obj_name + (`Solved findlib_full_name) + mp + end + | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> mp) MapString.empty @@ -1708,7 +2415,7 @@ module OASISLibrary = struct let lib_name = cs.cs_name in findlib_name_of_library_name lib_name in - let rec add_children nm_lst (children : tree MapString.t) = + let rec add_children nm_lst (children: tree MapString.t) = match nm_lst with | (hd :: tl) -> begin @@ -1778,7 +2485,9 @@ module OASISLibrary = struct (fun mp -> function | Library (cs, bs, lib) -> - add (cs, bs, lib) mp + add (cs, bs, `Library lib) mp + | Object (cs, bs, obj) -> + add (cs, bs, `Object obj) mp | _ -> mp) MapString.empty @@ -1809,11 +2518,13 @@ module OASISLibrary = struct findlib_name_of_library_name, library_name_of_findlib_name + let findlib_of_group = function | Container (fndlb_nm, _) | Package (fndlb_nm, _, _, _, _) -> fndlb_nm + let root_of_group grp = let rec root_lib_aux = (* We do a DFS in the group. *) @@ -1838,40 +2549,48 @@ module OASISLibrary = struct (f_ "Unable to determine root library of findlib library '%s'") (findlib_of_group grp) + end module OASISFlag = struct -(* # 21 "src/oasis/OASISFlag.ml" *) +(* # 22 "src/oasis/OASISFlag.ml" *) + end module OASISPackage = struct -(* # 21 "src/oasis/OASISPackage.ml" *) +(* # 22 "src/oasis/OASISPackage.ml" *) + end module OASISSourceRepository = struct -(* # 21 "src/oasis/OASISSourceRepository.ml" *) +(* # 22 "src/oasis/OASISSourceRepository.ml" *) + end module OASISTest = struct -(* # 21 "src/oasis/OASISTest.ml" *) +(* # 22 "src/oasis/OASISTest.ml" *) + end module OASISDocument = struct -(* # 21 "src/oasis/OASISDocument.ml" *) +(* # 22 "src/oasis/OASISDocument.ml" *) + end module OASISExec = struct -(* # 21 "src/oasis/OASISExec.ml" *) +(* # 22 "src/oasis/OASISExec.ml" *) + open OASISGettext open OASISUtils open OASISMessage + (* TODO: I don't like this quote, it is there because $(rm) foo expands to * 'rm -f' foo... *) @@ -1902,6 +2621,7 @@ module OASISExec = struct | Some f, i -> f i + let run_read_output ~ctxt ?f_exit_code cmd args = let fn = Filename.temp_file "oasis-" ".txt" @@ -1933,6 +2653,7 @@ module OASISExec = struct (try Sys.remove fn with _ -> ()); raise e + let run_read_one_line ~ctxt ?f_exit_code cmd args = match run_read_output ~ctxt ?f_exit_code cmd args with | [fst] -> @@ -1944,10 +2665,12 @@ module OASISExec = struct end module OASISFileUtil = struct -(* # 21 "src/oasis/OASISFileUtil.ml" *) +(* # 22 "src/oasis/OASISFileUtil.ml" *) + open OASISGettext + let file_exists_case fn = let dirname = Filename.dirname fn in let basename = Filename.basename fn in @@ -1961,6 +2684,7 @@ module OASISFileUtil = struct else false + let find_file ?(case_sensitive=true) paths exts = (* Cardinal product of two list *) @@ -1969,7 +2693,7 @@ module OASISFileUtil = struct (List.map (fun a -> List.map - (fun b -> a,b) + (fun b -> a, b) lst2) lst1) in @@ -1979,7 +2703,7 @@ module OASISFileUtil = struct | p1 :: p2 :: tl -> let acc = (List.map - (fun (a,b) -> Filename.concat a b) + (fun (a, b) -> Filename.concat a b) (p1 * p2)) in combined_paths (acc :: tl) @@ -1991,19 +2715,21 @@ module OASISFileUtil = struct let alternatives = List.map - (fun (p,e) -> + (fun (p, e) -> if String.length e > 0 && e.[0] <> '.' then p ^ "." ^ e else p ^ e) ((combined_paths paths) * exts) in - List.find + List.find (fun file -> (if case_sensitive then - file_exists_case + file_exists_case file else - Sys.file_exists) - alternatives + Sys.file_exists file) + && not (Sys.is_directory file) + ) alternatives + let which ~ctxt prg = let path_sep = @@ -2023,6 +2749,7 @@ module OASISFileUtil = struct in find_file ~case_sensitive:false [path_lst; [prg]] exec_ext + (**/**) let rec fix_dir dn = (* Windows hack because Sys.file_exists "src\\" = false when @@ -2036,9 +2763,11 @@ module OASISFileUtil = struct else dn + let q = Filename.quote (**/**) + let cp ~ctxt ?(recurse=false) src tgt = if recurse then match Sys.os_type with @@ -2055,6 +2784,7 @@ module OASISFileUtil = struct | _ -> "cp") [q src; q tgt] + let mkdir ~ctxt tgt = OASISExec.run ~ctxt (match Sys.os_type with @@ -2062,6 +2792,7 @@ module OASISFileUtil = struct | _ -> "mkdir") [q tgt] + let rec mkdir_parent ~ctxt f tgt = let tgt = fix_dir tgt @@ -2084,15 +2815,20 @@ module OASISFileUtil = struct end end + let rmdir ~ctxt tgt = - if Sys.readdir tgt = [||] then - begin - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt "rd" [q tgt] - | _ -> - OASISExec.run ~ctxt "rm" ["-r"; q tgt] - end + if Sys.readdir tgt = [||] then begin + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt "rd" [q tgt] + | _ -> + OASISExec.run ~ctxt "rm" ["-r"; q tgt] + end else begin + OASISMessage.error ~ctxt + (f_ "Cannot remove directory '%s': not empty.") + tgt + end + let glob ~ctxt fn = let basename = @@ -2139,19 +2875,23 @@ module OASISFileUtil = struct end -# 2142 "setup.ml" +# 2878 "setup.ml" module BaseEnvLight = struct -(* # 21 "src/base/BaseEnvLight.ml" *) +(* # 22 "src/base/BaseEnvLight.ml" *) + module MapString = Map.Make(String) + type t = string MapString.t + let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" + let load ?(allow_empty=false) ?(filename=default_filename) () = if Sys.file_exists filename then begin @@ -2209,26 +2949,29 @@ module BaseEnvLight = struct filename) end - let var_get name env = - let rec var_expand str = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff + + let rec var_expand str env = + let buff = + Buffer.create ((String.length str) * 2) in - var_expand (MapString.find name env) + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) env + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + + + let var_get name env = + var_expand (MapString.find name env) env + let var_choose lst env = OASISExpr.choose @@ -2237,20 +2980,24 @@ module BaseEnvLight = struct end -# 2240 "setup.ml" +# 2983 "setup.ml" module BaseContext = struct -(* # 21 "src/base/BaseContext.ml" *) +(* # 22 "src/base/BaseContext.ml" *) + (* TODO: get rid of this module. *) open OASISContext - let args = args + + let args () = fst (fspecs ()) + let default = default end module BaseMessage = struct -(* # 21 "src/base/BaseMessage.ml" *) +(* # 22 "src/base/BaseMessage.ml" *) + (** Message to user, overrid for Base @author Sylvain Le Gall @@ -2258,31 +3005,38 @@ module BaseMessage = struct open OASISMessage open BaseContext + let debug fmt = debug ~ctxt:!default fmt + let info fmt = info ~ctxt:!default fmt + let warning fmt = warning ~ctxt:!default fmt + let error fmt = error ~ctxt:!default fmt end module BaseEnv = struct -(* # 21 "src/base/BaseEnv.ml" *) +(* # 22 "src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils open PropList + module MapString = BaseEnvLight.MapString + type origin_t = | ODefault | OGetEnv | OFileLoad | OCommandLine + type cli_handle_t = | CLINone | CLIAuto @@ -2290,6 +3044,7 @@ module BaseEnv = struct | CLIEnable | CLIUser of (Arg.key * Arg.spec * Arg.doc) list + type definition_t = { hide: bool; @@ -2299,21 +3054,26 @@ module BaseEnv = struct group: string option; } + let schema = Schema.create "environment" + (* Environment data *) let env = Data.create () + (* Environment data from file *) let env_from_file = ref MapString.empty + (* Lexer for var *) let var_lxr = Genlex.make_lexer [] + let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) @@ -2364,6 +3124,7 @@ module BaseEnv = struct str; Buffer.contents buff + and var_get name = let vl = try @@ -2378,6 +3139,7 @@ module BaseEnv = struct in var_expand vl + let var_choose ?printer ?name lst = OASISExpr.choose ?printer @@ -2385,6 +3147,7 @@ module BaseEnv = struct var_get lst + let var_protect vl = let buff = Buffer.create (String.length vl) @@ -2396,6 +3159,7 @@ module BaseEnv = struct vl; Buffer.contents buff + let var_define ?(hide=false) ?(dump=true) @@ -2481,6 +3245,7 @@ module BaseEnv = struct fun () -> var_expand (var_get_low (var_get_lst env)) + let var_redefine ?hide ?dump @@ -2509,8 +3274,9 @@ module BaseEnv = struct dflt end - let var_ignore (e : unit -> string) = - () + + let var_ignore (e: unit -> string) = () + let print_hidden = var_define @@ -2521,6 +3287,7 @@ module BaseEnv = struct "print_hidden" (fun () -> "false") + let var_all () = List.rev (Schema.fold @@ -2532,24 +3299,28 @@ module BaseEnv = struct [] schema) + let default_filename = BaseEnvLight.default_filename + let load ?allow_empty ?filename () = env_from_file := BaseEnvLight.load ?allow_empty ?filename () + let unload () = env_from_file := MapString.empty; Data.clear env + let dump ?(filename=default_filename) () = let chn = open_out_bin filename in - let output nm value = + let output nm value = Printf.fprintf chn "%s=%S\n" nm value in - let mp_todo = + let mp_todo = (* Dump data from schema *) Schema.fold (fun mp_todo nm def _ -> @@ -2576,6 +3347,7 @@ module BaseEnv = struct (* End of the dump *) close_out chn + let print () = let printable_vars = Schema.fold @@ -2614,11 +3386,12 @@ module BaseEnv = struct Printf.printf "\nConfiguration: \n"; List.iter - (fun (name,value) -> + (fun (name, value) -> Printf.printf "%s: %s %s\n" name (dot_pad name) value) (List.rev printable_vars); Printf.printf "\n%!" + let args () = let arg_concat = OASISUtils.varname_concat ~hyphen:'-' @@ -2729,11 +3502,13 @@ module BaseEnv = struct end module BaseArgExt = struct -(* # 21 "src/base/BaseArgExt.ml" *) +(* # 22 "src/base/BaseArgExt.ml" *) + open OASISUtils open OASISGettext + let parse argv args = (* Simulate command line for Arg *) let current = @@ -2757,13 +3532,15 @@ module BaseArgExt = struct end module BaseCheck = struct -(* # 21 "src/base/BaseCheck.ml" *) +(* # 22 "src/base/BaseCheck.ml" *) + open BaseEnv open BaseMessage open OASISUtils open OASISGettext + let prog_best prg prg_lst = var_redefine prg @@ -2786,15 +3563,19 @@ module BaseCheck = struct | Some prg -> prg | None -> raise Not_found) + let prog prg = prog_best prg [prg] + let prog_opt prg = prog_best prg [prg^".opt"; prg] + let ocamlfind = prog "ocamlfind" + let version var_prefix cmp @@ -2836,11 +3617,13 @@ module BaseCheck = struct version_str) () + let package_version pkg = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%v"; pkg] + let package ?version_comparator pkg () = let var = OASISUtils.varname_concat @@ -2883,18 +3666,21 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -(* # 21 "src/base/BaseOCamlcConfig.ml" *) +(* # 22 "src/base/BaseOCamlcConfig.ml" *) open BaseEnv open OASISUtils open OASISGettext + module SMap = Map.Make(String) + let ocamlc = BaseCheck.prog_opt "ocamlc" + let ocamlc_config_map = (* Map name to value for ocamlc -config output (name ^": "^value) @@ -2940,7 +3726,7 @@ module BaseOCamlcConfig = struct mp in - let cache = + let cache = lazy (var_protect (Marshal.to_string @@ -2959,6 +3745,7 @@ module BaseOCamlcConfig = struct (* TODO: update if ocamlc change !!! *) Lazy.force cache) + let var_define nm = (* Extract data from ocamlc -config *) let avlbl_config_get () = @@ -2967,15 +3754,15 @@ module BaseOCamlcConfig = struct 0 in let chop_version_suffix s = - try + try String.sub s 0 (String.index s '+') - with _ -> + with _ -> s in let nm_config, value_config = match nm with - | "ocaml_version" -> + | "ocaml_version" -> "version", chop_version_suffix | _ -> nm, (fun x -> x) in @@ -2999,7 +3786,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -(* # 21 "src/base/BaseStandardVar.ml" *) +(* # 22 "src/base/BaseStandardVar.ml" *) open OASISGettext @@ -3008,6 +3795,7 @@ module BaseStandardVar = struct open BaseCheck open BaseEnv + let ocamlfind = BaseCheck.ocamlfind let ocamlc = BaseOCamlcConfig.ocamlc let ocamlopt = prog_opt "ocamlopt" @@ -3018,13 +3806,16 @@ module BaseStandardVar = struct let rpkg = ref None + let pkg_get () = match !rpkg with | Some pkg -> pkg | None -> failwith (s_ "OASIS Package is not set") + let var_cond = ref [] + let var_define_cond ~since_version f dflt = let holder = ref (fun () -> dflt) in let since_version = @@ -3036,14 +3827,17 @@ module BaseStandardVar = struct holder := f ()) :: !var_cond; fun () -> !holder () + (**/**) + let pkg_name = var_define ~short_desc:(fun () -> s_ "Package name") "pkg_name" (fun () -> (pkg_get ()).name) + let pkg_version = var_define ~short_desc:(fun () -> s_ "Package version") @@ -3051,16 +3845,20 @@ module BaseStandardVar = struct (fun () -> (OASISVersion.string_of_version (pkg_get ()).version)) + let c = BaseOCamlcConfig.var_define + let os_type = c "os_type" let system = c "system" let architecture = c "architecture" let ccomp_type = c "ccomp_type" let ocaml_version = c "ocaml_version" + (* TODO: Check standard variable presence at runtime *) + let standard_library_default = c "standard_library_default" let standard_library = c "standard_library" let standard_runtime = c "standard_runtime" @@ -3074,24 +3872,27 @@ module BaseStandardVar = struct let default_executable_name = c "default_executable_name" let systhread_supported = c "systhread_supported" - let flexlink = + + let flexlink = BaseCheck.prog "flexlink" + let flexdll_version = var_define ~short_desc:(fun () -> "FlexDLL version (Win32)") "flexdll_version" (fun () -> - let lst = + let lst = OASISExec.run_read_output ~ctxt:!BaseContext.default (flexlink ()) ["-help"] in - match lst with + match lst with | line :: _ -> Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) | [] -> raise Not_found) + (**/**) let p name hlp dflt = var_define @@ -3101,6 +3902,7 @@ module BaseStandardVar = struct name dflt + let (/) a b = if os_type () = Sys.os_type then Filename.concat a b @@ -3111,6 +3913,7 @@ module BaseStandardVar = struct (os_type ()) (**/**) + let prefix = p "prefix" (fun () -> s_ "Install architecture-independent files dir") @@ -3124,96 +3927,115 @@ module BaseStandardVar = struct | _ -> "/usr/local") + let exec_prefix = p "exec_prefix" (fun () -> s_ "Install architecture-dependent files in dir") (fun () -> "$prefix") + let bindir = p "bindir" (fun () -> s_ "User executables") (fun () -> "$exec_prefix"/"bin") + let sbindir = p "sbindir" (fun () -> s_ "System admin executables") (fun () -> "$exec_prefix"/"sbin") + let libexecdir = p "libexecdir" (fun () -> s_ "Program executables") (fun () -> "$exec_prefix"/"libexec") + let sysconfdir = p "sysconfdir" (fun () -> s_ "Read-only single-machine data") (fun () -> "$prefix"/"etc") + let sharedstatedir = p "sharedstatedir" (fun () -> s_ "Modifiable architecture-independent data") (fun () -> "$prefix"/"com") + let localstatedir = p "localstatedir" (fun () -> s_ "Modifiable single-machine data") (fun () -> "$prefix"/"var") + let libdir = p "libdir" (fun () -> s_ "Object code libraries") (fun () -> "$exec_prefix"/"lib") + let datarootdir = p "datarootdir" (fun () -> s_ "Read-only arch-independent data root") (fun () -> "$prefix"/"share") + let datadir = p "datadir" (fun () -> s_ "Read-only architecture-independent data") (fun () -> "$datarootdir") + let infodir = p "infodir" (fun () -> s_ "Info documentation") (fun () -> "$datarootdir"/"info") + let localedir = p "localedir" (fun () -> s_ "Locale-dependent data") (fun () -> "$datarootdir"/"locale") + let mandir = p "mandir" (fun () -> s_ "Man documentation") (fun () -> "$datarootdir"/"man") + let docdir = p "docdir" (fun () -> s_ "Documentation root") (fun () -> "$datarootdir"/"doc"/"$pkg_name") + let htmldir = p "htmldir" (fun () -> s_ "HTML documentation") (fun () -> "$docdir") + let dvidir = p "dvidir" (fun () -> s_ "DVI documentation") (fun () -> "$docdir") + let pdfdir = p "pdfdir" (fun () -> s_ "PDF documentation") (fun () -> "$docdir") + let psdir = p "psdir" (fun () -> s_ "PS documentation") (fun () -> "$docdir") + let destdir = p "destdir" (fun () -> s_ "Prepend a path when installing package") @@ -3223,35 +4045,39 @@ module BaseStandardVar = struct ("destdir", Some (s_ "undefined by construct")))) + let findlib_version = var_define "findlib_version" (fun () -> BaseCheck.package_version "findlib") + let is_native = var_define "is_native" (fun () -> try - let _s : string = + let _s: string = ocamlopt () in "true" with PropList.Not_set _ -> - let _s : string = + let _s: string = ocamlc () in "false") + let ext_program = var_define "suffix_program" (fun () -> match os_type () with - | "Win32" -> ".exe" + | "Win32" | "Cygwin" -> ".exe" | _ -> "") + let rm = var_define ~short_desc:(fun () -> s_ "Remove a file.") @@ -3261,6 +4087,7 @@ module BaseStandardVar = struct | "Win32" -> "del" | _ -> "rm -f") + let rmdir = var_define ~short_desc:(fun () -> s_ "Remove a directory.") @@ -3270,6 +4097,7 @@ module BaseStandardVar = struct | "Win32" -> "rd" | _ -> "rm -rf") + let debug = var_define ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") @@ -3277,6 +4105,7 @@ module BaseStandardVar = struct "debug" (fun () -> "true") + let profile = var_define ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") @@ -3284,6 +4113,7 @@ module BaseStandardVar = struct "profile" (fun () -> "false") + let tests = var_define_cond ~since_version:"0.3" (fun () -> @@ -3295,6 +4125,7 @@ module BaseStandardVar = struct (fun () -> "false")) "true" + let docs = var_define_cond ~since_version:"0.3" (fun () -> @@ -3305,6 +4136,7 @@ module BaseStandardVar = struct (fun () -> "true")) "true" + let native_dynlink = var_define ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") @@ -3312,7 +4144,7 @@ module BaseStandardVar = struct "native_dynlink" (fun () -> let res = - let ocaml_lt_312 () = + let ocaml_lt_312 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (ocaml_version ())) (OASISVersion.VLesser @@ -3324,7 +4156,7 @@ module BaseStandardVar = struct (OASISVersion.VLesser (OASISVersion.version_of_string "0.30")) in - let has_native_dynlink = + let has_native_dynlink = let ocamlfind = ocamlfind () in try let fn = @@ -3342,10 +4174,10 @@ module BaseStandardVar = struct false else if ocaml_lt_312 () then false - else if (os_type () = "Win32" || os_type () = "Cygwin") + else if (os_type () = "Win32" || os_type () = "Cygwin") && flexdll_lt_030 () then begin - BaseMessage.warning + BaseMessage.warning (f_ ".cmxs generation disabled because FlexDLL needs to be \ at least 0.30. Please upgrade FlexDLL from %s to 0.30.") (flexdll_version ()); @@ -3356,6 +4188,7 @@ module BaseStandardVar = struct in string_of_bool res) + let init pkg = rpkg := Some pkg; List.iter (fun f -> f pkg.oasis_version) !var_cond @@ -3363,12 +4196,14 @@ module BaseStandardVar = struct end module BaseFileAB = struct -(* # 21 "src/base/BaseFileAB.ml" *) +(* # 22 "src/base/BaseFileAB.ml" *) + open BaseEnv open OASISGettext open BaseMessage + let to_filename fn = let fn = OASISHostPath.of_unix fn @@ -3379,6 +4214,7 @@ module BaseFileAB = struct fn; Filename.chop_extension fn + let replace fn_lst = let buff = Buffer.create 13 @@ -3411,15 +4247,18 @@ module BaseFileAB = struct end module BaseLog = struct -(* # 21 "src/base/BaseLog.ml" *) +(* # 22 "src/base/BaseLog.ml" *) + open OASISUtils + let default_filename = Filename.concat (Filename.dirname BaseEnv.default_filename) "setup.log" + module SetTupleString = Set.Make (struct @@ -3430,6 +4269,7 @@ module BaseLog = struct | n -> n end) + let load () = if Sys.file_exists default_filename then begin @@ -3479,6 +4319,7 @@ module BaseLog = struct [] end + let register event data = let chn_out = open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename @@ -3486,6 +4327,7 @@ module BaseLog = struct Printf.fprintf chn_out "%S %S\n" event data; close_out chn_out + let unregister event data = if Sys.file_exists default_filename then begin @@ -3511,6 +4353,7 @@ module BaseLog = struct Sys.remove default_filename end + let filter events = let st_events = List.fold_left @@ -3523,6 +4366,7 @@ module BaseLog = struct (fun (e, _) -> SetString.mem e st_events) (load ()) + let exists event data = List.exists (fun v -> (event, data) = v) @@ -3530,31 +4374,38 @@ module BaseLog = struct end module BaseBuilt = struct -(* # 21 "src/base/BaseBuilt.ml" *) +(* # 22 "src/base/BaseBuilt.ml" *) + open OASISTypes open OASISGettext open BaseStandardVar open BaseMessage + type t = | BExec (* Executable *) | BExecLib (* Library coming with executable *) | BLib (* Library *) + | BObj (* Library *) | BDoc (* Document *) + let to_log_event_file t nm = "built_"^ (match t with | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" + | BObj -> "obj" | BDoc -> "doc")^ "_"^nm + let to_log_event_done t nm = "is_"^(to_log_event_file t nm) + let register t nm lst = BaseLog.register (to_log_event_done t nm) @@ -3585,6 +4436,7 @@ module BaseBuilt = struct (String.concat (s_ ", ") alt)) lst + let unregister t nm = List.iter (fun (e, d) -> @@ -3593,6 +4445,7 @@ module BaseBuilt = struct [to_log_event_file t nm; to_log_event_done t nm]) + let fold t nm f acc = List.fold_left (fun acc (_, fn) -> @@ -3612,6 +4465,8 @@ module BaseBuilt = struct (f_ "executable %s") | BLib -> (f_ "library %s") + | BObj -> + (f_ "object %s") | BDoc -> (f_ "documentation %s")) nm); @@ -3621,6 +4476,7 @@ module BaseBuilt = struct (BaseLog.filter [to_log_event_file t nm]) + let is_built t nm = List.fold_left (fun is_built (_, d) -> @@ -3632,6 +4488,7 @@ module BaseBuilt = struct (BaseLog.filter [to_log_event_done t nm]) + let of_executable ffn (cs, bs, exec) = let unix_exec_is, unix_dll_opt = OASISExecutable.unix_exec_is @@ -3655,6 +4512,7 @@ module BaseBuilt = struct unix_exec_is, unix_dll_opt + let of_library ffn (cs, bs, lib) = let unix_lst = OASISLibrary.generated_unix_files @@ -3674,16 +4532,35 @@ module BaseBuilt = struct in evs, unix_lst + + let of_object ffn (cs, bs, obj) = + let unix_lst = + OASISObject.generated_unix_files + ~ctxt:!BaseContext.default + ~source_file_exists:(fun fn -> + OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) + ~is_native:(bool_of_string (is_native ())) + (cs, bs, obj) + in + let evs = + [BObj, + cs.cs_name, + List.map (List.map ffn) unix_lst] + in + evs, unix_lst + end module BaseCustom = struct -(* # 21 "src/base/BaseCustom.ml" *) +(* # 22 "src/base/BaseCustom.ml" *) + open BaseEnv open BaseMessage open OASISTypes open OASISGettext + let run cmd args extra_args = OASISExec.run ~ctxt:!BaseContext.default ~quote:false (var_expand cmd) @@ -3691,6 +4568,7 @@ module BaseCustom = struct var_expand (args @ (Array.to_list extra_args))) + let hook ?(failsafe=false) cstm f e = let optional_command lst = let printer = @@ -3727,7 +4605,7 @@ module BaseCustom = struct end module BaseDynVar = struct -(* # 21 "src/base/BaseDynVar.ml" *) +(* # 22 "src/base/BaseDynVar.ml" *) open OASISTypes @@ -3735,6 +4613,7 @@ module BaseDynVar = struct open BaseEnv open BaseBuilt + let init pkg = (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) (* TODO: provide compile option for library libary_byte_args_VARNAME... *) @@ -3768,13 +4647,14 @@ module BaseDynVar = struct (f_ "Executable '%s' not yet built.") cs.cs_name))))) - | Library _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> + | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> ()) pkg.sections end module BaseTest = struct -(* # 21 "src/base/BaseTest.ml" *) +(* # 22 "src/base/BaseTest.ml" *) + open BaseEnv open BaseMessage @@ -3782,6 +4662,7 @@ module BaseTest = struct open OASISExpr open OASISGettext + let test lst pkg extra_args = let one_test (failure, n) (test_plugin, cs, test) = @@ -3832,7 +4713,7 @@ module BaseTest = struct (failure, n) end in - let (failed, n) = + let failed, n = List.fold_left one_test (0.0, 0) @@ -3855,7 +4736,7 @@ module BaseTest = struct info "%s" msg; (* Possible explanation why the tests where not run. *) - if OASISVersion.version_0_3_or_after pkg.oasis_version && + if OASISFeatures.package_test OASISFeatures.flag_tests pkg && not (bool_of_string (BaseStandardVar.tests ())) && lst <> [] then BaseMessage.warning @@ -3864,13 +4745,15 @@ module BaseTest = struct end module BaseDoc = struct -(* # 21 "src/base/BaseDoc.ml" *) +(* # 22 "src/base/BaseDoc.ml" *) + open BaseEnv open BaseMessage open OASISTypes open OASISGettext + let doc lst pkg extra_args = let one_doc (doc_plugin, cs, doc) = @@ -3890,7 +4773,7 @@ module BaseDoc = struct in List.iter one_doc lst; - if OASISVersion.version_0_3_or_after pkg.oasis_version && + if OASISFeatures.package_test OASISFeatures.flag_docs pkg && not (bool_of_string (BaseStandardVar.docs ())) && lst <> [] then BaseMessage.warning @@ -3899,7 +4782,7 @@ module BaseDoc = struct end module BaseSetup = struct -(* # 21 "src/base/BaseSetup.ml" *) +(* # 22 "src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage @@ -3908,12 +4791,15 @@ module BaseSetup = struct open OASISGettext open OASISUtils + type std_args_fun = package -> string array -> unit + type ('a, 'b) section_args_fun = name * (package -> (common_section * 'a) -> string array -> 'b) + type t = { configure: std_args_fun; @@ -3937,6 +4823,7 @@ module BaseSetup = struct setup_update: bool; } + (* Associate a plugin function with data from package *) let join_plugin_sections filter_map lst = List.rev @@ -3950,6 +4837,7 @@ module BaseSetup = struct [] lst) + (* Search for plugin data associated with a section name *) let lookup_plugin_section plugin action nm lst = try @@ -3961,11 +4849,12 @@ module BaseSetup = struct nm action + let configure t args = (* Run configure *) BaseCustom.hook t.package.conf_custom - (fun () -> + (fun () -> (* Reload if preconf has changed it *) begin try @@ -3992,12 +4881,14 @@ module BaseSetup = struct (* Replace data in file *) BaseFileAB.replace t.package.files_ab + let build t args = BaseCustom.hook t.package.build_custom (t.build t.package) args + let doc t args = BaseDoc.doc (join_plugin_sections @@ -4017,6 +4908,7 @@ module BaseSetup = struct t.package args + let test t args = BaseTest.test (join_plugin_sections @@ -4036,12 +4928,16 @@ module BaseSetup = struct t.package args + let all t args = let rno_doc = ref false in let rno_test = ref false + in + let arg_rest = + ref [] in Arg.parse_argv ~current:(ref 0) @@ -4056,12 +4952,16 @@ module BaseSetup = struct "-no-test", Arg.Set rno_test, s_ "Don't run test target"; + + "--", + Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), + s_ "All arguments for configure."; ] (failwithf (f_ "Don't know what to do with '%s'")) ""; info "Running configure step"; - configure t [||]; + configure t (Array.of_list (List.rev !arg_rest)); info "Running build step"; build t [||]; @@ -4089,22 +4989,26 @@ module BaseSetup = struct info "Skipping test step" end + let install t args = BaseCustom.hook t.package.install_custom (t.install t.package) args + let uninstall t args = BaseCustom.hook t.package.uninstall_custom (t.uninstall t.package) args + let reinstall t args = uninstall t args; install t args + let clean, distclean = let failsafe f a = try @@ -4146,6 +5050,7 @@ module BaseSetup = struct (f t.package (cs, doc)) args | Library _ + | Object _ | Executable _ | Flag _ | SrcRepo _ -> @@ -4201,9 +5106,11 @@ module BaseSetup = struct clean, distclean + let version t _ = print_endline t.oasis_version + let update_setup_ml, no_update_setup_ml_cli = let b = ref true in b, @@ -4211,11 +5118,15 @@ module BaseSetup = struct Arg.Clear b, s_ " Don't try to update setup.ml, even if _oasis has changed.") + + let default_oasis_fn = "_oasis" + + let update_setup_ml t = let oasis_fn = match t.oasis_fn with | Some fn -> fn - | None -> "_oasis" + | None -> default_oasis_fn in let oasis_exec = match t.oasis_exec with @@ -4313,7 +5224,8 @@ module BaseSetup = struct try match t.oasis_digest with | Some dgst -> - if Sys.file_exists oasis_fn && dgst <> Digest.file "_oasis" then + if Sys.file_exists oasis_fn && + dgst <> Digest.file default_oasis_fn then begin do_update (); true @@ -4333,6 +5245,7 @@ module BaseSetup = struct else false + let setup t = let catch_exn = ref true @@ -4474,41 +5387,34 @@ module BaseSetup = struct error "%s" (Printexc.to_string e); exit 1 + end -# 4480 "setup.ml" +# 5394 "setup.ml" module InternalConfigurePlugin = struct -(* # 21 "src/plugins/internal/InternalConfigurePlugin.ml" *) +(* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) + (** Configure using internal scheme @author Sylvain Le Gall *) + open BaseEnv open OASISTypes open OASISUtils open OASISGettext open BaseMessage + (** Configure build using provided series of check to be done * and then output corresponding file. *) let configure pkg argv = - let var_ignore_eval var = - let _s : string = - var () - in - () - in - - let errors = - ref SetString.empty - in - - let buff = - Buffer.create 13 - in + let var_ignore_eval var = let _s: string = var () in () in + let errors = ref SetString.empty in + let buff = Buffer.create 13 in let add_errors fmt = Printf.kbprintf @@ -4656,6 +5562,20 @@ module InternalConfigurePlugin = struct | None -> () end; + (* Make sure the findlib version is fine for the OCaml compiler. *) + begin + let ocaml_ge4 = + OASISVersion.version_compare + (OASISVersion.version_of_string (BaseStandardVar.ocaml_version())) + (OASISVersion.version_of_string "4.0.0") >= 0 in + if ocaml_ge4 then + let findlib_lt132 = + OASISVersion.version_compare + (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) + (OASISVersion.version_of_string "1.3.2") < 0 in + if findlib_lt132 then + add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" + end; (* FlexDLL *) if BaseStandardVar.os_type () = "Win32" || @@ -4718,43 +5638,58 @@ module InternalConfigurePlugin = struct (SetString.cardinal !errors) end + end module InternalInstallPlugin = struct -(* # 21 "src/plugins/internal/InternalInstallPlugin.ml" *) +(* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) + (** Install using internal scheme @author Sylvain Le Gall *) + open BaseEnv open BaseStandardVar open BaseMessage open OASISTypes - open OASISLibrary + open OASISFindlib open OASISGettext open OASISUtils + let exec_hook = ref (fun (cs, bs, exec) -> cs, bs, exec) + let lib_hook = ref (fun (cs, bs, lib) -> cs, bs, lib, []) + + let obj_hook = + ref (fun (cs, bs, obj) -> cs, bs, obj, []) + + let doc_hook = ref (fun (cs, doc) -> cs, doc) + let install_file_ev = "install-file" + let install_dir_ev = "install-dir" + let install_findlib_ev = "install-findlib" + let win32_max_command_line_length = 8000 + let split_install_command ocamlfind findlib_name meta files = if Sys.os_type = "Win32" then (* Arguments for the first command: *) @@ -4794,20 +5729,21 @@ module InternalInstallPlugin = struct | (firsts, others) -> let cmd = args @ firsts in (* Use -add for remaining commands: *) - let () = + let () = let findlib_ge_132 = OASISVersion.comparator_apply - (OASISVersion.version_of_string + (OASISVersion.version_of_string (BaseStandardVar.findlib_version ())) - (OASISVersion.VGreaterEqual + (OASISVersion.VGreaterEqual (OASISVersion.version_of_string "1.3.2")) in if not findlib_ge_132 then failwithf - (f_ "Installing the library %s require to use the flag \ - '-add' of ocamlfind because the command line is too \ - long. This flag is only available for findlib 1.3.2. \ - Please upgrade findlib from %s to 1.3.2") + (f_ "Installing the library %s require to use the \ + flag '-add' of ocamlfind because the command \ + line is too long. This flag is only available \ + for findlib 1.3.2. Please upgrade findlib from \ + %s to 1.3.2") findlib_name (BaseStandardVar.findlib_version ()) in let cmds = split other_args others in @@ -4818,6 +5754,7 @@ module InternalInstallPlugin = struct else ["install" :: findlib_name :: meta :: files] + let install pkg argv = let in_destdir = @@ -4961,6 +5898,75 @@ module InternalInstallPlugin = struct begin (f_data, acc) end + and files_of_object (f_data, acc) data_obj = + let cs, bs, obj, obj_extra = + !obj_hook data_obj + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then + begin + let acc = + (* Start with acc + obj_extra *) + List.rev_append obj_extra acc + in + let acc = + (* Add uncompiled header from the source tree *) + let path = + OASISHostPath.of_unix bs.bs_path + in + List.fold_left + (fun acc modul -> + try + List.find + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + [modul^".mli"; + modul^".ml"; + String.uncapitalize modul^".mli"; + String.capitalize modul^".mli"; + String.uncapitalize modul^".ml"; + String.capitalize modul^".ml"]) + :: acc + with Not_found -> + begin + warning + (f_ "Cannot find source header for module %s \ + in object %s") + modul cs.cs_name; + acc + end) + acc + obj.obj_modules + in + + let acc = + (* Get generated files *) + BaseBuilt.fold + BaseBuilt.BObj + cs.cs_name + (fun acc fn -> fn :: acc) + acc + in + + let f_data () = + (* Install data associated with the object *) + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name); + f_data () + in + + (f_data, acc) + end + else + begin + (f_data, acc) + end + in (* Install one group of library *) @@ -4971,8 +5977,10 @@ module InternalInstallPlugin = struct match grp with | Container (_, children) -> data_and_files, children - | Package (_, cs, bs, lib, children) -> + | Package (_, cs, bs, `Library lib, children) -> files_of_library data_and_files (cs, bs, lib), children + | Package (_, cs, bs, `Object obj, children) -> + files_of_object data_and_files (cs, bs, obj), children in List.fold_left install_group_lib_aux @@ -5006,7 +6014,7 @@ module InternalInstallPlugin = struct begin let meta = (* Search META file *) - let (_, bs, _) = + let _, bs, _ = root_lib in let res = @@ -5019,7 +6027,7 @@ module InternalInstallPlugin = struct findlib_name; res in - let files = + let files = (* Make filename shorter to avoid hitting command max line length * too early, esp. on Windows. *) @@ -5028,24 +6036,24 @@ module InternalInstallPlugin = struct let nlen = String.length n in if plen <= nlen && String.sub n 0 plen = p then begin - let fn_sep = + let fn_sep = if Sys.os_type = "Win32" then '\\' else '/' in let cutpoint = plen + - (if plen < nlen && n.[plen] = fn_sep then + (if plen < nlen && n.[plen] = fn_sep then 1 - else + else 0) in String.sub n cutpoint (nlen - cutpoint) end - else + else n in - List.map (remove_prefix (Sys.getcwd ())) files + List.map (remove_prefix (Sys.getcwd ())) files in info (f_ "Installing findlib library '%s'") @@ -5079,7 +6087,7 @@ module InternalInstallPlugin = struct let install_execs pkg = let install_exec data_exec = - let (cs, bs, exec) = + let cs, bs, exec = !exec_hook data_exec in if var_choose bs.bs_install && @@ -5126,7 +6134,7 @@ module InternalInstallPlugin = struct let install_docs pkg = let install_doc data = - let (cs, doc) = + let cs, doc = !doc_hook data in if var_choose doc.doc_install && @@ -5162,6 +6170,7 @@ module InternalInstallPlugin = struct install_execs pkg; install_docs pkg + (* Uninstall already installed data *) let uninstall _ argv = List.iter @@ -5225,24 +6234,34 @@ module InternalInstallPlugin = struct (BaseLog.filter [install_file_ev; install_dir_ev; - install_findlib_ev;])) + install_findlib_ev])) + end -# 5233 "setup.ml" +# 6243 "setup.ml" module OCamlbuildCommon = struct -(* # 21 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) +(* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) + (** Functions common to OCamlbuild build and doc plugin *) + open OASISGettext open BaseEnv open BaseStandardVar + open OASISTypes + + + + + type extra_args = string list + + + let ocamlbuild_clean_ev = "ocamlbuild-clean" - let ocamlbuild_clean_ev = - "ocamlbuild-clean" let ocamlbuildflags = var_define @@ -5250,6 +6269,7 @@ module OCamlbuildCommon = struct "ocamlbuildflags" (fun () -> "") + (** Fix special arguments depending on environment *) let fix_args args extra_argv = List.flatten @@ -5288,6 +6308,7 @@ module OCamlbuildCommon = struct Array.to_list extra_argv; ] + (** Run 'ocamlbuild -clean' if not already done *) let run_clean extra_argv = let extra_cli = @@ -5307,6 +6328,7 @@ module OCamlbuildCommon = struct ()) end + (** Run ocamlbuild, unregister all clean events *) let run_ocamlbuild args extra_argv = (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html @@ -5318,6 +6340,7 @@ module OCamlbuildCommon = struct (fun (e, d) -> BaseLog.unregister e d) (BaseLog.filter [ocamlbuild_clean_ev]) + (** Determine real build directory *) let build_dir extra_argv = let rec search_args dir = @@ -5331,28 +6354,36 @@ module OCamlbuildCommon = struct in search_args "_build" (fix_args [] extra_argv) + end module OCamlbuildPlugin = struct -(* # 21 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) +(* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) + (** Build using ocamlbuild @author Sylvain Le Gall *) + open OASISTypes open OASISGettext open OASISUtils + open OASISString open BaseEnv open OCamlbuildCommon open BaseStandardVar open BaseMessage + + + + let cond_targets_hook = ref (fun lst -> lst) - let build pkg argv = + let build extra_args pkg argv = (* Return the filename in build directory *) let in_build_dir fn = Filename.concat @@ -5377,16 +6408,36 @@ module OCamlbuildPlugin = struct (cs, bs, lib) in - let ends_with nd fn = - let nd_len = - String.length nd - in - (String.length fn >= nd_len) - && - (String.sub - fn - (String.length fn - nd_len) - nd_len) = nd + let tgts = + List.flatten + (List.filter + (fun l -> l <> []) + (List.map + (List.filter + (fun fn -> + ends_with ~what:".cma" fn + || ends_with ~what:".cmxs" fn + || ends_with ~what:".cmxa" fn + || ends_with ~what:(ext_lib ()) fn + || ends_with ~what:(ext_dll ()) fn)) + unix_files)) + in + + match tgts with + | _ :: _ -> + (evs, tgts) :: acc + | [] -> + failwithf + (f_ "No possible ocamlbuild targets for library %s") + cs.cs_name + end + + | Object (cs, bs, obj) when var_choose bs.bs_build -> + begin + let evs, unix_files = + BaseBuilt.of_object + in_build_dir_of_unix + (cs, bs, obj) in let tgts = @@ -5396,11 +6447,8 @@ module OCamlbuildPlugin = struct (List.map (List.filter (fun fn -> - ends_with ".cma" fn - || ends_with ".cmxs" fn - || ends_with ".cmxa" fn - || ends_with (ext_lib ()) fn - || ends_with (ext_dll ()) fn)) + ends_with ".cmo" fn + || ends_with ".cmx" fn)) unix_files)) in @@ -5409,7 +6457,7 @@ module OCamlbuildPlugin = struct (evs, tgts) :: acc | [] -> failwithf - (f_ "No possible ocamlbuild targets for library %s") + (f_ "No possible ocamlbuild targets for object %s") cs.cs_name end @@ -5428,12 +6476,13 @@ module OCamlbuildPlugin = struct (OASISUnixPath.chop_extension exec.exec_main_is))^ext in - let evs = + let evs = (* Fix evs, we want to use the unix_tgt, without copying *) List.map (function | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> - BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]] + BaseBuilt.BExec, nm, + [[in_build_dir_of_unix unix_tgt]] | ev -> ev) evs @@ -5455,7 +6504,7 @@ module OCamlbuildPlugin = struct acc end - | Library _ | Executable _ | Test _ + | Library _ | Object _ | Executable _ | Test _ | SrcRepo _ | Flag _ | Doc _ -> acc) [] @@ -5469,26 +6518,22 @@ module OCamlbuildPlugin = struct (fun fns -> if not (List.exists OASISFileUtil.file_exists_case fns) then failwithf - (f_ "No one of expected built files %s exists") - (String.concat (s_ ", ") (List.map (Printf.sprintf "'%s'") fns))) + (fn_ + "Expected built file %s doesn't exist." + "None of expected built files %s exists." + (List.length fns)) + (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) lst; (BaseBuilt.register bt bnm lst) in - let cond_targets = - (* Run the hook *) - !cond_targets_hook cond_targets - in + (* Run the hook *) + let cond_targets = !cond_targets_hook cond_targets in - (* Run a list of target... *) - run_ocamlbuild - (List.flatten - (List.map snd cond_targets)) - argv; - (* ... and register events *) - List.iter - check_and_register - (List.flatten (List.map fst cond_targets)) + (* Run a list of target... *) + run_ocamlbuild (List.flatten (List.map snd cond_targets) @ extra_args) argv; + (* ... and register events *) + List.iter check_and_register (List.flatten (List.map fst cond_targets)) let clean pkg extra_args = @@ -5504,15 +6549,18 @@ module OCamlbuildPlugin = struct ()) pkg.sections + end module OCamlbuildDocPlugin = struct -(* # 21 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) +(* # 22 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) + (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall *) + open OASISTypes open OASISGettext open OASISMessage @@ -5521,11 +6569,19 @@ module OCamlbuildDocPlugin = struct - let doc_build path pkg (cs, doc) argv = + + type run_t = + { + extra_args: string list; + run_path: unix_filename; + } + + + let doc_build run pkg (cs, doc) argv = let index_html = OASISUnixPath.make [ - path; + run.run_path; cs.cs_name^".docdir"; "index.html"; ] @@ -5534,11 +6590,11 @@ module OCamlbuildDocPlugin = struct OASISHostPath.make [ build_dir argv; - OASISHostPath.of_unix path; + OASISHostPath.of_unix run.run_path; cs.cs_name^".docdir"; ] in - run_ocamlbuild [index_html] argv; + run_ocamlbuild (index_html :: run.extra_args) argv; List.iter (fun glb -> BaseBuilt.register @@ -5548,20 +6604,22 @@ module OCamlbuildDocPlugin = struct (Filename.concat tgt_dir glb)]) ["*.html"; "*.css"] - let doc_clean t pkg (cs, doc) argv = + + let doc_clean run pkg (cs, doc) argv = run_clean argv; BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name + end -# 5558 "setup.ml" +# 6616 "setup.ml" open OASISTypes;; let setup_t = { BaseSetup.configure = InternalConfigurePlugin.configure; - build = OCamlbuildPlugin.build; + build = OCamlbuildPlugin.build []; test = []; doc = []; install = InternalInstallPlugin.install; @@ -5577,6 +6635,8 @@ let setup_t = oasis_version = "0.3"; ocaml_version = None; findlib_version = None; + alpha_features = []; + beta_features = []; name = "stdext"; version = "0.9.1"; license = @@ -5585,8 +6645,8 @@ let setup_t = { OASISLicense.license = "LGPL"; excption = Some "OCaml linking"; - version = OASISLicense.Version "2.1"; - }); + version = OASISLicense.Version "2.1" + }); license_file = None; copyrights = ["(C) 2012 Citrix"]; maintainers = []; @@ -5595,39 +6655,39 @@ let setup_t = synopsis = "Standard extension library"; description = None; categories = []; - conf_type = (`Configure, "internal", Some "0.3"); + conf_type = (`Configure, "internal", Some "0.4"); conf_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - build_type = (`Build, "ocamlbuild", Some "0.3"); + post_command = [(OASISExpr.EBool true, None)] + }; + build_type = (`Build, "ocamlbuild", Some "0.4"); build_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - install_type = (`Install, "internal", Some "0.3"); + post_command = [(OASISExpr.EBool true, None)] + }; + install_type = (`Install, "internal", Some "0.4"); install_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; + post_command = [(OASISExpr.EBool true, None)] + }; uninstall_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; + post_command = [(OASISExpr.EBool true, None)] + }; clean_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; + post_command = [(OASISExpr.EBool true, None)] + }; distclean_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; + post_command = [(OASISExpr.EBool true, None)] + }; files_ab = []; sections = [ @@ -5635,8 +6695,8 @@ let setup_t = ({ cs_name = "stdext"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; @@ -5664,8 +6724,8 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, { lib_modules = [ @@ -5692,7 +6752,7 @@ let setup_t = "Qring"; "Range"; "Ring"; - "Stringext"; + "Xstringext"; "Threadext"; "Trie"; "Unixext"; @@ -5703,24 +6763,25 @@ let setup_t = lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; - lib_findlib_containers = []; - }) + lib_findlib_containers = [] + }) ]; plugins = [(`Extra, "DevFiles", Some "0.3"); (`Extra, "META", Some "0.3")]; + disable_oasis_section = []; schema_data = PropList.Data.create (); - plugin_data = []; - }; + plugin_data = [] + }; oasis_fn = Some "_oasis"; - oasis_version = "0.3.0"; - oasis_digest = Some "\182W\177\022$V\021IF\016\234!w\138\156<"; + oasis_version = "0.4.4"; + oasis_digest = Some "\173\172[\017\177 \224\175x/~\152\151\193\166\180"; oasis_exec = None; oasis_setup_args = []; - setup_update = false; - };; + setup_update = false + };; let setup () = BaseSetup.setup setup_t;; -# 5725 "setup.ml" +# 6786 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 6ee67695a7d82a8bf04a40eaf084cdfc28158fc7 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Fri, 30 May 2014 11:24:20 +0100 Subject: [PATCH 020/199] Release 0.11.0 Signed-off-by: Jon Ludlam --- ChangeLog | 3 ++ _oasis | 2 +- lib/META | 4 +- myocamlbuild.ml | 20 +++++----- setup.ml | 102 ++++++++++++++++++++++++------------------------ 5 files changed, 67 insertions(+), 64 deletions(-) diff --git a/ChangeLog b/ChangeLog index c3977331908..c0c4733d0c8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,6 @@ +0.11.0 (30-May-2013): +* Change Stringext module to Xstringext to avoid conflict with other packages + 0.9.1 (10-Sep-2013): * Add Unixext.domain_of_addr * Add String.sub_{before,after} diff --git a/_oasis b/_oasis index d11d0934fb6..1d6e33cd169 100644 --- a/_oasis +++ b/_oasis @@ -1,6 +1,6 @@ OASISFormat: 0.3 Name: stdext -Version: 0.9.1 +Version: 0.11.0 Synopsis: Standard extension library License: LGPL-2.1 with OCaml linking exception Authors: various diff --git a/lib/META b/lib/META index e71d8eafa6c..1a05f6893a8 100644 --- a/lib/META +++ b/lib/META @@ -1,6 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: 3ed2adb163391595a1dfeed7f6c4f8ba) -version = "0.9.1" +# DO NOT EDIT (digest: 10d53985c4344a03d83fd38e1a65d6d2) +version = "0.11.0" description = "Standard extension library" requires = "threads uuidm unix fd-send-recv bigarray" archive(byte) = "stdext.cma" diff --git a/myocamlbuild.ml b/myocamlbuild.ml index c64d730ff16..f662a5eb79d 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: b8faf3da52e902fb96e77b14b83140c9) *) +(* DO NOT EDIT (digest: fe2b018630989841943e3a87fe69634e) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -39,10 +39,10 @@ module OASISExpr = struct open OASISGettext - type test = string + type test = string - type flag = string + type flag = string type t = @@ -52,10 +52,10 @@ module OASISExpr = struct | EOr of t * t | EFlag of flag | ETest of test * string + - - type 'a choices = (t * 'a) list + type 'a choices = (t * 'a) list let eval var_get t = @@ -430,10 +430,10 @@ module MyOCamlbuildBase = struct module OC = Ocamlbuild_pack.Ocaml_compiler - type dir = string - type file = string - type name = string - type tag = string + type dir = string + type file = string + type name = string + type tag = string (* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) @@ -448,7 +448,7 @@ module MyOCamlbuildBase = struct * directory. *) includes: (dir * dir list) list; - } + } let env_filename = diff --git a/setup.ml b/setup.ml index d5d098901ef..3b78788c187 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: b645ca291090034a33aada1d81713d4b) *) +(* DO NOT EDIT (digest: 97066dc5555ba92c7e4960fd3a2f318d) *) (* Regenerated by OASIS v0.4.4 Visit http://oasis.forge.ocamlcore.org for more information and @@ -739,7 +739,7 @@ module OASISVersion = struct type s = string - type t = string + type t = string type comparator = @@ -750,7 +750,7 @@ module OASISVersion = struct | VLesserEqual of t | VOr of comparator * comparator | VAnd of comparator * comparator - + (* Range of allowed characters *) @@ -945,17 +945,17 @@ module OASISLicense = struct - type license = string + type license = string - type license_exception = string + type license_exception = string type license_version = | Version of OASISVersion.t | VersionOrLater of OASISVersion.t | NoVersion - + type license_dep_5_unit = @@ -964,19 +964,19 @@ module OASISLicense = struct excption: license_exception option; version: license_version; } - + type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list | DEP5And of license_dep_5 list - + type t = | DEP5License of license_dep_5 | OtherLicense of string (* URL *) - + end @@ -991,10 +991,10 @@ module OASISExpr = struct open OASISGettext - type test = string + type test = string - type flag = string + type flag = string type t = @@ -1004,10 +1004,10 @@ module OASISExpr = struct | EOr of t * t | EFlag of flag | ETest of test * string + - - type 'a choices = (t * 'a) list + type 'a choices = (t * 'a) list let eval var_get t = @@ -1089,9 +1089,9 @@ module OASISText = struct | Para of string | Verbatim of string | BlankLine + - - type t = elt list + type t = elt list end @@ -1102,40 +1102,40 @@ module OASISTypes = struct - type name = string - type package_name = string - type url = string - type unix_dirname = string - type unix_filename = string - type host_dirname = string - type host_filename = string - type prog = string - type arg = string - type args = string list - type command_line = (prog * arg list) + type name = string + type package_name = string + type url = string + type unix_dirname = string + type unix_filename = string + type host_dirname = string + type host_filename = string + type prog = string + type arg = string + type args = string list + type command_line = (prog * arg list) - type findlib_name = string - type findlib_full = string + type findlib_name = string + type findlib_full = string type compiled_object = | Byte | Native | Best - + type dependency = | FindlibPackage of findlib_full * OASISVersion.comparator option | InternalLibrary of name - + type tool = | ExternalTool of name | InternalExecutable of name - + type vcs = @@ -1148,7 +1148,7 @@ module OASISTypes = struct | Arch | Monotone | OtherVCS of url - + type plugin_kind = @@ -1176,7 +1176,7 @@ module OASISTypes = struct ] - type 'a plugin = 'a * name * OASISVersion.t option + type 'a plugin = 'a * name * OASISVersion.t option type all_plugin = plugin_kind plugin @@ -1188,7 +1188,7 @@ module OASISTypes = struct (* # 115 "src/oasis/OASISTypes.ml" *) - type 'a conditional = 'a OASISExpr.choices + type 'a conditional = 'a OASISExpr.choices type custom = @@ -1196,7 +1196,7 @@ module OASISTypes = struct pre_command: (command_line option) conditional; post_command: (command_line option) conditional; } - + type common_section = @@ -1205,7 +1205,7 @@ module OASISTypes = struct cs_data: PropList.Data.t; cs_plugin_data: plugin_data; } - + type build_section = @@ -1225,7 +1225,7 @@ module OASISTypes = struct bs_byteopt: args conditional; bs_nativeopt: args conditional; } - + type library = @@ -1236,28 +1236,28 @@ module OASISTypes = struct lib_findlib_parent: findlib_name option; lib_findlib_name: findlib_name option; lib_findlib_containers: findlib_name list; - } + } type object_ = { obj_modules: string list; obj_findlib_fullname: findlib_name list option; - } + } type executable = { exec_custom: bool; exec_main_is: unix_filename; - } + } type flag = { flag_description: string option; flag_default: bool conditional; - } + } type source_repository = @@ -1269,7 +1269,7 @@ module OASISTypes = struct src_repo_branch: string option; src_repo_tag: string option; src_repo_subdir: unix_filename option; - } + } type test = @@ -1280,7 +1280,7 @@ module OASISTypes = struct test_working_directory: unix_filename option; test_run: bool conditional; test_tools: tool list; - } + } type doc_format = @@ -1291,7 +1291,7 @@ module OASISTypes = struct | Info of unix_filename | DVI | OtherDoc - + type doc = @@ -1307,7 +1307,7 @@ module OASISTypes = struct doc_format: doc_format; doc_data_files: (unix_filename * unix_filename option) list; doc_build_tools: tool list; - } + } type section = @@ -1318,7 +1318,7 @@ module OASISTypes = struct | SrcRepo of common_section * source_repository | Test of common_section * test | Doc of common_section * doc - + type section_kind = @@ -1363,7 +1363,7 @@ module OASISTypes = struct disable_oasis_section: unix_filename list; schema_data: PropList.Data.t; plugin_data: plugin_data; - } + } end @@ -6257,7 +6257,7 @@ module OCamlbuildCommon = struct - type extra_args = string list + type extra_args = string list let ocamlbuild_clean_ev = "ocamlbuild-clean" @@ -6574,7 +6574,7 @@ module OCamlbuildDocPlugin = struct { extra_args: string list; run_path: unix_filename; - } + } let doc_build run pkg (cs, doc) argv = @@ -6638,7 +6638,7 @@ let setup_t = alpha_features = []; beta_features = []; name = "stdext"; - version = "0.9.1"; + version = "0.11.0"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -6774,7 +6774,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.4"; - oasis_digest = Some "\173\172[\017\177 \224\175x/~\152\151\193\166\180"; + oasis_digest = Some "^l\005\192\196INu\255~\006Y\"\218\148\154"; oasis_exec = None; oasis_setup_args = []; setup_update = false From 8f632c4804e217621c808a2eba6ae46449e48097 Mon Sep 17 00:00:00 2001 From: David Scott Date: Thu, 7 Aug 2014 16:53:25 +0100 Subject: [PATCH 021/199] Fix build on OS X * blkgetsize_stubs.c is from mirage/mirage-block-unix * O_DIRECT is not present on OS X; use the closest analog * setsockopt level SOL_TCP is IPPROTO_TCP on OS X * setsockopt TCP_KEEPIDLE is Linux-specific Signed-off-by: David Scott --- _oasis | 2 +- lib/blkgetsize_stubs.c | 106 +++++++++++++++++++++++++++++++++++++++ lib/unixext_open_stubs.c | 20 ++++++-- lib/unixext_stubs.c | 33 +++++++----- 4 files changed, 142 insertions(+), 19 deletions(-) create mode 100644 lib/blkgetsize_stubs.c diff --git a/_oasis b/_oasis index 1d6e33cd169..6e87f34c969 100644 --- a/_oasis +++ b/_oasis @@ -11,7 +11,7 @@ Plugins: DevFiles (0.3), META (0.3) Library stdext Path: lib Modules: Arrayext, Backtrace, Base64, Bigbuffer, Config, Date, Either, Encodings, ExtentlistSet, Filenameext, Fring, Fun, Hashtblext, Int64ext, LazyList, Listext, Mapext, Monad, Opt, Pervasiveext, Qring, Range, Ring, Xstringext, Threadext, Trie, Unixext, VIO, Zerocheck - CSources: unixext_open_stubs.c, unixext_stubs.c, unixext_write_stubs.c, zerocheck_stub.c + CSources: blkgetsize_stubs.c, unixext_open_stubs.c, unixext_stubs.c, unixext_write_stubs.c, zerocheck_stub.c BuildDepends: threads, uuidm, unix, fd-send-recv, bigarray diff --git a/lib/blkgetsize_stubs.c b/lib/blkgetsize_stubs.c new file mode 100644 index 00000000000..e28bed518d8 --- /dev/null +++ b/lib/blkgetsize_stubs.c @@ -0,0 +1,106 @@ +/* + * Copyright (C) 2012-2013 Citrix Inc + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + */ + +#include +#include +#include + +#include +#include +#include +#include + +#include +#include +#include +#include +#include +#include + +#ifdef __linux__ +#include + +int blkgetsize(int fd, uint64_t *psize) +{ +#ifdef BLKGETSIZE64 + int ret = ioctl(fd, BLKGETSIZE64, psize); +#elif BLKGETSIZE + unsigned long sectors = 0; + int ret = ioctl(fd, BLKGETSIZE, §ors); + *psize = sectors * 512ULL; +#else +# error "Linux configuration error (blkgetsize)" +#endif + return ret; +} + +#elif defined(__APPLE__) +#include + +int blkgetsize(int fd, uint64_t *psize) +{ + unsigned long blocksize = 0; + int ret = ioctl(fd, DKIOCGETBLOCKSIZE, &blocksize); + if (!ret) { + unsigned long nblocks; + ret = ioctl(fd, DKIOCGETBLOCKCOUNT, &nblocks); + if (!ret) + *psize = (uint64_t)nblocks * blocksize; + } + return ret; +} + +#elif defined(__FreeBSD__) +#include + +int blkgetsize(int fd, uint64_t *psize) +{ + int ret = ioctl(fd, DIOCGMEDIASIZE, psize); + return ret; +} + +#else +# error "Unable to query block device size: unsupported platform, please report." +#endif + +/* ocaml/ocaml/unixsupport.c */ +extern void uerror(char *cmdname, value cmdarg); +#define Nothing ((value) 0) + +CAMLprim value stub_blkgetsize(value filename){ + CAMLparam1(filename); + CAMLlocal1(result); + uint64_t size_in_bytes; + int fd; + int success = -1; + + const char *filename_c = strdup(String_val(filename)); + + enter_blocking_section(); + fd = open(filename_c, O_RDONLY, 0); + if (blkgetsize(fd, &size_in_bytes) == 0) + success = 0; + close(fd); + leave_blocking_section(); + + free((void*)filename_c); + + if (fd == -1) uerror("open", filename); + if (success == -1) uerror("BLKGETSIZE", filename); + + result = caml_copy_int64(size_in_bytes); + CAMLreturn(result); +} diff --git a/lib/unixext_open_stubs.c b/lib/unixext_open_stubs.c index 3b6cce4dd85..35b58713fa3 100644 --- a/lib/unixext_open_stubs.c +++ b/lib/unixext_open_stubs.c @@ -44,17 +44,27 @@ static int open_flag_table[] = { CAMLprim value stub_stdext_unix_open_direct(value path, value flags, value perm) { CAMLparam3(path, flags, perm); - int ret, cv_flags; + int fd, ret, cv_flags; char * p; - cv_flags = convert_flag_list(flags, open_flag_table) | O_DIRECT; + cv_flags = convert_flag_list(flags, open_flag_table); + +#ifdef O_DIRECT + cv_flags |= O_DIRECT; +#endif p = stat_alloc(string_length(path) + 1); strcpy(p, String_val(path)); /* open on a named FIFO can block (PR#1533) */ enter_blocking_section(); - ret = open(p, cv_flags, Int_val(perm)); + fd = open(p, cv_flags, Int_val(perm)); +#ifndef O_DIRECT + if (fd != -1) + ret = fcntl(fd, F_NOCACHE); +#endif leave_blocking_section(); stat_free(p); - if (ret == -1) uerror("open", path); - CAMLreturn (Val_int(ret)); + if (fd == -1) uerror("open", path); + if (ret == -1) uerror("fcntl", path); + + CAMLreturn (Val_int(fd)); } diff --git a/lib/unixext_stubs.c b/lib/unixext_stubs.c index 6b9e597671b..5821a0ab25e 100644 --- a/lib/unixext_stubs.c +++ b/lib/unixext_stubs.c @@ -22,7 +22,9 @@ #include /* snprintf */ #include #include -#include +#if defined(__linux__) +# include +#endif #include #include @@ -53,12 +55,15 @@ CAMLprim value stub_unixext_fsync (value fd) CAMLreturn(Val_unit); } +extern uint64_t blkgetsize(int fd, uint64_t *psize); + CAMLprim value stub_unixext_blkgetsize64(value fd) { CAMLparam1(fd); uint64_t size; int c_fd = Int_val(fd); - if(ioctl(c_fd,BLKGETSIZE64,&size)) { + /* mirage-block-unix binding: */ + if (blkgetsize(c_fd, &size)) { uerror("ioctl(BLKGETSIZE64)", Nothing); } CAMLreturn(caml_copy_int64(size)); @@ -72,6 +77,14 @@ CAMLprim value stub_unixext_get_max_fd (value unit) CAMLreturn(Val_int(maxfd)); } +#if defined(__linux__) +# define TCP_LEVEL SOL_TCP +#elif defined(__APPLE__) +# define TCP_LEVEL IPPROTO_TCP +#else +# error "Don't know how to use setsockopt on this platform" +#endif + CAMLprim value stub_unixext_set_sock_keepalives(value fd, value count, value idle, value interval) { CAMLparam4(fd, count, idle, interval); @@ -81,17 +94,17 @@ CAMLprim value stub_unixext_set_sock_keepalives(value fd, value count, value idl socklen_t optlen=sizeof(optval); optval = Int_val(count); - if(setsockopt(c_fd, SOL_TCP, TCP_KEEPCNT, &optval, optlen) < 0) { + if(setsockopt(c_fd, TCP_LEVEL, TCP_KEEPCNT, &optval, optlen) < 0) { uerror("setsockopt(TCP_KEEPCNT)", Nothing); } - +#if defined(__linux__) optval = Int_val(idle); - if(setsockopt(c_fd, SOL_TCP, TCP_KEEPIDLE, &optval, optlen) < 0) { + if(setsockopt(c_fd, TCP_LEVEL, TCP_KEEPIDLE, &optval, optlen) < 0) { uerror("setsockopt(TCP_KEEPIDLE)", Nothing); } - +#endif optval = Int_val(interval); - if(setsockopt(c_fd, SOL_TCP, TCP_KEEPINTVL, &optval, optlen) < 0) { + if(setsockopt(c_fd, TCP_LEVEL, TCP_KEEPINTVL, &optval, optlen) < 0) { uerror("setsockopt(TCP_KEEPINTVL)", Nothing); } @@ -299,12 +312,6 @@ CAMLprim value stub_fdset_is_empty(value set) CAMLreturn(Bool_val(ret == 0)); } -static int msg_flag_table[] = { - MSG_OOB, MSG_DONTROUTE, MSG_PEEK -}; - -#define UNIX_BUFFER_SIZE 16384 - CAMLprim value stub_statvfs(value filename) { CAMLparam1(filename); From 734cf4a6680d3da876fdf3a6df03356e79831374 Mon Sep 17 00:00:00 2001 From: David Scott Date: Thu, 7 Aug 2014 17:15:45 +0100 Subject: [PATCH 022/199] Regenerate OASIS Signed-off-by: David Scott --- _tags | 7 ++- lib/libstdext_stubs.clib | 3 +- myocamlbuild.ml | 20 ++++---- setup.ml | 103 ++++++++++++++++++++------------------- 4 files changed, 70 insertions(+), 63 deletions(-) diff --git a/_tags b/_tags index a1e0d13b480..3eb4c0d757f 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 97b078caaf9aa5877a841adb67d7deb6) +# DO NOT EDIT (digest: ad1a1bbbb71d472f0711580d2cc59333) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -21,6 +21,11 @@ : pkg_threads : pkg_unix : pkg_uuidm +"lib/blkgetsize_stubs.c": pkg_bigarray +"lib/blkgetsize_stubs.c": pkg_fd-send-recv +"lib/blkgetsize_stubs.c": pkg_threads +"lib/blkgetsize_stubs.c": pkg_unix +"lib/blkgetsize_stubs.c": pkg_uuidm "lib/unixext_open_stubs.c": pkg_bigarray "lib/unixext_open_stubs.c": pkg_fd-send-recv "lib/unixext_open_stubs.c": pkg_threads diff --git a/lib/libstdext_stubs.clib b/lib/libstdext_stubs.clib index 8cbca027bcc..f61f7464884 100644 --- a/lib/libstdext_stubs.clib +++ b/lib/libstdext_stubs.clib @@ -1,5 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: 6a87487702231dfad360de7126120d50) +# DO NOT EDIT (digest: b4d5196086bdd5d02be639885c7103de) +blkgetsize_stubs.o unixext_open_stubs.o unixext_stubs.o unixext_write_stubs.o diff --git a/myocamlbuild.ml b/myocamlbuild.ml index f662a5eb79d..c64d730ff16 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: fe2b018630989841943e3a87fe69634e) *) +(* DO NOT EDIT (digest: b8faf3da52e902fb96e77b14b83140c9) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -39,10 +39,10 @@ module OASISExpr = struct open OASISGettext - type test = string + type test = string - type flag = string + type flag = string type t = @@ -52,10 +52,10 @@ module OASISExpr = struct | EOr of t * t | EFlag of flag | ETest of test * string - - type 'a choices = (t * 'a) list + + type 'a choices = (t * 'a) list let eval var_get t = @@ -430,10 +430,10 @@ module MyOCamlbuildBase = struct module OC = Ocamlbuild_pack.Ocaml_compiler - type dir = string - type file = string - type name = string - type tag = string + type dir = string + type file = string + type name = string + type tag = string (* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) @@ -448,7 +448,7 @@ module MyOCamlbuildBase = struct * directory. *) includes: (dir * dir list) list; - } + } let env_filename = diff --git a/setup.ml b/setup.ml index 3b78788c187..bdd672e3639 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 97066dc5555ba92c7e4960fd3a2f318d) *) +(* DO NOT EDIT (digest: c6a046ac6a0d0de7dbc290b0c0ddb8b1) *) (* Regenerated by OASIS v0.4.4 Visit http://oasis.forge.ocamlcore.org for more information and @@ -739,7 +739,7 @@ module OASISVersion = struct type s = string - type t = string + type t = string type comparator = @@ -750,7 +750,7 @@ module OASISVersion = struct | VLesserEqual of t | VOr of comparator * comparator | VAnd of comparator * comparator - + (* Range of allowed characters *) @@ -945,17 +945,17 @@ module OASISLicense = struct - type license = string + type license = string - type license_exception = string + type license_exception = string type license_version = | Version of OASISVersion.t | VersionOrLater of OASISVersion.t | NoVersion - + type license_dep_5_unit = @@ -964,19 +964,19 @@ module OASISLicense = struct excption: license_exception option; version: license_version; } - + type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list | DEP5And of license_dep_5 list - + type t = | DEP5License of license_dep_5 | OtherLicense of string (* URL *) - + end @@ -991,10 +991,10 @@ module OASISExpr = struct open OASISGettext - type test = string + type test = string - type flag = string + type flag = string type t = @@ -1004,10 +1004,10 @@ module OASISExpr = struct | EOr of t * t | EFlag of flag | ETest of test * string - - type 'a choices = (t * 'a) list + + type 'a choices = (t * 'a) list let eval var_get t = @@ -1089,9 +1089,9 @@ module OASISText = struct | Para of string | Verbatim of string | BlankLine - - type t = elt list + + type t = elt list end @@ -1102,40 +1102,40 @@ module OASISTypes = struct - type name = string - type package_name = string - type url = string - type unix_dirname = string - type unix_filename = string - type host_dirname = string - type host_filename = string - type prog = string - type arg = string - type args = string list - type command_line = (prog * arg list) + type name = string + type package_name = string + type url = string + type unix_dirname = string + type unix_filename = string + type host_dirname = string + type host_filename = string + type prog = string + type arg = string + type args = string list + type command_line = (prog * arg list) - type findlib_name = string - type findlib_full = string + type findlib_name = string + type findlib_full = string type compiled_object = | Byte | Native | Best - + type dependency = | FindlibPackage of findlib_full * OASISVersion.comparator option | InternalLibrary of name - + type tool = | ExternalTool of name | InternalExecutable of name - + type vcs = @@ -1148,7 +1148,7 @@ module OASISTypes = struct | Arch | Monotone | OtherVCS of url - + type plugin_kind = @@ -1176,7 +1176,7 @@ module OASISTypes = struct ] - type 'a plugin = 'a * name * OASISVersion.t option + type 'a plugin = 'a * name * OASISVersion.t option type all_plugin = plugin_kind plugin @@ -1188,7 +1188,7 @@ module OASISTypes = struct (* # 115 "src/oasis/OASISTypes.ml" *) - type 'a conditional = 'a OASISExpr.choices + type 'a conditional = 'a OASISExpr.choices type custom = @@ -1196,7 +1196,7 @@ module OASISTypes = struct pre_command: (command_line option) conditional; post_command: (command_line option) conditional; } - + type common_section = @@ -1205,7 +1205,7 @@ module OASISTypes = struct cs_data: PropList.Data.t; cs_plugin_data: plugin_data; } - + type build_section = @@ -1225,7 +1225,7 @@ module OASISTypes = struct bs_byteopt: args conditional; bs_nativeopt: args conditional; } - + type library = @@ -1236,28 +1236,28 @@ module OASISTypes = struct lib_findlib_parent: findlib_name option; lib_findlib_name: findlib_name option; lib_findlib_containers: findlib_name list; - } + } type object_ = { obj_modules: string list; obj_findlib_fullname: findlib_name list option; - } + } type executable = { exec_custom: bool; exec_main_is: unix_filename; - } + } type flag = { flag_description: string option; flag_default: bool conditional; - } + } type source_repository = @@ -1269,7 +1269,7 @@ module OASISTypes = struct src_repo_branch: string option; src_repo_tag: string option; src_repo_subdir: unix_filename option; - } + } type test = @@ -1280,7 +1280,7 @@ module OASISTypes = struct test_working_directory: unix_filename option; test_run: bool conditional; test_tools: tool list; - } + } type doc_format = @@ -1291,7 +1291,7 @@ module OASISTypes = struct | Info of unix_filename | DVI | OtherDoc - + type doc = @@ -1307,7 +1307,7 @@ module OASISTypes = struct doc_format: doc_format; doc_data_files: (unix_filename * unix_filename option) list; doc_build_tools: tool list; - } + } type section = @@ -1318,7 +1318,7 @@ module OASISTypes = struct | SrcRepo of common_section * source_repository | Test of common_section * test | Doc of common_section * doc - + type section_kind = @@ -1363,7 +1363,7 @@ module OASISTypes = struct disable_oasis_section: unix_filename list; schema_data: PropList.Data.t; plugin_data: plugin_data; - } + } end @@ -6257,7 +6257,7 @@ module OCamlbuildCommon = struct - type extra_args = string list + type extra_args = string list let ocamlbuild_clean_ev = "ocamlbuild-clean" @@ -6574,7 +6574,7 @@ module OCamlbuildDocPlugin = struct { extra_args: string list; run_path: unix_filename; - } + } let doc_build run pkg (cs, doc) argv = @@ -6713,6 +6713,7 @@ let setup_t = bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = [ + "blkgetsize_stubs.c"; "unixext_open_stubs.c"; "unixext_stubs.c"; "unixext_write_stubs.c"; @@ -6774,7 +6775,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.4"; - oasis_digest = Some "^l\005\192\196INu\255~\006Y\"\218\148\154"; + oasis_digest = Some "\006\005]\028\150'A\031\137iU}Z"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -6782,6 +6783,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 6786 "setup.ml" +# 6787 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 8d8666d1f2e1d83d737d9c391c9bdbef98d4ea89 Mon Sep 17 00:00:00 2001 From: David Scott Date: Fri, 26 Sep 2014 18:28:31 +0100 Subject: [PATCH 023/199] Release 0.12.0 Signed-off-by: David Scott --- ChangeLog | 3 +++ _oasis | 4 ++-- lib/META | 4 ++-- setup.ml | 8 ++++---- 4 files changed, 11 insertions(+), 8 deletions(-) diff --git a/ChangeLog b/ChangeLog index c0c4733d0c8..8bb0bc59cdf 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,6 @@ +0.12.0 (26-Sep-2014): +* Build on OS X + 0.11.0 (30-May-2013): * Change Stringext module to Xstringext to avoid conflict with other packages diff --git a/_oasis b/_oasis index 6e87f34c969..35340cd155e 100644 --- a/_oasis +++ b/_oasis @@ -1,10 +1,10 @@ OASISFormat: 0.3 Name: stdext -Version: 0.11.0 +Version: 0.12.0 Synopsis: Standard extension library License: LGPL-2.1 with OCaml linking exception Authors: various -Copyrights: (C) 2012 Citrix +Copyrights: (C) 2006-2014 Citrix BuildTools: ocamlbuild Plugins: DevFiles (0.3), META (0.3) diff --git a/lib/META b/lib/META index 1a05f6893a8..5d1be3faa05 100644 --- a/lib/META +++ b/lib/META @@ -1,6 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: 10d53985c4344a03d83fd38e1a65d6d2) -version = "0.11.0" +# DO NOT EDIT (digest: aeed1c526e0bfd4c0e4829294ebbc5b8) +version = "0.12.0" description = "Standard extension library" requires = "threads uuidm unix fd-send-recv bigarray" archive(byte) = "stdext.cma" diff --git a/setup.ml b/setup.ml index bdd672e3639..b595f2c1db1 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: c6a046ac6a0d0de7dbc290b0c0ddb8b1) *) +(* DO NOT EDIT (digest: 72c9f45132c57d19659d7e295a4a393d) *) (* Regenerated by OASIS v0.4.4 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6638,7 +6638,7 @@ let setup_t = alpha_features = []; beta_features = []; name = "stdext"; - version = "0.11.0"; + version = "0.12.0"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -6648,7 +6648,7 @@ let setup_t = version = OASISLicense.Version "2.1" }); license_file = None; - copyrights = ["(C) 2012 Citrix"]; + copyrights = ["(C) 2006-2014 Citrix"]; maintainers = []; authors = ["various"]; homepage = None; @@ -6775,7 +6775,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.4"; - oasis_digest = Some "\006\005]\028\150'A\031\137iU}Z"; + oasis_digest = Some "z,0> fagT\014H\1517z"; oasis_exec = None; oasis_setup_args = []; setup_update = false From b6a45313b5c6d953e1a3bd63ebe8d7f053e95a83 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sun, 2 Nov 2014 17:42:08 +0000 Subject: [PATCH 024/199] Add opam file Signed-off-by: David Scott --- opam | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 opam diff --git a/opam b/opam new file mode 100644 index 00000000000..b2ba0410b63 --- /dev/null +++ b/opam @@ -0,0 +1,17 @@ +opam-version: "1" +maintainer: "jonathan.ludlam@eu.citrix.com" +build: [ + [make] + [make "install" "BINDIR=%{bin}%"] +] +remove: [ + [make "uninstall" "BINDIR=%{bin}%"] + ["ocamlfind" "remove" "stdext"] +] +depends: [ + "ocamlfind" + "uuidm" + "fd-send-recv" + "sexplib" + "xapi-backtrace" +] From 2626fdb0609cf102ad1c8e42be0576291913373c Mon Sep 17 00:00:00 2001 From: David Scott Date: Sun, 2 Nov 2014 17:42:24 +0000 Subject: [PATCH 025/199] Add .gitignore Signed-off-by: David Scott --- .gitignore | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000000..3e01f99e805 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +_build/ +setup.data +setup.log From 91d0852d70dcb9a576a87e44d97f81c3b8141f70 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sun, 2 Nov 2014 17:42:56 +0000 Subject: [PATCH 026/199] Encodings: fix a parse error under camlp4 Signed-off-by: David Scott --- lib/encodings.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/encodings.ml b/lib/encodings.ml index 15c35136b0e..ad3bf91110b 100644 --- a/lib/encodings.ml +++ b/lib/encodings.ml @@ -95,9 +95,9 @@ end module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) = struct let width_required_for_ucs_value value = - if value < 0x000080l (* 1 << 7 *) then 1 else - if value < 0x000800l (* 1 << 11 *) then 2 else - if value < 0x010000l (* 1 << 16 *) then 3 else 4 + if value < 0x000080l (* 1 lsl 7 *) then 1 else + if value < 0x000800l (* 1 lsl 11 *) then 2 else + if value < 0x010000l (* 1 lsl 16 *) then 3 else 4 (* === Decoding === *) From 08754ec563def7def45087f11a5c804d575c6129 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sun, 2 Nov 2014 17:44:57 +0000 Subject: [PATCH 027/199] Remove the Backtrace module, depend on the backtrace package Signed-off-by: David Scott --- ChangeLog | 4 ++-- _oasis | 8 ++++---- lib/backtrace.ml | 33 --------------------------------- lib/backtrace.mli | 14 -------------- 4 files changed, 6 insertions(+), 53 deletions(-) delete mode 100644 lib/backtrace.ml delete mode 100644 lib/backtrace.mli diff --git a/ChangeLog b/ChangeLog index 8bb0bc59cdf..b63a069f871 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,5 @@ -0.12.0 (26-Sep-2014): -* Build on OS X +0.12.0 (unreleased) +* Depend on Backtrace from xapi-backtrace 0.11.0 (30-May-2013): * Change Stringext module to Xstringext to avoid conflict with other packages diff --git a/_oasis b/_oasis index 35340cd155e..4f6368a1645 100644 --- a/_oasis +++ b/_oasis @@ -1,17 +1,17 @@ OASISFormat: 0.3 Name: stdext -Version: 0.12.0 +Version: 0.11.0 Synopsis: Standard extension library License: LGPL-2.1 with OCaml linking exception Authors: various -Copyrights: (C) 2006-2014 Citrix +Copyrights: (C) 2012 Citrix BuildTools: ocamlbuild Plugins: DevFiles (0.3), META (0.3) Library stdext Path: lib - Modules: Arrayext, Backtrace, Base64, Bigbuffer, Config, Date, Either, Encodings, ExtentlistSet, Filenameext, Fring, Fun, Hashtblext, Int64ext, LazyList, Listext, Mapext, Monad, Opt, Pervasiveext, Qring, Range, Ring, Xstringext, Threadext, Trie, Unixext, VIO, Zerocheck + Modules: Arrayext, Base64, Bigbuffer, Config, Date, Either, Encodings, ExtentlistSet, Filenameext, Fring, Fun, Hashtblext, Int64ext, LazyList, Listext, Mapext, Monad, Opt, Pervasiveext, Qring, Range, Ring, Xstringext, Threadext, Trie, Unixext, VIO, Zerocheck CSources: blkgetsize_stubs.c, unixext_open_stubs.c, unixext_stubs.c, unixext_write_stubs.c, zerocheck_stub.c - BuildDepends: threads, uuidm, unix, fd-send-recv, bigarray + BuildDepends: threads, uuidm, unix, fd-send-recv, bigarray, sexplib, sexplib.syntax, xapi-backtrace diff --git a/lib/backtrace.ml b/lib/backtrace.ml deleted file mode 100644 index 0d5985b8a51..00000000000 --- a/lib/backtrace.ml +++ /dev/null @@ -1,33 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -let get_backtrace () = - let b = Printexc.get_backtrace () in - let nicify_locator s = - try - match Xstringext.String.split ',' s with - | file :: line :: character :: [] -> - let i = String.index_from file 0 '"' + 1 in - let i2 = String.index_from file i '"' in - String.concat "" [ String.sub file i (i2 - i); ":"; - (try String.sub line 6 (String.length line - 6) with _ -> line); "."; - (try String.sub character 12 (String.length character - 12) with _ -> character) ] - | _ -> s - with _ -> s - in - try - let list = Xstringext.String.split '\n' b in - let list = List.filter ((<>) "") list in - "Raised at " ^ (String.concat " -> " (List.map nicify_locator list)) - with _ -> - b diff --git a/lib/backtrace.mli b/lib/backtrace.mli deleted file mode 100644 index 4d693b0f6b4..00000000000 --- a/lib/backtrace.mli +++ /dev/null @@ -1,14 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -val get_backtrace : unit -> string From 865c46728aa60f0882140c0f695c95af84723c53 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sun, 2 Nov 2014 17:45:21 +0000 Subject: [PATCH 028/199] Pervasiveext: record the current backtrace when running 'finally' Note the exnhook is also removed-- this was only being used to print partial backtrace fragments to the log. Signed-off-by: David Scott --- lib/pervasiveext.ml | 14 +++++++------- lib/pervasiveext.mli | 5 ++++- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/lib/pervasiveext.ml b/lib/pervasiveext.ml index 2ca52fa5773..bd99cda583f 100644 --- a/lib/pervasiveext.ml +++ b/lib/pervasiveext.ml @@ -15,15 +15,15 @@ * Even if fct raises an exception, clean_f is applied *) -let exnhook = ref None let finally fct clean_f = - let result = try - fct (); - with - exn -> - (match !exnhook with None -> () | Some f -> f exn); - clean_f (); raise exn in + let result = + try + fct (); + with exn -> + Backtrace.is_important exn; + clean_f (); + raise exn in clean_f (); result diff --git a/lib/pervasiveext.mli b/lib/pervasiveext.mli index 49a734e7766..b0043458eb2 100644 --- a/lib/pervasiveext.mli +++ b/lib/pervasiveext.mli @@ -11,8 +11,11 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -val exnhook : (exn -> unit) option ref + val finally : (unit -> 'a) -> (unit -> 'b) -> 'a +(** [finally f g] returns [f ()] guaranteeing to run clean-up actions + [g ()] even if [f ()] throws an exception. *) + val maybe_with_default : 'b -> ('a -> 'b) -> 'a option -> 'b val may : ('a -> 'b) -> 'a option -> 'b option val default : 'a -> 'a option -> 'a From 74fc819bfffa6cb3d6864da7bc95b7b616620a09 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sun, 2 Nov 2014 17:46:41 +0000 Subject: [PATCH 029/199] Xstringext: avoid using exceptions in simple utility functions Signed-off-by: David Scott --- lib/xstringext.ml | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/lib/xstringext.ml b/lib/xstringext.ml index c7de560e360..d9d94cd3fc9 100644 --- a/lib/xstringext.ml +++ b/lib/xstringext.ml @@ -84,8 +84,9 @@ let strip predicate string = let escaped ?rules string = match rules with | None -> String.escaped string | Some rules -> - let aux h t = (try List.assoc h rules - with Not_found -> of_char h) :: t in + let aux h t = (if List.mem_assoc h rules + then List.assoc h rules + else of_char h) :: t in concat "" (fold_right aux string []) (** Take a predicate and a string, return a list of strings separated by @@ -104,8 +105,18 @@ let split_f p str = end in List.rev (List.map implode (alternate [] true (explode str))) +let index_opt s c = + let rec loop i = + if String.length s = i + then None + else + if s.[i] = c + then Some i + else loop (i + 1) in + loop 0 + let rec split ?limit:(limit=(-1)) c s = - let i = try String.index s c with Not_found -> -1 in + let i = match index_opt s c with | Some x -> x | None -> -1 in let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in if i = -1 || nlimit = 0 then [ s ] From 7a537fbcea4cc4344d137cafe39a3c2a67564194 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sun, 2 Nov 2014 17:48:19 +0000 Subject: [PATCH 030/199] Regenerate OASIS Signed-off-by: David Scott --- _tags | 31 +++++-- lib/META | 7 +- lib/stdext.mldylib | 31 +++++++ lib/stdext.mllib | 3 +- myocamlbuild.ml | 88 +++++++++++--------- setup.ml | 195 +++++++++++++++++++++++++++------------------ 6 files changed, 228 insertions(+), 127 deletions(-) create mode 100644 lib/stdext.mldylib diff --git a/_tags b/_tags index 3eb4c0d757f..3f63dbbf48d 100644 --- a/_tags +++ b/_tags @@ -1,8 +1,9 @@ # OASIS_START -# DO NOT EDIT (digest: ad1a1bbbb71d472f0711580d2cc59333) +# DO NOT EDIT (digest: 0b1ac2bd701986ac4e927661d05dbd2f) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process +true: annot, bin_annot <**/.svn>: -traverse <**/.svn>: not_hygienic ".bzr": -traverse @@ -16,34 +17,52 @@ # Library stdext "lib/stdext.cmxs": use_stdext : use_libstdext_stubs -: pkg_bigarray -: pkg_fd-send-recv -: pkg_threads -: pkg_unix -: pkg_uuidm +: pkg_bigarray +: pkg_fd-send-recv +: pkg_sexplib +: pkg_sexplib.syntax +: pkg_threads +: pkg_unix +: pkg_uuidm +: pkg_xapi-backtrace "lib/blkgetsize_stubs.c": pkg_bigarray "lib/blkgetsize_stubs.c": pkg_fd-send-recv +"lib/blkgetsize_stubs.c": pkg_sexplib +"lib/blkgetsize_stubs.c": pkg_sexplib.syntax "lib/blkgetsize_stubs.c": pkg_threads "lib/blkgetsize_stubs.c": pkg_unix "lib/blkgetsize_stubs.c": pkg_uuidm +"lib/blkgetsize_stubs.c": pkg_xapi-backtrace "lib/unixext_open_stubs.c": pkg_bigarray "lib/unixext_open_stubs.c": pkg_fd-send-recv +"lib/unixext_open_stubs.c": pkg_sexplib +"lib/unixext_open_stubs.c": pkg_sexplib.syntax "lib/unixext_open_stubs.c": pkg_threads "lib/unixext_open_stubs.c": pkg_unix "lib/unixext_open_stubs.c": pkg_uuidm +"lib/unixext_open_stubs.c": pkg_xapi-backtrace "lib/unixext_stubs.c": pkg_bigarray "lib/unixext_stubs.c": pkg_fd-send-recv +"lib/unixext_stubs.c": pkg_sexplib +"lib/unixext_stubs.c": pkg_sexplib.syntax "lib/unixext_stubs.c": pkg_threads "lib/unixext_stubs.c": pkg_unix "lib/unixext_stubs.c": pkg_uuidm +"lib/unixext_stubs.c": pkg_xapi-backtrace "lib/unixext_write_stubs.c": pkg_bigarray "lib/unixext_write_stubs.c": pkg_fd-send-recv +"lib/unixext_write_stubs.c": pkg_sexplib +"lib/unixext_write_stubs.c": pkg_sexplib.syntax "lib/unixext_write_stubs.c": pkg_threads "lib/unixext_write_stubs.c": pkg_unix "lib/unixext_write_stubs.c": pkg_uuidm +"lib/unixext_write_stubs.c": pkg_xapi-backtrace "lib/zerocheck_stub.c": pkg_bigarray "lib/zerocheck_stub.c": pkg_fd-send-recv +"lib/zerocheck_stub.c": pkg_sexplib +"lib/zerocheck_stub.c": pkg_sexplib.syntax "lib/zerocheck_stub.c": pkg_threads "lib/zerocheck_stub.c": pkg_unix "lib/zerocheck_stub.c": pkg_uuidm +"lib/zerocheck_stub.c": pkg_xapi-backtrace # OASIS_STOP diff --git a/lib/META b/lib/META index 5d1be3faa05..b00d19d2432 100644 --- a/lib/META +++ b/lib/META @@ -1,8 +1,9 @@ # OASIS_START -# DO NOT EDIT (digest: aeed1c526e0bfd4c0e4829294ebbc5b8) -version = "0.12.0" +# DO NOT EDIT (digest: 21fd61b70457600a802589019bd01d38) +version = "0.11.0" description = "Standard extension library" -requires = "threads uuidm unix fd-send-recv bigarray" +requires = +"threads uuidm unix fd-send-recv bigarray sexplib sexplib.syntax xapi-backtrace" archive(byte) = "stdext.cma" archive(byte, plugin) = "stdext.cma" archive(native) = "stdext.cmxa" diff --git a/lib/stdext.mldylib b/lib/stdext.mldylib new file mode 100644 index 00000000000..9a4e7d369e7 --- /dev/null +++ b/lib/stdext.mldylib @@ -0,0 +1,31 @@ +# OASIS_START +# DO NOT EDIT (digest: 3ba17b3a67d7a4ec569fbc8550f6f99c) +Arrayext +Base64 +Bigbuffer +Config +Date +Either +Encodings +ExtentlistSet +Filenameext +Fring +Fun +Hashtblext +Int64ext +LazyList +Listext +Mapext +Monad +Opt +Pervasiveext +Qring +Range +Ring +Xstringext +Threadext +Trie +Unixext +VIO +Zerocheck +# OASIS_STOP diff --git a/lib/stdext.mllib b/lib/stdext.mllib index a6c9d9ccf43..9a4e7d369e7 100644 --- a/lib/stdext.mllib +++ b/lib/stdext.mllib @@ -1,7 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: c978081ca056d24ca2e8600834c60c52) +# DO NOT EDIT (digest: 3ba17b3a67d7a4ec569fbc8550f6f99c) Arrayext -Backtrace Base64 Bigbuffer Config diff --git a/myocamlbuild.ml b/myocamlbuild.ml index c64d730ff16..be989b5b6cb 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: b8faf3da52e902fb96e77b14b83140c9) *) +(* DO NOT EDIT (digest: dba92887184f22116d0dac650d66e896) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -249,6 +249,9 @@ module MyOCamlbuildFindlib = struct *) open Ocamlbuild_plugin + type conf = + { no_automatic_syntax: bool; + } (* these functions are not really officially exported *) let run_and_read = @@ -315,7 +318,7 @@ module MyOCamlbuildFindlib = struct (* This lists all supported packages. *) let find_packages () = - List.map before_space (split_nl & run_and_read "ocamlfind list") + List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) (* Mock to list available syntaxes. *) @@ -338,7 +341,7 @@ module MyOCamlbuildFindlib = struct ] - let dispatch = + let dispatch conf = function | After_options -> (* By using Before_options one let command line options have an higher @@ -357,31 +360,39 @@ module MyOCamlbuildFindlib = struct * -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; - (* For each ocamlfind package one inject the -package option when - * compiling, computing dependencies, generating documentation and - * linking. *) - List.iter - begin fun pkg -> - let base_args = [A"-package"; A pkg] in - (* TODO: consider how to really choose camlp4o or camlp4r. *) - let syn_args = [A"-syntax"; A "camlp4o"] in - let args = - (* Heuristic to identify syntax extensions: whether they end in - ".syntax"; some might not. - *) - if Filename.check_suffix pkg "syntax" || - List.mem pkg well_known_syntax then - syn_args @ base_args - else - base_args - in - flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; - flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; - flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; - flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; - flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; - end - (find_packages ()); + if not (conf.no_automatic_syntax) then begin + (* For each ocamlfind package one inject the -package option when + * compiling, computing dependencies, generating documentation and + * linking. *) + List.iter + begin fun pkg -> + let base_args = [A"-package"; A pkg] in + (* TODO: consider how to really choose camlp4o or camlp4r. *) + let syn_args = [A"-syntax"; A "camlp4o"] in + let (args, pargs) = + (* Heuristic to identify syntax extensions: whether they end in + ".syntax"; some might not. + *) + if Filename.check_suffix pkg "syntax" || + List.mem pkg well_known_syntax then + (syn_args @ base_args, syn_args) + else + (base_args, []) + in + flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; + flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; + flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; + flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; + flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; + + (* TODO: Check if this is allowed for OCaml < 3.12.1 *) + flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; + end + (find_packages ()); + end; (* Like -package but for extensions syntax. Morover -syntax is useless * when linking. *) @@ -546,12 +557,13 @@ module MyOCamlbuildBase = struct (* When ocaml link something that use the C library, then one need that file to be up to date. + This holds both for programs and for libraries. *) - dep ["link"; "ocaml"; "program"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + dep ["link"; "ocaml"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - dep ["compile"; "ocaml"; "program"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + dep ["compile"; "ocaml"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; (* TODO: be more specific about what depends on headers *) (* Depends on .h files *) @@ -580,18 +592,18 @@ module MyOCamlbuildBase = struct () - let dispatch_default t = + let dispatch_default conf t = dispatch_combine [ dispatch t; - MyOCamlbuildFindlib.dispatch; + MyOCamlbuildFindlib.dispatch conf; ] end -# 594 "myocamlbuild.ml" +# 606 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { @@ -602,8 +614,10 @@ let package_default = } ;; -let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; +let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} + +let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; -# 608 "myocamlbuild.ml" +# 622 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/setup.ml b/setup.ml index b595f2c1db1..decfc762101 100644 --- a/setup.ml +++ b/setup.ml @@ -1,9 +1,9 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 72c9f45132c57d19659d7e295a4a393d) *) +(* DO NOT EDIT (digest: a74dc04df9f5f3ec12eeba326d41df40) *) (* - Regenerated by OASIS v0.4.4 + Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) @@ -242,11 +242,9 @@ module OASISString = struct let replace_chars f s = - let buf = String.make (String.length s) 'X' in - for i = 0 to String.length s - 1 do - buf.[i] <- f s.[i] - done; - buf + let buf = Buffer.create (String.length s) in + String.iter (fun c -> Buffer.add_char buf (f c)) s; + Buffer.contents buf end @@ -1729,6 +1727,13 @@ module OASISFeatures = struct (fun () -> s_ "Allows the OASIS section comments and digest to be omitted in \ generated files.") + + let no_automatic_syntax = + create "no_automatic_syntax" alpha + (fun () -> + s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ + that matches the internal heuristic (if a dependency ends with \ + a .syntax or is a well known syntax).") end module OASISUnixPath = struct @@ -2099,16 +2104,6 @@ module OASISLibrary = struct lst in - (* The headers that should be compiled along *) - let headers = - if lib.lib_pack then - [] - else - find_modules - lib.lib_modules - "cmi" - in - (* The .cmx that be compiled along *) let cmxs = let should_be_built = @@ -2134,12 +2129,32 @@ module OASISLibrary = struct [] in + (* The headers and annot/cmt files that should be compiled along *) + let headers = + let sufx = + if lib.lib_pack + then [".cmti"; ".cmt"; ".annot"] + else [".cmi"; ".cmti"; ".cmt"; ".annot"] + in + List.map + begin + List.fold_left + begin fun accu s -> + let dot = String.rindex s '.' in + let base = String.sub s 0 dot in + List.map ((^) base) sufx @ accu + end + [] + end + (find_modules lib.lib_modules "cmi") + in + (* Compute what libraries should be built *) let acc_nopath = (* Add the packed header file if required *) let add_pack_header acc = if lib.lib_pack then - [cs.cs_name^".cmi"] :: acc + [cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc else acc in @@ -2499,13 +2514,13 @@ module OASISFindlib = struct in let library_name_of_findlib_name = - Lazy.lazy_from_fun - (fun () -> - (* Revert findlib_name_of_library_name. *) - MapString.fold - (fun k v mp -> MapString.add v k mp) - fndlb_name_of_lib_name - MapString.empty) + lazy begin + (* Revert findlib_name_of_library_name. *) + MapString.fold + (fun k v mp -> MapString.add v k mp) + fndlb_name_of_lib_name + MapString.empty + end in let library_name_of_findlib_name fndlb_nm = try @@ -2875,7 +2890,7 @@ module OASISFileUtil = struct end -# 2878 "setup.ml" +# 2893 "setup.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) @@ -2980,7 +2995,7 @@ module BaseEnvLight = struct end -# 2983 "setup.ml" +# 2998 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) @@ -5391,7 +5406,7 @@ module BaseSetup = struct end -# 5394 "setup.ml" +# 5409 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) @@ -5827,6 +5842,17 @@ module InternalInstallPlugin = struct lst in + let make_fnames modul sufx = + List.fold_right + begin fun sufx accu -> + (String.capitalize modul ^ sufx) :: + (String.uncapitalize modul ^ sufx) :: + accu + end + sufx + [] + in + (** Install all libraries *) let install_libs pkg = @@ -5847,27 +5873,29 @@ module InternalInstallPlugin = struct OASISHostPath.of_unix bs.bs_path in List.fold_left - (fun acc modul -> - try - List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - [modul^".mli"; - modul^".ml"; - String.uncapitalize modul^".mli"; - String.capitalize modul^".mli"; - String.uncapitalize modul^".ml"; - String.capitalize modul^".ml"]) - :: acc - with Not_found -> - begin - warning - (f_ "Cannot find source header for module %s \ - in library %s") - modul cs.cs_name; - acc - end) + begin fun acc modul -> + begin + try + [List.find + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + (make_fnames modul [".mli"; ".ml"]))] + with Not_found -> + warning + (f_ "Cannot find source header for module %s \ + in library %s") + modul cs.cs_name; + [] + end + @ + List.filter + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + (make_fnames modul [".annot";".cmti";".cmt"])) + @ acc + end acc lib.lib_modules in @@ -5915,27 +5943,29 @@ module InternalInstallPlugin = struct OASISHostPath.of_unix bs.bs_path in List.fold_left - (fun acc modul -> - try - List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - [modul^".mli"; - modul^".ml"; - String.uncapitalize modul^".mli"; - String.capitalize modul^".mli"; - String.uncapitalize modul^".ml"; - String.capitalize modul^".ml"]) - :: acc - with Not_found -> - begin - warning - (f_ "Cannot find source header for module %s \ - in object %s") - modul cs.cs_name; - acc - end) + begin fun acc modul -> + begin + try + [List.find + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + (make_fnames modul [".mli"; ".ml"]))] + with Not_found -> + warning + (f_ "Cannot find source header for module %s \ + in object %s") + modul cs.cs_name; + [] + end + @ + List.filter + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + (make_fnames modul [".annot";".cmti";".cmt"])) + @ acc + end acc obj.obj_modules in @@ -6240,7 +6270,7 @@ module InternalInstallPlugin = struct end -# 6243 "setup.ml" +# 6273 "setup.ml" module OCamlbuildCommon = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) @@ -6298,6 +6328,11 @@ module OCamlbuildCommon = struct else []; + if bool_of_string (tests ()) then + ["-tag"; "tests"] + else + []; + if bool_of_string (profile ()) then ["-tag"; "profile"] else @@ -6613,7 +6648,7 @@ module OCamlbuildDocPlugin = struct end -# 6616 "setup.ml" +# 6651 "setup.ml" open OASISTypes;; let setup_t = @@ -6638,7 +6673,7 @@ let setup_t = alpha_features = []; beta_features = []; name = "stdext"; - version = "0.12.0"; + version = "0.11.0"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -6648,7 +6683,7 @@ let setup_t = version = OASISLicense.Version "2.1" }); license_file = None; - copyrights = ["(C) 2006-2014 Citrix"]; + copyrights = ["(C) 2012 Citrix"]; maintainers = []; authors = ["various"]; homepage = None; @@ -6708,7 +6743,10 @@ let setup_t = FindlibPackage ("uuidm", None); FindlibPackage ("unix", None); FindlibPackage ("fd-send-recv", None); - FindlibPackage ("bigarray", None) + FindlibPackage ("bigarray", None); + FindlibPackage ("sexplib", None); + FindlibPackage ("sexplib.syntax", None); + FindlibPackage ("xapi-backtrace", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = @@ -6731,7 +6769,6 @@ let setup_t = lib_modules = [ "Arrayext"; - "Backtrace"; "Base64"; "Bigbuffer"; "Config"; @@ -6774,8 +6811,8 @@ let setup_t = plugin_data = [] }; oasis_fn = Some "_oasis"; - oasis_version = "0.4.4"; - oasis_digest = Some "z,0> fagT\014H\1517z"; + oasis_version = "0.4.5"; + oasis_digest = Some "\163-\012\027p\254\203\1566C\011\236\167/\154\245"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -6783,6 +6820,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 6787 "setup.ml" +# 6824 "setup.ml" (* OASIS_STOP *) let () = setup ();; From f195f64211466eb32b404e163b1427a21630eeb8 Mon Sep 17 00:00:00 2001 From: David Scott Date: Thu, 20 Nov 2014 11:43:23 +0000 Subject: [PATCH 031/199] Release 0.13.0 Signed-off-by: David Scott --- ChangeLog | 6 +++++- _oasis | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index b63a069f871..36ed33d8b79 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,9 @@ -0.12.0 (unreleased) +0.13.0 (20-Nov-2014): * Depend on Backtrace from xapi-backtrace +* Add an opam file + +0.12.0 (26-Sep-2014): +* Fix build errors on OS X 0.11.0 (30-May-2013): * Change Stringext module to Xstringext to avoid conflict with other packages diff --git a/_oasis b/_oasis index 4f6368a1645..158a1e1f860 100644 --- a/_oasis +++ b/_oasis @@ -1,6 +1,6 @@ OASISFormat: 0.3 Name: stdext -Version: 0.11.0 +Version: 0.13.0 Synopsis: Standard extension library License: LGPL-2.1 with OCaml linking exception Authors: various From 27f4a18e4c7d9faca8b49e5dfcfd473be92ca4e2 Mon Sep 17 00:00:00 2001 From: David Scott Date: Thu, 20 Nov 2014 11:43:29 +0000 Subject: [PATCH 032/199] Regenerate OASIS Signed-off-by: David Scott --- lib/META | 4 ++-- setup.ml | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/lib/META b/lib/META index b00d19d2432..4a967007f23 100644 --- a/lib/META +++ b/lib/META @@ -1,6 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: 21fd61b70457600a802589019bd01d38) -version = "0.11.0" +# DO NOT EDIT (digest: f8690efb71f599dc91ab26389ca83c22) +version = "0.13.0" description = "Standard extension library" requires = "threads uuidm unix fd-send-recv bigarray sexplib sexplib.syntax xapi-backtrace" diff --git a/setup.ml b/setup.ml index decfc762101..0a2dd2c2499 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: a74dc04df9f5f3ec12eeba326d41df40) *) +(* DO NOT EDIT (digest: 7f0d0bf60c57dd29e570e0c0886d7805) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6673,7 +6673,7 @@ let setup_t = alpha_features = []; beta_features = []; name = "stdext"; - version = "0.11.0"; + version = "0.13.0"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -6812,7 +6812,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; - oasis_digest = Some "\163-\012\027p\254\203\1566C\011\236\167/\154\245"; + oasis_digest = Some "\240\188\225\230VH\224\168\151\140\209/\t\160\1459"; oasis_exec = None; oasis_setup_args = []; setup_update = false From 52920d98078cdf4c71755a2f9b4d4fee484f9420 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Thu, 3 Sep 2015 15:40:26 +0100 Subject: [PATCH 033/199] Fix a clash of stubs with mirage-block-volume. Signed-off-by: Jon Ludlam --- lib/blkgetsize_stubs.c | 35 +++-------------------------------- lib/unixext_stubs.c | 4 ++-- 2 files changed, 5 insertions(+), 34 deletions(-) diff --git a/lib/blkgetsize_stubs.c b/lib/blkgetsize_stubs.c index e28bed518d8..78fc6e52acf 100644 --- a/lib/blkgetsize_stubs.c +++ b/lib/blkgetsize_stubs.c @@ -33,7 +33,7 @@ #ifdef __linux__ #include -int blkgetsize(int fd, uint64_t *psize) +int stdext_blkgetsize(int fd, uint64_t *psize) { #ifdef BLKGETSIZE64 int ret = ioctl(fd, BLKGETSIZE64, psize); @@ -50,7 +50,7 @@ int blkgetsize(int fd, uint64_t *psize) #elif defined(__APPLE__) #include -int blkgetsize(int fd, uint64_t *psize) +int stdext_blkgetsize(int fd, uint64_t *psize) { unsigned long blocksize = 0; int ret = ioctl(fd, DKIOCGETBLOCKSIZE, &blocksize); @@ -66,7 +66,7 @@ int blkgetsize(int fd, uint64_t *psize) #elif defined(__FreeBSD__) #include -int blkgetsize(int fd, uint64_t *psize) +int stdext_blkgetsize(int fd, uint64_t *psize) { int ret = ioctl(fd, DIOCGMEDIASIZE, psize); return ret; @@ -75,32 +75,3 @@ int blkgetsize(int fd, uint64_t *psize) #else # error "Unable to query block device size: unsupported platform, please report." #endif - -/* ocaml/ocaml/unixsupport.c */ -extern void uerror(char *cmdname, value cmdarg); -#define Nothing ((value) 0) - -CAMLprim value stub_blkgetsize(value filename){ - CAMLparam1(filename); - CAMLlocal1(result); - uint64_t size_in_bytes; - int fd; - int success = -1; - - const char *filename_c = strdup(String_val(filename)); - - enter_blocking_section(); - fd = open(filename_c, O_RDONLY, 0); - if (blkgetsize(fd, &size_in_bytes) == 0) - success = 0; - close(fd); - leave_blocking_section(); - - free((void*)filename_c); - - if (fd == -1) uerror("open", filename); - if (success == -1) uerror("BLKGETSIZE", filename); - - result = caml_copy_int64(size_in_bytes); - CAMLreturn(result); -} diff --git a/lib/unixext_stubs.c b/lib/unixext_stubs.c index 5821a0ab25e..af948060077 100644 --- a/lib/unixext_stubs.c +++ b/lib/unixext_stubs.c @@ -55,7 +55,7 @@ CAMLprim value stub_unixext_fsync (value fd) CAMLreturn(Val_unit); } -extern uint64_t blkgetsize(int fd, uint64_t *psize); +extern uint64_t stdext_blkgetsize(int fd, uint64_t *psize); CAMLprim value stub_unixext_blkgetsize64(value fd) { @@ -63,7 +63,7 @@ CAMLprim value stub_unixext_blkgetsize64(value fd) uint64_t size; int c_fd = Int_val(fd); /* mirage-block-unix binding: */ - if (blkgetsize(c_fd, &size)) { + if (stdext_blkgetsize(c_fd, &size)) { uerror("ioctl(BLKGETSIZE64)", Nothing); } CAMLreturn(caml_copy_int64(size)); From d7339b634c031ed208a834e33ea4168add9edda9 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Fri, 20 May 2016 17:20:26 +0100 Subject: [PATCH 034/199] Pack the stdext library Signed-off-by: Jon Ludlam --- _oasis | 2 + _tags | 30 +++++++- lib/stdext.mldylib | 31 +------- lib/stdext.mllib | 31 +------- lib/stdext.mlpack | 31 ++++++++ myocamlbuild.ml | 174 +++++++++++++++++++++++++++++++++++++++++++-- setup.ml | 74 ++++++++++++------- 7 files changed, 282 insertions(+), 91 deletions(-) create mode 100644 lib/stdext.mlpack diff --git a/_oasis b/_oasis index 158a1e1f860..7be96df43d0 100644 --- a/_oasis +++ b/_oasis @@ -10,6 +10,8 @@ Plugins: DevFiles (0.3), META (0.3) Library stdext Path: lib + FindlibName: stdext + Pack: true Modules: Arrayext, Base64, Bigbuffer, Config, Date, Either, Encodings, ExtentlistSet, Filenameext, Fring, Fun, Hashtblext, Int64ext, LazyList, Listext, Mapext, Monad, Opt, Pervasiveext, Qring, Range, Ring, Xstringext, Threadext, Trie, Unixext, VIO, Zerocheck CSources: blkgetsize_stubs.c, unixext_open_stubs.c, unixext_stubs.c, unixext_write_stubs.c, zerocheck_stub.c BuildDepends: threads, uuidm, unix, fd-send-recv, bigarray, sexplib, sexplib.syntax, xapi-backtrace diff --git a/_tags b/_tags index 3f63dbbf48d..f9c604f837b 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 0b1ac2bd701986ac4e927661d05dbd2f) +# DO NOT EDIT (digest: fd955a6e26aaf02da6d2229f5c87ec2e) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -16,6 +16,34 @@ true: annot, bin_annot "_darcs": not_hygienic # Library stdext "lib/stdext.cmxs": use_stdext +"lib/arrayext.cmx": for-pack(Stdext) +"lib/base64.cmx": for-pack(Stdext) +"lib/bigbuffer.cmx": for-pack(Stdext) +"lib/config.cmx": for-pack(Stdext) +"lib/date.cmx": for-pack(Stdext) +"lib/either.cmx": for-pack(Stdext) +"lib/encodings.cmx": for-pack(Stdext) +"lib/extentlistSet.cmx": for-pack(Stdext) +"lib/filenameext.cmx": for-pack(Stdext) +"lib/fring.cmx": for-pack(Stdext) +"lib/fun.cmx": for-pack(Stdext) +"lib/hashtblext.cmx": for-pack(Stdext) +"lib/int64ext.cmx": for-pack(Stdext) +"lib/lazyList.cmx": for-pack(Stdext) +"lib/listext.cmx": for-pack(Stdext) +"lib/mapext.cmx": for-pack(Stdext) +"lib/monad.cmx": for-pack(Stdext) +"lib/opt.cmx": for-pack(Stdext) +"lib/pervasiveext.cmx": for-pack(Stdext) +"lib/qring.cmx": for-pack(Stdext) +"lib/range.cmx": for-pack(Stdext) +"lib/ring.cmx": for-pack(Stdext) +"lib/xstringext.cmx": for-pack(Stdext) +"lib/threadext.cmx": for-pack(Stdext) +"lib/trie.cmx": for-pack(Stdext) +"lib/unixext.cmx": for-pack(Stdext) +"lib/vIO.cmx": for-pack(Stdext) +"lib/zerocheck.cmx": for-pack(Stdext) : use_libstdext_stubs : pkg_bigarray : pkg_fd-send-recv diff --git a/lib/stdext.mldylib b/lib/stdext.mldylib index 9a4e7d369e7..931fdde2593 100644 --- a/lib/stdext.mldylib +++ b/lib/stdext.mldylib @@ -1,31 +1,4 @@ # OASIS_START -# DO NOT EDIT (digest: 3ba17b3a67d7a4ec569fbc8550f6f99c) -Arrayext -Base64 -Bigbuffer -Config -Date -Either -Encodings -ExtentlistSet -Filenameext -Fring -Fun -Hashtblext -Int64ext -LazyList -Listext -Mapext -Monad -Opt -Pervasiveext -Qring -Range -Ring -Xstringext -Threadext -Trie -Unixext -VIO -Zerocheck +# DO NOT EDIT (digest: 2bbe9a6396c26d99b35474fffa94ee2a) +Stdext # OASIS_STOP diff --git a/lib/stdext.mllib b/lib/stdext.mllib index 9a4e7d369e7..931fdde2593 100644 --- a/lib/stdext.mllib +++ b/lib/stdext.mllib @@ -1,31 +1,4 @@ # OASIS_START -# DO NOT EDIT (digest: 3ba17b3a67d7a4ec569fbc8550f6f99c) -Arrayext -Base64 -Bigbuffer -Config -Date -Either -Encodings -ExtentlistSet -Filenameext -Fring -Fun -Hashtblext -Int64ext -LazyList -Listext -Mapext -Monad -Opt -Pervasiveext -Qring -Range -Ring -Xstringext -Threadext -Trie -Unixext -VIO -Zerocheck +# DO NOT EDIT (digest: 2bbe9a6396c26d99b35474fffa94ee2a) +Stdext # OASIS_STOP diff --git a/lib/stdext.mlpack b/lib/stdext.mlpack new file mode 100644 index 00000000000..9a4e7d369e7 --- /dev/null +++ b/lib/stdext.mlpack @@ -0,0 +1,31 @@ +# OASIS_START +# DO NOT EDIT (digest: 3ba17b3a67d7a4ec569fbc8550f6f99c) +Arrayext +Base64 +Bigbuffer +Config +Date +Either +Encodings +ExtentlistSet +Filenameext +Fring +Fun +Hashtblext +Int64ext +LazyList +Listext +Mapext +Monad +Opt +Pervasiveext +Qring +Range +Ring +Xstringext +Threadext +Trie +Unixext +VIO +Zerocheck +# OASIS_STOP diff --git a/myocamlbuild.ml b/myocamlbuild.ml index be989b5b6cb..7e91ce5cfc1 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: dba92887184f22116d0dac650d66e896) *) +(* DO NOT EDIT (digest: 40228c21bfd6ad9f9fc2150a8b442a28) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -29,6 +29,166 @@ module OASISGettext = struct end +module OASISString = struct +(* # 22 "src/oasis/OASISString.ml" *) + + + (** Various string utilities. + + Mostly inspired by extlib and batteries ExtString and BatString libraries. + + @author Sylvain Le Gall + *) + + + let nsplitf str f = + if str = "" then + [] + else + let buf = Buffer.create 13 in + let lst = ref [] in + let push () = + lst := Buffer.contents buf :: !lst; + Buffer.clear buf + in + let str_len = String.length str in + for i = 0 to str_len - 1 do + if f str.[i] then + push () + else + Buffer.add_char buf str.[i] + done; + push (); + List.rev !lst + + + (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the + separator. + *) + let nsplit str c = + nsplitf str ((=) c) + + + let find ~what ?(offset=0) str = + let what_idx = ref 0 in + let str_idx = ref offset in + while !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx + else + what_idx := 0; + incr str_idx + done; + if !what_idx <> String.length what then + raise Not_found + else + !str_idx - !what_idx + + + let sub_start str len = + let str_len = String.length str in + if len >= str_len then + "" + else + String.sub str len (str_len - len) + + + let sub_end ?(offset=0) str len = + let str_len = String.length str in + if len >= str_len then + "" + else + String.sub str 0 (str_len - len) + + + let starts_with ~what ?(offset=0) str = + let what_idx = ref 0 in + let str_idx = ref offset in + let ok = ref true in + while !ok && + !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx + else + ok := false; + incr str_idx + done; + if !what_idx = String.length what then + true + else + false + + + let strip_starts_with ~what str = + if starts_with ~what str then + sub_start str (String.length what) + else + raise Not_found + + + let ends_with ~what ?(offset=0) str = + let what_idx = ref ((String.length what) - 1) in + let str_idx = ref ((String.length str) - 1) in + let ok = ref true in + while !ok && + offset <= !str_idx && + 0 <= !what_idx do + if str.[!str_idx] = what.[!what_idx] then + decr what_idx + else + ok := false; + decr str_idx + done; + if !what_idx = -1 then + true + else + false + + + let strip_ends_with ~what str = + if ends_with ~what str then + sub_end str (String.length what) + else + raise Not_found + + + let replace_chars f s = + let buf = Buffer.create (String.length s) in + String.iter (fun c -> Buffer.add_char buf (f c)) s; + Buffer.contents buf + + let lowercase_ascii = + replace_chars + (fun c -> + if (c >= 'A' && c <= 'Z') then + Char.chr (Char.code c + 32) + else + c) + + let uncapitalize_ascii s = + if s <> "" then + (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) + else + s + + let uppercase_ascii = + replace_chars + (fun c -> + if (c >= 'a' && c <= 'z') then + Char.chr (Char.code c - 32) + else + c) + + let capitalize_ascii s = + if s <> "" then + (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) + else + s + +end + module OASISExpr = struct (* # 22 "src/oasis/OASISExpr.ml" *) @@ -129,7 +289,7 @@ module OASISExpr = struct end -# 132 "myocamlbuild.ml" +# 292 "myocamlbuild.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) @@ -234,7 +394,7 @@ module BaseEnvLight = struct end -# 237 "myocamlbuild.ml" +# 397 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) @@ -516,7 +676,7 @@ module MyOCamlbuildBase = struct | nm, [], intf_modules -> ocaml_lib nm; let cmis = - List.map (fun m -> (String.uncapitalize m) ^ ".cmi") + List.map (fun m -> (OASISString.uncapitalize_ascii m) ^ ".cmi") intf_modules in dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis | nm, dir :: tl, intf_modules -> @@ -529,7 +689,7 @@ module MyOCamlbuildBase = struct ["compile"; "infer_interface"; "doc"]) tl; let cmis = - List.map (fun m -> dir^"/"^(String.uncapitalize m)^".cmi") + List.map (fun m -> dir^"/"^(OASISString.uncapitalize_ascii m)^".cmi") intf_modules in dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] cmis) @@ -603,7 +763,7 @@ module MyOCamlbuildBase = struct end -# 606 "myocamlbuild.ml" +# 766 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { @@ -618,6 +778,6 @@ let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; -# 622 "myocamlbuild.ml" +# 782 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/setup.ml b/setup.ml index 0a2dd2c2499..3e9a421e4d6 100644 --- a/setup.ml +++ b/setup.ml @@ -1,9 +1,9 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 7f0d0bf60c57dd29e570e0c0886d7805) *) +(* DO NOT EDIT (digest: 26ca5de20434d7de30e9268a928955ef) *) (* - Regenerated by OASIS v0.4.5 + Regenerated by OASIS v0.4.6 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) @@ -246,6 +246,33 @@ module OASISString = struct String.iter (fun c -> Buffer.add_char buf (f c)) s; Buffer.contents buf + let lowercase_ascii = + replace_chars + (fun c -> + if (c >= 'A' && c <= 'Z') then + Char.chr (Char.code c + 32) + else + c) + + let uncapitalize_ascii s = + if s <> "" then + (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) + else + s + + let uppercase_ascii = + replace_chars + (fun c -> + if (c >= 'a' && c <= 'z') then + Char.chr (Char.code c - 32) + else + c) + + let capitalize_ascii s = + if s <> "" then + (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) + else + s end @@ -315,19 +342,15 @@ module OASISUtils = struct let compare_csl s1 s2 = - String.compare (String.lowercase s1) (String.lowercase s2) + String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2) module HashStringCsl = Hashtbl.Make (struct type t = string - - let equal s1 s2 = - (String.lowercase s1) = (String.lowercase s2) - - let hash s = - Hashtbl.hash (String.lowercase s) + let equal s1 s2 = (compare_csl s1 s2) = 0 + let hash s = Hashtbl.hash (OASISString.lowercase_ascii s) end) module SetStringCsl = @@ -365,7 +388,7 @@ module OASISUtils = struct else buf in - String.lowercase buf + OASISString.lowercase_ascii buf end @@ -471,7 +494,7 @@ module PropList = struct order = Queue.create (); name_norm = (if case_insensitive then - String.lowercase + OASISString.lowercase_ascii else fun s -> s); } @@ -1822,13 +1845,13 @@ module OASISUnixPath = struct let capitalize_file f = let dir = dirname f in let base = basename f in - concat dir (String.capitalize base) + concat dir (OASISString.capitalize_ascii base) let uncapitalize_file f = let dir = dirname f in let base = basename f in - concat dir (String.uncapitalize base) + concat dir (OASISString.uncapitalize_ascii base) end @@ -2890,7 +2913,7 @@ module OASISFileUtil = struct end -# 2893 "setup.ml" +# 2916 "setup.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) @@ -2995,7 +3018,7 @@ module BaseEnvLight = struct end -# 2998 "setup.ml" +# 3021 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) @@ -5406,7 +5429,7 @@ module BaseSetup = struct end -# 5409 "setup.ml" +# 5432 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) @@ -5845,8 +5868,8 @@ module InternalInstallPlugin = struct let make_fnames modul sufx = List.fold_right begin fun sufx accu -> - (String.capitalize modul ^ sufx) :: - (String.uncapitalize modul ^ sufx) :: + (OASISString.capitalize_ascii modul ^ sufx) :: + (OASISString.uncapitalize_ascii modul ^ sufx) :: accu end sufx @@ -6270,7 +6293,7 @@ module InternalInstallPlugin = struct end -# 6273 "setup.ml" +# 6296 "setup.ml" module OCamlbuildCommon = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) @@ -6648,7 +6671,7 @@ module OCamlbuildDocPlugin = struct end -# 6651 "setup.ml" +# 6674 "setup.ml" open OASISTypes;; let setup_t = @@ -6797,10 +6820,10 @@ let setup_t = "VIO"; "Zerocheck" ]; - lib_pack = false; + lib_pack = true; lib_internal_modules = []; lib_findlib_parent = None; - lib_findlib_name = None; + lib_findlib_name = Some "stdext"; lib_findlib_containers = [] }) ]; @@ -6811,8 +6834,9 @@ let setup_t = plugin_data = [] }; oasis_fn = Some "_oasis"; - oasis_version = "0.4.5"; - oasis_digest = Some "\240\188\225\230VH\224\168\151\140\209/\t\160\1459"; + oasis_version = "0.4.6"; + oasis_digest = + Some "\028\140;\140b\226\161\246\234\150\133\161\237\227\251 "; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -6820,6 +6844,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 6824 "setup.ml" +# 6848 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 10234fa8ecb744210d9fd42a90169d248241b42d Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Wed, 22 Jun 2016 10:43:34 +0100 Subject: [PATCH 035/199] Prepare to release 2.0.0 This version has all modules namespaced under Stdext and requires oasis to build Signed-off-by: Jon Ludlam --- ChangeLog | 3 + Makefile | 41 - _oasis | 2 +- _tags | 96 - configure | 27 - lib/META | 13 - lib/stdext.mldylib | 4 - lib/stdext.mllib | 4 - lib/stdext.mlpack | 31 - myocamlbuild.ml | 783 ----- opam | 13 +- setup.ml | 6849 -------------------------------------------- 12 files changed, 15 insertions(+), 7851 deletions(-) delete mode 100644 Makefile delete mode 100644 _tags delete mode 100755 configure delete mode 100644 lib/META delete mode 100644 lib/stdext.mldylib delete mode 100644 lib/stdext.mllib delete mode 100644 lib/stdext.mlpack delete mode 100644 myocamlbuild.ml delete mode 100644 setup.ml diff --git a/ChangeLog b/ChangeLog index 36ed33d8b79..f8daef44ec6 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,6 @@ +2.0.0 (22-Jun-2016): +* Namespace everything under Stdext. This is a backwards incompatible change. + 0.13.0 (20-Nov-2014): * Depend on Backtrace from xapi-backtrace * Add an opam file diff --git a/Makefile b/Makefile deleted file mode 100644 index 3639f14addb..00000000000 --- a/Makefile +++ /dev/null @@ -1,41 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954) - -SETUP = ocaml setup.ml - -build: setup.data - $(SETUP) -build $(BUILDFLAGS) - -doc: setup.data build - $(SETUP) -doc $(DOCFLAGS) - -test: setup.data build - $(SETUP) -test $(TESTFLAGS) - -all: - $(SETUP) -all $(ALLFLAGS) - -install: setup.data - $(SETUP) -install $(INSTALLFLAGS) - -uninstall: setup.data - $(SETUP) -uninstall $(UNINSTALLFLAGS) - -reinstall: setup.data - $(SETUP) -reinstall $(REINSTALLFLAGS) - -clean: - $(SETUP) -clean $(CLEANFLAGS) - -distclean: - $(SETUP) -distclean $(DISTCLEANFLAGS) - -setup.data: - $(SETUP) -configure $(CONFIGUREFLAGS) - -configure: - $(SETUP) -configure $(CONFIGUREFLAGS) - -.PHONY: build doc test all install uninstall reinstall clean distclean configure - -# OASIS_STOP diff --git a/_oasis b/_oasis index 7be96df43d0..9123fb69e0f 100644 --- a/_oasis +++ b/_oasis @@ -1,6 +1,6 @@ OASISFormat: 0.3 Name: stdext -Version: 0.13.0 +Version: 2.0 Synopsis: Standard extension library License: LGPL-2.1 with OCaml linking exception Authors: various diff --git a/_tags b/_tags deleted file mode 100644 index f9c604f837b..00000000000 --- a/_tags +++ /dev/null @@ -1,96 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: fd955a6e26aaf02da6d2229f5c87ec2e) -# Ignore VCS directories, you can use the same kind of rule outside -# OASIS_START/STOP if you want to exclude directories that contains -# useless stuff for the build process -true: annot, bin_annot -<**/.svn>: -traverse -<**/.svn>: not_hygienic -".bzr": -traverse -".bzr": not_hygienic -".hg": -traverse -".hg": not_hygienic -".git": -traverse -".git": not_hygienic -"_darcs": -traverse -"_darcs": not_hygienic -# Library stdext -"lib/stdext.cmxs": use_stdext -"lib/arrayext.cmx": for-pack(Stdext) -"lib/base64.cmx": for-pack(Stdext) -"lib/bigbuffer.cmx": for-pack(Stdext) -"lib/config.cmx": for-pack(Stdext) -"lib/date.cmx": for-pack(Stdext) -"lib/either.cmx": for-pack(Stdext) -"lib/encodings.cmx": for-pack(Stdext) -"lib/extentlistSet.cmx": for-pack(Stdext) -"lib/filenameext.cmx": for-pack(Stdext) -"lib/fring.cmx": for-pack(Stdext) -"lib/fun.cmx": for-pack(Stdext) -"lib/hashtblext.cmx": for-pack(Stdext) -"lib/int64ext.cmx": for-pack(Stdext) -"lib/lazyList.cmx": for-pack(Stdext) -"lib/listext.cmx": for-pack(Stdext) -"lib/mapext.cmx": for-pack(Stdext) -"lib/monad.cmx": for-pack(Stdext) -"lib/opt.cmx": for-pack(Stdext) -"lib/pervasiveext.cmx": for-pack(Stdext) -"lib/qring.cmx": for-pack(Stdext) -"lib/range.cmx": for-pack(Stdext) -"lib/ring.cmx": for-pack(Stdext) -"lib/xstringext.cmx": for-pack(Stdext) -"lib/threadext.cmx": for-pack(Stdext) -"lib/trie.cmx": for-pack(Stdext) -"lib/unixext.cmx": for-pack(Stdext) -"lib/vIO.cmx": for-pack(Stdext) -"lib/zerocheck.cmx": for-pack(Stdext) -: use_libstdext_stubs -: pkg_bigarray -: pkg_fd-send-recv -: pkg_sexplib -: pkg_sexplib.syntax -: pkg_threads -: pkg_unix -: pkg_uuidm -: pkg_xapi-backtrace -"lib/blkgetsize_stubs.c": pkg_bigarray -"lib/blkgetsize_stubs.c": pkg_fd-send-recv -"lib/blkgetsize_stubs.c": pkg_sexplib -"lib/blkgetsize_stubs.c": pkg_sexplib.syntax -"lib/blkgetsize_stubs.c": pkg_threads -"lib/blkgetsize_stubs.c": pkg_unix -"lib/blkgetsize_stubs.c": pkg_uuidm -"lib/blkgetsize_stubs.c": pkg_xapi-backtrace -"lib/unixext_open_stubs.c": pkg_bigarray -"lib/unixext_open_stubs.c": pkg_fd-send-recv -"lib/unixext_open_stubs.c": pkg_sexplib -"lib/unixext_open_stubs.c": pkg_sexplib.syntax -"lib/unixext_open_stubs.c": pkg_threads -"lib/unixext_open_stubs.c": pkg_unix -"lib/unixext_open_stubs.c": pkg_uuidm -"lib/unixext_open_stubs.c": pkg_xapi-backtrace -"lib/unixext_stubs.c": pkg_bigarray -"lib/unixext_stubs.c": pkg_fd-send-recv -"lib/unixext_stubs.c": pkg_sexplib -"lib/unixext_stubs.c": pkg_sexplib.syntax -"lib/unixext_stubs.c": pkg_threads -"lib/unixext_stubs.c": pkg_unix -"lib/unixext_stubs.c": pkg_uuidm -"lib/unixext_stubs.c": pkg_xapi-backtrace -"lib/unixext_write_stubs.c": pkg_bigarray -"lib/unixext_write_stubs.c": pkg_fd-send-recv -"lib/unixext_write_stubs.c": pkg_sexplib -"lib/unixext_write_stubs.c": pkg_sexplib.syntax -"lib/unixext_write_stubs.c": pkg_threads -"lib/unixext_write_stubs.c": pkg_unix -"lib/unixext_write_stubs.c": pkg_uuidm -"lib/unixext_write_stubs.c": pkg_xapi-backtrace -"lib/zerocheck_stub.c": pkg_bigarray -"lib/zerocheck_stub.c": pkg_fd-send-recv -"lib/zerocheck_stub.c": pkg_sexplib -"lib/zerocheck_stub.c": pkg_sexplib.syntax -"lib/zerocheck_stub.c": pkg_threads -"lib/zerocheck_stub.c": pkg_unix -"lib/zerocheck_stub.c": pkg_uuidm -"lib/zerocheck_stub.c": pkg_xapi-backtrace -# OASIS_STOP diff --git a/configure b/configure deleted file mode 100755 index 6acfaeb953f..00000000000 --- a/configure +++ /dev/null @@ -1,27 +0,0 @@ -#!/bin/sh - -# OASIS_START -# DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) -set -e - -FST=true -for i in "$@"; do - if $FST; then - set -- - FST=false - fi - - case $i in - --*=*) - ARG=${i%%=*} - VAL=${i##*=} - set -- "$@" "$ARG" "$VAL" - ;; - *) - set -- "$@" "$i" - ;; - esac -done - -ocaml setup.ml -configure "$@" -# OASIS_STOP diff --git a/lib/META b/lib/META deleted file mode 100644 index 4a967007f23..00000000000 --- a/lib/META +++ /dev/null @@ -1,13 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: f8690efb71f599dc91ab26389ca83c22) -version = "0.13.0" -description = "Standard extension library" -requires = -"threads uuidm unix fd-send-recv bigarray sexplib sexplib.syntax xapi-backtrace" -archive(byte) = "stdext.cma" -archive(byte, plugin) = "stdext.cma" -archive(native) = "stdext.cmxa" -archive(native, plugin) = "stdext.cmxs" -exists_if = "stdext.cma" -# OASIS_STOP - diff --git a/lib/stdext.mldylib b/lib/stdext.mldylib deleted file mode 100644 index 931fdde2593..00000000000 --- a/lib/stdext.mldylib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 2bbe9a6396c26d99b35474fffa94ee2a) -Stdext -# OASIS_STOP diff --git a/lib/stdext.mllib b/lib/stdext.mllib deleted file mode 100644 index 931fdde2593..00000000000 --- a/lib/stdext.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 2bbe9a6396c26d99b35474fffa94ee2a) -Stdext -# OASIS_STOP diff --git a/lib/stdext.mlpack b/lib/stdext.mlpack deleted file mode 100644 index 9a4e7d369e7..00000000000 --- a/lib/stdext.mlpack +++ /dev/null @@ -1,31 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 3ba17b3a67d7a4ec569fbc8550f6f99c) -Arrayext -Base64 -Bigbuffer -Config -Date -Either -Encodings -ExtentlistSet -Filenameext -Fring -Fun -Hashtblext -Int64ext -LazyList -Listext -Mapext -Monad -Opt -Pervasiveext -Qring -Range -Ring -Xstringext -Threadext -Trie -Unixext -VIO -Zerocheck -# OASIS_STOP diff --git a/myocamlbuild.ml b/myocamlbuild.ml deleted file mode 100644 index 7e91ce5cfc1..00000000000 --- a/myocamlbuild.ml +++ /dev/null @@ -1,783 +0,0 @@ -(* OASIS_START *) -(* DO NOT EDIT (digest: 40228c21bfd6ad9f9fc2150a8b442a28) *) -module OASISGettext = struct -(* # 22 "src/oasis/OASISGettext.ml" *) - - - let ns_ str = - str - - - let s_ str = - str - - - let f_ (str: ('a, 'b, 'c, 'd) format4) = - str - - - let fn_ fmt1 fmt2 n = - if n = 1 then - fmt1^^"" - else - fmt2^^"" - - - let init = - [] - - -end - -module OASISString = struct -(* # 22 "src/oasis/OASISString.ml" *) - - - (** Various string utilities. - - Mostly inspired by extlib and batteries ExtString and BatString libraries. - - @author Sylvain Le Gall - *) - - - let nsplitf str f = - if str = "" then - [] - else - let buf = Buffer.create 13 in - let lst = ref [] in - let push () = - lst := Buffer.contents buf :: !lst; - Buffer.clear buf - in - let str_len = String.length str in - for i = 0 to str_len - 1 do - if f str.[i] then - push () - else - Buffer.add_char buf str.[i] - done; - push (); - List.rev !lst - - - (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the - separator. - *) - let nsplit str c = - nsplitf str ((=) c) - - - let find ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - while !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - what_idx := 0; - incr str_idx - done; - if !what_idx <> String.length what then - raise Not_found - else - !str_idx - !what_idx - - - let sub_start str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str len (str_len - len) - - - let sub_end ?(offset=0) str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str 0 (str_len - len) - - - let starts_with ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - let ok = ref true in - while !ok && - !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - ok := false; - incr str_idx - done; - if !what_idx = String.length what then - true - else - false - - - let strip_starts_with ~what str = - if starts_with ~what str then - sub_start str (String.length what) - else - raise Not_found - - - let ends_with ~what ?(offset=0) str = - let what_idx = ref ((String.length what) - 1) in - let str_idx = ref ((String.length str) - 1) in - let ok = ref true in - while !ok && - offset <= !str_idx && - 0 <= !what_idx do - if str.[!str_idx] = what.[!what_idx] then - decr what_idx - else - ok := false; - decr str_idx - done; - if !what_idx = -1 then - true - else - false - - - let strip_ends_with ~what str = - if ends_with ~what str then - sub_end str (String.length what) - else - raise Not_found - - - let replace_chars f s = - let buf = Buffer.create (String.length s) in - String.iter (fun c -> Buffer.add_char buf (f c)) s; - Buffer.contents buf - - let lowercase_ascii = - replace_chars - (fun c -> - if (c >= 'A' && c <= 'Z') then - Char.chr (Char.code c + 32) - else - c) - - let uncapitalize_ascii s = - if s <> "" then - (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) - else - s - - let uppercase_ascii = - replace_chars - (fun c -> - if (c >= 'a' && c <= 'z') then - Char.chr (Char.code c - 32) - else - c) - - let capitalize_ascii s = - if s <> "" then - (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) - else - s - -end - -module OASISExpr = struct -(* # 22 "src/oasis/OASISExpr.ml" *) - - - - - - open OASISGettext - - - type test = string - - - type flag = string - - - type t = - | EBool of bool - | ENot of t - | EAnd of t * t - | EOr of t * t - | EFlag of flag - | ETest of test * string - - - - type 'a choices = (t * 'a) list - - - let eval var_get t = - let rec eval' = - function - | EBool b -> - b - - | ENot e -> - not (eval' e) - - | EAnd (e1, e2) -> - (eval' e1) && (eval' e2) - - | EOr (e1, e2) -> - (eval' e1) || (eval' e2) - - | EFlag nm -> - let v = - var_get nm - in - assert(v = "true" || v = "false"); - (v = "true") - - | ETest (nm, vl) -> - let v = - var_get nm - in - (v = vl) - in - eval' t - - - let choose ?printer ?name var_get lst = - let rec choose_aux = - function - | (cond, vl) :: tl -> - if eval var_get cond then - vl - else - choose_aux tl - | [] -> - let str_lst = - if lst = [] then - s_ "" - else - String.concat - (s_ ", ") - (List.map - (fun (cond, vl) -> - match printer with - | Some p -> p vl - | None -> s_ "") - lst) - in - match name with - | Some nm -> - failwith - (Printf.sprintf - (f_ "No result for the choice list '%s': %s") - nm str_lst) - | None -> - failwith - (Printf.sprintf - (f_ "No result for a choice list: %s") - str_lst) - in - choose_aux (List.rev lst) - - -end - - -# 292 "myocamlbuild.ml" -module BaseEnvLight = struct -(* # 22 "src/base/BaseEnvLight.ml" *) - - - module MapString = Map.Make(String) - - - type t = string MapString.t - - - let default_filename = - Filename.concat - (Sys.getcwd ()) - "setup.data" - - - let load ?(allow_empty=false) ?(filename=default_filename) () = - if Sys.file_exists filename then - begin - let chn = - open_in_bin filename - in - let st = - Stream.of_channel chn - in - let line = - ref 1 - in - let st_line = - Stream.from - (fun _ -> - try - match Stream.next st with - | '\n' -> incr line; Some '\n' - | c -> Some c - with Stream.Failure -> None) - in - let lexer = - Genlex.make_lexer ["="] st_line - in - let rec read_file mp = - match Stream.npeek 3 lexer with - | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lexer; - Stream.junk lexer; - Stream.junk lexer; - read_file (MapString.add nm value mp) - | [] -> - mp - | _ -> - failwith - (Printf.sprintf - "Malformed data file '%s' line %d" - filename !line) - in - let mp = - read_file MapString.empty - in - close_in chn; - mp - end - else if allow_empty then - begin - MapString.empty - end - else - begin - failwith - (Printf.sprintf - "Unable to load environment, the file '%s' doesn't exist." - filename) - end - - - let rec var_expand str env = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) env - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff - - - let var_get name env = - var_expand (MapString.find name env) env - - - let var_choose lst env = - OASISExpr.choose - (fun nm -> var_get nm env) - lst -end - - -# 397 "myocamlbuild.ml" -module MyOCamlbuildFindlib = struct -(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) - - - (** OCamlbuild extension, copied from - * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild - * by N. Pouillard and others - * - * Updated on 2009/02/28 - * - * Modified by Sylvain Le Gall - *) - open Ocamlbuild_plugin - - type conf = - { no_automatic_syntax: bool; - } - - (* these functions are not really officially exported *) - let run_and_read = - Ocamlbuild_pack.My_unix.run_and_read - - - let blank_sep_strings = - Ocamlbuild_pack.Lexers.blank_sep_strings - - - let exec_from_conf exec = - let exec = - let env_filename = Pathname.basename BaseEnvLight.default_filename in - let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in - try - BaseEnvLight.var_get exec env - with Not_found -> - Printf.eprintf "W: Cannot get variable %s\n" exec; - exec - in - let fix_win32 str = - if Sys.os_type = "Win32" then begin - let buff = Buffer.create (String.length str) in - (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. - *) - String.iter - (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) - str; - Buffer.contents buff - end else begin - str - end - in - fix_win32 exec - - let split s ch = - let buf = Buffer.create 13 in - let x = ref [] in - let flush () = - x := (Buffer.contents buf) :: !x; - Buffer.clear buf - in - String.iter - (fun c -> - if c = ch then - flush () - else - Buffer.add_char buf c) - s; - flush (); - List.rev !x - - - let split_nl s = split s '\n' - - - let before_space s = - try - String.before s (String.index s ' ') - with Not_found -> s - - (* ocamlfind command *) - let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] - - (* This lists all supported packages. *) - let find_packages () = - List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) - - - (* Mock to list available syntaxes. *) - let find_syntaxes () = ["camlp4o"; "camlp4r"] - - - let well_known_syntax = [ - "camlp4.quotations.o"; - "camlp4.quotations.r"; - "camlp4.exceptiontracer"; - "camlp4.extend"; - "camlp4.foldgenerator"; - "camlp4.listcomprehension"; - "camlp4.locationstripper"; - "camlp4.macro"; - "camlp4.mapgenerator"; - "camlp4.metagenerator"; - "camlp4.profiler"; - "camlp4.tracer" - ] - - - let dispatch conf = - function - | After_options -> - (* By using Before_options one let command line options have an higher - * priority on the contrary using After_options will guarantee to have - * the higher priority override default commands by ocamlfind ones *) - Options.ocamlc := ocamlfind & A"ocamlc"; - Options.ocamlopt := ocamlfind & A"ocamlopt"; - Options.ocamldep := ocamlfind & A"ocamldep"; - Options.ocamldoc := ocamlfind & A"ocamldoc"; - Options.ocamlmktop := ocamlfind & A"ocamlmktop"; - Options.ocamlmklib := ocamlfind & A"ocamlmklib" - - | After_rules -> - - (* When one link an OCaml library/binary/package, one should use - * -linkpkg *) - flag ["ocaml"; "link"; "program"] & A"-linkpkg"; - - if not (conf.no_automatic_syntax) then begin - (* For each ocamlfind package one inject the -package option when - * compiling, computing dependencies, generating documentation and - * linking. *) - List.iter - begin fun pkg -> - let base_args = [A"-package"; A pkg] in - (* TODO: consider how to really choose camlp4o or camlp4r. *) - let syn_args = [A"-syntax"; A "camlp4o"] in - let (args, pargs) = - (* Heuristic to identify syntax extensions: whether they end in - ".syntax"; some might not. - *) - if Filename.check_suffix pkg "syntax" || - List.mem pkg well_known_syntax then - (syn_args @ base_args, syn_args) - else - (base_args, []) - in - flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; - flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; - flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; - flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; - flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; - - (* TODO: Check if this is allowed for OCaml < 3.12.1 *) - flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; - end - (find_packages ()); - end; - - (* Like -package but for extensions syntax. Morover -syntax is useless - * when linking. *) - List.iter begin fun syntax -> - flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & - S[A"-syntax"; A syntax]; - end (find_syntaxes ()); - - (* The default "thread" tag is not compatible with ocamlfind. - * Indeed, the default rules add the "threads.cma" or "threads.cmxa" - * options when using this tag. When using the "-linkpkg" option with - * ocamlfind, this module will then be added twice on the command line. - * - * To solve this, one approach is to add the "-thread" option when using - * the "threads" package using the previous plugin. - *) - flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); - flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); - flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); - flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); - flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); - flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); - - | _ -> - () -end - -module MyOCamlbuildBase = struct -(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) - - - (** Base functions for writing myocamlbuild.ml - @author Sylvain Le Gall - *) - - - - - - open Ocamlbuild_plugin - module OC = Ocamlbuild_pack.Ocaml_compiler - - - type dir = string - type file = string - type name = string - type tag = string - - -(* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) - - - type t = - { - lib_ocaml: (name * dir list * string list) list; - lib_c: (name * dir * file list) list; - flags: (tag list * (spec OASISExpr.choices)) list; - (* Replace the 'dir: include' from _tags by a precise interdepends in - * directory. - *) - includes: (dir * dir list) list; - } - - - let env_filename = - Pathname.basename - BaseEnvLight.default_filename - - - let dispatch_combine lst = - fun e -> - List.iter - (fun dispatch -> dispatch e) - lst - - - let tag_libstubs nm = - "use_lib"^nm^"_stubs" - - - let nm_libstubs nm = - nm^"_stubs" - - - let dispatch t e = - let env = - BaseEnvLight.load - ~filename:env_filename - ~allow_empty:true - () - in - match e with - | Before_options -> - let no_trailing_dot s = - if String.length s >= 1 && s.[0] = '.' then - String.sub s 1 ((String.length s) - 1) - else - s - in - List.iter - (fun (opt, var) -> - try - opt := no_trailing_dot (BaseEnvLight.var_get var env) - with Not_found -> - Printf.eprintf "W: Cannot get variable %s\n" var) - [ - Options.ext_obj, "ext_obj"; - Options.ext_lib, "ext_lib"; - Options.ext_dll, "ext_dll"; - ] - - | After_rules -> - (* Declare OCaml libraries *) - List.iter - (function - | nm, [], intf_modules -> - ocaml_lib nm; - let cmis = - List.map (fun m -> (OASISString.uncapitalize_ascii m) ^ ".cmi") - intf_modules in - dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis - | nm, dir :: tl, intf_modules -> - ocaml_lib ~dir:dir (dir^"/"^nm); - List.iter - (fun dir -> - List.iter - (fun str -> - flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) - ["compile"; "infer_interface"; "doc"]) - tl; - let cmis = - List.map (fun m -> dir^"/"^(OASISString.uncapitalize_ascii m)^".cmi") - intf_modules in - dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] - cmis) - t.lib_ocaml; - - (* Declare directories dependencies, replace "include" in _tags. *) - List.iter - (fun (dir, include_dirs) -> - Pathname.define_context dir include_dirs) - t.includes; - - (* Declare C libraries *) - List.iter - (fun (lib, dir, headers) -> - (* Handle C part of library *) - flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] - (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; - A("-l"^(nm_libstubs lib))]); - - flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] - (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); - - flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] - (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); - - (* When ocaml link something that use the C library, then one - need that file to be up to date. - This holds both for programs and for libraries. - *) - dep ["link"; "ocaml"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - - dep ["compile"; "ocaml"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - - (* TODO: be more specific about what depends on headers *) - (* Depends on .h files *) - dep ["compile"; "c"] - headers; - - (* Setup search path for lib *) - flag ["link"; "ocaml"; "use_"^lib] - (S[A"-I"; P(dir)]); - ) - t.lib_c; - - (* Add flags *) - List.iter - (fun (tags, cond_specs) -> - let spec = BaseEnvLight.var_choose cond_specs env in - let rec eval_specs = - function - | S lst -> S (List.map eval_specs lst) - | A str -> A (BaseEnvLight.var_expand str env) - | spec -> spec - in - flag tags & (eval_specs spec)) - t.flags - | _ -> - () - - - let dispatch_default conf t = - dispatch_combine - [ - dispatch t; - MyOCamlbuildFindlib.dispatch conf; - ] - - -end - - -# 766 "myocamlbuild.ml" -open Ocamlbuild_plugin;; -let package_default = - { - MyOCamlbuildBase.lib_ocaml = [("stdext", ["lib"], [])]; - lib_c = [("stdext", "lib", [])]; - flags = []; - includes = [] - } - ;; - -let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} - -let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; - -# 782 "myocamlbuild.ml" -(* OASIS_STOP *) -Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/opam b/opam index b2ba0410b63..2f9e8f8a757 100644 --- a/opam +++ b/opam @@ -1,7 +1,15 @@ -opam-version: "1" -maintainer: "jonathan.ludlam@eu.citrix.com" +opam-version: "1.2" +maintainer: "jonathan.ludlam@citrix.com" +authors: "xen-api@list.xen.org" +bug-reports: "https://github.com/xapi-project/stdext/issues" +dev-repo: "git://github.com/xapi-project/stdext.git" +homepage: "https://xapi-project.github.io/" build: [ + ["oasis" "setup"] + ["configure"] [make] +] +install: [ [make "install" "BINDIR=%{bin}%"] ] remove: [ @@ -14,4 +22,5 @@ depends: [ "fd-send-recv" "sexplib" "xapi-backtrace" + "oasis" ] diff --git a/setup.ml b/setup.ml deleted file mode 100644 index 3e9a421e4d6..00000000000 --- a/setup.ml +++ /dev/null @@ -1,6849 +0,0 @@ -(* setup.ml generated for the first time by OASIS v0.3.0 *) - -(* OASIS_START *) -(* DO NOT EDIT (digest: 26ca5de20434d7de30e9268a928955ef) *) -(* - Regenerated by OASIS v0.4.6 - Visit http://oasis.forge.ocamlcore.org for more information and - documentation about functions used in this file. -*) -module OASISGettext = struct -(* # 22 "src/oasis/OASISGettext.ml" *) - - - let ns_ str = - str - - - let s_ str = - str - - - let f_ (str: ('a, 'b, 'c, 'd) format4) = - str - - - let fn_ fmt1 fmt2 n = - if n = 1 then - fmt1^^"" - else - fmt2^^"" - - - let init = - [] - - -end - -module OASISContext = struct -(* # 22 "src/oasis/OASISContext.ml" *) - - - open OASISGettext - - - type level = - [ `Debug - | `Info - | `Warning - | `Error] - - - type t = - { - (* TODO: replace this by a proplist. *) - quiet: bool; - info: bool; - debug: bool; - ignore_plugins: bool; - ignore_unknown_fields: bool; - printf: level -> string -> unit; - } - - - let printf lvl str = - let beg = - match lvl with - | `Error -> s_ "E: " - | `Warning -> s_ "W: " - | `Info -> s_ "I: " - | `Debug -> s_ "D: " - in - prerr_endline (beg^str) - - - let default = - ref - { - quiet = false; - info = false; - debug = false; - ignore_plugins = false; - ignore_unknown_fields = false; - printf = printf; - } - - - let quiet = - {!default with quiet = true} - - - let fspecs () = - (* TODO: don't act on default. *) - let ignore_plugins = ref false in - ["-quiet", - Arg.Unit (fun () -> default := {!default with quiet = true}), - s_ " Run quietly"; - - "-info", - Arg.Unit (fun () -> default := {!default with info = true}), - s_ " Display information message"; - - - "-debug", - Arg.Unit (fun () -> default := {!default with debug = true}), - s_ " Output debug message"; - - "-ignore-plugins", - Arg.Set ignore_plugins, - s_ " Ignore plugin's field."; - - "-C", - (* TODO: remove this chdir. *) - Arg.String (fun str -> Sys.chdir str), - s_ "dir Change directory before running."], - fun () -> {!default with ignore_plugins = !ignore_plugins} -end - -module OASISString = struct -(* # 22 "src/oasis/OASISString.ml" *) - - - (** Various string utilities. - - Mostly inspired by extlib and batteries ExtString and BatString libraries. - - @author Sylvain Le Gall - *) - - - let nsplitf str f = - if str = "" then - [] - else - let buf = Buffer.create 13 in - let lst = ref [] in - let push () = - lst := Buffer.contents buf :: !lst; - Buffer.clear buf - in - let str_len = String.length str in - for i = 0 to str_len - 1 do - if f str.[i] then - push () - else - Buffer.add_char buf str.[i] - done; - push (); - List.rev !lst - - - (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the - separator. - *) - let nsplit str c = - nsplitf str ((=) c) - - - let find ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - while !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - what_idx := 0; - incr str_idx - done; - if !what_idx <> String.length what then - raise Not_found - else - !str_idx - !what_idx - - - let sub_start str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str len (str_len - len) - - - let sub_end ?(offset=0) str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str 0 (str_len - len) - - - let starts_with ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - let ok = ref true in - while !ok && - !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - ok := false; - incr str_idx - done; - if !what_idx = String.length what then - true - else - false - - - let strip_starts_with ~what str = - if starts_with ~what str then - sub_start str (String.length what) - else - raise Not_found - - - let ends_with ~what ?(offset=0) str = - let what_idx = ref ((String.length what) - 1) in - let str_idx = ref ((String.length str) - 1) in - let ok = ref true in - while !ok && - offset <= !str_idx && - 0 <= !what_idx do - if str.[!str_idx] = what.[!what_idx] then - decr what_idx - else - ok := false; - decr str_idx - done; - if !what_idx = -1 then - true - else - false - - - let strip_ends_with ~what str = - if ends_with ~what str then - sub_end str (String.length what) - else - raise Not_found - - - let replace_chars f s = - let buf = Buffer.create (String.length s) in - String.iter (fun c -> Buffer.add_char buf (f c)) s; - Buffer.contents buf - - let lowercase_ascii = - replace_chars - (fun c -> - if (c >= 'A' && c <= 'Z') then - Char.chr (Char.code c + 32) - else - c) - - let uncapitalize_ascii s = - if s <> "" then - (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) - else - s - - let uppercase_ascii = - replace_chars - (fun c -> - if (c >= 'a' && c <= 'z') then - Char.chr (Char.code c - 32) - else - c) - - let capitalize_ascii s = - if s <> "" then - (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) - else - s - -end - -module OASISUtils = struct -(* # 22 "src/oasis/OASISUtils.ml" *) - - - open OASISGettext - - - module MapExt = - struct - module type S = - sig - include Map.S - val add_list: 'a t -> (key * 'a) list -> 'a t - val of_list: (key * 'a) list -> 'a t - val to_list: 'a t -> (key * 'a) list - end - - module Make (Ord: Map.OrderedType) = - struct - include Map.Make(Ord) - - let rec add_list t = - function - | (k, v) :: tl -> add_list (add k v t) tl - | [] -> t - - let of_list lst = add_list empty lst - - let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] - end - end - - - module MapString = MapExt.Make(String) - - - module SetExt = - struct - module type S = - sig - include Set.S - val add_list: t -> elt list -> t - val of_list: elt list -> t - val to_list: t -> elt list - end - - module Make (Ord: Set.OrderedType) = - struct - include Set.Make(Ord) - - let rec add_list t = - function - | e :: tl -> add_list (add e t) tl - | [] -> t - - let of_list lst = add_list empty lst - - let to_list = elements - end - end - - - module SetString = SetExt.Make(String) - - - let compare_csl s1 s2 = - String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2) - - - module HashStringCsl = - Hashtbl.Make - (struct - type t = string - let equal s1 s2 = (compare_csl s1 s2) = 0 - let hash s = Hashtbl.hash (OASISString.lowercase_ascii s) - end) - - module SetStringCsl = - SetExt.Make - (struct - type t = string - let compare = compare_csl - end) - - - let varname_of_string ?(hyphen='_') s = - if String.length s = 0 then - begin - invalid_arg "varname_of_string" - end - else - begin - let buf = - OASISString.replace_chars - (fun c -> - if ('a' <= c && c <= 'z') - || - ('A' <= c && c <= 'Z') - || - ('0' <= c && c <= '9') then - c - else - hyphen) - s; - in - let buf = - (* Start with a _ if digit *) - if '0' <= s.[0] && s.[0] <= '9' then - "_"^buf - else - buf - in - OASISString.lowercase_ascii buf - end - - - let varname_concat ?(hyphen='_') p s = - let what = String.make 1 hyphen in - let p = - try - OASISString.strip_ends_with ~what p - with Not_found -> - p - in - let s = - try - OASISString.strip_starts_with ~what s - with Not_found -> - s - in - p^what^s - - - let is_varname str = - str = varname_of_string str - - - let failwithf fmt = Printf.ksprintf failwith fmt - - -end - -module PropList = struct -(* # 22 "src/oasis/PropList.ml" *) - - - open OASISGettext - - - type name = string - - - exception Not_set of name * string option - exception No_printer of name - exception Unknown_field of name * name - - - let () = - Printexc.register_printer - (function - | Not_set (nm, Some rsn) -> - Some - (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) - | Not_set (nm, None) -> - Some - (Printf.sprintf (f_ "Field '%s' is not set") nm) - | No_printer nm -> - Some - (Printf.sprintf (f_ "No default printer for value %s") nm) - | Unknown_field (nm, schm) -> - Some - (Printf.sprintf - (f_ "Field %s is not defined in schema %s") nm schm) - | _ -> - None) - - - module Data = - struct - type t = - (name, unit -> unit) Hashtbl.t - - let create () = - Hashtbl.create 13 - - let clear t = - Hashtbl.clear t - - -(* # 78 "src/oasis/PropList.ml" *) - end - - - module Schema = - struct - type ('ctxt, 'extra) value = - { - get: Data.t -> string; - set: Data.t -> ?context:'ctxt -> string -> unit; - help: (unit -> string) option; - extra: 'extra; - } - - type ('ctxt, 'extra) t = - { - name: name; - fields: (name, ('ctxt, 'extra) value) Hashtbl.t; - order: name Queue.t; - name_norm: string -> string; - } - - let create ?(case_insensitive=false) nm = - { - name = nm; - fields = Hashtbl.create 13; - order = Queue.create (); - name_norm = - (if case_insensitive then - OASISString.lowercase_ascii - else - fun s -> s); - } - - let add t nm set get extra help = - let key = - t.name_norm nm - in - - if Hashtbl.mem t.fields key then - failwith - (Printf.sprintf - (f_ "Field '%s' is already defined in schema '%s'") - nm t.name); - Hashtbl.add - t.fields - key - { - set = set; - get = get; - help = help; - extra = extra; - }; - Queue.add nm t.order - - let mem t nm = - Hashtbl.mem t.fields nm - - let find t nm = - try - Hashtbl.find t.fields (t.name_norm nm) - with Not_found -> - raise (Unknown_field (nm, t.name)) - - let get t data nm = - (find t nm).get data - - let set t data nm ?context x = - (find t nm).set - data - ?context - x - - let fold f acc t = - Queue.fold - (fun acc k -> - let v = - find t k - in - f acc k v.extra v.help) - acc - t.order - - let iter f t = - fold - (fun () -> f) - () - t - - let name t = - t.name - end - - - module Field = - struct - type ('ctxt, 'value, 'extra) t = - { - set: Data.t -> ?context:'ctxt -> 'value -> unit; - get: Data.t -> 'value; - sets: Data.t -> ?context:'ctxt -> string -> unit; - gets: Data.t -> string; - help: (unit -> string) option; - extra: 'extra; - } - - let new_id = - let last_id = - ref 0 - in - fun () -> incr last_id; !last_id - - let create ?schema ?name ?parse ?print ?default ?update ?help extra = - (* Default value container *) - let v = - ref None - in - - (* If name is not given, create unique one *) - let nm = - match name with - | Some s -> s - | None -> Printf.sprintf "_anon_%d" (new_id ()) - in - - (* Last chance to get a value: the default *) - let default () = - match default with - | Some d -> d - | None -> raise (Not_set (nm, Some (s_ "no default value"))) - in - - (* Get data *) - let get data = - (* Get value *) - try - (Hashtbl.find data nm) (); - match !v with - | Some x -> x - | None -> default () - with Not_found -> - default () - in - - (* Set data *) - let set data ?context x = - let x = - match update with - | Some f -> - begin - try - f ?context (get data) x - with Not_set _ -> - x - end - | None -> - x - in - Hashtbl.replace - data - nm - (fun () -> v := Some x) - in - - (* Parse string value, if possible *) - let parse = - match parse with - | Some f -> - f - | None -> - fun ?context s -> - failwith - (Printf.sprintf - (f_ "Cannot parse field '%s' when setting value %S") - nm - s) - in - - (* Set data, from string *) - let sets data ?context s = - set ?context data (parse ?context s) - in - - (* Output value as string, if possible *) - let print = - match print with - | Some f -> - f - | None -> - fun _ -> raise (No_printer nm) - in - - (* Get data, as a string *) - let gets data = - print (get data) - in - - begin - match schema with - | Some t -> - Schema.add t nm sets gets extra help - | None -> - () - end; - - { - set = set; - get = get; - sets = sets; - gets = gets; - help = help; - extra = extra; - } - - let fset data t ?context x = - t.set data ?context x - - let fget data t = - t.get data - - let fsets data t ?context s = - t.sets data ?context s - - let fgets data t = - t.gets data - end - - - module FieldRO = - struct - let create ?schema ?name ?parse ?print ?default ?update ?help extra = - let fld = - Field.create ?schema ?name ?parse ?print ?default ?update ?help extra - in - fun data -> Field.fget data fld - end -end - -module OASISMessage = struct -(* # 22 "src/oasis/OASISMessage.ml" *) - - - open OASISGettext - open OASISContext - - - let generic_message ~ctxt lvl fmt = - let cond = - if ctxt.quiet then - false - else - match lvl with - | `Debug -> ctxt.debug - | `Info -> ctxt.info - | _ -> true - in - Printf.ksprintf - (fun str -> - if cond then - begin - ctxt.printf lvl str - end) - fmt - - - let debug ~ctxt fmt = - generic_message ~ctxt `Debug fmt - - - let info ~ctxt fmt = - generic_message ~ctxt `Info fmt - - - let warning ~ctxt fmt = - generic_message ~ctxt `Warning fmt - - - let error ~ctxt fmt = - generic_message ~ctxt `Error fmt - -end - -module OASISVersion = struct -(* # 22 "src/oasis/OASISVersion.ml" *) - - - open OASISGettext - - - - - - type s = string - - - type t = string - - - type comparator = - | VGreater of t - | VGreaterEqual of t - | VEqual of t - | VLesser of t - | VLesserEqual of t - | VOr of comparator * comparator - | VAnd of comparator * comparator - - - - (* Range of allowed characters *) - let is_digit c = - '0' <= c && c <= '9' - - - let is_alpha c = - ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') - - - let is_special = - function - | '.' | '+' | '-' | '~' -> true - | _ -> false - - - let rec version_compare v1 v2 = - if v1 <> "" || v2 <> "" then - begin - (* Compare ascii string, using special meaning for version - * related char - *) - let val_ascii c = - if c = '~' then -1 - else if is_digit c then 0 - else if c = '\000' then 0 - else if is_alpha c then Char.code c - else (Char.code c) + 256 - in - - let len1 = String.length v1 in - let len2 = String.length v2 in - - let p = ref 0 in - - (** Compare ascii part *) - let compare_vascii () = - let cmp = ref 0 in - while !cmp = 0 && - !p < len1 && !p < len2 && - not (is_digit v1.[!p] && is_digit v2.[!p]) do - cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); - incr p - done; - if !cmp = 0 && !p < len1 && !p = len2 then - val_ascii v1.[!p] - else if !cmp = 0 && !p = len1 && !p < len2 then - - (val_ascii v2.[!p]) - else - !cmp - in - - (** Compare digit part *) - let compare_digit () = - let extract_int v p = - let start_p = !p in - while !p < String.length v && is_digit v.[!p] do - incr p - done; - let substr = - String.sub v !p ((String.length v) - !p) - in - let res = - match String.sub v start_p (!p - start_p) with - | "" -> 0 - | s -> int_of_string s - in - res, substr - in - let i1, tl1 = extract_int v1 (ref !p) in - let i2, tl2 = extract_int v2 (ref !p) in - i1 - i2, tl1, tl2 - in - - match compare_vascii () with - | 0 -> - begin - match compare_digit () with - | 0, tl1, tl2 -> - if tl1 <> "" && is_digit tl1.[0] then - 1 - else if tl2 <> "" && is_digit tl2.[0] then - -1 - else - version_compare tl1 tl2 - | n, _, _ -> - n - end - | n -> - n - end - else - begin - 0 - end - - - let version_of_string str = str - - - let string_of_version t = t - - - let version_compare_string s1 s2 = - version_compare (version_of_string s1) (version_of_string s2) - - - let chop t = - try - let pos = - String.rindex t '.' - in - String.sub t 0 pos - with Not_found -> - t - - - let rec comparator_apply v op = - match op with - | VGreater cv -> - (version_compare v cv) > 0 - | VGreaterEqual cv -> - (version_compare v cv) >= 0 - | VLesser cv -> - (version_compare v cv) < 0 - | VLesserEqual cv -> - (version_compare v cv) <= 0 - | VEqual cv -> - (version_compare v cv) = 0 - | VOr (op1, op2) -> - (comparator_apply v op1) || (comparator_apply v op2) - | VAnd (op1, op2) -> - (comparator_apply v op1) && (comparator_apply v op2) - - - let rec string_of_comparator = - function - | VGreater v -> "> "^(string_of_version v) - | VEqual v -> "= "^(string_of_version v) - | VLesser v -> "< "^(string_of_version v) - | VGreaterEqual v -> ">= "^(string_of_version v) - | VLesserEqual v -> "<= "^(string_of_version v) - | VOr (c1, c2) -> - (string_of_comparator c1)^" || "^(string_of_comparator c2) - | VAnd (c1, c2) -> - (string_of_comparator c1)^" && "^(string_of_comparator c2) - - - let rec varname_of_comparator = - let concat p v = - OASISUtils.varname_concat - p - (OASISUtils.varname_of_string - (string_of_version v)) - in - function - | VGreater v -> concat "gt" v - | VLesser v -> concat "lt" v - | VEqual v -> concat "eq" v - | VGreaterEqual v -> concat "ge" v - | VLesserEqual v -> concat "le" v - | VOr (c1, c2) -> - (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) - | VAnd (c1, c2) -> - (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) - - - let rec comparator_ge v' = - let cmp v = version_compare v v' >= 0 in - function - | VEqual v - | VGreaterEqual v - | VGreater v -> cmp v - | VLesserEqual _ - | VLesser _ -> false - | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2 - | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2 - - -end - -module OASISLicense = struct -(* # 22 "src/oasis/OASISLicense.ml" *) - - - (** License for _oasis fields - @author Sylvain Le Gall - *) - - - - - - type license = string - - - type license_exception = string - - - type license_version = - | Version of OASISVersion.t - | VersionOrLater of OASISVersion.t - | NoVersion - - - - type license_dep_5_unit = - { - license: license; - excption: license_exception option; - version: license_version; - } - - - - type license_dep_5 = - | DEP5Unit of license_dep_5_unit - | DEP5Or of license_dep_5 list - | DEP5And of license_dep_5 list - - - type t = - | DEP5License of license_dep_5 - | OtherLicense of string (* URL *) - - - -end - -module OASISExpr = struct -(* # 22 "src/oasis/OASISExpr.ml" *) - - - - - - open OASISGettext - - - type test = string - - - type flag = string - - - type t = - | EBool of bool - | ENot of t - | EAnd of t * t - | EOr of t * t - | EFlag of flag - | ETest of test * string - - - - type 'a choices = (t * 'a) list - - - let eval var_get t = - let rec eval' = - function - | EBool b -> - b - - | ENot e -> - not (eval' e) - - | EAnd (e1, e2) -> - (eval' e1) && (eval' e2) - - | EOr (e1, e2) -> - (eval' e1) || (eval' e2) - - | EFlag nm -> - let v = - var_get nm - in - assert(v = "true" || v = "false"); - (v = "true") - - | ETest (nm, vl) -> - let v = - var_get nm - in - (v = vl) - in - eval' t - - - let choose ?printer ?name var_get lst = - let rec choose_aux = - function - | (cond, vl) :: tl -> - if eval var_get cond then - vl - else - choose_aux tl - | [] -> - let str_lst = - if lst = [] then - s_ "" - else - String.concat - (s_ ", ") - (List.map - (fun (cond, vl) -> - match printer with - | Some p -> p vl - | None -> s_ "") - lst) - in - match name with - | Some nm -> - failwith - (Printf.sprintf - (f_ "No result for the choice list '%s': %s") - nm str_lst) - | None -> - failwith - (Printf.sprintf - (f_ "No result for a choice list: %s") - str_lst) - in - choose_aux (List.rev lst) - - -end - -module OASISText = struct -(* # 22 "src/oasis/OASISText.ml" *) - - - - type elt = - | Para of string - | Verbatim of string - | BlankLine - - - type t = elt list - -end - -module OASISTypes = struct -(* # 22 "src/oasis/OASISTypes.ml" *) - - - - - - type name = string - type package_name = string - type url = string - type unix_dirname = string - type unix_filename = string - type host_dirname = string - type host_filename = string - type prog = string - type arg = string - type args = string list - type command_line = (prog * arg list) - - - type findlib_name = string - type findlib_full = string - - - type compiled_object = - | Byte - | Native - | Best - - - - type dependency = - | FindlibPackage of findlib_full * OASISVersion.comparator option - | InternalLibrary of name - - - - type tool = - | ExternalTool of name - | InternalExecutable of name - - - - type vcs = - | Darcs - | Git - | Svn - | Cvs - | Hg - | Bzr - | Arch - | Monotone - | OtherVCS of url - - - - type plugin_kind = - [ `Configure - | `Build - | `Doc - | `Test - | `Install - | `Extra - ] - - - type plugin_data_purpose = - [ `Configure - | `Build - | `Install - | `Clean - | `Distclean - | `Install - | `Uninstall - | `Test - | `Doc - | `Extra - | `Other of string - ] - - - type 'a plugin = 'a * name * OASISVersion.t option - - - type all_plugin = plugin_kind plugin - - - type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list - - -(* # 115 "src/oasis/OASISTypes.ml" *) - - - type 'a conditional = 'a OASISExpr.choices - - - type custom = - { - pre_command: (command_line option) conditional; - post_command: (command_line option) conditional; - } - - - - type common_section = - { - cs_name: name; - cs_data: PropList.Data.t; - cs_plugin_data: plugin_data; - } - - - - type build_section = - { - bs_build: bool conditional; - bs_install: bool conditional; - bs_path: unix_dirname; - bs_compiled_object: compiled_object; - bs_build_depends: dependency list; - bs_build_tools: tool list; - bs_c_sources: unix_filename list; - bs_data_files: (unix_filename * unix_filename option) list; - bs_ccopt: args conditional; - bs_cclib: args conditional; - bs_dlllib: args conditional; - bs_dllpath: args conditional; - bs_byteopt: args conditional; - bs_nativeopt: args conditional; - } - - - - type library = - { - lib_modules: string list; - lib_pack: bool; - lib_internal_modules: string list; - lib_findlib_parent: findlib_name option; - lib_findlib_name: findlib_name option; - lib_findlib_containers: findlib_name list; - } - - - type object_ = - { - obj_modules: string list; - obj_findlib_fullname: findlib_name list option; - } - - - type executable = - { - exec_custom: bool; - exec_main_is: unix_filename; - } - - - type flag = - { - flag_description: string option; - flag_default: bool conditional; - } - - - type source_repository = - { - src_repo_type: vcs; - src_repo_location: url; - src_repo_browser: url option; - src_repo_module: string option; - src_repo_branch: string option; - src_repo_tag: string option; - src_repo_subdir: unix_filename option; - } - - - type test = - { - test_type: [`Test] plugin; - test_command: command_line conditional; - test_custom: custom; - test_working_directory: unix_filename option; - test_run: bool conditional; - test_tools: tool list; - } - - - type doc_format = - | HTML of unix_filename - | DocText - | PDF - | PostScript - | Info of unix_filename - | DVI - | OtherDoc - - - - type doc = - { - doc_type: [`Doc] plugin; - doc_custom: custom; - doc_build: bool conditional; - doc_install: bool conditional; - doc_install_dir: unix_filename; - doc_title: string; - doc_authors: string list; - doc_abstract: string option; - doc_format: doc_format; - doc_data_files: (unix_filename * unix_filename option) list; - doc_build_tools: tool list; - } - - - type section = - | Library of common_section * build_section * library - | Object of common_section * build_section * object_ - | Executable of common_section * build_section * executable - | Flag of common_section * flag - | SrcRepo of common_section * source_repository - | Test of common_section * test - | Doc of common_section * doc - - - - type section_kind = - [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] - - - type package = - { - oasis_version: OASISVersion.t; - ocaml_version: OASISVersion.comparator option; - findlib_version: OASISVersion.comparator option; - alpha_features: string list; - beta_features: string list; - name: package_name; - version: OASISVersion.t; - license: OASISLicense.t; - license_file: unix_filename option; - copyrights: string list; - maintainers: string list; - authors: string list; - homepage: url option; - synopsis: string; - description: OASISText.t option; - categories: url list; - - conf_type: [`Configure] plugin; - conf_custom: custom; - - build_type: [`Build] plugin; - build_custom: custom; - - install_type: [`Install] plugin; - install_custom: custom; - uninstall_custom: custom; - - clean_custom: custom; - distclean_custom: custom; - - files_ab: unix_filename list; - sections: section list; - plugins: [`Extra] plugin list; - disable_oasis_section: unix_filename list; - schema_data: PropList.Data.t; - plugin_data: plugin_data; - } - - -end - -module OASISFeatures = struct -(* # 22 "src/oasis/OASISFeatures.ml" *) - - open OASISTypes - open OASISUtils - open OASISGettext - open OASISVersion - - module MapPlugin = - Map.Make - (struct - type t = plugin_kind * name - let compare = Pervasives.compare - end) - - module Data = - struct - type t = - { - oasis_version: OASISVersion.t; - plugin_versions: OASISVersion.t option MapPlugin.t; - alpha_features: string list; - beta_features: string list; - } - - let create oasis_version alpha_features beta_features = - { - oasis_version = oasis_version; - plugin_versions = MapPlugin.empty; - alpha_features = alpha_features; - beta_features = beta_features - } - - let of_package pkg = - create - pkg.OASISTypes.oasis_version - pkg.OASISTypes.alpha_features - pkg.OASISTypes.beta_features - - let add_plugin (plugin_kind, plugin_name, plugin_version) t = - {t with - plugin_versions = MapPlugin.add - (plugin_kind, plugin_name) - plugin_version - t.plugin_versions} - - let plugin_version plugin_kind plugin_name t = - MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions - - let to_string t = - Printf.sprintf - "oasis_version: %s; alpha_features: %s; beta_features: %s; \ - plugins_version: %s" - (OASISVersion.string_of_version t.oasis_version) - (String.concat ", " t.alpha_features) - (String.concat ", " t.beta_features) - (String.concat ", " - (MapPlugin.fold - (fun (_, plg) ver_opt acc -> - (plg^ - (match ver_opt with - | Some v -> - " "^(OASISVersion.string_of_version v) - | None -> "")) - :: acc) - t.plugin_versions [])) - end - - type origin = - | Field of string * string - | Section of string - | NoOrigin - - type stage = Alpha | Beta - - - let string_of_stage = - function - | Alpha -> "alpha" - | Beta -> "beta" - - - let field_of_stage = - function - | Alpha -> "AlphaFeatures" - | Beta -> "BetaFeatures" - - type publication = InDev of stage | SinceVersion of OASISVersion.t - - type t = - { - name: string; - plugin: all_plugin option; - publication: publication; - description: unit -> string; - } - - (* TODO: mutex protect this. *) - let all_features = Hashtbl.create 13 - - - let since_version ver_str = SinceVersion (version_of_string ver_str) - let alpha = InDev Alpha - let beta = InDev Beta - - - let to_string t = - Printf.sprintf - "feature: %s; plugin: %s; publication: %s" - t.name - (match t.plugin with - | None -> "" - | Some (_, nm, _) -> nm) - (match t.publication with - | InDev stage -> string_of_stage stage - | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) - - let data_check t data origin = - let no_message = "no message" in - - let check_feature features stage = - let has_feature = List.mem t.name features in - if not has_feature then - match origin with - | Field (fld, where) -> - Some - (Printf.sprintf - (f_ "Field %s in %s is only available when feature %s \ - is in field %s.") - fld where t.name (field_of_stage stage)) - | Section sct -> - Some - (Printf.sprintf - (f_ "Section %s is only available when features %s \ - is in field %s.") - sct t.name (field_of_stage stage)) - | NoOrigin -> - Some no_message - else - None - in - - let version_is_good ~min_version version fmt = - let version_is_good = - OASISVersion.comparator_apply - version (OASISVersion.VGreaterEqual min_version) - in - Printf.ksprintf - (fun str -> - if version_is_good then - None - else - Some str) - fmt - in - - match origin, t.plugin, t.publication with - | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha - | _, _, InDev Beta -> check_feature data.Data.beta_features Beta - | Field(fld, where), None, SinceVersion min_version -> - version_is_good ~min_version data.Data.oasis_version - (f_ "Field %s in %s is only valid since OASIS v%s, update \ - OASISFormat field from '%s' to '%s' after checking \ - OASIS changelog.") - fld where (string_of_version min_version) - (string_of_version data.Data.oasis_version) - (string_of_version min_version) - - | Field(fld, where), Some(plugin_knd, plugin_name, _), - SinceVersion min_version -> - begin - try - let plugin_version_current = - try - match Data.plugin_version plugin_knd plugin_name data with - | Some ver -> ver - | None -> - failwithf - (f_ "Field %s in %s is only valid for the OASIS \ - plugin %s since v%s, but no plugin version is \ - defined in the _oasis file, change '%s' to \ - '%s (%s)' in your _oasis file.") - fld where plugin_name (string_of_version min_version) - plugin_name - plugin_name (string_of_version min_version) - with Not_found -> - failwithf - (f_ "Field %s in %s is only valid when the OASIS plugin %s \ - is defined.") - fld where plugin_name - in - version_is_good ~min_version plugin_version_current - (f_ "Field %s in %s is only valid for the OASIS plugin %s \ - since v%s, update your plugin from '%s (%s)' to \ - '%s (%s)' after checking the plugin's changelog.") - fld where plugin_name (string_of_version min_version) - plugin_name (string_of_version plugin_version_current) - plugin_name (string_of_version min_version) - with Failure msg -> - Some msg - end - - | Section sct, None, SinceVersion min_version -> - version_is_good ~min_version data.Data.oasis_version - (f_ "Section %s is only valid for since OASIS v%s, update \ - OASISFormat field from '%s' to '%s' after checking OASIS \ - changelog.") - sct (string_of_version min_version) - (string_of_version data.Data.oasis_version) - (string_of_version min_version) - - | Section sct, Some(plugin_knd, plugin_name, _), - SinceVersion min_version -> - begin - try - let plugin_version_current = - try - match Data.plugin_version plugin_knd plugin_name data with - | Some ver -> ver - | None -> - failwithf - (f_ "Section %s is only valid for the OASIS \ - plugin %s since v%s, but no plugin version is \ - defined in the _oasis file, change '%s' to \ - '%s (%s)' in your _oasis file.") - sct plugin_name (string_of_version min_version) - plugin_name - plugin_name (string_of_version min_version) - with Not_found -> - failwithf - (f_ "Section %s is only valid when the OASIS plugin %s \ - is defined.") - sct plugin_name - in - version_is_good ~min_version plugin_version_current - (f_ "Section %s is only valid for the OASIS plugin %s \ - since v%s, update your plugin from '%s (%s)' to \ - '%s (%s)' after checking the plugin's changelog.") - sct plugin_name (string_of_version min_version) - plugin_name (string_of_version plugin_version_current) - plugin_name (string_of_version min_version) - with Failure msg -> - Some msg - end - - | NoOrigin, None, SinceVersion min_version -> - version_is_good ~min_version data.Data.oasis_version "%s" no_message - - | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> - begin - try - let plugin_version_current = - match Data.plugin_version plugin_knd plugin_name data with - | Some ver -> ver - | None -> raise Not_found - in - version_is_good ~min_version plugin_version_current - "%s" no_message - with Not_found -> - Some no_message - end - - - let data_assert t data origin = - match data_check t data origin with - | None -> () - | Some str -> failwith str - - - let data_test t data = - match data_check t data NoOrigin with - | None -> true - | Some str -> false - - - let package_test t pkg = - data_test t (Data.of_package pkg) - - - let create ?plugin name publication description = - let () = - if Hashtbl.mem all_features name then - failwithf "Feature '%s' is already declared." name - in - let t = - { - name = name; - plugin = plugin; - publication = publication; - description = description; - } - in - Hashtbl.add all_features name t; - t - - - let get_stage name = - try - (Hashtbl.find all_features name).publication - with Not_found -> - failwithf (f_ "Feature %s doesn't exist.") name - - - let list () = - Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] - - (* - * Real flags. - *) - - - let features = - create "features_fields" - (since_version "0.4") - (fun () -> - s_ "Enable to experiment not yet official features.") - - - let flag_docs = - create "flag_docs" - (since_version "0.3") - (fun () -> - s_ "Building docs require '-docs' flag at configure.") - - - let flag_tests = - create "flag_tests" - (since_version "0.3") - (fun () -> - s_ "Running tests require '-tests' flag at configure.") - - - let pack = - create "pack" - (since_version "0.3") - (fun () -> - s_ "Allow to create packed library.") - - - let section_object = - create "section_object" beta - (fun () -> - s_ "Implement an object section.") - - - let dynrun_for_release = - create "dynrun_for_release" alpha - (fun () -> - s_ "Make '-setup-update dynamic' suitable for releasing project.") - - - let compiled_setup_ml = - create "compiled_setup_ml" alpha - (fun () -> - s_ "It compiles the setup.ml and speed-up actions done with it.") - - let disable_oasis_section = - create "disable_oasis_section" alpha - (fun () -> - s_ "Allows the OASIS section comments and digest to be omitted in \ - generated files.") - - let no_automatic_syntax = - create "no_automatic_syntax" alpha - (fun () -> - s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ - that matches the internal heuristic (if a dependency ends with \ - a .syntax or is a well known syntax).") -end - -module OASISUnixPath = struct -(* # 22 "src/oasis/OASISUnixPath.ml" *) - - - type unix_filename = string - type unix_dirname = string - - - type host_filename = string - type host_dirname = string - - - let current_dir_name = "." - - - let parent_dir_name = ".." - - - let is_current_dir fn = - fn = current_dir_name || fn = "" - - - let concat f1 f2 = - if is_current_dir f1 then - f2 - else - let f1' = - try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 - in - f1'^"/"^f2 - - - let make = - function - | hd :: tl -> - List.fold_left - (fun f p -> concat f p) - hd - tl - | [] -> - invalid_arg "OASISUnixPath.make" - - - let dirname f = - try - String.sub f 0 (String.rindex f '/') - with Not_found -> - current_dir_name - - - let basename f = - try - let pos_start = - (String.rindex f '/') + 1 - in - String.sub f pos_start ((String.length f) - pos_start) - with Not_found -> - f - - - let chop_extension f = - try - let last_dot = - String.rindex f '.' - in - let sub = - String.sub f 0 last_dot - in - try - let last_slash = - String.rindex f '/' - in - if last_slash < last_dot then - sub - else - f - with Not_found -> - sub - - with Not_found -> - f - - - let capitalize_file f = - let dir = dirname f in - let base = basename f in - concat dir (OASISString.capitalize_ascii base) - - - let uncapitalize_file f = - let dir = dirname f in - let base = basename f in - concat dir (OASISString.uncapitalize_ascii base) - - -end - -module OASISHostPath = struct -(* # 22 "src/oasis/OASISHostPath.ml" *) - - - open Filename - - - module Unix = OASISUnixPath - - - let make = - function - | [] -> - invalid_arg "OASISHostPath.make" - | hd :: tl -> - List.fold_left Filename.concat hd tl - - - let of_unix ufn = - if Sys.os_type = "Unix" then - ufn - else - make - (List.map - (fun p -> - if p = Unix.current_dir_name then - current_dir_name - else if p = Unix.parent_dir_name then - parent_dir_name - else - p) - (OASISString.nsplit ufn '/')) - - -end - -module OASISSection = struct -(* # 22 "src/oasis/OASISSection.ml" *) - - - open OASISTypes - - - let section_kind_common = - function - | Library (cs, _, _) -> - `Library, cs - | Object (cs, _, _) -> - `Object, cs - | Executable (cs, _, _) -> - `Executable, cs - | Flag (cs, _) -> - `Flag, cs - | SrcRepo (cs, _) -> - `SrcRepo, cs - | Test (cs, _) -> - `Test, cs - | Doc (cs, _) -> - `Doc, cs - - - let section_common sct = - snd (section_kind_common sct) - - - let section_common_set cs = - function - | Library (_, bs, lib) -> Library (cs, bs, lib) - | Object (_, bs, obj) -> Object (cs, bs, obj) - | Executable (_, bs, exec) -> Executable (cs, bs, exec) - | Flag (_, flg) -> Flag (cs, flg) - | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) - | Test (_, tst) -> Test (cs, tst) - | Doc (_, doc) -> Doc (cs, doc) - - - (** Key used to identify section - *) - let section_id sct = - let k, cs = - section_kind_common sct - in - k, cs.cs_name - - - let string_of_section sct = - let k, nm = - section_id sct - in - (match k with - | `Library -> "library" - | `Object -> "object" - | `Executable -> "executable" - | `Flag -> "flag" - | `SrcRepo -> "src repository" - | `Test -> "test" - | `Doc -> "doc") - ^" "^nm - - - let section_find id scts = - List.find - (fun sct -> id = section_id sct) - scts - - - module CSection = - struct - type t = section - - let id = section_id - - let compare t1 t2 = - compare (id t1) (id t2) - - let equal t1 t2 = - (id t1) = (id t2) - - let hash t = - Hashtbl.hash (id t) - end - - - module MapSection = Map.Make(CSection) - module SetSection = Set.Make(CSection) - - -end - -module OASISBuildSection = struct -(* # 22 "src/oasis/OASISBuildSection.ml" *) - - -end - -module OASISExecutable = struct -(* # 22 "src/oasis/OASISExecutable.ml" *) - - - open OASISTypes - - - let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = - let dir = - OASISUnixPath.concat - bs.bs_path - (OASISUnixPath.dirname exec.exec_main_is) - in - let is_native_exec = - match bs.bs_compiled_object with - | Native -> true - | Best -> is_native () - | Byte -> false - in - - OASISUnixPath.concat - dir - (cs.cs_name^(suffix_program ())), - - if not is_native_exec && - not exec.exec_custom && - bs.bs_c_sources <> [] then - Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) - else - None - - -end - -module OASISLibrary = struct -(* # 22 "src/oasis/OASISLibrary.ml" *) - - - open OASISTypes - open OASISUtils - open OASISGettext - open OASISSection - - - (* Look for a module file, considering capitalization or not. *) - let find_module source_file_exists bs modul = - let possible_base_fn = - List.map - (OASISUnixPath.concat bs.bs_path) - [modul; - OASISUnixPath.uncapitalize_file modul; - OASISUnixPath.capitalize_file modul] - in - (* TODO: we should be able to be able to determine the source for every - * files. Hence we should introduce a Module(source: fn) for the fields - * Modules and InternalModules - *) - List.fold_left - (fun acc base_fn -> - match acc with - | `No_sources _ -> - begin - let file_found = - List.fold_left - (fun acc ext -> - if source_file_exists (base_fn^ext) then - (base_fn^ext) :: acc - else - acc) - [] - [".ml"; ".mli"; ".mll"; ".mly"] - in - match file_found with - | [] -> - acc - | lst -> - `Sources (base_fn, lst) - end - | `Sources _ -> - acc) - (`No_sources possible_base_fn) - possible_base_fn - - - let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = - List.fold_left - (fun acc modul -> - match find_module source_file_exists bs modul with - | `Sources (base_fn, lst) -> - (base_fn, lst) :: acc - | `No_sources _ -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in library %s") - modul cs.cs_name; - acc) - [] - (lib.lib_modules @ lib.lib_internal_modules) - - - let generated_unix_files - ~ctxt - ~is_native - ~has_native_dynlink - ~ext_lib - ~ext_dll - ~source_file_exists - (cs, bs, lib) = - - let find_modules lst ext = - let find_module modul = - match find_module source_file_exists bs modul with - | `Sources (base_fn, [fn]) when ext <> "cmi" - && Filename.check_suffix fn ".mli" -> - None (* No implementation files for pure interface. *) - | `Sources (base_fn, _) -> - Some [base_fn] - | `No_sources lst -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in library %s") - modul cs.cs_name; - Some lst - in - List.fold_left - (fun acc nm -> - match find_module nm with - | None -> acc - | Some base_fns -> - List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) - [] - lst - in - - (* The .cmx that be compiled along *) - let cmxs = - let should_be_built = - match bs.bs_compiled_object with - | Native -> true - | Best -> is_native - | Byte -> false - in - if should_be_built then - if lib.lib_pack then - find_modules - [cs.cs_name] - "cmx" - else - find_modules - (lib.lib_modules @ lib.lib_internal_modules) - "cmx" - else - [] - in - - let acc_nopath = - [] - in - - (* The headers and annot/cmt files that should be compiled along *) - let headers = - let sufx = - if lib.lib_pack - then [".cmti"; ".cmt"; ".annot"] - else [".cmi"; ".cmti"; ".cmt"; ".annot"] - in - List.map - begin - List.fold_left - begin fun accu s -> - let dot = String.rindex s '.' in - let base = String.sub s 0 dot in - List.map ((^) base) sufx @ accu - end - [] - end - (find_modules lib.lib_modules "cmi") - in - - (* Compute what libraries should be built *) - let acc_nopath = - (* Add the packed header file if required *) - let add_pack_header acc = - if lib.lib_pack then - [cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc - else - acc - in - let byte acc = - add_pack_header ([cs.cs_name^".cma"] :: acc) - in - let native acc = - let acc = - add_pack_header - (if has_native_dynlink then - [cs.cs_name^".cmxs"] :: acc - else acc) - in - [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc - in - match bs.bs_compiled_object with - | Native -> - byte (native acc_nopath) - | Best when is_native -> - byte (native acc_nopath) - | Byte | Best -> - byte acc_nopath - in - - (* Add C library to be built *) - let acc_nopath = - if bs.bs_c_sources <> [] then - begin - ["lib"^cs.cs_name^"_stubs"^ext_lib] - :: - ["dll"^cs.cs_name^"_stubs"^ext_dll] - :: - acc_nopath - end - else - acc_nopath - in - - (* All the files generated *) - List.rev_append - (List.rev_map - (List.rev_map - (OASISUnixPath.concat bs.bs_path)) - acc_nopath) - (headers @ cmxs) - - -end - -module OASISObject = struct -(* # 22 "src/oasis/OASISObject.ml" *) - - - open OASISTypes - open OASISGettext - - - let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = - List.fold_left - (fun acc modul -> - match OASISLibrary.find_module source_file_exists bs modul with - | `Sources (base_fn, lst) -> - (base_fn, lst) :: acc - | `No_sources _ -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in object %s") - modul cs.cs_name; - acc) - [] - obj.obj_modules - - - let generated_unix_files - ~ctxt - ~is_native - ~source_file_exists - (cs, bs, obj) = - - let find_module ext modul = - match OASISLibrary.find_module source_file_exists bs modul with - | `Sources (base_fn, _) -> [base_fn ^ ext] - | `No_sources lst -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in object %s") - modul cs.cs_name ; - lst - in - - let header, byte, native, c_object, f = - match obj.obj_modules with - | [ m ] -> (find_module ".cmi" m, - find_module ".cmo" m, - find_module ".cmx" m, - find_module ".o" m, - fun x -> x) - | _ -> ([cs.cs_name ^ ".cmi"], - [cs.cs_name ^ ".cmo"], - [cs.cs_name ^ ".cmx"], - [cs.cs_name ^ ".o"], - OASISUnixPath.concat bs.bs_path) - in - List.map (List.map f) ( - match bs.bs_compiled_object with - | Native -> - native :: c_object :: byte :: header :: [] - | Best when is_native -> - native :: c_object :: byte :: header :: [] - | Byte | Best -> - byte :: header :: []) - - -end - -module OASISFindlib = struct -(* # 22 "src/oasis/OASISFindlib.ml" *) - - - open OASISTypes - open OASISUtils - open OASISGettext - open OASISSection - - - type library_name = name - type findlib_part_name = name - type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t - - - exception InternalLibraryNotFound of library_name - exception FindlibPackageNotFound of findlib_name - - - type group_t = - | Container of findlib_name * group_t list - | Package of (findlib_name * - common_section * - build_section * - [`Library of library | `Object of object_] * - group_t list) - - - type data = common_section * - build_section * - [`Library of library | `Object of object_] - type tree = - | Node of (data option) * (tree MapString.t) - | Leaf of data - - - let findlib_mapping pkg = - (* Map from library name to either full findlib name or parts + parent. *) - let fndlb_parts_of_lib_name = - let fndlb_parts cs lib = - let name = - match lib.lib_findlib_name with - | Some nm -> nm - | None -> cs.cs_name - in - let name = - String.concat "." (lib.lib_findlib_containers @ [name]) - in - name - in - List.fold_left - (fun mp -> - function - | Library (cs, _, lib) -> - begin - let lib_name = cs.cs_name in - let fndlb_parts = fndlb_parts cs lib in - if MapString.mem lib_name mp then - failwithf - (f_ "The library name '%s' is used more than once.") - lib_name; - match lib.lib_findlib_parent with - | Some lib_name_parent -> - MapString.add - lib_name - (`Unsolved (lib_name_parent, fndlb_parts)) - mp - | None -> - MapString.add - lib_name - (`Solved fndlb_parts) - mp - end - - | Object (cs, _, obj) -> - begin - let obj_name = cs.cs_name in - if MapString.mem obj_name mp then - failwithf - (f_ "The object name '%s' is used more than once.") - obj_name; - let findlib_full_name = match obj.obj_findlib_fullname with - | Some ns -> String.concat "." ns - | None -> obj_name - in - MapString.add - obj_name - (`Solved findlib_full_name) - mp - end - - | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> - mp) - MapString.empty - pkg.sections - in - - (* Solve the above graph to be only library name to full findlib name. *) - let fndlb_name_of_lib_name = - let rec solve visited mp lib_name lib_name_child = - if SetString.mem lib_name visited then - failwithf - (f_ "Library '%s' is involved in a cycle \ - with regard to findlib naming.") - lib_name; - let visited = SetString.add lib_name visited in - try - match MapString.find lib_name mp with - | `Solved fndlb_nm -> - fndlb_nm, mp - | `Unsolved (lib_nm_parent, post_fndlb_nm) -> - let pre_fndlb_nm, mp = - solve visited mp lib_nm_parent lib_name - in - let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in - fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp - with Not_found -> - failwithf - (f_ "Library '%s', which is defined as the findlib parent of \ - library '%s', doesn't exist.") - lib_name lib_name_child - in - let mp = - MapString.fold - (fun lib_name status mp -> - match status with - | `Solved _ -> - (* Solved initialy, no need to go further *) - mp - | `Unsolved _ -> - let _, mp = solve SetString.empty mp lib_name "" in - mp) - fndlb_parts_of_lib_name - fndlb_parts_of_lib_name - in - MapString.map - (function - | `Solved fndlb_nm -> fndlb_nm - | `Unsolved _ -> assert false) - mp - in - - (* Convert an internal library name to a findlib name. *) - let findlib_name_of_library_name lib_nm = - try - MapString.find lib_nm fndlb_name_of_lib_name - with Not_found -> - raise (InternalLibraryNotFound lib_nm) - in - - (* Add a library to the tree. - *) - let add sct mp = - let fndlb_fullname = - let cs, _, _ = sct in - let lib_name = cs.cs_name in - findlib_name_of_library_name lib_name - in - let rec add_children nm_lst (children: tree MapString.t) = - match nm_lst with - | (hd :: tl) -> - begin - let node = - try - add_node tl (MapString.find hd children) - with Not_found -> - (* New node *) - new_node tl - in - MapString.add hd node children - end - | [] -> - (* Should not have a nameless library. *) - assert false - and add_node tl node = - if tl = [] then - begin - match node with - | Node (None, children) -> - Node (Some sct, children) - | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> - (* TODO: allow to merge Package, i.e. - * archive(byte) = "foo.cma foo_init.cmo" - *) - let cs, _, _ = sct in - failwithf - (f_ "Library '%s' and '%s' have the same findlib name '%s'") - cs.cs_name cs'.cs_name fndlb_fullname - end - else - begin - match node with - | Leaf data -> - Node (Some data, add_children tl MapString.empty) - | Node (data_opt, children) -> - Node (data_opt, add_children tl children) - end - and new_node = - function - | [] -> - Leaf sct - | hd :: tl -> - Node (None, MapString.add hd (new_node tl) MapString.empty) - in - add_children (OASISString.nsplit fndlb_fullname '.') mp - in - - let rec group_of_tree mp = - MapString.fold - (fun nm node acc -> - let cur = - match node with - | Node (Some (cs, bs, lib), children) -> - Package (nm, cs, bs, lib, group_of_tree children) - | Node (None, children) -> - Container (nm, group_of_tree children) - | Leaf (cs, bs, lib) -> - Package (nm, cs, bs, lib, []) - in - cur :: acc) - mp [] - in - - let group_mp = - List.fold_left - (fun mp -> - function - | Library (cs, bs, lib) -> - add (cs, bs, `Library lib) mp - | Object (cs, bs, obj) -> - add (cs, bs, `Object obj) mp - | _ -> - mp) - MapString.empty - pkg.sections - in - - let groups = - group_of_tree group_mp - in - - let library_name_of_findlib_name = - lazy begin - (* Revert findlib_name_of_library_name. *) - MapString.fold - (fun k v mp -> MapString.add v k mp) - fndlb_name_of_lib_name - MapString.empty - end - in - let library_name_of_findlib_name fndlb_nm = - try - MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) - with Not_found -> - raise (FindlibPackageNotFound fndlb_nm) - in - - groups, - findlib_name_of_library_name, - library_name_of_findlib_name - - - let findlib_of_group = - function - | Container (fndlb_nm, _) - | Package (fndlb_nm, _, _, _, _) -> fndlb_nm - - - let root_of_group grp = - let rec root_lib_aux = - (* We do a DFS in the group. *) - function - | Container (_, children) -> - List.fold_left - (fun res grp -> - if res = None then - root_lib_aux grp - else - res) - None - children - | Package (_, cs, bs, lib, _) -> - Some (cs, bs, lib) - in - match root_lib_aux grp with - | Some res -> - res - | None -> - failwithf - (f_ "Unable to determine root library of findlib library '%s'") - (findlib_of_group grp) - - -end - -module OASISFlag = struct -(* # 22 "src/oasis/OASISFlag.ml" *) - - -end - -module OASISPackage = struct -(* # 22 "src/oasis/OASISPackage.ml" *) - - -end - -module OASISSourceRepository = struct -(* # 22 "src/oasis/OASISSourceRepository.ml" *) - - -end - -module OASISTest = struct -(* # 22 "src/oasis/OASISTest.ml" *) - - -end - -module OASISDocument = struct -(* # 22 "src/oasis/OASISDocument.ml" *) - - -end - -module OASISExec = struct -(* # 22 "src/oasis/OASISExec.ml" *) - - - open OASISGettext - open OASISUtils - open OASISMessage - - - (* TODO: I don't like this quote, it is there because $(rm) foo expands to - * 'rm -f' foo... - *) - let run ~ctxt ?f_exit_code ?(quote=true) cmd args = - let cmd = - if quote then - if Sys.os_type = "Win32" then - if String.contains cmd ' ' then - (* Double the 1st double quote... win32... sigh *) - "\""^(Filename.quote cmd) - else - cmd - else - Filename.quote cmd - else - cmd - in - let cmdline = - String.concat " " (cmd :: args) - in - info ~ctxt (f_ "Running command '%s'") cmdline; - match f_exit_code, Sys.command cmdline with - | None, 0 -> () - | None, i -> - failwithf - (f_ "Command '%s' terminated with error code %d") - cmdline i - | Some f, i -> - f i - - - let run_read_output ~ctxt ?f_exit_code cmd args = - let fn = - Filename.temp_file "oasis-" ".txt" - in - try - begin - let () = - run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) - in - let chn = - open_in fn - in - let routput = - ref [] - in - begin - try - while true do - routput := (input_line chn) :: !routput - done - with End_of_file -> - () - end; - close_in chn; - Sys.remove fn; - List.rev !routput - end - with e -> - (try Sys.remove fn with _ -> ()); - raise e - - - let run_read_one_line ~ctxt ?f_exit_code cmd args = - match run_read_output ~ctxt ?f_exit_code cmd args with - | [fst] -> - fst - | lst -> - failwithf - (f_ "Command return unexpected output %S") - (String.concat "\n" lst) -end - -module OASISFileUtil = struct -(* # 22 "src/oasis/OASISFileUtil.ml" *) - - - open OASISGettext - - - let file_exists_case fn = - let dirname = Filename.dirname fn in - let basename = Filename.basename fn in - if Sys.file_exists dirname then - if basename = Filename.current_dir_name then - true - else - List.mem - basename - (Array.to_list (Sys.readdir dirname)) - else - false - - - let find_file ?(case_sensitive=true) paths exts = - - (* Cardinal product of two list *) - let ( * ) lst1 lst2 = - List.flatten - (List.map - (fun a -> - List.map - (fun b -> a, b) - lst2) - lst1) - in - - let rec combined_paths lst = - match lst with - | p1 :: p2 :: tl -> - let acc = - (List.map - (fun (a, b) -> Filename.concat a b) - (p1 * p2)) - in - combined_paths (acc :: tl) - | [e] -> - e - | [] -> - [] - in - - let alternatives = - List.map - (fun (p, e) -> - if String.length e > 0 && e.[0] <> '.' then - p ^ "." ^ e - else - p ^ e) - ((combined_paths paths) * exts) - in - List.find (fun file -> - (if case_sensitive then - file_exists_case file - else - Sys.file_exists file) - && not (Sys.is_directory file) - ) alternatives - - - let which ~ctxt prg = - let path_sep = - match Sys.os_type with - | "Win32" -> - ';' - | _ -> - ':' - in - let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in - let exec_ext = - match Sys.os_type with - | "Win32" -> - "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) - | _ -> - [""] - in - find_file ~case_sensitive:false [path_lst; [prg]] exec_ext - - - (**/**) - let rec fix_dir dn = - (* Windows hack because Sys.file_exists "src\\" = false when - * Sys.file_exists "src" = true - *) - let ln = - String.length dn - in - if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then - fix_dir (String.sub dn 0 (ln - 1)) - else - dn - - - let q = Filename.quote - (**/**) - - - let cp ~ctxt ?(recurse=false) src tgt = - if recurse then - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt - "xcopy" [q src; q tgt; "/E"] - | _ -> - OASISExec.run ~ctxt - "cp" ["-r"; q src; q tgt] - else - OASISExec.run ~ctxt - (match Sys.os_type with - | "Win32" -> "copy" - | _ -> "cp") - [q src; q tgt] - - - let mkdir ~ctxt tgt = - OASISExec.run ~ctxt - (match Sys.os_type with - | "Win32" -> "md" - | _ -> "mkdir") - [q tgt] - - - let rec mkdir_parent ~ctxt f tgt = - let tgt = - fix_dir tgt - in - if Sys.file_exists tgt then - begin - if not (Sys.is_directory tgt) then - OASISUtils.failwithf - (f_ "Cannot create directory '%s', a file of the same name already \ - exists") - tgt - end - else - begin - mkdir_parent ~ctxt f (Filename.dirname tgt); - if not (Sys.file_exists tgt) then - begin - f tgt; - mkdir ~ctxt tgt - end - end - - - let rmdir ~ctxt tgt = - if Sys.readdir tgt = [||] then begin - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt "rd" [q tgt] - | _ -> - OASISExec.run ~ctxt "rm" ["-r"; q tgt] - end else begin - OASISMessage.error ~ctxt - (f_ "Cannot remove directory '%s': not empty.") - tgt - end - - - let glob ~ctxt fn = - let basename = - Filename.basename fn - in - if String.length basename >= 2 && - basename.[0] = '*' && - basename.[1] = '.' then - begin - let ext_len = - (String.length basename) - 2 - in - let ext = - String.sub basename 2 ext_len - in - let dirname = - Filename.dirname fn - in - Array.fold_left - (fun acc fn -> - try - let fn_ext = - String.sub - fn - ((String.length fn) - ext_len) - ext_len - in - if fn_ext = ext then - (Filename.concat dirname fn) :: acc - else - acc - with Invalid_argument _ -> - acc) - [] - (Sys.readdir dirname) - end - else - begin - if file_exists_case fn then - [fn] - else - [] - end -end - - -# 2916 "setup.ml" -module BaseEnvLight = struct -(* # 22 "src/base/BaseEnvLight.ml" *) - - - module MapString = Map.Make(String) - - - type t = string MapString.t - - - let default_filename = - Filename.concat - (Sys.getcwd ()) - "setup.data" - - - let load ?(allow_empty=false) ?(filename=default_filename) () = - if Sys.file_exists filename then - begin - let chn = - open_in_bin filename - in - let st = - Stream.of_channel chn - in - let line = - ref 1 - in - let st_line = - Stream.from - (fun _ -> - try - match Stream.next st with - | '\n' -> incr line; Some '\n' - | c -> Some c - with Stream.Failure -> None) - in - let lexer = - Genlex.make_lexer ["="] st_line - in - let rec read_file mp = - match Stream.npeek 3 lexer with - | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lexer; - Stream.junk lexer; - Stream.junk lexer; - read_file (MapString.add nm value mp) - | [] -> - mp - | _ -> - failwith - (Printf.sprintf - "Malformed data file '%s' line %d" - filename !line) - in - let mp = - read_file MapString.empty - in - close_in chn; - mp - end - else if allow_empty then - begin - MapString.empty - end - else - begin - failwith - (Printf.sprintf - "Unable to load environment, the file '%s' doesn't exist." - filename) - end - - - let rec var_expand str env = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) env - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff - - - let var_get name env = - var_expand (MapString.find name env) env - - - let var_choose lst env = - OASISExpr.choose - (fun nm -> var_get nm env) - lst -end - - -# 3021 "setup.ml" -module BaseContext = struct -(* # 22 "src/base/BaseContext.ml" *) - - (* TODO: get rid of this module. *) - open OASISContext - - - let args () = fst (fspecs ()) - - - let default = default - -end - -module BaseMessage = struct -(* # 22 "src/base/BaseMessage.ml" *) - - - (** Message to user, overrid for Base - @author Sylvain Le Gall - *) - open OASISMessage - open BaseContext - - - let debug fmt = debug ~ctxt:!default fmt - - - let info fmt = info ~ctxt:!default fmt - - - let warning fmt = warning ~ctxt:!default fmt - - - let error fmt = error ~ctxt:!default fmt - -end - -module BaseEnv = struct -(* # 22 "src/base/BaseEnv.ml" *) - - open OASISGettext - open OASISUtils - open PropList - - - module MapString = BaseEnvLight.MapString - - - type origin_t = - | ODefault - | OGetEnv - | OFileLoad - | OCommandLine - - - type cli_handle_t = - | CLINone - | CLIAuto - | CLIWith - | CLIEnable - | CLIUser of (Arg.key * Arg.spec * Arg.doc) list - - - type definition_t = - { - hide: bool; - dump: bool; - cli: cli_handle_t; - arg_help: string option; - group: string option; - } - - - let schema = - Schema.create "environment" - - - (* Environment data *) - let env = - Data.create () - - - (* Environment data from file *) - let env_from_file = - ref MapString.empty - - - (* Lexer for var *) - let var_lxr = - Genlex.make_lexer [] - - - let rec var_expand str = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - (* TODO: this is a quick hack to allow calling Test.Command - * without defining executable name really. I.e. if there is - * an exec Executable toto, then $(toto) should be replace - * by its real name. It is however useful to have this function - * for other variable that depend on the host and should be - * written better than that. - *) - let st = - var_lxr (Stream.of_string var) - in - match Stream.npeek 3 st with - | [Genlex.Ident "utoh"; Genlex.Ident nm] -> - OASISHostPath.of_unix (var_get nm) - | [Genlex.Ident "utoh"; Genlex.String s] -> - OASISHostPath.of_unix s - | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> - String.escaped (var_get nm) - | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> - String.escaped s - | [Genlex.Ident nm] -> - var_get nm - | _ -> - failwithf - (f_ "Unknown expression '%s' in variable expansion of %s.") - var - str - with - | Unknown_field (_, _) -> - failwithf - (f_ "No variable %s defined when trying to expand %S.") - var - str - | Stream.Error e -> - failwithf - (f_ "Syntax error when parsing '%s' when trying to \ - expand %S: %s") - var - str - e) - str; - Buffer.contents buff - - - and var_get name = - let vl = - try - Schema.get schema env name - with Unknown_field _ as e -> - begin - try - MapString.find name !env_from_file - with Not_found -> - raise e - end - in - var_expand vl - - - let var_choose ?printer ?name lst = - OASISExpr.choose - ?printer - ?name - var_get - lst - - - let var_protect vl = - let buff = - Buffer.create (String.length vl) - in - String.iter - (function - | '$' -> Buffer.add_string buff "\\$" - | c -> Buffer.add_char buff c) - vl; - Buffer.contents buff - - - let var_define - ?(hide=false) - ?(dump=true) - ?short_desc - ?(cli=CLINone) - ?arg_help - ?group - name (* TODO: type constraint on the fact that name must be a valid OCaml - id *) - dflt = - - let default = - [ - OFileLoad, (fun () -> MapString.find name !env_from_file); - ODefault, dflt; - OGetEnv, (fun () -> Sys.getenv name); - ] - in - - let extra = - { - hide = hide; - dump = dump; - cli = cli; - arg_help = arg_help; - group = group; - } - in - - (* Try to find a value that can be defined - *) - let var_get_low lst = - let errors, res = - List.fold_left - (fun (errors, res) (o, v) -> - if res = None then - begin - try - errors, Some (v ()) - with - | Not_found -> - errors, res - | Failure rsn -> - (rsn :: errors), res - | e -> - (Printexc.to_string e) :: errors, res - end - else - errors, res) - ([], None) - (List.sort - (fun (o1, _) (o2, _) -> - Pervasives.compare o2 o1) - lst) - in - match res, errors with - | Some v, _ -> - v - | None, [] -> - raise (Not_set (name, None)) - | None, lst -> - raise (Not_set (name, Some (String.concat (s_ ", ") lst))) - in - - let help = - match short_desc with - | Some fs -> Some fs - | None -> None - in - - let var_get_lst = - FieldRO.create - ~schema - ~name - ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) - ~print:var_get_low - ~default - ~update:(fun ?context x old_x -> x @ old_x) - ?help - extra - in - - fun () -> - var_expand (var_get_low (var_get_lst env)) - - - let var_redefine - ?hide - ?dump - ?short_desc - ?cli - ?arg_help - ?group - name - dflt = - if Schema.mem schema name then - begin - (* TODO: look suspsicious, we want to memorize dflt not dflt () *) - Schema.set schema env ~context:ODefault name (dflt ()); - fun () -> var_get name - end - else - begin - var_define - ?hide - ?dump - ?short_desc - ?cli - ?arg_help - ?group - name - dflt - end - - - let var_ignore (e: unit -> string) = () - - - let print_hidden = - var_define - ~hide:true - ~dump:false - ~cli:CLIAuto - ~arg_help:"Print even non-printable variable. (debug)" - "print_hidden" - (fun () -> "false") - - - let var_all () = - List.rev - (Schema.fold - (fun acc nm def _ -> - if not def.hide || bool_of_string (print_hidden ()) then - nm :: acc - else - acc) - [] - schema) - - - let default_filename = - BaseEnvLight.default_filename - - - let load ?allow_empty ?filename () = - env_from_file := BaseEnvLight.load ?allow_empty ?filename () - - - let unload () = - env_from_file := MapString.empty; - Data.clear env - - - let dump ?(filename=default_filename) () = - let chn = - open_out_bin filename - in - let output nm value = - Printf.fprintf chn "%s=%S\n" nm value - in - let mp_todo = - (* Dump data from schema *) - Schema.fold - (fun mp_todo nm def _ -> - if def.dump then - begin - try - let value = - Schema.get - schema - env - nm - in - output nm value - with Not_set _ -> - () - end; - MapString.remove nm mp_todo) - !env_from_file - schema - in - (* Dump data defined outside of schema *) - MapString.iter output mp_todo; - - (* End of the dump *) - close_out chn - - - let print () = - let printable_vars = - Schema.fold - (fun acc nm def short_descr_opt -> - if not def.hide || bool_of_string (print_hidden ()) then - begin - try - let value = - Schema.get - schema - env - nm - in - let txt = - match short_descr_opt with - | Some s -> s () - | None -> nm - in - (txt, value) :: acc - with Not_set _ -> - acc - end - else - acc) - [] - schema - in - let max_length = - List.fold_left max 0 - (List.rev_map String.length - (List.rev_map fst printable_vars)) - in - let dot_pad str = - String.make ((max_length - (String.length str)) + 3) '.' - in - - Printf.printf "\nConfiguration: \n"; - List.iter - (fun (name, value) -> - Printf.printf "%s: %s %s\n" name (dot_pad name) value) - (List.rev printable_vars); - Printf.printf "\n%!" - - - let args () = - let arg_concat = - OASISUtils.varname_concat ~hyphen:'-' - in - [ - "--override", - Arg.Tuple - ( - let rvr = ref "" - in - let rvl = ref "" - in - [ - Arg.Set_string rvr; - Arg.Set_string rvl; - Arg.Unit - (fun () -> - Schema.set - schema - env - ~context:OCommandLine - !rvr - !rvl) - ] - ), - "var+val Override any configuration variable."; - - ] - @ - List.flatten - (Schema.fold - (fun acc name def short_descr_opt -> - let var_set s = - Schema.set - schema - env - ~context:OCommandLine - name - s - in - - let arg_name = - OASISUtils.varname_of_string ~hyphen:'-' name - in - - let hlp = - match short_descr_opt with - | Some txt -> txt () - | None -> "" - in - - let arg_hlp = - match def.arg_help with - | Some s -> s - | None -> "str" - in - - let default_value = - try - Printf.sprintf - (f_ " [%s]") - (Schema.get - schema - env - name) - with Not_set _ -> - "" - in - - let args = - match def.cli with - | CLINone -> - [] - | CLIAuto -> - [ - arg_concat "--" arg_name, - Arg.String var_set, - Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value - ] - | CLIWith -> - [ - arg_concat "--with-" arg_name, - Arg.String var_set, - Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value - ] - | CLIEnable -> - let dflt = - if default_value = " [true]" then - s_ " [default: enabled]" - else - s_ " [default: disabled]" - in - [ - arg_concat "--enable-" arg_name, - Arg.Unit (fun () -> var_set "true"), - Printf.sprintf (f_ " %s%s") hlp dflt; - - arg_concat "--disable-" arg_name, - Arg.Unit (fun () -> var_set "false"), - Printf.sprintf (f_ " %s%s") hlp dflt - ] - | CLIUser lst -> - lst - in - args :: acc) - [] - schema) -end - -module BaseArgExt = struct -(* # 22 "src/base/BaseArgExt.ml" *) - - - open OASISUtils - open OASISGettext - - - let parse argv args = - (* Simulate command line for Arg *) - let current = - ref 0 - in - - try - Arg.parse_argv - ~current:current - (Array.concat [[|"none"|]; argv]) - (Arg.align args) - (failwithf (f_ "Don't know what to do with arguments: '%s'")) - (s_ "configure options:") - with - | Arg.Help txt -> - print_endline txt; - exit 0 - | Arg.Bad txt -> - prerr_endline txt; - exit 1 -end - -module BaseCheck = struct -(* # 22 "src/base/BaseCheck.ml" *) - - - open BaseEnv - open BaseMessage - open OASISUtils - open OASISGettext - - - let prog_best prg prg_lst = - var_redefine - prg - (fun () -> - let alternate = - List.fold_left - (fun res e -> - match res with - | Some _ -> - res - | None -> - try - Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) - with Not_found -> - None) - None - prg_lst - in - match alternate with - | Some prg -> prg - | None -> raise Not_found) - - - let prog prg = - prog_best prg [prg] - - - let prog_opt prg = - prog_best prg [prg^".opt"; prg] - - - let ocamlfind = - prog "ocamlfind" - - - let version - var_prefix - cmp - fversion - () = - (* Really compare version provided *) - let var = - var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) - in - var_redefine - ~hide:true - var - (fun () -> - let version_str = - match fversion () with - | "[Distributed with OCaml]" -> - begin - try - (var_get "ocaml_version") - with Not_found -> - warning - (f_ "Variable ocaml_version not defined, fallback \ - to default"); - Sys.ocaml_version - end - | res -> - res - in - let version = - OASISVersion.version_of_string version_str - in - if OASISVersion.comparator_apply version cmp then - version_str - else - failwithf - (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") - var_prefix - (OASISVersion.string_of_comparator cmp) - version_str) - () - - - let package_version pkg = - OASISExec.run_read_one_line ~ctxt:!BaseContext.default - (ocamlfind ()) - ["query"; "-format"; "%v"; pkg] - - - let package ?version_comparator pkg () = - let var = - OASISUtils.varname_concat - "pkg_" - (OASISUtils.varname_of_string pkg) - in - let findlib_dir pkg = - let dir = - OASISExec.run_read_one_line ~ctxt:!BaseContext.default - (ocamlfind ()) - ["query"; "-format"; "%d"; pkg] - in - if Sys.file_exists dir && Sys.is_directory dir then - dir - else - failwithf - (f_ "When looking for findlib package %s, \ - directory %s return doesn't exist") - pkg dir - in - let vl = - var_redefine - var - (fun () -> findlib_dir pkg) - () - in - ( - match version_comparator with - | Some ver_cmp -> - ignore - (version - var - ver_cmp - (fun _ -> package_version pkg) - ()) - | None -> - () - ); - vl -end - -module BaseOCamlcConfig = struct -(* # 22 "src/base/BaseOCamlcConfig.ml" *) - - - open BaseEnv - open OASISUtils - open OASISGettext - - - module SMap = Map.Make(String) - - - let ocamlc = - BaseCheck.prog_opt "ocamlc" - - - let ocamlc_config_map = - (* Map name to value for ocamlc -config output - (name ^": "^value) - *) - let rec split_field mp lst = - match lst with - | line :: tl -> - let mp = - try - let pos_semicolon = - String.index line ':' - in - if pos_semicolon > 1 then - ( - let name = - String.sub line 0 pos_semicolon - in - let linelen = - String.length line - in - let value = - if linelen > pos_semicolon + 2 then - String.sub - line - (pos_semicolon + 2) - (linelen - pos_semicolon - 2) - else - "" - in - SMap.add name value mp - ) - else - ( - mp - ) - with Not_found -> - ( - mp - ) - in - split_field mp tl - | [] -> - mp - in - - let cache = - lazy - (var_protect - (Marshal.to_string - (split_field - SMap.empty - (OASISExec.run_read_output - ~ctxt:!BaseContext.default - (ocamlc ()) ["-config"])) - [])) - in - var_redefine - "ocamlc_config_map" - ~hide:true - ~dump:false - (fun () -> - (* TODO: update if ocamlc change !!! *) - Lazy.force cache) - - - let var_define nm = - (* Extract data from ocamlc -config *) - let avlbl_config_get () = - Marshal.from_string - (ocamlc_config_map ()) - 0 - in - let chop_version_suffix s = - try - String.sub s 0 (String.index s '+') - with _ -> - s - in - - let nm_config, value_config = - match nm with - | "ocaml_version" -> - "version", chop_version_suffix - | _ -> nm, (fun x -> x) - in - var_redefine - nm - (fun () -> - try - let map = - avlbl_config_get () - in - let value = - SMap.find nm_config map - in - value_config value - with Not_found -> - failwithf - (f_ "Cannot find field '%s' in '%s -config' output") - nm - (ocamlc ())) - -end - -module BaseStandardVar = struct -(* # 22 "src/base/BaseStandardVar.ml" *) - - - open OASISGettext - open OASISTypes - open OASISExpr - open BaseCheck - open BaseEnv - - - let ocamlfind = BaseCheck.ocamlfind - let ocamlc = BaseOCamlcConfig.ocamlc - let ocamlopt = prog_opt "ocamlopt" - let ocamlbuild = prog "ocamlbuild" - - - (**/**) - let rpkg = - ref None - - - let pkg_get () = - match !rpkg with - | Some pkg -> pkg - | None -> failwith (s_ "OASIS Package is not set") - - - let var_cond = ref [] - - - let var_define_cond ~since_version f dflt = - let holder = ref (fun () -> dflt) in - let since_version = - OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) - in - var_cond := - (fun ver -> - if OASISVersion.comparator_apply ver since_version then - holder := f ()) :: !var_cond; - fun () -> !holder () - - - (**/**) - - - let pkg_name = - var_define - ~short_desc:(fun () -> s_ "Package name") - "pkg_name" - (fun () -> (pkg_get ()).name) - - - let pkg_version = - var_define - ~short_desc:(fun () -> s_ "Package version") - "pkg_version" - (fun () -> - (OASISVersion.string_of_version (pkg_get ()).version)) - - - let c = BaseOCamlcConfig.var_define - - - let os_type = c "os_type" - let system = c "system" - let architecture = c "architecture" - let ccomp_type = c "ccomp_type" - let ocaml_version = c "ocaml_version" - - - (* TODO: Check standard variable presence at runtime *) - - - let standard_library_default = c "standard_library_default" - let standard_library = c "standard_library" - let standard_runtime = c "standard_runtime" - let bytecomp_c_compiler = c "bytecomp_c_compiler" - let native_c_compiler = c "native_c_compiler" - let model = c "model" - let ext_obj = c "ext_obj" - let ext_asm = c "ext_asm" - let ext_lib = c "ext_lib" - let ext_dll = c "ext_dll" - let default_executable_name = c "default_executable_name" - let systhread_supported = c "systhread_supported" - - - let flexlink = - BaseCheck.prog "flexlink" - - - let flexdll_version = - var_define - ~short_desc:(fun () -> "FlexDLL version (Win32)") - "flexdll_version" - (fun () -> - let lst = - OASISExec.run_read_output ~ctxt:!BaseContext.default - (flexlink ()) ["-help"] - in - match lst with - | line :: _ -> - Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) - | [] -> - raise Not_found) - - - (**/**) - let p name hlp dflt = - var_define - ~short_desc:hlp - ~cli:CLIAuto - ~arg_help:"dir" - name - dflt - - - let (/) a b = - if os_type () = Sys.os_type then - Filename.concat a b - else if os_type () = "Unix" then - OASISUnixPath.concat a b - else - OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") - (os_type ()) - (**/**) - - - let prefix = - p "prefix" - (fun () -> s_ "Install architecture-independent files dir") - (fun () -> - match os_type () with - | "Win32" -> - let program_files = - Sys.getenv "PROGRAMFILES" - in - program_files/(pkg_name ()) - | _ -> - "/usr/local") - - - let exec_prefix = - p "exec_prefix" - (fun () -> s_ "Install architecture-dependent files in dir") - (fun () -> "$prefix") - - - let bindir = - p "bindir" - (fun () -> s_ "User executables") - (fun () -> "$exec_prefix"/"bin") - - - let sbindir = - p "sbindir" - (fun () -> s_ "System admin executables") - (fun () -> "$exec_prefix"/"sbin") - - - let libexecdir = - p "libexecdir" - (fun () -> s_ "Program executables") - (fun () -> "$exec_prefix"/"libexec") - - - let sysconfdir = - p "sysconfdir" - (fun () -> s_ "Read-only single-machine data") - (fun () -> "$prefix"/"etc") - - - let sharedstatedir = - p "sharedstatedir" - (fun () -> s_ "Modifiable architecture-independent data") - (fun () -> "$prefix"/"com") - - - let localstatedir = - p "localstatedir" - (fun () -> s_ "Modifiable single-machine data") - (fun () -> "$prefix"/"var") - - - let libdir = - p "libdir" - (fun () -> s_ "Object code libraries") - (fun () -> "$exec_prefix"/"lib") - - - let datarootdir = - p "datarootdir" - (fun () -> s_ "Read-only arch-independent data root") - (fun () -> "$prefix"/"share") - - - let datadir = - p "datadir" - (fun () -> s_ "Read-only architecture-independent data") - (fun () -> "$datarootdir") - - - let infodir = - p "infodir" - (fun () -> s_ "Info documentation") - (fun () -> "$datarootdir"/"info") - - - let localedir = - p "localedir" - (fun () -> s_ "Locale-dependent data") - (fun () -> "$datarootdir"/"locale") - - - let mandir = - p "mandir" - (fun () -> s_ "Man documentation") - (fun () -> "$datarootdir"/"man") - - - let docdir = - p "docdir" - (fun () -> s_ "Documentation root") - (fun () -> "$datarootdir"/"doc"/"$pkg_name") - - - let htmldir = - p "htmldir" - (fun () -> s_ "HTML documentation") - (fun () -> "$docdir") - - - let dvidir = - p "dvidir" - (fun () -> s_ "DVI documentation") - (fun () -> "$docdir") - - - let pdfdir = - p "pdfdir" - (fun () -> s_ "PDF documentation") - (fun () -> "$docdir") - - - let psdir = - p "psdir" - (fun () -> s_ "PS documentation") - (fun () -> "$docdir") - - - let destdir = - p "destdir" - (fun () -> s_ "Prepend a path when installing package") - (fun () -> - raise - (PropList.Not_set - ("destdir", - Some (s_ "undefined by construct")))) - - - let findlib_version = - var_define - "findlib_version" - (fun () -> - BaseCheck.package_version "findlib") - - - let is_native = - var_define - "is_native" - (fun () -> - try - let _s: string = - ocamlopt () - in - "true" - with PropList.Not_set _ -> - let _s: string = - ocamlc () - in - "false") - - - let ext_program = - var_define - "suffix_program" - (fun () -> - match os_type () with - | "Win32" | "Cygwin" -> ".exe" - | _ -> "") - - - let rm = - var_define - ~short_desc:(fun () -> s_ "Remove a file.") - "rm" - (fun () -> - match os_type () with - | "Win32" -> "del" - | _ -> "rm -f") - - - let rmdir = - var_define - ~short_desc:(fun () -> s_ "Remove a directory.") - "rmdir" - (fun () -> - match os_type () with - | "Win32" -> "rd" - | _ -> "rm -rf") - - - let debug = - var_define - ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") - ~cli:CLIEnable - "debug" - (fun () -> "true") - - - let profile = - var_define - ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") - ~cli:CLIEnable - "profile" - (fun () -> "false") - - - let tests = - var_define_cond ~since_version:"0.3" - (fun () -> - var_define - ~short_desc:(fun () -> - s_ "Compile tests executable and library and run them") - ~cli:CLIEnable - "tests" - (fun () -> "false")) - "true" - - - let docs = - var_define_cond ~since_version:"0.3" - (fun () -> - var_define - ~short_desc:(fun () -> s_ "Create documentations") - ~cli:CLIEnable - "docs" - (fun () -> "true")) - "true" - - - let native_dynlink = - var_define - ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") - ~cli:CLINone - "native_dynlink" - (fun () -> - let res = - let ocaml_lt_312 () = - OASISVersion.comparator_apply - (OASISVersion.version_of_string (ocaml_version ())) - (OASISVersion.VLesser - (OASISVersion.version_of_string "3.12.0")) - in - let flexdll_lt_030 () = - OASISVersion.comparator_apply - (OASISVersion.version_of_string (flexdll_version ())) - (OASISVersion.VLesser - (OASISVersion.version_of_string "0.30")) - in - let has_native_dynlink = - let ocamlfind = ocamlfind () in - try - let fn = - OASISExec.run_read_one_line - ~ctxt:!BaseContext.default - ocamlfind - ["query"; "-predicates"; "native"; "dynlink"; - "-format"; "%d/%a"] - in - Sys.file_exists fn - with _ -> - false - in - if not has_native_dynlink then - false - else if ocaml_lt_312 () then - false - else if (os_type () = "Win32" || os_type () = "Cygwin") - && flexdll_lt_030 () then - begin - BaseMessage.warning - (f_ ".cmxs generation disabled because FlexDLL needs to be \ - at least 0.30. Please upgrade FlexDLL from %s to 0.30.") - (flexdll_version ()); - false - end - else - true - in - string_of_bool res) - - - let init pkg = - rpkg := Some pkg; - List.iter (fun f -> f pkg.oasis_version) !var_cond - -end - -module BaseFileAB = struct -(* # 22 "src/base/BaseFileAB.ml" *) - - - open BaseEnv - open OASISGettext - open BaseMessage - - - let to_filename fn = - let fn = - OASISHostPath.of_unix fn - in - if not (Filename.check_suffix fn ".ab") then - warning - (f_ "File '%s' doesn't have '.ab' extension") - fn; - Filename.chop_extension fn - - - let replace fn_lst = - let buff = - Buffer.create 13 - in - List.iter - (fun fn -> - let fn = - OASISHostPath.of_unix fn - in - let chn_in = - open_in fn - in - let chn_out = - open_out (to_filename fn) - in - ( - try - while true do - Buffer.add_string buff (var_expand (input_line chn_in)); - Buffer.add_char buff '\n' - done - with End_of_file -> - () - ); - Buffer.output_buffer chn_out buff; - Buffer.clear buff; - close_in chn_in; - close_out chn_out) - fn_lst -end - -module BaseLog = struct -(* # 22 "src/base/BaseLog.ml" *) - - - open OASISUtils - - - let default_filename = - Filename.concat - (Filename.dirname BaseEnv.default_filename) - "setup.log" - - - module SetTupleString = - Set.Make - (struct - type t = string * string - let compare (s11, s12) (s21, s22) = - match String.compare s11 s21 with - | 0 -> String.compare s12 s22 - | n -> n - end) - - - let load () = - if Sys.file_exists default_filename then - begin - let chn = - open_in default_filename - in - let scbuf = - Scanf.Scanning.from_file default_filename - in - let rec read_aux (st, lst) = - if not (Scanf.Scanning.end_of_input scbuf) then - begin - let acc = - try - Scanf.bscanf scbuf "%S %S\n" - (fun e d -> - let t = - e, d - in - if SetTupleString.mem t st then - st, lst - else - SetTupleString.add t st, - t :: lst) - with Scanf.Scan_failure _ -> - failwith - (Scanf.bscanf scbuf - "%l" - (fun line -> - Printf.sprintf - "Malformed log file '%s' at line %d" - default_filename - line)) - in - read_aux acc - end - else - begin - close_in chn; - List.rev lst - end - in - read_aux (SetTupleString.empty, []) - end - else - begin - [] - end - - - let register event data = - let chn_out = - open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename - in - Printf.fprintf chn_out "%S %S\n" event data; - close_out chn_out - - - let unregister event data = - if Sys.file_exists default_filename then - begin - let lst = - load () - in - let chn_out = - open_out default_filename - in - let write_something = - ref false - in - List.iter - (fun (e, d) -> - if e <> event || d <> data then - begin - write_something := true; - Printf.fprintf chn_out "%S %S\n" e d - end) - lst; - close_out chn_out; - if not !write_something then - Sys.remove default_filename - end - - - let filter events = - let st_events = - List.fold_left - (fun st e -> - SetString.add e st) - SetString.empty - events - in - List.filter - (fun (e, _) -> SetString.mem e st_events) - (load ()) - - - let exists event data = - List.exists - (fun v -> (event, data) = v) - (load ()) -end - -module BaseBuilt = struct -(* # 22 "src/base/BaseBuilt.ml" *) - - - open OASISTypes - open OASISGettext - open BaseStandardVar - open BaseMessage - - - type t = - | BExec (* Executable *) - | BExecLib (* Library coming with executable *) - | BLib (* Library *) - | BObj (* Library *) - | BDoc (* Document *) - - - let to_log_event_file t nm = - "built_"^ - (match t with - | BExec -> "exec" - | BExecLib -> "exec_lib" - | BLib -> "lib" - | BObj -> "obj" - | BDoc -> "doc")^ - "_"^nm - - - let to_log_event_done t nm = - "is_"^(to_log_event_file t nm) - - - let register t nm lst = - BaseLog.register - (to_log_event_done t nm) - "true"; - List.iter - (fun alt -> - let registered = - List.fold_left - (fun registered fn -> - if OASISFileUtil.file_exists_case fn then - begin - BaseLog.register - (to_log_event_file t nm) - (if Filename.is_relative fn then - Filename.concat (Sys.getcwd ()) fn - else - fn); - true - end - else - registered) - false - alt - in - if not registered then - warning - (f_ "Cannot find an existing alternative files among: %s") - (String.concat (s_ ", ") alt)) - lst - - - let unregister t nm = - List.iter - (fun (e, d) -> - BaseLog.unregister e d) - (BaseLog.filter - [to_log_event_file t nm; - to_log_event_done t nm]) - - - let fold t nm f acc = - List.fold_left - (fun acc (_, fn) -> - if OASISFileUtil.file_exists_case fn then - begin - f acc fn - end - else - begin - warning - (f_ "File '%s' has been marked as built \ - for %s but doesn't exist") - fn - (Printf.sprintf - (match t with - | BExec | BExecLib -> - (f_ "executable %s") - | BLib -> - (f_ "library %s") - | BObj -> - (f_ "object %s") - | BDoc -> - (f_ "documentation %s")) - nm); - acc - end) - acc - (BaseLog.filter - [to_log_event_file t nm]) - - - let is_built t nm = - List.fold_left - (fun is_built (_, d) -> - (try - bool_of_string d - with _ -> - false)) - false - (BaseLog.filter - [to_log_event_done t nm]) - - - let of_executable ffn (cs, bs, exec) = - let unix_exec_is, unix_dll_opt = - OASISExecutable.unix_exec_is - (cs, bs, exec) - (fun () -> - bool_of_string - (is_native ())) - ext_dll - ext_program - in - let evs = - (BExec, cs.cs_name, [[ffn unix_exec_is]]) - :: - (match unix_dll_opt with - | Some fn -> - [BExecLib, cs.cs_name, [[ffn fn]]] - | None -> - []) - in - evs, - unix_exec_is, - unix_dll_opt - - - let of_library ffn (cs, bs, lib) = - let unix_lst = - OASISLibrary.generated_unix_files - ~ctxt:!BaseContext.default - ~source_file_exists:(fun fn -> - OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) - ~is_native:(bool_of_string (is_native ())) - ~has_native_dynlink:(bool_of_string (native_dynlink ())) - ~ext_lib:(ext_lib ()) - ~ext_dll:(ext_dll ()) - (cs, bs, lib) - in - let evs = - [BLib, - cs.cs_name, - List.map (List.map ffn) unix_lst] - in - evs, unix_lst - - - let of_object ffn (cs, bs, obj) = - let unix_lst = - OASISObject.generated_unix_files - ~ctxt:!BaseContext.default - ~source_file_exists:(fun fn -> - OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) - ~is_native:(bool_of_string (is_native ())) - (cs, bs, obj) - in - let evs = - [BObj, - cs.cs_name, - List.map (List.map ffn) unix_lst] - in - evs, unix_lst - -end - -module BaseCustom = struct -(* # 22 "src/base/BaseCustom.ml" *) - - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - - - let run cmd args extra_args = - OASISExec.run ~ctxt:!BaseContext.default ~quote:false - (var_expand cmd) - (List.map - var_expand - (args @ (Array.to_list extra_args))) - - - let hook ?(failsafe=false) cstm f e = - let optional_command lst = - let printer = - function - | Some (cmd, args) -> String.concat " " (cmd :: args) - | None -> s_ "No command" - in - match - var_choose - ~name:(s_ "Pre/Post Command") - ~printer - lst with - | Some (cmd, args) -> - begin - try - run cmd args [||] - with e when failsafe -> - warning - (f_ "Command '%s' fail with error: %s") - (String.concat " " (cmd :: args)) - (match e with - | Failure msg -> msg - | e -> Printexc.to_string e) - end - | None -> - () - in - let res = - optional_command cstm.pre_command; - f e - in - optional_command cstm.post_command; - res -end - -module BaseDynVar = struct -(* # 22 "src/base/BaseDynVar.ml" *) - - - open OASISTypes - open OASISGettext - open BaseEnv - open BaseBuilt - - - let init pkg = - (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) - (* TODO: provide compile option for library libary_byte_args_VARNAME... *) - List.iter - (function - | Executable (cs, bs, exec) -> - if var_choose bs.bs_build then - var_ignore - (var_redefine - (* We don't save this variable *) - ~dump:false - ~short_desc:(fun () -> - Printf.sprintf - (f_ "Filename of executable '%s'") - cs.cs_name) - (OASISUtils.varname_of_string cs.cs_name) - (fun () -> - let fn_opt = - fold - BExec cs.cs_name - (fun _ fn -> Some fn) - None - in - match fn_opt with - | Some fn -> fn - | None -> - raise - (PropList.Not_set - (cs.cs_name, - Some (Printf.sprintf - (f_ "Executable '%s' not yet built.") - cs.cs_name))))) - - | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> - ()) - pkg.sections -end - -module BaseTest = struct -(* # 22 "src/base/BaseTest.ml" *) - - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISExpr - open OASISGettext - - - let test lst pkg extra_args = - - let one_test (failure, n) (test_plugin, cs, test) = - if var_choose - ~name:(Printf.sprintf - (f_ "test %s run") - cs.cs_name) - ~printer:string_of_bool - test.test_run then - begin - let () = - info (f_ "Running test '%s'") cs.cs_name - in - let back_cwd = - match test.test_working_directory with - | Some dir -> - let cwd = - Sys.getcwd () - in - let chdir d = - info (f_ "Changing directory to '%s'") d; - Sys.chdir d - in - chdir dir; - fun () -> chdir cwd - - | None -> - fun () -> () - in - try - let failure_percent = - BaseCustom.hook - test.test_custom - (test_plugin pkg (cs, test)) - extra_args - in - back_cwd (); - (failure_percent +. failure, n + 1) - with e -> - begin - back_cwd (); - raise e - end - end - else - begin - info (f_ "Skipping test '%s'") cs.cs_name; - (failure, n) - end - in - let failed, n = - List.fold_left - one_test - (0.0, 0) - lst - in - let failure_percent = - if n = 0 then - 0.0 - else - failed /. (float_of_int n) - in - let msg = - Printf.sprintf - (f_ "Tests had a %.2f%% failure rate") - (100. *. failure_percent) - in - if failure_percent > 0.0 then - failwith msg - else - info "%s" msg; - - (* Possible explanation why the tests where not run. *) - if OASISFeatures.package_test OASISFeatures.flag_tests pkg && - not (bool_of_string (BaseStandardVar.tests ())) && - lst <> [] then - BaseMessage.warning - "Tests are turned off, consider enabling with \ - 'ocaml setup.ml -configure --enable-tests'" -end - -module BaseDoc = struct -(* # 22 "src/base/BaseDoc.ml" *) - - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - - - let doc lst pkg extra_args = - - let one_doc (doc_plugin, cs, doc) = - if var_choose - ~name:(Printf.sprintf - (f_ "documentation %s build") - cs.cs_name) - ~printer:string_of_bool - doc.doc_build then - begin - info (f_ "Building documentation '%s'") cs.cs_name; - BaseCustom.hook - doc.doc_custom - (doc_plugin pkg (cs, doc)) - extra_args - end - in - List.iter one_doc lst; - - if OASISFeatures.package_test OASISFeatures.flag_docs pkg && - not (bool_of_string (BaseStandardVar.docs ())) && - lst <> [] then - BaseMessage.warning - "Docs are turned off, consider enabling with \ - 'ocaml setup.ml -configure --enable-docs'" -end - -module BaseSetup = struct -(* # 22 "src/base/BaseSetup.ml" *) - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISSection - open OASISGettext - open OASISUtils - - - type std_args_fun = - package -> string array -> unit - - - type ('a, 'b) section_args_fun = - name * (package -> (common_section * 'a) -> string array -> 'b) - - - type t = - { - configure: std_args_fun; - build: std_args_fun; - doc: ((doc, unit) section_args_fun) list; - test: ((test, float) section_args_fun) list; - install: std_args_fun; - uninstall: std_args_fun; - clean: std_args_fun list; - clean_doc: (doc, unit) section_args_fun list; - clean_test: (test, unit) section_args_fun list; - distclean: std_args_fun list; - distclean_doc: (doc, unit) section_args_fun list; - distclean_test: (test, unit) section_args_fun list; - package: package; - oasis_fn: string option; - oasis_version: string; - oasis_digest: Digest.t option; - oasis_exec: string option; - oasis_setup_args: string list; - setup_update: bool; - } - - - (* Associate a plugin function with data from package *) - let join_plugin_sections filter_map lst = - List.rev - (List.fold_left - (fun acc sct -> - match filter_map sct with - | Some e -> - e :: acc - | None -> - acc) - [] - lst) - - - (* Search for plugin data associated with a section name *) - let lookup_plugin_section plugin action nm lst = - try - List.assoc nm lst - with Not_found -> - failwithf - (f_ "Cannot find plugin %s matching section %s for %s action") - plugin - nm - action - - - let configure t args = - (* Run configure *) - BaseCustom.hook - t.package.conf_custom - (fun () -> - (* Reload if preconf has changed it *) - begin - try - unload (); - load (); - with _ -> - () - end; - - (* Run plugin's configure *) - t.configure t.package args; - - (* Dump to allow postconf to change it *) - dump ()) - (); - - (* Reload environment *) - unload (); - load (); - - (* Save environment *) - print (); - - (* Replace data in file *) - BaseFileAB.replace t.package.files_ab - - - let build t args = - BaseCustom.hook - t.package.build_custom - (t.build t.package) - args - - - let doc t args = - BaseDoc.doc - (join_plugin_sections - (function - | Doc (cs, e) -> - Some - (lookup_plugin_section - "documentation" - (s_ "build") - cs.cs_name - t.doc, - cs, - e) - | _ -> - None) - t.package.sections) - t.package - args - - - let test t args = - BaseTest.test - (join_plugin_sections - (function - | Test (cs, e) -> - Some - (lookup_plugin_section - "test" - (s_ "run") - cs.cs_name - t.test, - cs, - e) - | _ -> - None) - t.package.sections) - t.package - args - - - let all t args = - let rno_doc = - ref false - in - let rno_test = - ref false - in - let arg_rest = - ref [] - in - Arg.parse_argv - ~current:(ref 0) - (Array.of_list - ((Sys.executable_name^" all") :: - (Array.to_list args))) - [ - "-no-doc", - Arg.Set rno_doc, - s_ "Don't run doc target"; - - "-no-test", - Arg.Set rno_test, - s_ "Don't run test target"; - - "--", - Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), - s_ "All arguments for configure."; - ] - (failwithf (f_ "Don't know what to do with '%s'")) - ""; - - info "Running configure step"; - configure t (Array.of_list (List.rev !arg_rest)); - - info "Running build step"; - build t [||]; - - (* Load setup.log dynamic variables *) - BaseDynVar.init t.package; - - if not !rno_doc then - begin - info "Running doc step"; - doc t [||]; - end - else - begin - info "Skipping doc step" - end; - - if not !rno_test then - begin - info "Running test step"; - test t [||] - end - else - begin - info "Skipping test step" - end - - - let install t args = - BaseCustom.hook - t.package.install_custom - (t.install t.package) - args - - - let uninstall t args = - BaseCustom.hook - t.package.uninstall_custom - (t.uninstall t.package) - args - - - let reinstall t args = - uninstall t args; - install t args - - - let clean, distclean = - let failsafe f a = - try - f a - with e -> - warning - (f_ "Action fail with error: %s") - (match e with - | Failure msg -> msg - | e -> Printexc.to_string e) - in - - let generic_clean t cstm mains docs tests args = - BaseCustom.hook - ~failsafe:true - cstm - (fun () -> - (* Clean section *) - List.iter - (function - | Test (cs, test) -> - let f = - try - List.assoc cs.cs_name tests - with Not_found -> - fun _ _ _ -> () - in - failsafe - (f t.package (cs, test)) - args - | Doc (cs, doc) -> - let f = - try - List.assoc cs.cs_name docs - with Not_found -> - fun _ _ _ -> () - in - failsafe - (f t.package (cs, doc)) - args - | Library _ - | Object _ - | Executable _ - | Flag _ - | SrcRepo _ -> - ()) - t.package.sections; - (* Clean whole package *) - List.iter - (fun f -> - failsafe - (f t.package) - args) - mains) - () - in - - let clean t args = - generic_clean - t - t.package.clean_custom - t.clean - t.clean_doc - t.clean_test - args - in - - let distclean t args = - (* Call clean *) - clean t args; - - (* Call distclean code *) - generic_clean - t - t.package.distclean_custom - t.distclean - t.distclean_doc - t.distclean_test - args; - - (* Remove generated file *) - List.iter - (fun fn -> - if Sys.file_exists fn then - begin - info (f_ "Remove '%s'") fn; - Sys.remove fn - end) - (BaseEnv.default_filename - :: - BaseLog.default_filename - :: - (List.rev_map BaseFileAB.to_filename t.package.files_ab)) - in - - clean, distclean - - - let version t _ = - print_endline t.oasis_version - - - let update_setup_ml, no_update_setup_ml_cli = - let b = ref true in - b, - ("-no-update-setup-ml", - Arg.Clear b, - s_ " Don't try to update setup.ml, even if _oasis has changed.") - - - let default_oasis_fn = "_oasis" - - - let update_setup_ml t = - let oasis_fn = - match t.oasis_fn with - | Some fn -> fn - | None -> default_oasis_fn - in - let oasis_exec = - match t.oasis_exec with - | Some fn -> fn - | None -> "oasis" - in - let ocaml = - Sys.executable_name - in - let setup_ml, args = - match Array.to_list Sys.argv with - | setup_ml :: args -> - setup_ml, args - | [] -> - failwith - (s_ "Expecting non-empty command line arguments.") - in - let ocaml, setup_ml = - if Sys.executable_name = Sys.argv.(0) then - (* We are not running in standard mode, probably the script - * is precompiled. - *) - "ocaml", "setup.ml" - else - ocaml, setup_ml - in - let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in - let do_update () = - let oasis_exec_version = - OASISExec.run_read_one_line - ~ctxt:!BaseContext.default - ~f_exit_code: - (function - | 0 -> - () - | 1 -> - failwithf - (f_ "Executable '%s' is probably an old version \ - of oasis (< 0.3.0), please update to version \ - v%s.") - oasis_exec t.oasis_version - | 127 -> - failwithf - (f_ "Cannot find executable '%s', please install \ - oasis v%s.") - oasis_exec t.oasis_version - | n -> - failwithf - (f_ "Command '%s version' exited with code %d.") - oasis_exec n) - oasis_exec ["version"] - in - if OASISVersion.comparator_apply - (OASISVersion.version_of_string oasis_exec_version) - (OASISVersion.VGreaterEqual - (OASISVersion.version_of_string t.oasis_version)) then - begin - (* We have a version >= for the executable oasis, proceed with - * update. - *) - (* TODO: delegate this check to 'oasis setup'. *) - if Sys.os_type = "Win32" then - failwithf - (f_ "It is not possible to update the running script \ - setup.ml on Windows. Please update setup.ml by \ - running '%s'.") - (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) - else - begin - OASISExec.run - ~ctxt:!BaseContext.default - ~f_exit_code: - (function - | 0 -> - () - | n -> - failwithf - (f_ "Unable to update setup.ml using '%s', \ - please fix the problem and retry.") - oasis_exec) - oasis_exec ("setup" :: t.oasis_setup_args); - OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) - end - end - else - failwithf - (f_ "The version of '%s' (v%s) doesn't match the version of \ - oasis used to generate the %s file. Please install at \ - least oasis v%s.") - oasis_exec oasis_exec_version setup_ml t.oasis_version - in - - if !update_setup_ml then - begin - try - match t.oasis_digest with - | Some dgst -> - if Sys.file_exists oasis_fn && - dgst <> Digest.file default_oasis_fn then - begin - do_update (); - true - end - else - false - | None -> - false - with e -> - error - (f_ "Error when updating setup.ml. If you want to avoid this error, \ - you can bypass the update of %s by running '%s %s %s %s'") - setup_ml ocaml setup_ml no_update_setup_ml_cli - (String.concat " " args); - raise e - end - else - false - - - let setup t = - let catch_exn = - ref true - in - try - let act_ref = - ref (fun _ -> - failwithf - (f_ "No action defined, run '%s %s -help'") - Sys.executable_name - Sys.argv.(0)) - - in - let extra_args_ref = - ref [] - in - let allow_empty_env_ref = - ref false - in - let arg_handle ?(allow_empty_env=false) act = - Arg.Tuple - [ - Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); - - Arg.Unit - (fun () -> - allow_empty_env_ref := allow_empty_env; - act_ref := act); - ] - in - - Arg.parse - (Arg.align - ([ - "-configure", - arg_handle ~allow_empty_env:true configure, - s_ "[options*] Configure the whole build process."; - - "-build", - arg_handle build, - s_ "[options*] Build executables and libraries."; - - "-doc", - arg_handle doc, - s_ "[options*] Build documents."; - - "-test", - arg_handle test, - s_ "[options*] Run tests."; - - "-all", - arg_handle ~allow_empty_env:true all, - s_ "[options*] Run configure, build, doc and test targets."; - - "-install", - arg_handle install, - s_ "[options*] Install libraries, data, executables \ - and documents."; - - "-uninstall", - arg_handle uninstall, - s_ "[options*] Uninstall libraries, data, executables \ - and documents."; - - "-reinstall", - arg_handle reinstall, - s_ "[options*] Uninstall and install libraries, data, \ - executables and documents."; - - "-clean", - arg_handle ~allow_empty_env:true clean, - s_ "[options*] Clean files generated by a build."; - - "-distclean", - arg_handle ~allow_empty_env:true distclean, - s_ "[options*] Clean files generated by a build and configure."; - - "-version", - arg_handle ~allow_empty_env:true version, - s_ " Display version of OASIS used to generate this setup.ml."; - - "-no-catch-exn", - Arg.Clear catch_exn, - s_ " Don't catch exception, useful for debugging."; - ] - @ - (if t.setup_update then - [no_update_setup_ml_cli] - else - []) - @ (BaseContext.args ()))) - (failwithf (f_ "Don't know what to do with '%s'")) - (s_ "Setup and run build process current package\n"); - - (* Build initial environment *) - load ~allow_empty:!allow_empty_env_ref (); - - (** Initialize flags *) - List.iter - (function - | Flag (cs, {flag_description = hlp; - flag_default = choices}) -> - begin - let apply ?short_desc () = - var_ignore - (var_define - ~cli:CLIEnable - ?short_desc - (OASISUtils.varname_of_string cs.cs_name) - (fun () -> - string_of_bool - (var_choose - ~name:(Printf.sprintf - (f_ "default value of flag %s") - cs.cs_name) - ~printer:string_of_bool - choices))) - in - match hlp with - | Some hlp -> - apply ~short_desc:(fun () -> hlp) () - | None -> - apply () - end - | _ -> - ()) - t.package.sections; - - BaseStandardVar.init t.package; - - BaseDynVar.init t.package; - - if t.setup_update && update_setup_ml t then - () - else - !act_ref t (Array.of_list (List.rev !extra_args_ref)) - - with e when !catch_exn -> - error "%s" (Printexc.to_string e); - exit 1 - - -end - - -# 5432 "setup.ml" -module InternalConfigurePlugin = struct -(* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) - - - (** Configure using internal scheme - @author Sylvain Le Gall - *) - - - open BaseEnv - open OASISTypes - open OASISUtils - open OASISGettext - open BaseMessage - - - (** Configure build using provided series of check to be done - * and then output corresponding file. - *) - let configure pkg argv = - let var_ignore_eval var = let _s: string = var () in () in - let errors = ref SetString.empty in - let buff = Buffer.create 13 in - - let add_errors fmt = - Printf.kbprintf - (fun b -> - errors := SetString.add (Buffer.contents b) !errors; - Buffer.clear b) - buff - fmt - in - - let warn_exception e = - warning "%s" (Printexc.to_string e) - in - - (* Check tools *) - let check_tools lst = - List.iter - (function - | ExternalTool tool -> - begin - try - var_ignore_eval (BaseCheck.prog tool) - with e -> - warn_exception e; - add_errors (f_ "Cannot find external tool '%s'") tool - end - | InternalExecutable nm1 -> - (* Check that matching tool is built *) - List.iter - (function - | Executable ({cs_name = nm2}, - {bs_build = build}, - _) when nm1 = nm2 -> - if not (var_choose build) then - add_errors - (f_ "Cannot find buildable internal executable \ - '%s' when checking build depends") - nm1 - | _ -> - ()) - pkg.sections) - lst - in - - let build_checks sct bs = - if var_choose bs.bs_build then - begin - if bs.bs_compiled_object = Native then - begin - try - var_ignore_eval BaseStandardVar.ocamlopt - with e -> - warn_exception e; - add_errors - (f_ "Section %s requires native compilation") - (OASISSection.string_of_section sct) - end; - - (* Check tools *) - check_tools bs.bs_build_tools; - - (* Check depends *) - List.iter - (function - | FindlibPackage (findlib_pkg, version_comparator) -> - begin - try - var_ignore_eval - (BaseCheck.package ?version_comparator findlib_pkg) - with e -> - warn_exception e; - match version_comparator with - | None -> - add_errors - (f_ "Cannot find findlib package %s") - findlib_pkg - | Some ver_cmp -> - add_errors - (f_ "Cannot find findlib package %s (%s)") - findlib_pkg - (OASISVersion.string_of_comparator ver_cmp) - end - | InternalLibrary nm1 -> - (* Check that matching library is built *) - List.iter - (function - | Library ({cs_name = nm2}, - {bs_build = build}, - _) when nm1 = nm2 -> - if not (var_choose build) then - add_errors - (f_ "Cannot find buildable internal library \ - '%s' when checking build depends") - nm1 - | _ -> - ()) - pkg.sections) - bs.bs_build_depends - end - in - - (* Parse command line *) - BaseArgExt.parse argv (BaseEnv.args ()); - - (* OCaml version *) - begin - match pkg.ocaml_version with - | Some ver_cmp -> - begin - try - var_ignore_eval - (BaseCheck.version - "ocaml" - ver_cmp - BaseStandardVar.ocaml_version) - with e -> - warn_exception e; - add_errors - (f_ "OCaml version %s doesn't match version constraint %s") - (BaseStandardVar.ocaml_version ()) - (OASISVersion.string_of_comparator ver_cmp) - end - | None -> - () - end; - - (* Findlib version *) - begin - match pkg.findlib_version with - | Some ver_cmp -> - begin - try - var_ignore_eval - (BaseCheck.version - "findlib" - ver_cmp - BaseStandardVar.findlib_version) - with e -> - warn_exception e; - add_errors - (f_ "Findlib version %s doesn't match version constraint %s") - (BaseStandardVar.findlib_version ()) - (OASISVersion.string_of_comparator ver_cmp) - end - | None -> - () - end; - (* Make sure the findlib version is fine for the OCaml compiler. *) - begin - let ocaml_ge4 = - OASISVersion.version_compare - (OASISVersion.version_of_string (BaseStandardVar.ocaml_version())) - (OASISVersion.version_of_string "4.0.0") >= 0 in - if ocaml_ge4 then - let findlib_lt132 = - OASISVersion.version_compare - (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) - (OASISVersion.version_of_string "1.3.2") < 0 in - if findlib_lt132 then - add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" - end; - - (* FlexDLL *) - if BaseStandardVar.os_type () = "Win32" || - BaseStandardVar.os_type () = "Cygwin" then - begin - try - var_ignore_eval BaseStandardVar.flexlink - with e -> - warn_exception e; - add_errors (f_ "Cannot find 'flexlink'") - end; - - (* Check build depends *) - List.iter - (function - | Executable (_, bs, _) - | Library (_, bs, _) as sct -> - build_checks sct bs - | Doc (_, doc) -> - if var_choose doc.doc_build then - check_tools doc.doc_build_tools - | Test (_, test) -> - if var_choose test.test_run then - check_tools test.test_tools - | _ -> - ()) - pkg.sections; - - (* Check if we need native dynlink (presence of libraries that compile to - * native) - *) - begin - let has_cmxa = - List.exists - (function - | Library (_, bs, _) -> - var_choose bs.bs_build && - (bs.bs_compiled_object = Native || - (bs.bs_compiled_object = Best && - bool_of_string (BaseStandardVar.is_native ()))) - | _ -> - false) - pkg.sections - in - if has_cmxa then - var_ignore_eval BaseStandardVar.native_dynlink - end; - - (* Check errors *) - if SetString.empty != !errors then - begin - List.iter - (fun e -> error "%s" e) - (SetString.elements !errors); - failwithf - (fn_ - "%d configuration error" - "%d configuration errors" - (SetString.cardinal !errors)) - (SetString.cardinal !errors) - end - - -end - -module InternalInstallPlugin = struct -(* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) - - - (** Install using internal scheme - @author Sylvain Le Gall - *) - - - open BaseEnv - open BaseStandardVar - open BaseMessage - open OASISTypes - open OASISFindlib - open OASISGettext - open OASISUtils - - - let exec_hook = - ref (fun (cs, bs, exec) -> cs, bs, exec) - - - let lib_hook = - ref (fun (cs, bs, lib) -> cs, bs, lib, []) - - - let obj_hook = - ref (fun (cs, bs, obj) -> cs, bs, obj, []) - - - let doc_hook = - ref (fun (cs, doc) -> cs, doc) - - - let install_file_ev = - "install-file" - - - let install_dir_ev = - "install-dir" - - - let install_findlib_ev = - "install-findlib" - - - let win32_max_command_line_length = 8000 - - - let split_install_command ocamlfind findlib_name meta files = - if Sys.os_type = "Win32" then - (* Arguments for the first command: *) - let first_args = ["install"; findlib_name; meta] in - (* Arguments for remaining commands: *) - let other_args = ["install"; findlib_name; "-add"] in - (* Extract as much files as possible from [files], [len] is - the current command line length: *) - let rec get_files len acc files = - match files with - | [] -> - (List.rev acc, []) - | file :: rest -> - let len = len + 1 + String.length file in - if len > win32_max_command_line_length then - (List.rev acc, files) - else - get_files len (file :: acc) rest - in - (* Split the command into several commands. *) - let rec split args files = - match files with - | [] -> - [] - | _ -> - (* Length of "ocamlfind install [META|-add]" *) - let len = - List.fold_left - (fun len arg -> - len + 1 (* for the space *) + String.length arg) - (String.length ocamlfind) - args - in - match get_files len [] files with - | ([], _) -> - failwith (s_ "Command line too long.") - | (firsts, others) -> - let cmd = args @ firsts in - (* Use -add for remaining commands: *) - let () = - let findlib_ge_132 = - OASISVersion.comparator_apply - (OASISVersion.version_of_string - (BaseStandardVar.findlib_version ())) - (OASISVersion.VGreaterEqual - (OASISVersion.version_of_string "1.3.2")) - in - if not findlib_ge_132 then - failwithf - (f_ "Installing the library %s require to use the \ - flag '-add' of ocamlfind because the command \ - line is too long. This flag is only available \ - for findlib 1.3.2. Please upgrade findlib from \ - %s to 1.3.2") - findlib_name (BaseStandardVar.findlib_version ()) - in - let cmds = split other_args others in - cmd :: cmds - in - (* The first command does not use -add: *) - split first_args files - else - ["install" :: findlib_name :: meta :: files] - - - let install pkg argv = - - let in_destdir = - try - let destdir = - destdir () - in - (* Practically speaking destdir is prepended - * at the beginning of the target filename - *) - fun fn -> destdir^fn - with PropList.Not_set _ -> - fun fn -> fn - in - - let install_file ?tgt_fn src_file envdir = - let tgt_dir = - in_destdir (envdir ()) - in - let tgt_file = - Filename.concat - tgt_dir - (match tgt_fn with - | Some fn -> - fn - | None -> - Filename.basename src_file) - in - (* Create target directory if needed *) - OASISFileUtil.mkdir_parent - ~ctxt:!BaseContext.default - (fun dn -> - info (f_ "Creating directory '%s'") dn; - BaseLog.register install_dir_ev dn) - tgt_dir; - - (* Really install files *) - info (f_ "Copying file '%s' to '%s'") src_file tgt_file; - OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; - BaseLog.register install_file_ev tgt_file - in - - (* Install data into defined directory *) - let install_data srcdir lst tgtdir = - let tgtdir = - OASISHostPath.of_unix (var_expand tgtdir) - in - List.iter - (fun (src, tgt_opt) -> - let real_srcs = - OASISFileUtil.glob - ~ctxt:!BaseContext.default - (Filename.concat srcdir src) - in - if real_srcs = [] then - failwithf - (f_ "Wildcard '%s' doesn't match any files") - src; - List.iter - (fun fn -> - install_file - fn - (fun () -> - match tgt_opt with - | Some s -> - OASISHostPath.of_unix (var_expand s) - | None -> - tgtdir)) - real_srcs) - lst - in - - let make_fnames modul sufx = - List.fold_right - begin fun sufx accu -> - (OASISString.capitalize_ascii modul ^ sufx) :: - (OASISString.uncapitalize_ascii modul ^ sufx) :: - accu - end - sufx - [] - in - - (** Install all libraries *) - let install_libs pkg = - - let files_of_library (f_data, acc) data_lib = - let cs, bs, lib, lib_extra = - !lib_hook data_lib - in - if var_choose bs.bs_install && - BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then - begin - let acc = - (* Start with acc + lib_extra *) - List.rev_append lib_extra acc - in - let acc = - (* Add uncompiled header from the source tree *) - let path = - OASISHostPath.of_unix bs.bs_path - in - List.fold_left - begin fun acc modul -> - begin - try - [List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".mli"; ".ml"]))] - with Not_found -> - warning - (f_ "Cannot find source header for module %s \ - in library %s") - modul cs.cs_name; - [] - end - @ - List.filter - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".annot";".cmti";".cmt"])) - @ acc - end - acc - lib.lib_modules - in - - let acc = - (* Get generated files *) - BaseBuilt.fold - BaseBuilt.BLib - cs.cs_name - (fun acc fn -> fn :: acc) - acc - in - - let f_data () = - (* Install data associated with the library *) - install_data - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name); - f_data () - in - - (f_data, acc) - end - else - begin - (f_data, acc) - end - and files_of_object (f_data, acc) data_obj = - let cs, bs, obj, obj_extra = - !obj_hook data_obj - in - if var_choose bs.bs_install && - BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then - begin - let acc = - (* Start with acc + obj_extra *) - List.rev_append obj_extra acc - in - let acc = - (* Add uncompiled header from the source tree *) - let path = - OASISHostPath.of_unix bs.bs_path - in - List.fold_left - begin fun acc modul -> - begin - try - [List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".mli"; ".ml"]))] - with Not_found -> - warning - (f_ "Cannot find source header for module %s \ - in object %s") - modul cs.cs_name; - [] - end - @ - List.filter - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".annot";".cmti";".cmt"])) - @ acc - end - acc - obj.obj_modules - in - - let acc = - (* Get generated files *) - BaseBuilt.fold - BaseBuilt.BObj - cs.cs_name - (fun acc fn -> fn :: acc) - acc - in - - let f_data () = - (* Install data associated with the object *) - install_data - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name); - f_data () - in - - (f_data, acc) - end - else - begin - (f_data, acc) - end - - in - - (* Install one group of library *) - let install_group_lib grp = - (* Iterate through all group nodes *) - let rec install_group_lib_aux data_and_files grp = - let data_and_files, children = - match grp with - | Container (_, children) -> - data_and_files, children - | Package (_, cs, bs, `Library lib, children) -> - files_of_library data_and_files (cs, bs, lib), children - | Package (_, cs, bs, `Object obj, children) -> - files_of_object data_and_files (cs, bs, obj), children - in - List.fold_left - install_group_lib_aux - data_and_files - children - in - - (* Findlib name of the root library *) - let findlib_name = - findlib_of_group grp - in - - (* Determine root library *) - let root_lib = - root_of_group grp - in - - (* All files to install for this library *) - let f_data, files = - install_group_lib_aux (ignore, []) grp - in - - (* Really install, if there is something to install *) - if files = [] then - begin - warning - (f_ "Nothing to install for findlib library '%s'") - findlib_name - end - else - begin - let meta = - (* Search META file *) - let _, bs, _ = - root_lib - in - let res = - Filename.concat bs.bs_path "META" - in - if not (OASISFileUtil.file_exists_case res) then - failwithf - (f_ "Cannot find file '%s' for findlib library %s") - res - findlib_name; - res - in - let files = - (* Make filename shorter to avoid hitting command max line length - * too early, esp. on Windows. - *) - let remove_prefix p n = - let plen = String.length p in - let nlen = String.length n in - if plen <= nlen && String.sub n 0 plen = p then - begin - let fn_sep = - if Sys.os_type = "Win32" then - '\\' - else - '/' - in - let cutpoint = plen + - (if plen < nlen && n.[plen] = fn_sep then - 1 - else - 0) - in - String.sub n cutpoint (nlen - cutpoint) - end - else - n - in - List.map (remove_prefix (Sys.getcwd ())) files - in - info - (f_ "Installing findlib library '%s'") - findlib_name; - let ocamlfind = ocamlfind () in - let commands = - split_install_command - ocamlfind - findlib_name - meta - files - in - List.iter - (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) - commands; - BaseLog.register install_findlib_ev findlib_name - end; - - (* Install data files *) - f_data (); - - in - - let group_libs, _, _ = - findlib_mapping pkg - in - - (* We install libraries in groups *) - List.iter install_group_lib group_libs - in - - let install_execs pkg = - let install_exec data_exec = - let cs, bs, exec = - !exec_hook data_exec - in - if var_choose bs.bs_install && - BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then - begin - let exec_libdir () = - Filename.concat - (libdir ()) - pkg.name - in - BaseBuilt.fold - BaseBuilt.BExec - cs.cs_name - (fun () fn -> - install_file - ~tgt_fn:(cs.cs_name ^ ext_program ()) - fn - bindir) - (); - BaseBuilt.fold - BaseBuilt.BExecLib - cs.cs_name - (fun () fn -> - install_file - fn - exec_libdir) - (); - install_data - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name) - end - in - List.iter - (function - | Executable (cs, bs, exec)-> - install_exec (cs, bs, exec) - | _ -> - ()) - pkg.sections - in - - let install_docs pkg = - let install_doc data = - let cs, doc = - !doc_hook data - in - if var_choose doc.doc_install && - BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then - begin - let tgt_dir = - OASISHostPath.of_unix (var_expand doc.doc_install_dir) - in - BaseBuilt.fold - BaseBuilt.BDoc - cs.cs_name - (fun () fn -> - install_file - fn - (fun () -> tgt_dir)) - (); - install_data - Filename.current_dir_name - doc.doc_data_files - doc.doc_install_dir - end - in - List.iter - (function - | Doc (cs, doc) -> - install_doc (cs, doc) - | _ -> - ()) - pkg.sections - in - - install_libs pkg; - install_execs pkg; - install_docs pkg - - - (* Uninstall already installed data *) - let uninstall _ argv = - List.iter - (fun (ev, data) -> - if ev = install_file_ev then - begin - if OASISFileUtil.file_exists_case data then - begin - info - (f_ "Removing file '%s'") - data; - Sys.remove data - end - else - begin - warning - (f_ "File '%s' doesn't exist anymore") - data - end - end - else if ev = install_dir_ev then - begin - if Sys.file_exists data && Sys.is_directory data then - begin - if Sys.readdir data = [||] then - begin - info - (f_ "Removing directory '%s'") - data; - OASISFileUtil.rmdir ~ctxt:!BaseContext.default data - end - else - begin - warning - (f_ "Directory '%s' is not empty (%s)") - data - (String.concat - ", " - (Array.to_list - (Sys.readdir data))) - end - end - else - begin - warning - (f_ "Directory '%s' doesn't exist anymore") - data - end - end - else if ev = install_findlib_ev then - begin - info (f_ "Removing findlib library '%s'") data; - OASISExec.run ~ctxt:!BaseContext.default - (ocamlfind ()) ["remove"; data] - end - else - failwithf (f_ "Unknown log event '%s'") ev; - BaseLog.unregister ev data) - (* We process event in reverse order *) - (List.rev - (BaseLog.filter - [install_file_ev; - install_dir_ev; - install_findlib_ev])) - - -end - - -# 6296 "setup.ml" -module OCamlbuildCommon = struct -(* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) - - - (** Functions common to OCamlbuild build and doc plugin - *) - - - open OASISGettext - open BaseEnv - open BaseStandardVar - open OASISTypes - - - - - type extra_args = string list - - - let ocamlbuild_clean_ev = "ocamlbuild-clean" - - - let ocamlbuildflags = - var_define - ~short_desc:(fun () -> "OCamlbuild additional flags") - "ocamlbuildflags" - (fun () -> "") - - - (** Fix special arguments depending on environment *) - let fix_args args extra_argv = - List.flatten - [ - if (os_type ()) = "Win32" then - [ - "-classic-display"; - "-no-log"; - "-no-links"; - "-install-lib-dir"; - (Filename.concat (standard_library ()) "ocamlbuild") - ] - else - []; - - if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then - [ - "-byte-plugin" - ] - else - []; - args; - - if bool_of_string (debug ()) then - ["-tag"; "debug"] - else - []; - - if bool_of_string (tests ()) then - ["-tag"; "tests"] - else - []; - - if bool_of_string (profile ()) then - ["-tag"; "profile"] - else - []; - - OASISString.nsplit (ocamlbuildflags ()) ' '; - - Array.to_list extra_argv; - ] - - - (** Run 'ocamlbuild -clean' if not already done *) - let run_clean extra_argv = - let extra_cli = - String.concat " " (Array.to_list extra_argv) - in - (* Run if never called with these args *) - if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then - begin - OASISExec.run ~ctxt:!BaseContext.default - (ocamlbuild ()) (fix_args ["-clean"] extra_argv); - BaseLog.register ocamlbuild_clean_ev extra_cli; - at_exit - (fun () -> - try - BaseLog.unregister ocamlbuild_clean_ev extra_cli - with _ -> - ()) - end - - - (** Run ocamlbuild, unregister all clean events *) - let run_ocamlbuild args extra_argv = - (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html - *) - OASISExec.run ~ctxt:!BaseContext.default - (ocamlbuild ()) (fix_args args extra_argv); - (* Remove any clean event, we must run it again *) - List.iter - (fun (e, d) -> BaseLog.unregister e d) - (BaseLog.filter [ocamlbuild_clean_ev]) - - - (** Determine real build directory *) - let build_dir extra_argv = - let rec search_args dir = - function - | "-build-dir" :: dir :: tl -> - search_args dir tl - | _ :: tl -> - search_args dir tl - | [] -> - dir - in - search_args "_build" (fix_args [] extra_argv) - - -end - -module OCamlbuildPlugin = struct -(* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) - - - (** Build using ocamlbuild - @author Sylvain Le Gall - *) - - - open OASISTypes - open OASISGettext - open OASISUtils - open OASISString - open BaseEnv - open OCamlbuildCommon - open BaseStandardVar - open BaseMessage - - - - - - let cond_targets_hook = - ref (fun lst -> lst) - - - let build extra_args pkg argv = - (* Return the filename in build directory *) - let in_build_dir fn = - Filename.concat - (build_dir argv) - fn - in - - (* Return the unix filename in host build directory *) - let in_build_dir_of_unix fn = - in_build_dir (OASISHostPath.of_unix fn) - in - - let cond_targets = - List.fold_left - (fun acc -> - function - | Library (cs, bs, lib) when var_choose bs.bs_build -> - begin - let evs, unix_files = - BaseBuilt.of_library - in_build_dir_of_unix - (cs, bs, lib) - in - - let tgts = - List.flatten - (List.filter - (fun l -> l <> []) - (List.map - (List.filter - (fun fn -> - ends_with ~what:".cma" fn - || ends_with ~what:".cmxs" fn - || ends_with ~what:".cmxa" fn - || ends_with ~what:(ext_lib ()) fn - || ends_with ~what:(ext_dll ()) fn)) - unix_files)) - in - - match tgts with - | _ :: _ -> - (evs, tgts) :: acc - | [] -> - failwithf - (f_ "No possible ocamlbuild targets for library %s") - cs.cs_name - end - - | Object (cs, bs, obj) when var_choose bs.bs_build -> - begin - let evs, unix_files = - BaseBuilt.of_object - in_build_dir_of_unix - (cs, bs, obj) - in - - let tgts = - List.flatten - (List.filter - (fun l -> l <> []) - (List.map - (List.filter - (fun fn -> - ends_with ".cmo" fn - || ends_with ".cmx" fn)) - unix_files)) - in - - match tgts with - | _ :: _ -> - (evs, tgts) :: acc - | [] -> - failwithf - (f_ "No possible ocamlbuild targets for object %s") - cs.cs_name - end - - | Executable (cs, bs, exec) when var_choose bs.bs_build -> - begin - let evs, unix_exec_is, unix_dll_opt = - BaseBuilt.of_executable - in_build_dir_of_unix - (cs, bs, exec) - in - - let target ext = - let unix_tgt = - (OASISUnixPath.concat - bs.bs_path - (OASISUnixPath.chop_extension - exec.exec_main_is))^ext - in - let evs = - (* Fix evs, we want to use the unix_tgt, without copying *) - List.map - (function - | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> - BaseBuilt.BExec, nm, - [[in_build_dir_of_unix unix_tgt]] - | ev -> - ev) - evs - in - evs, [unix_tgt] - in - - (* Add executable *) - let acc = - match bs.bs_compiled_object with - | Native -> - (target ".native") :: acc - | Best when bool_of_string (is_native ()) -> - (target ".native") :: acc - | Byte - | Best -> - (target ".byte") :: acc - in - acc - end - - | Library _ | Object _ | Executable _ | Test _ - | SrcRepo _ | Flag _ | Doc _ -> - acc) - [] - (* Keep the pkg.sections ordered *) - (List.rev pkg.sections); - in - - (* Check and register built files *) - let check_and_register (bt, bnm, lst) = - List.iter - (fun fns -> - if not (List.exists OASISFileUtil.file_exists_case fns) then - failwithf - (fn_ - "Expected built file %s doesn't exist." - "None of expected built files %s exists." - (List.length fns)) - (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) - lst; - (BaseBuilt.register bt bnm lst) - in - - (* Run the hook *) - let cond_targets = !cond_targets_hook cond_targets in - - (* Run a list of target... *) - run_ocamlbuild (List.flatten (List.map snd cond_targets) @ extra_args) argv; - (* ... and register events *) - List.iter check_and_register (List.flatten (List.map fst cond_targets)) - - - let clean pkg extra_args = - run_clean extra_args; - List.iter - (function - | Library (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BLib cs.cs_name - | Executable (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name - | _ -> - ()) - pkg.sections - - -end - -module OCamlbuildDocPlugin = struct -(* # 22 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) - - - (* Create documentation using ocamlbuild .odocl files - @author Sylvain Le Gall - *) - - - open OASISTypes - open OASISGettext - open OASISMessage - open OCamlbuildCommon - open BaseStandardVar - - - - - type run_t = - { - extra_args: string list; - run_path: unix_filename; - } - - - let doc_build run pkg (cs, doc) argv = - let index_html = - OASISUnixPath.make - [ - run.run_path; - cs.cs_name^".docdir"; - "index.html"; - ] - in - let tgt_dir = - OASISHostPath.make - [ - build_dir argv; - OASISHostPath.of_unix run.run_path; - cs.cs_name^".docdir"; - ] - in - run_ocamlbuild (index_html :: run.extra_args) argv; - List.iter - (fun glb -> - BaseBuilt.register - BaseBuilt.BDoc - cs.cs_name - [OASISFileUtil.glob ~ctxt:!BaseContext.default - (Filename.concat tgt_dir glb)]) - ["*.html"; "*.css"] - - - let doc_clean run pkg (cs, doc) argv = - run_clean argv; - BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name - - -end - - -# 6674 "setup.ml" -open OASISTypes;; - -let setup_t = - { - BaseSetup.configure = InternalConfigurePlugin.configure; - build = OCamlbuildPlugin.build []; - test = []; - doc = []; - install = InternalInstallPlugin.install; - uninstall = InternalInstallPlugin.uninstall; - clean = [OCamlbuildPlugin.clean]; - clean_test = []; - clean_doc = []; - distclean = []; - distclean_test = []; - distclean_doc = []; - package = - { - oasis_version = "0.3"; - ocaml_version = None; - findlib_version = None; - alpha_features = []; - beta_features = []; - name = "stdext"; - version = "0.13.0"; - license = - OASISLicense.DEP5License - (OASISLicense.DEP5Unit - { - OASISLicense.license = "LGPL"; - excption = Some "OCaml linking"; - version = OASISLicense.Version "2.1" - }); - license_file = None; - copyrights = ["(C) 2012 Citrix"]; - maintainers = []; - authors = ["various"]; - homepage = None; - synopsis = "Standard extension library"; - description = None; - categories = []; - conf_type = (`Configure, "internal", Some "0.4"); - conf_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - build_type = (`Build, "ocamlbuild", Some "0.4"); - build_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - install_type = (`Install, "internal", Some "0.4"); - install_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - uninstall_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - clean_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - distclean_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - files_ab = []; - sections = - [ - Library - ({ - cs_name = "stdext"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "lib"; - bs_compiled_object = Best; - bs_build_depends = - [ - FindlibPackage ("threads", None); - FindlibPackage ("uuidm", None); - FindlibPackage ("unix", None); - FindlibPackage ("fd-send-recv", None); - FindlibPackage ("bigarray", None); - FindlibPackage ("sexplib", None); - FindlibPackage ("sexplib.syntax", None); - FindlibPackage ("xapi-backtrace", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = - [ - "blkgetsize_stubs.c"; - "unixext_open_stubs.c"; - "unixext_stubs.c"; - "unixext_write_stubs.c"; - "zerocheck_stub.c" - ]; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = - [ - "Arrayext"; - "Base64"; - "Bigbuffer"; - "Config"; - "Date"; - "Either"; - "Encodings"; - "ExtentlistSet"; - "Filenameext"; - "Fring"; - "Fun"; - "Hashtblext"; - "Int64ext"; - "LazyList"; - "Listext"; - "Mapext"; - "Monad"; - "Opt"; - "Pervasiveext"; - "Qring"; - "Range"; - "Ring"; - "Xstringext"; - "Threadext"; - "Trie"; - "Unixext"; - "VIO"; - "Zerocheck" - ]; - lib_pack = true; - lib_internal_modules = []; - lib_findlib_parent = None; - lib_findlib_name = Some "stdext"; - lib_findlib_containers = [] - }) - ]; - plugins = - [(`Extra, "DevFiles", Some "0.3"); (`Extra, "META", Some "0.3")]; - disable_oasis_section = []; - schema_data = PropList.Data.create (); - plugin_data = [] - }; - oasis_fn = Some "_oasis"; - oasis_version = "0.4.6"; - oasis_digest = - Some "\028\140;\140b\226\161\246\234\150\133\161\237\227\251 "; - oasis_exec = None; - oasis_setup_args = []; - setup_update = false - };; - -let setup () = BaseSetup.setup setup_t;; - -# 6848 "setup.ml" -(* OASIS_STOP *) -let () = setup ();; From eaf4531db2164422c71661b6eea75bc5d9ffa197 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Wed, 22 Jun 2016 10:47:26 +0100 Subject: [PATCH 036/199] Add a merlin file Signed-off-by: Jon Ludlam --- .merlin | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 .merlin diff --git a/.merlin b/.merlin new file mode 100644 index 00000000000..3f9690c044e --- /dev/null +++ b/.merlin @@ -0,0 +1,4 @@ +PKG threads uuidm unix fd-send-recv bigarray sexplib sexplib.syntax xapi-backtrace +S lib +B _build/lib + From 084c6e53ed213702babf107cccc76d7331131704 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Wed, 22 Jun 2016 10:50:24 +0100 Subject: [PATCH 037/199] This doen't depend upon sexplib Signed-off-by: Jon Ludlam --- _oasis | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/_oasis b/_oasis index 9123fb69e0f..9d6fd5740d0 100644 --- a/_oasis +++ b/_oasis @@ -14,6 +14,6 @@ Library stdext Pack: true Modules: Arrayext, Base64, Bigbuffer, Config, Date, Either, Encodings, ExtentlistSet, Filenameext, Fring, Fun, Hashtblext, Int64ext, LazyList, Listext, Mapext, Monad, Opt, Pervasiveext, Qring, Range, Ring, Xstringext, Threadext, Trie, Unixext, VIO, Zerocheck CSources: blkgetsize_stubs.c, unixext_open_stubs.c, unixext_stubs.c, unixext_write_stubs.c, zerocheck_stub.c - BuildDepends: threads, uuidm, unix, fd-send-recv, bigarray, sexplib, sexplib.syntax, xapi-backtrace + BuildDepends: threads, uuidm, unix, fd-send-recv, bigarray, xapi-backtrace From 84dea7c6b1b84085456d7ecb3d82c5a2eb6dde7b Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Wed, 22 Jun 2016 11:31:42 +0100 Subject: [PATCH 038/199] Don't mention sexplib in opam either Signed-off-by: Jon Ludlam --- opam | 1 - 1 file changed, 1 deletion(-) diff --git a/opam b/opam index 2f9e8f8a757..dcf5a1093d5 100644 --- a/opam +++ b/opam @@ -20,7 +20,6 @@ depends: [ "ocamlfind" "uuidm" "fd-send-recv" - "sexplib" "xapi-backtrace" "oasis" ] From 3e44db25bf2851ea0682f1dba27b1b5d56ed7f57 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Wed, 22 Jun 2016 11:58:43 +0100 Subject: [PATCH 039/199] Embetterment due to @sjbx's review. Signed-off-by: Jon Ludlam --- .merlin | 3 +-- _oasis | 48 +++++++++++++++++++++++++++++++++++++++++++----- opam | 2 +- 3 files changed, 45 insertions(+), 8 deletions(-) diff --git a/.merlin b/.merlin index 3f9690c044e..401bbc9116d 100644 --- a/.merlin +++ b/.merlin @@ -1,4 +1,3 @@ -PKG threads uuidm unix fd-send-recv bigarray sexplib sexplib.syntax xapi-backtrace +PKG threads uuidm unix fd-send-recv bigarray xapi-backtrace S lib B _build/lib - diff --git a/_oasis b/_oasis index 9d6fd5740d0..08f38ccade7 100644 --- a/_oasis +++ b/_oasis @@ -1,6 +1,6 @@ OASISFormat: 0.3 Name: stdext -Version: 2.0 +Version: 2.0.0 Synopsis: Standard extension library License: LGPL-2.1 with OCaml linking exception Authors: various @@ -12,8 +12,46 @@ Library stdext Path: lib FindlibName: stdext Pack: true - Modules: Arrayext, Base64, Bigbuffer, Config, Date, Either, Encodings, ExtentlistSet, Filenameext, Fring, Fun, Hashtblext, Int64ext, LazyList, Listext, Mapext, Monad, Opt, Pervasiveext, Qring, Range, Ring, Xstringext, Threadext, Trie, Unixext, VIO, Zerocheck - CSources: blkgetsize_stubs.c, unixext_open_stubs.c, unixext_stubs.c, unixext_write_stubs.c, zerocheck_stub.c - BuildDepends: threads, uuidm, unix, fd-send-recv, bigarray, xapi-backtrace - + Modules: + Arrayext, + Base64, + Bigbuffer, + Config, + Date, + Either, + Encodings, + ExtentlistSet, + Filenameext, + Fring, + Fun, + Hashtblext, + Int64ext, + LazyList, + Listext, + Mapext, + Monad, + Opt, + Pervasiveext, + Qring, + Range, + Ring, + Xstringext, + Threadext, + Trie, + Unixext, + VIO, + Zerocheck + CSources: + blkgetsize_stubs.c, + unixext_open_stubs.c, + unixext_stubs.c, + unixext_write_stubs.c, + zerocheck_stub.c + BuildDepends: + threads, + uuidm, + unix, + fd-send-recv, + bigarray, + xapi-backtrace diff --git a/opam b/opam index dcf5a1093d5..8934cdcc918 100644 --- a/opam +++ b/opam @@ -21,5 +21,5 @@ depends: [ "uuidm" "fd-send-recv" "xapi-backtrace" - "oasis" + "oasis" {build} ] From 78b9f6fdc087e830ee103c4277fc1a9b30269495 Mon Sep 17 00:00:00 2001 From: John Else Date: Tue, 28 Jun 2016 16:29:33 +0100 Subject: [PATCH 040/199] Fix build instructions in opam file Signed-off-by: John Else --- opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/opam b/opam index 8934cdcc918..1d79520a3c4 100644 --- a/opam +++ b/opam @@ -6,7 +6,7 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" build: [ ["oasis" "setup"] - ["configure"] + ["./configure"] [make] ] install: [ From 9aa1161f66aae6ce396e8a070c6c79591b39ef13 Mon Sep 17 00:00:00 2001 From: Euan Harris Date: Mon, 1 Aug 2016 14:23:38 +0100 Subject: [PATCH 041/199] xstringext: Include standard String interface, rather than copying it Signed-off-by: Euan Harris --- lib/xstringext.mli | 34 ++-------------------------------- 1 file changed, 2 insertions(+), 32 deletions(-) diff --git a/lib/xstringext.mli b/lib/xstringext.mli index 09fdf9aa255..9ec3dd61721 100644 --- a/lib/xstringext.mli +++ b/lib/xstringext.mli @@ -13,38 +13,8 @@ *) module String : sig - external length : string -> int = "%string_length" - (** blabla *) - external get : string -> int -> char = "%string_safe_get" - external set : string -> int -> char -> unit = "%string_safe_set" - external create : int -> string = "caml_create_string" - val make : int -> char -> string - val copy : string -> string - val sub : string -> int -> int -> string - val fill : string -> int -> int -> char -> unit - val blit : string -> int -> string -> int -> int -> unit - val concat : string -> string list -> string - val iter : (char -> unit) -> string -> unit - val index : string -> char -> int - val rindex : string -> char -> int - val index_from : string -> int -> char -> int - val rindex_from : string -> int -> char -> int - val contains : string -> char -> bool - val contains_from : string -> int -> char -> bool - val rcontains_from : string -> int -> char -> bool - val uppercase : string -> string - val lowercase : string -> string - val capitalize : string -> string - val uncapitalize : string -> string - type t = string - val compare : t -> t -> int - external unsafe_get : string -> int -> char = "%string_unsafe_get" - external unsafe_set : string -> int -> char -> unit - = "%string_unsafe_set" - external unsafe_blit : string -> int -> string -> int -> int -> unit - = "caml_blit_string" "noalloc" - external unsafe_fill : string -> int -> int -> char -> unit - = "caml_fill_string" "noalloc" + include module type of String + val of_char : char -> string (** Make a string of the given length with characters generated by the From 6d6229b0aa730953d353a0ef8ded5c1150f40a9f Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Thu, 20 Oct 2016 14:39:32 +0100 Subject: [PATCH 042/199] add semaphore implementation (#17) The semaphore is used in `xcp-networkd` to limit the number of concurrent executions of a command (CA-225272). Signed-off-by: Marcello Seri --- _oasis | 3 ++- lib/semaphore.ml | 67 +++++++++++++++++++++++++++++++++++++++++++++++ lib/semaphore.mli | 40 ++++++++++++++++++++++++++++ 3 files changed, 109 insertions(+), 1 deletion(-) create mode 100644 lib/semaphore.ml create mode 100644 lib/semaphore.mli diff --git a/_oasis b/_oasis index 08f38ccade7..29f318d8529 100644 --- a/_oasis +++ b/_oasis @@ -35,6 +35,7 @@ Library stdext Qring, Range, Ring, + Semaphore, Xstringext, Threadext, Trie, @@ -47,7 +48,7 @@ Library stdext unixext_stubs.c, unixext_write_stubs.c, zerocheck_stub.c - BuildDepends: + BuildDepends: threads, uuidm, unix, diff --git a/lib/semaphore.ml b/lib/semaphore.ml new file mode 100644 index 00000000000..4f9bb365997 --- /dev/null +++ b/lib/semaphore.ml @@ -0,0 +1,67 @@ +(* + * Copyright (C) Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +type t = { + mutable n : int; + m : Mutex.t; + c : Condition.t; +} + +let create n = + if n <= 0 then + invalid_arg (Printf.sprintf + "Semaphore value must be positive, got %d" n); + let m = Mutex.create () + and c = Condition.create () in + { n; m; c; } + +exception Inconsistent_state of string +let inconsistent_state fmt = Printf.kprintf (fun msg -> + raise (Inconsistent_state msg)) fmt + +let acquire s k = + if k <= 0 then + invalid_arg (Printf.sprintf + "Semaphore acquisition requires a positive value, got %d" k); + Mutex.lock s.m; + while s.n < k do + Condition.wait s.c s.m; + done; + if not (s.n >= k) then + inconsistent_state "Semaphore value cannot be smaller than %d, got %d" k s.n; + s.n <- s.n - k; + Condition.signal s.c; + Mutex.unlock s.m + +let release s k = + if k <= 0 then + invalid_arg (Printf.sprintf + "Semaphore release requires a positive value, got %d" k); + Mutex.lock s.m; + s.n <- s.n + k; + Condition.signal s.c; + Mutex.unlock s.m + +let execute_with_weight s k f = + acquire s k; + try + let x = f () in + release s k; + x + with e -> + release s k; + raise e + +let execute s f = + execute_with_weight s 1 f diff --git a/lib/semaphore.mli b/lib/semaphore.mli new file mode 100644 index 00000000000..8cea7755e0c --- /dev/null +++ b/lib/semaphore.mli @@ -0,0 +1,40 @@ +(* + * Copyright (C) Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + + +type t +exception Inconsistent_state of string + +(** [create n] create a semaphore with initial value [n] (a positive integer). + Raise {Invalid_argument} if [n] <= 0 *) +val create : int -> t + +(** [acquire k s] block until the semaphore value is >= [k] (a positive integer), + then atomically decrement the semaphore value by [k]. + Raise {Invalid_argument} if [k] <= 0 *) +val acquire : t -> int -> unit + +(** [release k s] atomically increment the semaphore value by [k] (a positive + integer). + Raise {Invalid_argument} if [k] <= 0 *) +val release : t -> int -> unit + +(** [execute_with_weight s k f] {acquire} the semaphore with [k], + then run [f ()], and finally {release} the semaphore with the same value [k] + (even in case of failure in the execution of [f]). + Return the value of [f ()] or re-raise the exception if any. *) +val execute_with_weight : t -> int -> (unit -> 'a) -> 'a + +(** [execute s f] same as [{execute_with_weight} s 1 f] *) +val execute : t -> (unit -> 'a) -> 'a From afaf92a2dc33490f8773b21c7892b7ba7a92f8b2 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Thu, 20 Oct 2016 15:13:54 +0100 Subject: [PATCH 043/199] bump version for semaphore addition Signed-off-by: Marcello Seri --- ChangeLog | 3 +++ _oasis | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index f8daef44ec6..9a340a3afc5 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,6 @@ +2.1.0 (20-Oct-2016): +* New Semaphore module + 2.0.0 (22-Jun-2016): * Namespace everything under Stdext. This is a backwards incompatible change. diff --git a/_oasis b/_oasis index 29f318d8529..5d10524c23b 100644 --- a/_oasis +++ b/_oasis @@ -1,6 +1,6 @@ OASISFormat: 0.3 Name: stdext -Version: 2.0.0 +Version: 2.1.0 Synopsis: Standard extension library License: LGPL-2.1 with OCaml linking exception Authors: various From 6a084d2aa9fc91c0b798e7e5dfa9ac0ab35ea451 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Wed, 8 Mar 2017 16:20:22 +0000 Subject: [PATCH 044/199] opam: fix uninstall script Signed-off-by: Marcello Seri --- opam | 1 + 1 file changed, 1 insertion(+) diff --git a/opam b/opam index 1d79520a3c4..f76481ab5d1 100644 --- a/opam +++ b/opam @@ -13,6 +13,7 @@ install: [ [make "install" "BINDIR=%{bin}%"] ] remove: [ + ["oasis" "setup"] [make "uninstall" "BINDIR=%{bin}%"] ["ocamlfind" "remove" "stdext"] ] From 2a424df391a96707652d2cfacf9e226a69d1b3e5 Mon Sep 17 00:00:00 2001 From: Gabor Igloi Date: Fri, 9 Jun 2017 17:03:41 +0100 Subject: [PATCH 045/199] Sync opam file with xs-opam Signed-off-by: Gabor Igloi --- opam | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/opam b/opam index f76481ab5d1..eb6a6eba3a4 100644 --- a/opam +++ b/opam @@ -4,6 +4,7 @@ authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" +tags: [ "org:xapi-project" ] build: [ ["oasis" "setup"] ["./configure"] @@ -18,9 +19,12 @@ remove: [ ["ocamlfind" "remove" "stdext"] ] depends: [ - "ocamlfind" + "oasis" {build} + "ocamlfind" {build} + "base-bigarray" + "base-threads" + "base-unix" "uuidm" "fd-send-recv" "xapi-backtrace" - "oasis" {build} -] +] From 63de0506febbef3b1e51401f822a1d219ba7354c Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Mon, 3 Apr 2017 10:40:50 +0100 Subject: [PATCH 046/199] gzip, sha1sum: remove as they are now in xen-api-libs-transitional Signed-off-by: Marcello Seri --- lib/gzip.mli | 24 ------------------------ lib/sha1sum.mli | 17 ----------------- 2 files changed, 41 deletions(-) delete mode 100644 lib/gzip.mli delete mode 100644 lib/sha1sum.mli diff --git a/lib/gzip.mli b/lib/gzip.mli deleted file mode 100644 index b8613a3769e..00000000000 --- a/lib/gzip.mli +++ /dev/null @@ -1,24 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -(** Runs a compression process which is fed from a pipe whose entrance is passed to 'f' - and whose output is 'ofd' *) -val compress: Unix.file_descr -> (Unix.file_descr -> unit) -> unit - -(** Runs a decompression process which is fed from a pipe whose entrance is passed to 'f' - and whose output is 'ofd' *) -val decompress: Unix.file_descr -> (Unix.file_descr -> 'a) -> 'a - -(* Experimental decompressor which is fed from an fd and writes to a pipe *) -val decompress_passive: Unix.file_descr -> (Unix.file_descr -> 'a) -> 'a diff --git a/lib/sha1sum.mli b/lib/sha1sum.mli deleted file mode 100644 index 3c549fb2614..00000000000 --- a/lib/sha1sum.mli +++ /dev/null @@ -1,17 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -(** Takes a function which is supplied with an fd representing the input to the - sha1sum and returns the checksum as a string *) -val sha1sum: (Unix.file_descr -> unit) -> string From 4f7d17686cf1790355719756f5b2b15db6b73337 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Mon, 3 Apr 2017 10:43:55 +0100 Subject: [PATCH 047/199] Port to jbuilder Silencing deprecation warning for the moment. Signed-off-by: Marcello Seri --- .gitignore | 4 ++-- Makefile | 26 ++++++++++++++++++++ _oasis | 58 --------------------------------------------- lib/jbuild | 18 ++++++++++++++ opam => stdext.opam | 21 ++++------------ 5 files changed, 51 insertions(+), 76 deletions(-) create mode 100644 Makefile delete mode 100644 _oasis create mode 100644 lib/jbuild rename opam => stdext.opam (60%) diff --git a/.gitignore b/.gitignore index 3e01f99e805..4e66100e8f3 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,3 @@ _build/ -setup.data -setup.log +*.install +.merlin diff --git a/Makefile b/Makefile new file mode 100644 index 00000000000..38298ce7145 --- /dev/null +++ b/Makefile @@ -0,0 +1,26 @@ +.PHONY: build release install uninstall clean test doc reindent + +build: + jbuilder build @install --dev + +release: + jbuilder build @install + +install: + jbuilder install + +uninstall: + jbuilder uninstall + +clean: + jbuilder clean + +test: + jbuilder runtest + +# requires odoc +doc: + jbuilder build @doc + +reindent: + ocp-indent --syntax cstruct -i **/*.ml* diff --git a/_oasis b/_oasis deleted file mode 100644 index 5d10524c23b..00000000000 --- a/_oasis +++ /dev/null @@ -1,58 +0,0 @@ -OASISFormat: 0.3 -Name: stdext -Version: 2.1.0 -Synopsis: Standard extension library -License: LGPL-2.1 with OCaml linking exception -Authors: various -Copyrights: (C) 2012 Citrix -BuildTools: ocamlbuild -Plugins: DevFiles (0.3), META (0.3) - -Library stdext - Path: lib - FindlibName: stdext - Pack: true - Modules: - Arrayext, - Base64, - Bigbuffer, - Config, - Date, - Either, - Encodings, - ExtentlistSet, - Filenameext, - Fring, - Fun, - Hashtblext, - Int64ext, - LazyList, - Listext, - Mapext, - Monad, - Opt, - Pervasiveext, - Qring, - Range, - Ring, - Semaphore, - Xstringext, - Threadext, - Trie, - Unixext, - VIO, - Zerocheck - CSources: - blkgetsize_stubs.c, - unixext_open_stubs.c, - unixext_stubs.c, - unixext_write_stubs.c, - zerocheck_stub.c - BuildDepends: - threads, - uuidm, - unix, - fd-send-recv, - bigarray, - xapi-backtrace - diff --git a/lib/jbuild b/lib/jbuild new file mode 100644 index 00000000000..ff74acedc78 --- /dev/null +++ b/lib/jbuild @@ -0,0 +1,18 @@ +(jbuild_version 1) + +(library ( + (name stdext) + (public_name stdext) + (flags (:standard -w -3)) + (c_names (blkgetsize_stubs + unixext_open_stubs + unixext_stubs + unixext_write_stubs + zerocheck_stub)) + (libraries (threads + uuidm + unix + fd-send-recv + bigarray + xapi-backtrace)) + )) diff --git a/opam b/stdext.opam similarity index 60% rename from opam rename to stdext.opam index eb6a6eba3a4..7b5aaa9683d 100644 --- a/opam +++ b/stdext.opam @@ -5,26 +5,15 @@ bug-reports: "https://github.com/xapi-project/stdext/issues" dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [ - ["oasis" "setup"] - ["./configure"] - [make] -] -install: [ - [make "install" "BINDIR=%{bin}%"] -] -remove: [ - ["oasis" "setup"] - [make "uninstall" "BINDIR=%{bin}%"] - ["ocamlfind" "remove" "stdext"] -] + +build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] + depends: [ - "oasis" {build} - "ocamlfind" {build} + "jbuilder" {build} "base-bigarray" "base-threads" "base-unix" - "uuidm" "fd-send-recv" + "uuidm" "xapi-backtrace" ] From f84431e7cb56abee8366b8a4f5b855a7e317537d Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Fri, 28 Jul 2017 16:33:47 +0100 Subject: [PATCH 048/199] Fix warnings and move unused tests aside as tests Signed-off-by: Marcello Seri --- lib/base64.ml | 14 ---- lib/bigbuffer.ml | 13 ---- lib/config.ml | 15 ++-- lib/encodings.ml | 4 +- lib/encodings.mli | 92 +++++++++++++------------ lib/fring.mli | 6 +- lib/fun.ml | 4 +- lib/fun.mli | 4 +- lib/hashtblext.ml | 4 +- lib/lazyList.ml | 2 +- lib/lazyList.mli | 2 +- lib/opt.ml | 2 - lib/pervasiveext.ml | 14 ---- lib/pervasiveext.mli | 2 +- lib/range.ml | 3 - lib/ring.mli | 4 +- lib/threadext.ml | 3 +- lib/threadext.mli | 4 +- lib/trie.ml | 20 +++--- lib/unixext.ml | 6 +- lib/unixext.mli | 12 ++-- lib/xstringext.mli | 6 +- {lib => lib_test}/extentlistset_test.ml | 10 +-- lib_test/jbuild | 9 +++ {lib => lib_test}/set_test.ml | 0 {lib => lib_test}/set_test.mli | 0 stdext.opam | 1 + 27 files changed, 114 insertions(+), 142 deletions(-) rename {lib => lib_test}/extentlistset_test.ml (92%) create mode 100644 lib_test/jbuild rename {lib => lib_test}/set_test.ml (100%) rename {lib => lib_test}/set_test.mli (100%) diff --git a/lib/base64.ml b/lib/base64.ml index 4de817877cd..a70f4b2b20d 100644 --- a/lib/base64.ml +++ b/lib/base64.ml @@ -70,17 +70,3 @@ let encode x = output.[String.length output - i] <- '='; done; output - -let test x = - let x' = encode x in - let x'' = decode x' in - if x <> x'' - then failwith (Printf.sprintf "Original: '%s'; encoded = '%s'; decoded = '%s'" x x' x'') - -let tests = [ "hello"; - "this is a basic test"; "1"; "22"; "333"; "4444"; "5555"; - "\000"; "\000\000"; "\000\000\000"; "\000\000\000\000" ] - -(* -let _ = List.iter test tests -*) diff --git a/lib/bigbuffer.ml b/lib/bigbuffer.ml index fec2e92abf1..f3e06511a49 100644 --- a/lib/bigbuffer.ml +++ b/lib/bigbuffer.ml @@ -94,18 +94,5 @@ let to_string bigbuf = ); dest - -let test max = - let rec inner n = - if n>max then () else begin - let bb = make () in - let s = String.create n in - append_substring bb s 0 n; - assert ((to_string bb)=s); - inner (n+1) - end - in - inner 0 - let to_stream bigbuf outchan = to_fct bigbuf (fun s -> output_string outchan s) diff --git a/lib/config.ml b/lib/config.ml index 527c23bbd5a..44b33f1db08 100644 --- a/lib/config.ml +++ b/lib/config.ml @@ -76,9 +76,16 @@ let parse filename = close_in stream; cf +exception IntErr +exception FloatErr +exception BoolErr + let validate cf expected other = let err = ref [] in - let append x = err := x :: !err in + let append x = err := x :: !err in + let int_of_string v = try int_of_string v with Failure _ -> raise IntErr in + let float_of_string v = try float_of_string v with Failure _ -> raise FloatErr in + let bool_of_string v = try bool_of_string v with Failure _ -> raise BoolErr in List.iter (fun (k, v) -> try if not (List.mem_assoc k expected) then @@ -96,9 +103,9 @@ let validate cf expected other = | Set_float r -> r := (float_of_string v) with | Not_found -> append (k, "unknown key") - | Failure "int_of_string" -> append (k, "expect int arg") - | Failure "bool_of_string" -> append (k, "expect bool arg") - | Failure "float_of_string" -> append (k, "expect float arg") + | IntErr -> append (k, "expect int arg") + | BoolErr -> append (k, "expect bool arg") + | FloatErr -> append (k, "expect float arg") | exn -> append (k, Printexc.to_string exn) ) cf; if !err != [] then raise (Error !err) diff --git a/lib/encodings.ml b/lib/encodings.ml index ad3bf91110b..9a3840a4eac 100644 --- a/lib/encodings.ml +++ b/lib/encodings.ml @@ -180,7 +180,7 @@ module String_validator (Decoder : CHARACTER_DECODER) : STRING_VALIDATOR = struc let index = ref 0 and length = String.length string in begin try while !index < length do - let value, width = Decoder.decode_character string !index in + let _, width = Decoder.decode_character string !index in index := !index + width done; with @@ -193,7 +193,7 @@ module String_validator (Decoder : CHARACTER_DECODER) : STRING_VALIDATOR = struc let longest_valid_prefix string = try validate string; string - with Validation_error (index, reason) -> String.sub string 0 index + with Validation_error (index, _) -> String.sub string 0 index end diff --git a/lib/encodings.mli b/lib/encodings.mli index b028f014f82..e46a0f47678 100644 --- a/lib/encodings.mli +++ b/lib/encodings.mli @@ -11,6 +11,7 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) + (** Encoding helper modules *) (** {2 Exceptions} *) @@ -18,6 +19,7 @@ exception UCS_value_out_of_range exception UCS_value_prohibited_in_UTF8 exception UCS_value_prohibited_in_XML +exception UTF8_character_incomplete exception UTF8_header_byte_invalid exception UTF8_continuation_byte_invalid exception UTF8_encoding_not_canonical @@ -35,28 +37,28 @@ end module UTF8_UCS_validator : UCS_VALIDATOR (** Accepts all values within the UCS character value range except - * those which are invalid for all UTF-8-encoded XML documents. *) + * those which are invalid for all UTF-8-encoded XML documents. *) module XML_UTF8_UCS_validator : UCS_VALIDATOR module UCS : sig val min_value : int32 val max_value : int32 - (** Returns true if and only if the given value corresponds to a UCS *) - (** non-character. Such non-characters are forbidden for use in open *) - (** interchange of Unicode text data, and include the following: *) - (** 1. values from 0xFDD0 to 0xFDEF; and *) - (** 2. values 0xnFFFE and 0xnFFFF, where (0x0 <= n <= 0x10). *) - (** See the Unicode 5.0 Standard, section 16.7 for further details. *) + (** Returns true if and only if the given value corresponds to a UCS + * non-character. Such non-characters are forbidden for use in open + * interchange of Unicode text data, and include the following: + * 1. values from 0xFDD0 to 0xFDEF; and + * 2. values 0xnFFFE and 0xnFFFF, where (0x0 <= n <= 0x10). + * See the Unicode 5.0 Standard, section 16.7 for further details. *) val is_non_character : int32 -> bool - (** Returns true if and only if the given value lies outside the *) - (** entire UCS range. *) + (** Returns true if and only if the given value lies outside the + * entire UCS range. *) val is_out_of_range : int32 -> bool - (** Returns true if and only if the given value corresponds to a UCS *) - (** surrogate code point, only for use in UTF-16 encoded strings. *) - (** See the Unicode 5.0 Standard, section 16.6 for further details. *) + (** Returns true if and only if the given value corresponds to a UCS + * surrogate code point, only for use in UTF-16 encoded strings. + * See the Unicode 5.0 Standard, section 16.6 for further details. *) val is_surrogate : int32 -> bool end @@ -68,9 +70,9 @@ val (<<<) : int32 -> int -> int32 val (>>>) : int32 -> int -> int32 module XML : sig - (** Returns true if and only if the given value corresponds to *) - (** a forbidden control character as defined in section 2.2 of *) - (** the XML specification, version 1.0. *) + (** Returns true if and only if the given value corresponds to + * a forbidden control character as defined in section 2.2 of + * the XML specification, version 1.0. *) val is_forbidden_control_character : int32 -> bool end @@ -78,59 +80,59 @@ end module type CHARACTER_ENCODER = sig - (** Encodes a single character value, returning a string containing *) - (** the character. Raises an error if the character value is invalid. *) + (** Encodes a single character value, returning a string containing + * the character. Raises an error if the character value is invalid. *) val encode_character : int32 -> string end module type CHARACTER_DECODER = sig - (** Decodes a single character embedded within a string. Given a string *) - (** and an index into that string, returns a tuple (value, width) where: *) - (** value = the value of the character at the given index; and *) - (** width = the width of the character at the given index, in bytes. *) - (** Raises an appropriate error if the character is invalid. *) + (** Decodes a single character embedded within a string. Given a string + * and an index into that string, returns a tuple (value, width) where: + * value = the value of the character at the given index; and + * width = the width of the character at the given index, in bytes. + * Raises an appropriate error if the character is invalid. *) val decode_character : string -> int -> int32 * int end module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) : sig - (** Given a valid UCS value, returns the canonical *) - (** number of bytes required to encode the value. *) + (** Given a valid UCS value, returns the canonical + * number of bytes required to encode the value. *) val width_required_for_ucs_value : int32 -> int (** {3 Decoding} *) - (** Decodes a header byte, returning a tuple (v, w) where: *) - (** v = the (partial) value contained within the byte; and *) - (** w = the total width of the encoded character, in bytes. *) + (** Decodes a header byte, returning a tuple (v, w) where: + * v = the (partial) value contained within the byte; and + * w = the total width of the encoded character, in bytes. *) val decode_header_byte : int -> int * int - (** Decodes a continuation byte, returning the *) - (** 6-bit-wide value contained within the byte. *) + (** Decodes a continuation byte, returning the + * 6-bit-wide value contained within the byte. *) val decode_continuation_byte : int -> int - (** Decodes a single character embedded within a string. Given a string *) - (** and an index into that string, returns a tuple (value, width) where: *) - (** value = the value of the character at the given index; and *) - (** width = the width of the character at the given index, in bytes. *) - (** Raises an appropriate error if the character is invalid. *) + (** Decodes a single character embedded within a string. Given a string + * and an index into that string, returns a tuple (value, width) where: + * value = the value of the character at the given index; and + * width = the width of the character at the given index, in bytes. + * Raises an appropriate error if the character is invalid. *) val decode_character : string -> int -> int32 * int (** {3 Encoding} *) - (** Encodes a header byte for the given parameters, where: *) - (** width = the total width of the encoded character, in bytes; *) - (** value = the most significant bits of the original UCS value. *) + (** Encodes a header byte for the given parameters, where: + * width = the total width of the encoded character, in bytes; + * value = the most significant bits of the original UCS value. *) val encode_header_byte : int -> int32 -> int32 - (** Encodes a continuation byte from the given UCS *) - (** remainder value, returning a tuple (b, r), where: *) - (** b = the continuation byte; *) - (** r = a new UCS remainder value. *) + (** Encodes a continuation byte from the given UCS + * remainder value, returning a tuple (b, r), where: + * b = the continuation byte; + * r = a new UCS remainder value. *) val encode_continuation_byte : int32 -> int32 * int32 - (** Encodes a single character value, returning a string containing *) - (** the character. Raises an error if the character value is invalid. *) + (** Encodes a single character value, returning a string containing + * the character. Raises an error if the character value is invalid. *) val encode_character : int32 -> string end @@ -177,7 +179,7 @@ module String_validator (Decoder : CHARACTER_DECODER) : STRING_VALIDATOR (** Represents a validation error as a tuple [(i,e)], where: * [i] = the index of the first non-compliant character; - * [e] = the reason for non-compliance. *) + * [e] = the reason for non-compliance. *) exception Validation_error of int * exn (** Provides functions for validating and processing @@ -186,7 +188,7 @@ exception Validation_error of int * exn * Validly-encoded strings must satisfy RFC 3629. * * For further information, see: - * http://www.rfc.net/rfc3629.html *) + * http://www.rfc.net/rfc3629.html *) module UTF8 : STRING_VALIDATOR (** Provides functions for validating and processing diff --git a/lib/fring.mli b/lib/fring.mli index c14aa503ff5..d7569ccc85b 100644 --- a/lib/fring.mli +++ b/lib/fring.mli @@ -38,12 +38,12 @@ val peek : t -> int -> float val top : t -> float (** iterate over nb element of the ring, starting from the top *) -val iter_nb : t -> (float -> 'a) -> int -> unit +val iter_nb : t -> (float -> unit) -> int -> unit -val raw_iter : t -> (float -> 'a) -> unit +val raw_iter : t -> (float -> unit) -> unit (** iterate over all elements of the ring, starting from the top *) -val iter : t -> (float -> 'a) -> unit +val iter : t -> (float -> unit) -> unit (** get array of latest [nb] value *) val get_nb : t -> int -> float array diff --git a/lib/fun.ml b/lib/fun.ml index 4088caca3f5..d65fd2e4881 100644 --- a/lib/fun.ml +++ b/lib/fun.ml @@ -1,7 +1,5 @@ - - (* just forgets it's second argument: *) -let const a b = a +let const a _ = a let uncurry f (a,b) = f a b diff --git a/lib/fun.mli b/lib/fun.mli index e563ed05caf..a2e9bc5358a 100644 --- a/lib/fun.mli +++ b/lib/fun.mli @@ -7,6 +7,8 @@ val comp : ('b -> 'c) -> ('a -> 'b) -> ('a -> 'c) val comp2 : ('b -> 'c) -> ('a1 -> 'a2 -> 'b) -> ('a1 -> 'a2 -> 'c) val (+++) : ('c -> 'd) -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'd val (++) : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c -(** Forward pipe operator: facilitates left-to-right function composition. *) + val (|>) : 'a -> ('a -> 'b) -> 'b +(** Forward pipe operator: facilitates left-to-right function composition. *) + val ($) : ('a -> 'b) -> 'a -> 'b diff --git a/lib/hashtblext.ml b/lib/hashtblext.ml index eec1a82010e..c1eb01beb5c 100644 --- a/lib/hashtblext.ml +++ b/lib/hashtblext.ml @@ -17,11 +17,11 @@ let to_list tbl = (* this is not a fold ... *) let fold_keys tbl = - Hashtbl.fold (fun k v acc -> k :: acc) tbl [] + Hashtbl.fold (fun k _ acc -> k :: acc) tbl [] (* ... neither is this *) let fold_values tbl = - Hashtbl.fold (fun k v acc -> v :: acc) tbl [] + Hashtbl.fold (fun _ v acc -> v :: acc) tbl [] let add_empty tbl k v = if not (Hashtbl.mem tbl k) then diff --git a/lib/lazyList.ml b/lib/lazyList.ml index 9b0b93e2e37..b25b06b84e3 100644 --- a/lib/lazyList.ml +++ b/lib/lazyList.ml @@ -11,7 +11,7 @@ let rec map f xs = lazy(match Lazy.force xs with let rec take n xs = lazy(match n, Lazy.force xs with | 0, _ -> Empty - | n, Empty -> raise Not_found + | _, Empty -> raise Not_found | n, Cons(x, xs) -> Cons(x, take (n - 1) xs)) let rec iter f xs = match Lazy.force xs with diff --git a/lib/lazyList.mli b/lib/lazyList.mli index f6355a85e8a..29752afba13 100644 --- a/lib/lazyList.mli +++ b/lib/lazyList.mli @@ -13,4 +13,4 @@ val map : ('a -> 'b) -> 'a t -> 'b t val take : int -> 'a t -> 'a t (** [iter f xs] applies every list element to [f] *) -val iter : ('a -> 'b) -> 'a t -> unit +val iter : ('a -> unit) -> 'a t -> unit diff --git a/lib/opt.ml b/lib/opt.ml index a26f238ea7d..fc5171aba47 100644 --- a/lib/opt.ml +++ b/lib/opt.ml @@ -18,8 +18,6 @@ * (http://code.google.com/p/ocaml-extlib/) *) -open Pervasiveext - module Monad = Monad.M1.Make (struct type 'a m = 'a option diff --git a/lib/pervasiveext.ml b/lib/pervasiveext.ml index bd99cda583f..1066203de3d 100644 --- a/lib/pervasiveext.ml +++ b/lib/pervasiveext.ml @@ -62,17 +62,3 @@ let (++) f g x = Fun.comp f g x (* and application *) let ($) f a = f a - -(** Temporary measure to help with debugging CA-120159: extra details in int_of_string excn. *) -let int_of_string s = - try - int_of_string s - with - | Failure "int_of_string" -> - (let b = Printexc.get_backtrace () in - raise (Failure ("int_of_string (" ^ s ^ ")\n" ^ b))) - | Failure msg when (String.length msg > 13) - && (String.sub msg 0 13 = "int_of_string") - -> - (let b = Printexc.get_backtrace () in - raise (Failure (msg ^ "\n" ^ b))) diff --git a/lib/pervasiveext.mli b/lib/pervasiveext.mli index b0043458eb2..a0328b2fa03 100644 --- a/lib/pervasiveext.mli +++ b/lib/pervasiveext.mli @@ -12,7 +12,7 @@ * GNU Lesser General Public License for more details. *) -val finally : (unit -> 'a) -> (unit -> 'b) -> 'a +val finally : (unit -> 'a) -> (unit -> unit) -> 'a (** [finally f g] returns [f ()] guaranteeing to run clean-up actions [g ()] even if [f ()] throws an exception. *) diff --git a/lib/range.ml b/lib/range.ml index 5b362951b22..1aa889a4d4a 100644 --- a/lib/range.ml +++ b/lib/range.ml @@ -36,9 +36,6 @@ let rec fold_right_aux f l u accu = let fold_right f r accu = fold_right_aux f r.l r.u accu -let string_of_range r = - "[" ^ string_of_int r.l ^ ", " ^ string_of_int r.u ^ ")" - let to_list r = fold_right (fun x y -> x :: y) r [] diff --git a/lib/ring.mli b/lib/ring.mli index 95afdd1a048..c5cb4b0db64 100644 --- a/lib/ring.mli +++ b/lib/ring.mli @@ -17,8 +17,8 @@ val length : 'a t -> int val push : 'a t -> 'a -> unit val peek : 'a t -> int -> 'a val top : 'a t -> 'a -val iter_nb : 'a t -> ('a -> 'b) -> int -> unit +val iter_nb : 'a t -> ('a -> unit) -> int -> unit val raw_iter : 'a t -> ('a -> unit) -> unit -val iter : 'a t -> ('a -> 'b) -> unit +val iter : 'a t -> ('a -> unit) -> unit val get_nb : 'a t -> int -> 'a array val get : 'a t -> 'a array diff --git a/lib/threadext.ml b/lib/threadext.ml index b66312384a2..7dd0ca500f5 100644 --- a/lib/threadext.ml +++ b/lib/threadext.ml @@ -14,6 +14,7 @@ module Mutex = struct include Mutex + (** execute the function f with the mutex hold *) let execute lock f = Mutex.lock lock; @@ -226,7 +227,7 @@ module Thread = struct thread id *) -id - let rec join = function + let join = function | Running t -> Thread.join t | Pending ((_, _, pt) as t) -> if not (Lazy.lazy_is_val pt) then begin diff --git a/lib/threadext.mli b/lib/threadext.mli index e10d1dfe3bb..d4a12db153d 100644 --- a/lib/threadext.mli +++ b/lib/threadext.mli @@ -84,9 +84,11 @@ module Delay : returning early if someone calls 'signal'. Returns true if the full time period elapsed and false if signalled. Note that multple 'signals' are coalesced; 'signals' sent before 'wait' is called are not lost. *) + val wait : t -> float -> bool (** Sends a signal to a waiting thread. See 'wait' *) - val signal : t -> unit + + val signal : t -> unit end (** Keeps a thread alive without doing anything. Used e.g. in XML/RPC daemons. *) diff --git a/lib/trie.ml b/lib/trie.ml index d0d26e5f9c5..efd5aa91171 100644 --- a/lib/trie.ml +++ b/lib/trie.ml @@ -19,11 +19,11 @@ struct children: ('a,'b) t list; } - let create key value = { + (* let create key value = { key = key; value = Some value; children = []; - } + } *) let empty key = { key = key; @@ -31,21 +31,21 @@ struct children = [] } - let get_key node = node.key + (* let get_key node = node.key *) let get_value node = match node.value with | None -> raise Not_found - | Some value -> value + | Some value -> value - let get_children node = node.children + (* let get_children node = node.children *) let set_value node value = { node with value = Some value } let set_children node children = { node with children = children } - let add_child node child = - { node with children = child :: node.children } + (* let add_child node child = + { node with children = child :: node.children } *) end type ('a,'b) t = ('a,'b) Node.t list @@ -75,14 +75,14 @@ let remove_node nodes key = let create () = [] let rec iter f tree = - let rec aux node = + let aux node = f node.Node.key node.Node.value; iter f node.Node.children in List.iter aux tree let rec map f tree = - let rec aux node = + let aux node = let value = match node.Node.value with | None -> None @@ -93,7 +93,7 @@ let rec map f tree = List.filter (fun n -> n.Node.value <> None || n.Node.children <> []) (List.map aux tree) let rec fold f tree acc = - let rec aux accu node = + let aux accu node = fold f node.Node.children (f node.Node.key node.Node.value accu) in List.fold_left aux acc tree diff --git a/lib/unixext.ml b/lib/unixext.ml index fa557488541..49d5d98bed7 100644 --- a/lib/unixext.ml +++ b/lib/unixext.ml @@ -60,7 +60,7 @@ let pidfile_read filename = if rd = 0 then failwith "pidfile_read failed"; Scanf.sscanf (String.sub buf 0 rd) "%d" (fun i -> Some i) - with exn -> None) + with _ -> None) (fun () -> Unix.close fd) (** daemonize a process *) @@ -309,7 +309,7 @@ module CBuf = struct (* Offset of the character after the substring *) let next = min (String.length x.buffer) (x.start + x.len) in let len = next - x.start in - let written = try Unix.single_write fd x.buffer x.start len with e -> x.w_closed <- true; len in + let written = try Unix.single_write fd x.buffer x.start len with _ -> x.w_closed <- true; len in drop x written let read (x: t) fd = @@ -609,7 +609,7 @@ let resolve_dot_and_dotdot (path: string) : string = | "." :: rest, _ -> remove_dots n rest (* throw away ".", don't count as parent for ".." *) | ".." :: rest, _ -> remove_dots (n + 1) rest (* note the number of ".." *) | x :: rest, 0 -> x :: (remove_dots 0 rest) - | x :: rest, n -> remove_dots (n - 1) rest (* munch *) in + | _ :: rest, n -> remove_dots (n - 1) rest (* munch *) in to_string (remove_dots 0 (of_string path)) (** Seek to an absolute offset within a file descriptor *) diff --git a/lib/unixext.mli b/lib/unixext.mli index 889182ae707..f4daafc9659 100644 --- a/lib/unixext.mli +++ b/lib/unixext.mli @@ -77,16 +77,16 @@ val copy_file : ?limit:int64 -> Unix.file_descr -> Unix.file_descr -> int64 (** Returns true if and only if a file exists at the given path. *) val file_exists : string -> bool -(** Sets both the access and modification times of the file *) -(** at the given path to the current time. Creates an empty *) -(** file at the given path if no such file already exists. *) +(** Sets both the access and modification times of the file + * at the given path to the current time. Creates an empty + * file at the given path if no such file already exists. *) val touch_file : string -> unit (** Returns true if and only if an empty file exists at the given path. *) val is_empty_file : string -> bool -(** Safely deletes a file at the given path if (and only if) the *) -(** file exists and is empty. Returns true if a file was deleted. *) +(** Safely deletes a file at the given path if (and only if) the + * file exists and is empty. Returns true if a file was deleted. *) val delete_empty_file : string -> bool exception Host_not_found of string @@ -98,7 +98,7 @@ exception Process_still_alive val kill_and_wait : ?signal:int -> ?timeout:float -> int -> unit (** [string_of_signal x] translates an ocaml signal number into - a string suitable for logging. *) + * a string suitable for logging. *) val string_of_signal : int -> string val proxy : Unix.file_descr -> Unix.file_descr -> unit diff --git a/lib/xstringext.mli b/lib/xstringext.mli index 9ec3dd61721..2ea3c319939 100644 --- a/lib/xstringext.mli +++ b/lib/xstringext.mli @@ -29,13 +29,13 @@ module String : val rev_map : (char -> char) -> string -> string (** Iterate over the characters in a string in reverse order. *) - val rev_iter : (char -> 'a) -> string -> unit + val rev_iter : (char -> unit) -> string -> unit (** Fold over the characters in a string. *) val fold_left : ('a -> char -> 'a) -> 'a -> string -> 'a (** Iterate over the characters with the character index in argument *) - val iteri : (int -> char -> 'a) -> string -> unit + val iteri : (int -> char -> unit) -> string -> unit (** Iterate over the characters in a string in reverse order. *) val fold_right : (char -> 'a -> 'a) -> string -> 'a -> 'a @@ -76,7 +76,7 @@ module String : (** True if sub is a substr of str *) val has_substr : string -> string -> bool -(** find all occurences of needle in haystack and return all their respective index *) + (** find all occurences of needle in haystack and return all their respective index *) val find_all : string -> string -> int list (** replace all [f] substring in [s] by [t] *) diff --git a/lib/extentlistset_test.ml b/lib_test/extentlistset_test.ml similarity index 92% rename from lib/extentlistset_test.ml rename to lib_test/extentlistset_test.ml index 524cb4dc832..3edef31f2c3 100644 --- a/lib/extentlistset_test.ml +++ b/lib_test/extentlistset_test.ml @@ -1,5 +1,5 @@ (* We will check if a list of set equalities hold over random inputs *) - +open Stdext open Set_test (* We test using the integer domain only. *) @@ -56,11 +56,7 @@ type run = let to_run_list xs = let rec inner acc index = function | [] -> acc - | (x, y) :: xs -> inner (Full y :: (Empty (x - index)) :: acc) (x + y) xs in let map f xs = - let rec inner acc f = function - | [] -> acc - | (x :: xs) -> inner ((f x)::acc) f xs in - inner [] f xs in + | (x, y) :: xs -> inner (Full y :: (Empty (x - index)) :: acc) (x + y) xs in List.rev (inner [] 0 xs) @@ -81,7 +77,7 @@ let _ = Printf.printf "generated\n"; let x = to_list worst_case in Printf.printf "got a list\n"; - let y = Listext.List.map_tr hex x in + (* let y = Listext.List.map_tr hex x in *) Printf.printf "got lots of strings\n"; let s = to_string (to_list worst_case) in Printf.printf "Extent size=%d\n" (String.length s); diff --git a/lib_test/jbuild b/lib_test/jbuild new file mode 100644 index 00000000000..21e0b19fde5 --- /dev/null +++ b/lib_test/jbuild @@ -0,0 +1,9 @@ +(executable + ((name extentlistset_test) + (libraries (stdext)))) + +(alias + ((name runtest) + (deps (extentlistset_test.exe)) + (action (run ${<})))) + diff --git a/lib/set_test.ml b/lib_test/set_test.ml similarity index 100% rename from lib/set_test.ml rename to lib_test/set_test.ml diff --git a/lib/set_test.mli b/lib_test/set_test.mli similarity index 100% rename from lib/set_test.mli rename to lib_test/set_test.mli diff --git a/stdext.opam b/stdext.opam index 7b5aaa9683d..1d4365fce5f 100644 --- a/stdext.opam +++ b/stdext.opam @@ -7,6 +7,7 @@ homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] +build-test: [[ "jbuilder" "runtest" "-p" name "-j" jobs ]] depends: [ "jbuilder" {build} From e61cfb75e2fada47d725dd8abf6cb6a5429b9256 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Fri, 28 Jul 2017 16:36:46 +0100 Subject: [PATCH 049/199] Reindent code Signed-off-by: Marcello Seri --- lib/arrayext.ml | 84 ++-- lib/arrayext.mli | 90 ++-- lib/base64.ml | 4 +- lib/base64_main.ml | 6 +- lib/bigbuffer.ml | 120 ++--- lib/config.ml | 162 +++---- lib/config.mli | 18 +- lib/date.ml | 26 +- lib/either.ml | 36 +- lib/either.mli | 2 +- lib/encodings.ml | 216 ++++----- lib/encodings.mli | 188 ++++---- lib/extentlistSet.ml | 178 ++++---- lib/extentlistSet.mli | 26 +- lib/filenameext.ml | 4 +- lib/fring.ml | 78 ++-- lib/fring.mli | 2 +- lib/hashtblext.ml | 26 +- lib/hashtblext.mli | 14 +- lib/int64ext.ml | 22 +- lib/int64ext.mli | 22 +- lib/lazyList.ml | 22 +- lib/listext.ml | 404 ++++++++--------- lib/listext.mli | 352 +++++++-------- lib/mapext.ml | 84 ++-- lib/mapext.mli | 50 +-- lib/monad.ml | 80 ++-- lib/monad.mli | 80 ++-- lib/opt.ml | 62 +-- lib/pervasiveext.ml | 24 +- lib/qring.ml | 188 ++++---- lib/qring.mli | 14 +- lib/range.ml | 20 +- lib/ring.ml | 56 +-- lib/threadext.ml | 612 ++++++++++++------------- lib/threadext.mli | 106 ++--- lib/trie.ml | 254 +++++------ lib/trie.mli | 22 +- lib/unixext.ml | 784 ++++++++++++++++----------------- lib/unixext.mli | 84 ++-- lib/vIO.ml | 140 +++--- lib/vIO.mli | 14 +- lib/xstringext.ml | 424 +++++++++--------- lib/xstringext.mli | 122 ++--- lib/zerocheck.ml | 40 +- lib/zerocheck.mli | 8 +- lib_test/extentlistset_test.ml | 54 +-- lib_test/set_test.ml | 24 +- lib_test/set_test.mli | 24 +- 49 files changed, 2736 insertions(+), 2736 deletions(-) diff --git a/lib/arrayext.ml b/lib/arrayext.ml index 800373cf3c6..d783f9d8b14 100644 --- a/lib/arrayext.ml +++ b/lib/arrayext.ml @@ -13,47 +13,47 @@ *) module Array = struct include Array -(* Useful for vector addition. *) -let map2 f a b = - let len = length a in - if len <> length b then invalid_arg "map2"; - init len (fun i -> f a.(i) b.(i)) - -(* Useful for vector dot product. *) -let fold_left2 f x a b = - let len = length a in - if len <> length b then invalid_arg "fold_left2"; - let r = ref x in - for i = 0 to len - 1 do - r := f !r a.(i) b.(i) - done; - !r - -(* Useful for vector dot product. *) -let fold_right2 f a b x = - let len = length a in - if len <> length b then invalid_arg "fold_right2"; - let r = ref x in - for i = len - 1 downto 0 do - r := f a.(i) b.(i) !r - done; - !r - -let index e a = - let len = length a in - let rec check i = - if len <= i then -1 - else if get a i = e then i - else check (i + 1) - in check 0 - -let inner fold_left2 base f l1 l2 g = - fold_left2 (fun accu e1 e2 -> g accu (f e1 e2)) base l1 l2 - -let mem e a = - index e a <> -1 - -let remove n a = - append (sub a 0 n) (sub a (n+1) (length a - n - 1)) + (* Useful for vector addition. *) + let map2 f a b = + let len = length a in + if len <> length b then invalid_arg "map2"; + init len (fun i -> f a.(i) b.(i)) + + (* Useful for vector dot product. *) + let fold_left2 f x a b = + let len = length a in + if len <> length b then invalid_arg "fold_left2"; + let r = ref x in + for i = 0 to len - 1 do + r := f !r a.(i) b.(i) + done; + !r + + (* Useful for vector dot product. *) + let fold_right2 f a b x = + let len = length a in + if len <> length b then invalid_arg "fold_right2"; + let r = ref x in + for i = len - 1 downto 0 do + r := f a.(i) b.(i) !r + done; + !r + + let index e a = + let len = length a in + let rec check i = + if len <= i then -1 + else if get a i = e then i + else check (i + 1) + in check 0 + + let inner fold_left2 base f l1 l2 g = + fold_left2 (fun accu e1 e2 -> g accu (f e1 e2)) base l1 l2 + + let mem e a = + index e a <> -1 + + let remove n a = + append (sub a 0 n) (sub a (n+1) (length a - n - 1)) end diff --git a/lib/arrayext.mli b/lib/arrayext.mli index 94a13521297..bf2fcd3207d 100644 --- a/lib/arrayext.mli +++ b/lib/arrayext.mli @@ -13,56 +13,56 @@ *) module Array : sig - external length : 'a array -> int = "%array_length" - external get : 'a array -> int -> 'a = "%array_safe_get" - external set : 'a array -> int -> 'a -> unit = "%array_safe_set" - external make : int -> 'a -> 'a array = "caml_make_vect" - external create : int -> 'a -> 'a array = "caml_make_vect" - val init : int -> (int -> 'a) -> 'a array - val make_matrix : int -> int -> 'a -> 'a array array - val create_matrix : int -> int -> 'a -> 'a array array - val append : 'a array -> 'a array -> 'a array - val concat : 'a array list -> 'a array - val sub : 'a array -> int -> int -> 'a array - val copy : 'a array -> 'a array - val fill : 'a array -> int -> int -> 'a -> unit - val blit : 'a array -> int -> 'a array -> int -> int -> unit - val to_list : 'a array -> 'a list - val of_list : 'a list -> 'a array - val iter : ('a -> unit) -> 'a array -> unit - val map : ('a -> 'b) -> 'a array -> 'b array - val iteri : (int -> 'a -> unit) -> 'a array -> unit - val mapi : (int -> 'a -> 'b) -> 'a array -> 'b array - val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a - val fold_right : ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b - val sort : ('a -> 'a -> int) -> 'a array -> unit - val stable_sort : ('a -> 'a -> int) -> 'a array -> unit - val fast_sort : ('a -> 'a -> int) -> 'a array -> unit - external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get" - external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" + external length : 'a array -> int = "%array_length" + external get : 'a array -> int -> 'a = "%array_safe_get" + external set : 'a array -> int -> 'a -> unit = "%array_safe_set" + external make : int -> 'a -> 'a array = "caml_make_vect" + external create : int -> 'a -> 'a array = "caml_make_vect" + val init : int -> (int -> 'a) -> 'a array + val make_matrix : int -> int -> 'a -> 'a array array + val create_matrix : int -> int -> 'a -> 'a array array + val append : 'a array -> 'a array -> 'a array + val concat : 'a array list -> 'a array + val sub : 'a array -> int -> int -> 'a array + val copy : 'a array -> 'a array + val fill : 'a array -> int -> int -> 'a -> unit + val blit : 'a array -> int -> 'a array -> int -> int -> unit + val to_list : 'a array -> 'a list + val of_list : 'a list -> 'a array + val iter : ('a -> unit) -> 'a array -> unit + val map : ('a -> 'b) -> 'a array -> 'b array + val iteri : (int -> 'a -> unit) -> 'a array -> unit + val mapi : (int -> 'a -> 'b) -> 'a array -> 'b array + val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a + val fold_right : ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b + val sort : ('a -> 'a -> int) -> 'a array -> unit + val stable_sort : ('a -> 'a -> int) -> 'a array -> unit + val fast_sort : ('a -> 'a -> int) -> 'a array -> unit + external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get" + external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" - (** Map a function over a pair of arrays simultaneously. *) - val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array + (** Map a function over a pair of arrays simultaneously. *) + val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array - (** Fold a function over a pair of arrays simultaneously. *) - val fold_left2 : - ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a + (** Fold a function over a pair of arrays simultaneously. *) + val fold_left2 : + ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a - (** Fold a function over a pair of arrays simultaneously. *) - val fold_right2 : - ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c + (** Fold a function over a pair of arrays simultaneously. *) + val fold_right2 : + ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c - (** Get first index of an element in the array, or -1. *) - val index : 'a -> 'a array -> int + (** Get first index of an element in the array, or -1. *) + val index : 'a -> 'a array -> int - (** Compute the inner product of two arrays. *) - val inner : - (('a -> 'b -> 'c -> 'd) -> 'e -> 'f -> 'g -> 'h) -> - 'e -> ('b -> 'c -> 'i) -> 'f -> 'g -> ('a -> 'i -> 'd) -> 'h + (** Compute the inner product of two arrays. *) + val inner : + (('a -> 'b -> 'c -> 'd) -> 'e -> 'f -> 'g -> 'h) -> + 'e -> ('b -> 'c -> 'i) -> 'f -> 'g -> ('a -> 'i -> 'd) -> 'h - (** Check if an element appears in the array. *) - val mem : 'a -> 'a array -> bool + (** Check if an element appears in the array. *) + val mem : 'a -> 'a array -> bool - (** Remove the element at specified position from the array. *) - val remove : int -> 'a array -> 'a array + (** Remove the element at specified position from the array. *) + val remove : int -> 'a array -> 'a array end diff --git a/lib/base64.ml b/lib/base64.ml index a70f4b2b20d..54c121a908b 100644 --- a/lib/base64.ml +++ b/lib/base64.ml @@ -28,8 +28,8 @@ let decode x = let words = String.length x / 4 in let padding = if String.length x = 0 then 0 else ( - if x.[String.length x - 2] = padding - then 2 else (if x.[String.length x - 1] = padding then 1 else 0)) in + if x.[String.length x - 2] = padding + then 2 else (if x.[String.length x - 1] = padding then 1 else 0)) in let output = String.make (words * 3 - padding) '\000' in for i = 0 to words - 1 do let a = of_char x.[4 * i + 0] diff --git a/lib/base64_main.ml b/lib/base64_main.ml index 7f76e39c50f..77e69fa873f 100644 --- a/lib/base64_main.ml +++ b/lib/base64_main.ml @@ -21,8 +21,8 @@ let _ = if Array.length Sys.argv <> 3 then usage (); match Sys.argv.(1) with | "encode" -> - print_string (encode Sys.argv.(2)) + print_string (encode Sys.argv.(2)) | "decode" -> - print_string (decode Sys.argv.(2)) + print_string (decode Sys.argv.(2)) | _ -> - usage () + usage () diff --git a/lib/bigbuffer.ml b/lib/bigbuffer.ml index f3e06511a49..2f7517bd54f 100644 --- a/lib/bigbuffer.ml +++ b/lib/bigbuffer.ml @@ -13,8 +13,8 @@ *) type t = { - mutable cells: string option array; - mutable index: int64; + mutable cells: string option array; + mutable index: int64; } let cell_size = 4096 @@ -25,74 +25,74 @@ let make () = { cells = Array.make default_array_len None; index = 0L } let length bigbuf = bigbuf.index let get bigbuf n = - let array_offset = Int64.to_int (Int64.div n (Int64.of_int cell_size)) in - let cell_offset = Int64.to_int (Int64.rem n (Int64.of_int cell_size)) in - match bigbuf.cells.(array_offset) with - | None -> "".[0] - | Some buf -> buf.[cell_offset] + let array_offset = Int64.to_int (Int64.div n (Int64.of_int cell_size)) in + let cell_offset = Int64.to_int (Int64.rem n (Int64.of_int cell_size)) in + match bigbuf.cells.(array_offset) with + | None -> "".[0] + | Some buf -> buf.[cell_offset] let rec append_substring bigbuf s offset len = - let array_offset = Int64.to_int (Int64.div bigbuf.index (Int64.of_int cell_size)) in - let cell_offset = Int64.to_int (Int64.rem bigbuf.index (Int64.of_int cell_size)) in - - if Array.length bigbuf.cells <= array_offset then ( - (* we need to reallocate the array *) - bigbuf.cells <- Array.append bigbuf.cells (Array.make default_array_len None) - ); - - let buf = match bigbuf.cells.(array_offset) with - | None -> - let newbuf = String.create cell_size in - bigbuf.cells.(array_offset) <- Some newbuf; - newbuf - | Some buf -> - buf - in - if len + cell_offset <= cell_size then ( - String.blit s offset buf cell_offset len; - bigbuf.index <- Int64.add bigbuf.index (Int64.of_int len); - ) else ( - let rlen = cell_size - cell_offset in - String.blit s offset buf cell_offset rlen; - bigbuf.index <- Int64.add bigbuf.index (Int64.of_int rlen); - append_substring bigbuf s (offset + rlen) (len - rlen) - ); - () + let array_offset = Int64.to_int (Int64.div bigbuf.index (Int64.of_int cell_size)) in + let cell_offset = Int64.to_int (Int64.rem bigbuf.index (Int64.of_int cell_size)) in + + if Array.length bigbuf.cells <= array_offset then ( + (* we need to reallocate the array *) + bigbuf.cells <- Array.append bigbuf.cells (Array.make default_array_len None) + ); + + let buf = match bigbuf.cells.(array_offset) with + | None -> + let newbuf = String.create cell_size in + bigbuf.cells.(array_offset) <- Some newbuf; + newbuf + | Some buf -> + buf + in + if len + cell_offset <= cell_size then ( + String.blit s offset buf cell_offset len; + bigbuf.index <- Int64.add bigbuf.index (Int64.of_int len); + ) else ( + let rlen = cell_size - cell_offset in + String.blit s offset buf cell_offset rlen; + bigbuf.index <- Int64.add bigbuf.index (Int64.of_int rlen); + append_substring bigbuf s (offset + rlen) (len - rlen) + ); + () let append_string b s = append_substring b s 0 (String.length s) let to_fct bigbuf f = - let array_offset = Int64.to_int (Int64.div bigbuf.index (Int64.of_int cell_size)) in - let cell_offset = Int64.to_int (Int64.rem bigbuf.index (Int64.of_int cell_size)) in + let array_offset = Int64.to_int (Int64.div bigbuf.index (Int64.of_int cell_size)) in + let cell_offset = Int64.to_int (Int64.rem bigbuf.index (Int64.of_int cell_size)) in - (* copy all complete cells *) - for i = 0 to array_offset - 1 - do - match bigbuf.cells.(i) with - | None -> (* should never happen *) () - | Some cell -> f cell - done; + (* copy all complete cells *) + for i = 0 to array_offset - 1 + do + match bigbuf.cells.(i) with + | None -> (* should never happen *) () + | Some cell -> f cell + done; - if(cell_offset > 0) then - (* copy last cell *) - begin match bigbuf.cells.(array_offset) with - | None -> (* Should never happen (any more) *) () - | Some cell -> f (String.sub cell 0 cell_offset) - end + if(cell_offset > 0) then + (* copy last cell *) + begin match bigbuf.cells.(array_offset) with + | None -> (* Should never happen (any more) *) () + | Some cell -> f (String.sub cell 0 cell_offset) + end let to_string bigbuf = - if bigbuf.index > (Int64.of_int Sys.max_string_length) then - failwith "cannot allocate string big enough"; - - let dest = String.create (Int64.to_int bigbuf.index) in - let destoff = ref 0 in - to_fct bigbuf (fun s -> - let len = String.length s in - String.blit s 0 dest !destoff len; - destoff := !destoff + len - ); - dest + if bigbuf.index > (Int64.of_int Sys.max_string_length) then + failwith "cannot allocate string big enough"; + + let dest = String.create (Int64.to_int bigbuf.index) in + let destoff = ref 0 in + to_fct bigbuf (fun s -> + let len = String.length s in + String.blit s 0 dest !destoff len; + destoff := !destoff + len + ); + dest let to_stream bigbuf outchan = - to_fct bigbuf (fun s -> output_string outchan s) + to_fct bigbuf (fun s -> output_string outchan s) diff --git a/lib/config.ml b/lib/config.ml index 44b33f1db08..988e0fdf82d 100644 --- a/lib/config.ml +++ b/lib/config.ml @@ -12,105 +12,105 @@ * GNU Lesser General Public License for more details. *) type ty = - | Set_bool of bool ref - | Set_int of int ref - | Set_string of string ref - | Set_float of float ref - | Unit of (unit -> unit) - | Bool of (bool -> unit) - | Int of (int -> unit) - | String of (string -> unit) - | Float of (float -> unit) + | Set_bool of bool ref + | Set_int of int ref + | Set_string of string ref + | Set_float of float ref + | Unit of (unit -> unit) + | Bool of (bool -> unit) + | Int of (int -> unit) + | String of (string -> unit) + | Float of (float -> unit) exception Error of (string * string) list let trim_start lc s = - let len = String.length s and i = ref 0 in - while !i < len && (List.mem s.[!i] lc) - do - incr i - done; - if !i < len then String.sub s !i (len - !i) else "" + let len = String.length s and i = ref 0 in + while !i < len && (List.mem s.[!i] lc) + do + incr i + done; + if !i < len then String.sub s !i (len - !i) else "" let trim_end lc s = - let i = ref (String.length s - 1) in - while !i > 0 && (List.mem s.[!i] lc) - do - decr i - done; - if !i >= 0 then String.sub s 0 (!i + 1) else "" + let i = ref (String.length s - 1) in + while !i > 0 && (List.mem s.[!i] lc) + do + decr i + done; + if !i >= 0 then String.sub s 0 (!i + 1) else "" let rec split ?limit:(limit=(-1)) c s = - let i = try String.index s c with Not_found -> -1 in - let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in - if i = -1 || nlimit = 0 then - [ s ] - else - let a = String.sub s 0 i - and b = String.sub s (i + 1) (String.length s - i - 1) in - a :: (split ~limit: nlimit c b) + let i = try String.index s c with Not_found -> -1 in + let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in + if i = -1 || nlimit = 0 then + [ s ] + else + let a = String.sub s 0 i + and b = String.sub s (i + 1) (String.length s - i - 1) in + a :: (split ~limit: nlimit c b) let parse_line stream = - let lc = [ ' '; '\t' ] in - let trim_spaces s = trim_end lc (trim_start lc s) in - let to_config s = - match split ~limit:2 '=' s with - | k :: v :: [] -> Some (trim_end lc k, trim_start lc v) - | _ -> None in - let rec read_filter_line () = - try - let line = trim_spaces (input_line stream) in - if String.length line > 0 && line.[0] <> '#' then - match to_config line with - | None -> read_filter_line () - | Some x -> x :: read_filter_line () - else - read_filter_line () - with - End_of_file -> [] in - read_filter_line () + let lc = [ ' '; '\t' ] in + let trim_spaces s = trim_end lc (trim_start lc s) in + let to_config s = + match split ~limit:2 '=' s with + | k :: v :: [] -> Some (trim_end lc k, trim_start lc v) + | _ -> None in + let rec read_filter_line () = + try + let line = trim_spaces (input_line stream) in + if String.length line > 0 && line.[0] <> '#' then + match to_config line with + | None -> read_filter_line () + | Some x -> x :: read_filter_line () + else + read_filter_line () + with + End_of_file -> [] in + read_filter_line () let parse filename = - let stream = open_in filename in - let cf = parse_line stream in - close_in stream; - cf + let stream = open_in filename in + let cf = parse_line stream in + close_in stream; + cf exception IntErr exception FloatErr exception BoolErr let validate cf expected other = - let err = ref [] in - let append x = err := x :: !err in - let int_of_string v = try int_of_string v with Failure _ -> raise IntErr in - let float_of_string v = try float_of_string v with Failure _ -> raise FloatErr in - let bool_of_string v = try bool_of_string v with Failure _ -> raise BoolErr in - List.iter (fun (k, v) -> - try - if not (List.mem_assoc k expected) then - other k v - else let ty = List.assoc k expected in - match ty with - | Unit f -> f () - | Bool f -> f (bool_of_string v) - | String f -> f v - | Int f -> f (int_of_string v) - | Float f -> f (float_of_string v) - | Set_bool r -> r := (bool_of_string v) - | Set_string r -> r := v - | Set_int r -> r := int_of_string v - | Set_float r -> r := (float_of_string v) - with - | Not_found -> append (k, "unknown key") - | IntErr -> append (k, "expect int arg") - | BoolErr -> append (k, "expect bool arg") - | FloatErr -> append (k, "expect float arg") - | exn -> append (k, Printexc.to_string exn) - ) cf; - if !err != [] then raise (Error !err) + let err = ref [] in + let append x = err := x :: !err in + let int_of_string v = try int_of_string v with Failure _ -> raise IntErr in + let float_of_string v = try float_of_string v with Failure _ -> raise FloatErr in + let bool_of_string v = try bool_of_string v with Failure _ -> raise BoolErr in + List.iter (fun (k, v) -> + try + if not (List.mem_assoc k expected) then + other k v + else let ty = List.assoc k expected in + match ty with + | Unit f -> f () + | Bool f -> f (bool_of_string v) + | String f -> f v + | Int f -> f (int_of_string v) + | Float f -> f (float_of_string v) + | Set_bool r -> r := (bool_of_string v) + | Set_string r -> r := v + | Set_int r -> r := int_of_string v + | Set_float r -> r := (float_of_string v) + with + | Not_found -> append (k, "unknown key") + | IntErr -> append (k, "expect int arg") + | BoolErr -> append (k, "expect bool arg") + | FloatErr -> append (k, "expect float arg") + | exn -> append (k, Printexc.to_string exn) + ) cf; + if !err != [] then raise (Error !err) (** read a filename, parse and validate, and return the errors if any *) let read filename expected other = - let cf = parse filename in - validate cf expected other + let cf = parse filename in + validate cf expected other diff --git a/lib/config.mli b/lib/config.mli index 5cef5c63b80..55c1a9b3661 100644 --- a/lib/config.mli +++ b/lib/config.mli @@ -14,14 +14,14 @@ exception Error of (string * string) list type ty = - | Set_bool of bool ref - | Set_int of int ref - | Set_string of string ref - | Set_float of float ref - | Unit of (unit -> unit) - | Bool of (bool -> unit) - | Int of (int -> unit) - | String of (string -> unit) - | Float of (float -> unit) + | Set_bool of bool ref + | Set_int of int ref + | Set_string of string ref + | Set_float of float ref + | Unit of (unit -> unit) + | Bool of (bool -> unit) + | Int of (int -> unit) + | String of (string -> unit) + | Float of (float -> unit) val read: string -> (string * ty) list -> (string -> string -> unit) -> unit diff --git a/lib/date.ml b/lib/date.ml index ea82a9d2239..526fb304b70 100644 --- a/lib/date.ml +++ b/lib/date.ml @@ -26,7 +26,7 @@ let of_float x = time.Unix.tm_sec let months = [| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun"; - "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec" |] + "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec" |] let days = [| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |] let rfc822_of_float x = @@ -43,14 +43,14 @@ let to_float_localtime x = Scanf.sscanf x "%04d%02d%02dT%02d:%02d:%02d" (fun y mon d h min s -> fst (Unix.mktime { Unix.tm_year = y - 1900; - tm_mon = mon - 1; - tm_mday = d; - tm_hour = h; - tm_min = min; - tm_sec = s; - (* These are ignored: *) - tm_wday = 0; tm_yday = 0; tm_isdst = true; - })) + tm_mon = mon - 1; + tm_mday = d; + tm_hour = h; + tm_min = min; + tm_sec = s; + (* These are ignored: *) + tm_wday = 0; tm_yday = 0; tm_isdst = true; + })) (* Convert tm in UTC back into calendar time x (using offset between above UTC and localtime fns to determine offset between UTC and localtime, then @@ -59,14 +59,14 @@ let to_float_localtime x = let to_float x = let t = Unix.time() in let offset = (to_float_localtime (of_float t)) -. t in - (to_float_localtime x) -. offset + (to_float_localtime x) -. offset let to_string x = x let of_string x = x let assert_utc x = - try - Scanf.sscanf x "%_[0-9]T%_[0-9]:%_[0-9]:%_[0-9]Z" () - with _ -> invalid_arg x + try + Scanf.sscanf x "%_[0-9]T%_[0-9]:%_[0-9]:%_[0-9]Z" () + with _ -> invalid_arg x let never = of_float 0.0 diff --git a/lib/either.ml b/lib/either.ml index 8cfd9b33342..32fbc9b7068 100644 --- a/lib/either.ml +++ b/lib/either.ml @@ -5,38 +5,38 @@ type ('a,'b) t = Left of 'a | Right of 'b module Monad = Monad.M2.Make (struct - type ('a, 'b) m = ('b, 'a) t + type ('a, 'b) m = ('b, 'a) t - let bind value f = - match value with - | Left value -> Left value - | Right value -> f value + let bind value f = + match value with + | Left value -> Left value + | Right value -> f value - let return value = Right value + let return value = Right value -end) + end) let left x = Left x let right x = Right x let is_left = function - | Left _ -> true - | Right _ -> false + | Left _ -> true + | Right _ -> false let is_right x = not ++ is_left $ x let to_option = function - | Right x -> Some x - | Left _ -> None + | Right x -> Some x + | Left _ -> None let cat_right l = List.unbox_list ++ List.map to_option $ l let join = function - | Right (Right x) -> Right x - | Left x -> Left (Left x) - | Right (Left x) -> Left (Right x) + | Right (Right x) -> Right x + | Left x -> Left (Left x) + | Right (Left x) -> Left (Right x) let swap = function - | Right x -> Left x - | Left x -> Right x + | Right x -> Left x + | Left x -> Right x let of_exception f = - try Right (f ()) - with e -> Left e + try Right (f ()) + with e -> Left e diff --git a/lib/either.mli b/lib/either.mli index 494f4ea153b..a603a559510 100644 --- a/lib/either.mli +++ b/lib/either.mli @@ -3,7 +3,7 @@ Right is commonly used for success Left is commonly used for failure. - *) +*) type ('a,'b) t = Left of 'a | Right of 'b module Monad : sig include Monad.M2.MONAD with type ('a, 'b) m = ('b, 'a) t end diff --git a/lib/encodings.ml b/lib/encodings.ml index 9a3840a4eac..5086ff5881b 100644 --- a/lib/encodings.ml +++ b/lib/encodings.ml @@ -33,27 +33,27 @@ let ( >>> ) = Int32.shift_right_logical module UCS = struct - let min_value = 0x000000l - let max_value = 0x1fffffl + let min_value = 0x000000l + let max_value = 0x1fffffl - let is_non_character value = false - || (0xfdd0l <= value && value <= 0xfdefl) (* case 1 *) - || (Int32.logand 0xfffel value = 0xfffel) (* case 2 *) + let is_non_character value = false + || (0xfdd0l <= value && value <= 0xfdefl) (* case 1 *) + || (Int32.logand 0xfffel value = 0xfffel) (* case 2 *) - let is_out_of_range value = - value < min_value || value > max_value - - let is_surrogate value = - (0xd800l <= value && value <= 0xdfffl) + let is_out_of_range value = + value < min_value || value > max_value + + let is_surrogate value = + (0xd800l <= value && value <= 0xdfffl) end module XML = struct - let is_forbidden_control_character value = value < 0x20l - && value <> 0x09l - && value <> 0x0al - && value <> 0x0dl + let is_forbidden_control_character value = value < 0x20l + && value <> 0x09l + && value <> 0x0al + && value <> 0x0dl end @@ -61,101 +61,101 @@ end module type UCS_VALIDATOR = sig - val validate : int32 -> unit + val validate : int32 -> unit end module UTF8_UCS_validator : UCS_VALIDATOR = struct - let validate value = - if UCS.is_out_of_range value then raise UCS_value_out_of_range; - if UCS.is_non_character value then raise UCS_value_prohibited_in_UTF8; - if UCS.is_surrogate value then raise UCS_value_prohibited_in_UTF8 + let validate value = + if UCS.is_out_of_range value then raise UCS_value_out_of_range; + if UCS.is_non_character value then raise UCS_value_prohibited_in_UTF8; + if UCS.is_surrogate value then raise UCS_value_prohibited_in_UTF8 end module XML_UTF8_UCS_validator : UCS_VALIDATOR = struct - let validate value = - UTF8_UCS_validator.validate value; - if XML.is_forbidden_control_character value - then raise UCS_value_prohibited_in_XML + let validate value = + UTF8_UCS_validator.validate value; + if XML.is_forbidden_control_character value + then raise UCS_value_prohibited_in_XML end (* ==== Character Codecs ==== *) module type CHARACTER_DECODER = sig - val decode_character : string -> int -> int32 * int + val decode_character : string -> int -> int32 * int end module type CHARACTER_ENCODER = sig - val encode_character : int32 -> string + val encode_character : int32 -> string end module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) = struct - let width_required_for_ucs_value value = - if value < 0x000080l (* 1 lsl 7 *) then 1 else - if value < 0x000800l (* 1 lsl 11 *) then 2 else - if value < 0x010000l (* 1 lsl 16 *) then 3 else 4 - - (* === Decoding === *) - - let decode_header_byte byte = - if byte land 0b10000000 = 0b00000000 then (byte , 1) else - if byte land 0b11100000 = 0b11000000 then (byte land 0b0011111, 2) else - if byte land 0b11110000 = 0b11100000 then (byte land 0b0001111, 3) else - if byte land 0b11111000 = 0b11110000 then (byte land 0b0000111, 4) else - raise UTF8_header_byte_invalid - - let decode_continuation_byte byte = - if byte land 0b11000000 = 0b10000000 then byte land 0b00111111 else - raise UTF8_continuation_byte_invalid - - let decode_character string index = - let value, width = decode_header_byte (Char.code string.[index]) in - let value = if width = 1 then (Int32.of_int value) - else begin - let value = ref (Int32.of_int value) in - for index = index + 1 to index + width - 1 do - let chunk = decode_continuation_byte (Char.code string.[index]) in - value := (!value <<< 6) ||| (Int32.of_int chunk) - done; - if width > (width_required_for_ucs_value !value) - then raise UTF8_encoding_not_canonical; - !value - end in - UCS_validator.validate value; - (value, width) - - (* === Encoding === *) - - let encode_header_byte width value = - match width with - | 1 -> value - | 2 -> value ||| 0b11000000l - | 3 -> value ||| 0b11100000l - | 4 -> value ||| 0b11110000l - | _ -> raise UCS_value_out_of_range - - let encode_continuation_byte value = - ((value &&& 0b00111111l) ||| 0b10000000l, value >>> 6) - - let encode_character value = - UCS_validator.validate value; - let width = width_required_for_ucs_value value in - let string = String.make width ' ' in - (* Start by encoding the continuation bytes in reverse order. *) - let rec encode_continuation_bytes remainder index = - if index = 0 then remainder else - let byte, remainder = encode_continuation_byte remainder in - string.[index] <- Char.chr (Int32.to_int byte); - encode_continuation_bytes remainder (index - 1) in - let remainder = encode_continuation_bytes value (width - 1) in - (* Finish by encoding the header byte. *) - let byte = encode_header_byte width remainder in - string.[0] <- Char.chr (Int32.to_int byte); - string + let width_required_for_ucs_value value = + if value < 0x000080l (* 1 lsl 7 *) then 1 else + if value < 0x000800l (* 1 lsl 11 *) then 2 else + if value < 0x010000l (* 1 lsl 16 *) then 3 else 4 + + (* === Decoding === *) + + let decode_header_byte byte = + if byte land 0b10000000 = 0b00000000 then (byte , 1) else + if byte land 0b11100000 = 0b11000000 then (byte land 0b0011111, 2) else + if byte land 0b11110000 = 0b11100000 then (byte land 0b0001111, 3) else + if byte land 0b11111000 = 0b11110000 then (byte land 0b0000111, 4) else + raise UTF8_header_byte_invalid + + let decode_continuation_byte byte = + if byte land 0b11000000 = 0b10000000 then byte land 0b00111111 else + raise UTF8_continuation_byte_invalid + + let decode_character string index = + let value, width = decode_header_byte (Char.code string.[index]) in + let value = if width = 1 then (Int32.of_int value) + else begin + let value = ref (Int32.of_int value) in + for index = index + 1 to index + width - 1 do + let chunk = decode_continuation_byte (Char.code string.[index]) in + value := (!value <<< 6) ||| (Int32.of_int chunk) + done; + if width > (width_required_for_ucs_value !value) + then raise UTF8_encoding_not_canonical; + !value + end in + UCS_validator.validate value; + (value, width) + + (* === Encoding === *) + + let encode_header_byte width value = + match width with + | 1 -> value + | 2 -> value ||| 0b11000000l + | 3 -> value ||| 0b11100000l + | 4 -> value ||| 0b11110000l + | _ -> raise UCS_value_out_of_range + + let encode_continuation_byte value = + ((value &&& 0b00111111l) ||| 0b10000000l, value >>> 6) + + let encode_character value = + UCS_validator.validate value; + let width = width_required_for_ucs_value value in + let string = String.make width ' ' in + (* Start by encoding the continuation bytes in reverse order. *) + let rec encode_continuation_bytes remainder index = + if index = 0 then remainder else + let byte, remainder = encode_continuation_byte remainder in + string.[index] <- Char.chr (Int32.to_int byte); + encode_continuation_bytes remainder (index - 1) in + let remainder = encode_continuation_bytes value (width - 1) in + (* Finish by encoding the header byte. *) + let byte = encode_header_byte width remainder in + string.[0] <- Char.chr (Int32.to_int byte); + string end @@ -166,9 +166,9 @@ module XML_UTF8_codec = UTF8_CODEC (XML_UTF8_UCS_validator) module type STRING_VALIDATOR = sig - val is_valid : string -> bool - val validate : string -> unit - val longest_valid_prefix : string -> string + val is_valid : string -> bool + val validate : string -> unit + val longest_valid_prefix : string -> string end @@ -176,24 +176,24 @@ exception Validation_error of int * exn module String_validator (Decoder : CHARACTER_DECODER) : STRING_VALIDATOR = struct - let validate string = - let index = ref 0 and length = String.length string in - begin try - while !index < length do - let _, width = Decoder.decode_character string !index in - index := !index + width - done; - with - | Invalid_argument _ -> raise String_incomplete - | error -> raise (Validation_error (!index, error)) - end; assert (!index = length) - - let is_valid string = - try validate string; true with _ -> false - - let longest_valid_prefix string = - try validate string; string - with Validation_error (index, _) -> String.sub string 0 index + let validate string = + let index = ref 0 and length = String.length string in + begin try + while !index < length do + let _, width = Decoder.decode_character string !index in + index := !index + width + done; + with + | Invalid_argument _ -> raise String_incomplete + | error -> raise (Validation_error (!index, error)) + end; assert (!index = length) + + let is_valid string = + try validate string; true with _ -> false + + let longest_valid_prefix string = + try validate string; string + with Validation_error (index, _) -> String.sub string 0 index end diff --git a/lib/encodings.mli b/lib/encodings.mli index e46a0f47678..bc2bdd065c1 100644 --- a/lib/encodings.mli +++ b/lib/encodings.mli @@ -13,7 +13,7 @@ *) (** Encoding helper modules *) - + (** {2 Exceptions} *) exception UCS_value_out_of_range @@ -29,7 +29,7 @@ exception String_incomplete (** Validates UCS character values. *) module type UCS_VALIDATOR = sig - val validate : int32 -> unit + val validate : int32 -> unit end (** Accepts all values within the UCS character value range @@ -41,25 +41,25 @@ module UTF8_UCS_validator : UCS_VALIDATOR module XML_UTF8_UCS_validator : UCS_VALIDATOR module UCS : sig - val min_value : int32 - val max_value : int32 - - (** Returns true if and only if the given value corresponds to a UCS - * non-character. Such non-characters are forbidden for use in open - * interchange of Unicode text data, and include the following: - * 1. values from 0xFDD0 to 0xFDEF; and - * 2. values 0xnFFFE and 0xnFFFF, where (0x0 <= n <= 0x10). - * See the Unicode 5.0 Standard, section 16.7 for further details. *) - val is_non_character : int32 -> bool - - (** Returns true if and only if the given value lies outside the - * entire UCS range. *) - val is_out_of_range : int32 -> bool - - (** Returns true if and only if the given value corresponds to a UCS - * surrogate code point, only for use in UTF-16 encoded strings. - * See the Unicode 5.0 Standard, section 16.6 for further details. *) - val is_surrogate : int32 -> bool + val min_value : int32 + val max_value : int32 + + (** Returns true if and only if the given value corresponds to a UCS + * non-character. Such non-characters are forbidden for use in open + * interchange of Unicode text data, and include the following: + * 1. values from 0xFDD0 to 0xFDEF; and + * 2. values 0xnFFFE and 0xnFFFF, where (0x0 <= n <= 0x10). + * See the Unicode 5.0 Standard, section 16.7 for further details. *) + val is_non_character : int32 -> bool + + (** Returns true if and only if the given value lies outside the + * entire UCS range. *) + val is_out_of_range : int32 -> bool + + (** Returns true if and only if the given value corresponds to a UCS + * surrogate code point, only for use in UTF-16 encoded strings. + * See the Unicode 5.0 Standard, section 16.6 for further details. *) + val is_surrogate : int32 -> bool end val (+++) : int32 -> int32 -> int32 @@ -70,92 +70,92 @@ val (<<<) : int32 -> int -> int32 val (>>>) : int32 -> int -> int32 module XML : sig - (** Returns true if and only if the given value corresponds to - * a forbidden control character as defined in section 2.2 of - * the XML specification, version 1.0. *) - val is_forbidden_control_character : int32 -> bool + (** Returns true if and only if the given value corresponds to + * a forbidden control character as defined in section 2.2 of + * the XML specification, version 1.0. *) + val is_forbidden_control_character : int32 -> bool end (** {2 Character Codecs} *) module type CHARACTER_ENCODER = sig - (** Encodes a single character value, returning a string containing - * the character. Raises an error if the character value is invalid. *) - val encode_character : int32 -> string + (** Encodes a single character value, returning a string containing + * the character. Raises an error if the character value is invalid. *) + val encode_character : int32 -> string end module type CHARACTER_DECODER = sig - (** Decodes a single character embedded within a string. Given a string - * and an index into that string, returns a tuple (value, width) where: - * value = the value of the character at the given index; and - * width = the width of the character at the given index, in bytes. - * Raises an appropriate error if the character is invalid. *) - val decode_character : string -> int -> int32 * int + (** Decodes a single character embedded within a string. Given a string + * and an index into that string, returns a tuple (value, width) where: + * value = the value of the character at the given index; and + * width = the width of the character at the given index, in bytes. + * Raises an appropriate error if the character is invalid. *) + val decode_character : string -> int -> int32 * int end module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) : sig - (** Given a valid UCS value, returns the canonical - * number of bytes required to encode the value. *) - val width_required_for_ucs_value : int32 -> int - - (** {3 Decoding} *) - - (** Decodes a header byte, returning a tuple (v, w) where: - * v = the (partial) value contained within the byte; and - * w = the total width of the encoded character, in bytes. *) - val decode_header_byte : int -> int * int - - (** Decodes a continuation byte, returning the - * 6-bit-wide value contained within the byte. *) - val decode_continuation_byte : int -> int - - (** Decodes a single character embedded within a string. Given a string - * and an index into that string, returns a tuple (value, width) where: - * value = the value of the character at the given index; and - * width = the width of the character at the given index, in bytes. - * Raises an appropriate error if the character is invalid. *) - val decode_character : string -> int -> int32 * int - - (** {3 Encoding} *) - - (** Encodes a header byte for the given parameters, where: - * width = the total width of the encoded character, in bytes; - * value = the most significant bits of the original UCS value. *) - val encode_header_byte : int -> int32 -> int32 - - (** Encodes a continuation byte from the given UCS - * remainder value, returning a tuple (b, r), where: - * b = the continuation byte; - * r = a new UCS remainder value. *) - val encode_continuation_byte : int32 -> int32 * int32 - - (** Encodes a single character value, returning a string containing - * the character. Raises an error if the character value is invalid. *) - val encode_character : int32 -> string + (** Given a valid UCS value, returns the canonical + * number of bytes required to encode the value. *) + val width_required_for_ucs_value : int32 -> int + + (** {3 Decoding} *) + + (** Decodes a header byte, returning a tuple (v, w) where: + * v = the (partial) value contained within the byte; and + * w = the total width of the encoded character, in bytes. *) + val decode_header_byte : int -> int * int + + (** Decodes a continuation byte, returning the + * 6-bit-wide value contained within the byte. *) + val decode_continuation_byte : int -> int + + (** Decodes a single character embedded within a string. Given a string + * and an index into that string, returns a tuple (value, width) where: + * value = the value of the character at the given index; and + * width = the width of the character at the given index, in bytes. + * Raises an appropriate error if the character is invalid. *) + val decode_character : string -> int -> int32 * int + + (** {3 Encoding} *) + + (** Encodes a header byte for the given parameters, where: + * width = the total width of the encoded character, in bytes; + * value = the most significant bits of the original UCS value. *) + val encode_header_byte : int -> int32 -> int32 + + (** Encodes a continuation byte from the given UCS + * remainder value, returning a tuple (b, r), where: + * b = the continuation byte; + * r = a new UCS remainder value. *) + val encode_continuation_byte : int32 -> int32 * int32 + + (** Encodes a single character value, returning a string containing + * the character. Raises an error if the character value is invalid. *) + val encode_character : int32 -> string end module UTF8_codec : sig - val width_required_for_ucs_value : int32 -> int - val decode_header_byte : int -> int * int - val decode_continuation_byte : int -> int - val decode_character : string -> int -> int32 * int - - val encode_header_byte : int -> int32 -> int32 - val encode_continuation_byte : int32 -> int32 * int32 - val encode_character : int32 -> string + val width_required_for_ucs_value : int32 -> int + val decode_header_byte : int -> int * int + val decode_continuation_byte : int -> int + val decode_character : string -> int -> int32 * int + + val encode_header_byte : int -> int32 -> int32 + val encode_continuation_byte : int32 -> int32 * int32 + val encode_character : int32 -> string end module XML_UTF8_codec : sig - val width_required_for_ucs_value : int32 -> int - val decode_header_byte : int -> int * int - val decode_continuation_byte : int -> int - val decode_character : string -> int -> int32 * int - - val encode_header_byte : int -> int32 -> int32 - val encode_continuation_byte : int32 -> int32 * int32 - val encode_character : int32 -> string + val width_required_for_ucs_value : int32 -> int + val decode_header_byte : int -> int * int + val decode_continuation_byte : int -> int + val decode_character : string -> int -> int32 * int + + val encode_header_byte : int -> int32 -> int32 + val encode_continuation_byte : int32 -> int32 * int32 + val encode_character : int32 -> string end (** {2 String Validators} *) @@ -164,14 +164,14 @@ end * strings according to a particular character encoding. *) module type STRING_VALIDATOR = sig - (** Returns true if and only if the given string is validly-encoded. *) - val is_valid : string -> bool + (** Returns true if and only if the given string is validly-encoded. *) + val is_valid : string -> bool - (** Raises an encoding error if the given string is not validly-encoded. *) - val validate: string -> unit + (** Raises an encoding error if the given string is not validly-encoded. *) + val validate: string -> unit - (** Returns the longest validly-encoded prefix of the given string. *) - val longest_valid_prefix : string -> string + (** Returns the longest validly-encoded prefix of the given string. *) + val longest_valid_prefix : string -> string end diff --git a/lib/extentlistSet.ml b/lib/extentlistSet.ml index eda19a8c8d9..d4dd3ccf5d4 100644 --- a/lib/extentlistSet.ml +++ b/lib/extentlistSet.ml @@ -1,106 +1,106 @@ module type Number = sig - type t - val zero: t - val add : t -> t -> t - val sub : t -> t -> t + type t + val zero: t + val add : t -> t -> t + val sub : t -> t -> t end module ExtentlistSet (A : Number) = struct - type extent = A.t * A.t - type t = extent list + type extent = A.t * A.t + type t = extent list - let ($+) = A.add - let ($-) = A.sub + let ($+) = A.add + let ($-) = A.sub - let empty = [] + let empty = [] - let sort list : t = - List.sort (fun x y -> compare (fst x) (fst y)) list + let sort list : t = + List.sort (fun x y -> compare (fst x) (fst y)) list - let remove_zeroes = List.filter (fun (_, y) -> y <> A.zero) + let remove_zeroes = List.filter (fun (_, y) -> y <> A.zero) - let union (list1: t) (list2: t) : t = - let combined = sort (list1 @ list2) in - let rec inner l acc = - match l with - | (s1,e1)::(s2,e2)::ls -> - let extent1_end = s1 $+ e1 in - if extent1_end < s2 then - inner ((s2,e2)::ls) ((s1,e1)::acc) - else - let extent2_end = s2 $+ e2 in - if extent1_end > extent2_end then - inner ((s1,e1)::ls) acc - else - inner ((s1,s2 $+ e2 $- s1)::ls) acc - | (s1,e1)::[] -> (s1,e1)::acc - | [] -> [] - in List.rev (inner combined []) + let union (list1: t) (list2: t) : t = + let combined = sort (list1 @ list2) in + let rec inner l acc = + match l with + | (s1,e1)::(s2,e2)::ls -> + let extent1_end = s1 $+ e1 in + if extent1_end < s2 then + inner ((s2,e2)::ls) ((s1,e1)::acc) + else + let extent2_end = s2 $+ e2 in + if extent1_end > extent2_end then + inner ((s1,e1)::ls) acc + else + inner ((s1,s2 $+ e2 $- s1)::ls) acc + | (s1,e1)::[] -> (s1,e1)::acc + | [] -> [] + in List.rev (inner combined []) - let intersection (list1: t) (list2: t) = - let rec inner l1 l2 acc = - match (l1,l2) with - | (s1,e1)::l1s , (s2,e2)::l2s -> - if s1 > s2 then inner l2 l1 acc else - if s1 $+ e1 < s2 then inner l1s l2 acc else - if s1 < s2 then inner ((s2,e1 $+ s1 $- s2)::l1s) l2 acc else - (* s1=s2 *) - if e1 < e2 then - inner l1s ((s2 $+ e1,e2 $- e1)::l2s) ((s1,e1)::acc) - else if e1 > e2 then - inner ((s1 $+ e2,e1 $- e2)::l1s) l2s ((s2,e2)::acc) - else (* e1=e2 *) - inner l1s l2s ((s1,e1)::acc) - | _ -> List.rev acc - in - remove_zeroes(inner list1 list2 []) + let intersection (list1: t) (list2: t) = + let rec inner l1 l2 acc = + match (l1,l2) with + | (s1,e1)::l1s , (s2,e2)::l2s -> + if s1 > s2 then inner l2 l1 acc else + if s1 $+ e1 < s2 then inner l1s l2 acc else + if s1 < s2 then inner ((s2,e1 $+ s1 $- s2)::l1s) l2 acc else + (* s1=s2 *) + if e1 < e2 then + inner l1s ((s2 $+ e1,e2 $- e1)::l2s) ((s1,e1)::acc) + else if e1 > e2 then + inner ((s1 $+ e2,e1 $- e2)::l1s) l2s ((s2,e2)::acc) + else (* e1=e2 *) + inner l1s l2s ((s1,e1)::acc) + | _ -> List.rev acc + in + remove_zeroes(inner list1 list2 []) - let difference (list1: t) (list2: t) : t = - let rec inner l1 l2 acc = - match (l1,l2) with - | (s1,e1)::l1s , (s2,e2)::l2s -> - if s1 s2 then - inner ((s2,s1 $+ e1 $- s2)::l1s) l2 ((s1,s2 $- s1)::acc) - else - inner l1s l2 ((s1,e1)::acc) - end else if s1>s2 then begin - if s2 $+ e2 > s1 then - inner l1 ((s1,s2 $+ e2 $- s1)::l2s) acc - else - inner l1 l2s acc - end else begin - (* s1=s2 *) - if e1 > e2 then - inner ((s1 $+ e2,e1 $- e2)::l1s) l2s acc - else if e1 < e2 then - inner l1s ((s2 $+ e1,e2 $- e1)::l2s) acc - else - inner l1s l2s acc - end - | l1s, [] -> (List.rev acc) @ l1s - | [], _ -> List.rev acc - in - remove_zeroes(inner list1 list2 []) + let difference (list1: t) (list2: t) : t = + let rec inner l1 l2 acc = + match (l1,l2) with + | (s1,e1)::l1s , (s2,e2)::l2s -> + if s1 s2 then + inner ((s2,s1 $+ e1 $- s2)::l1s) l2 ((s1,s2 $- s1)::acc) + else + inner l1s l2 ((s1,e1)::acc) + end else if s1>s2 then begin + if s2 $+ e2 > s1 then + inner l1 ((s1,s2 $+ e2 $- s1)::l2s) acc + else + inner l1 l2s acc + end else begin + (* s1=s2 *) + if e1 > e2 then + inner ((s1 $+ e2,e1 $- e2)::l1s) l2s acc + else if e1 < e2 then + inner l1s ((s2 $+ e1,e2 $- e1)::l2s) acc + else + inner l1s l2s acc + end + | l1s, [] -> (List.rev acc) @ l1s + | [], _ -> List.rev acc + in + remove_zeroes(inner list1 list2 []) - let of_list (list: extent list) : t = - let l = sort list in - let rec inner ls acc = - match ls with - | (s1,e1)::(s2,e2)::rest -> - (* extents should be non-overlapping *) - if s1 $+ e1 > s2 then failwith "Bad list" - (* adjacent extents should be coalesced *) - else if s1 $+ e1=s2 then inner ((s1,e1 $+ e2)::rest) acc - else inner ((s2,e2)::rest) ((s1,e1)::acc) - | (s1,e1)::[] -> List.rev ((s1,e1)::acc) - | [] -> List.rev acc - in - inner l [] + let of_list (list: extent list) : t = + let l = sort list in + let rec inner ls acc = + match ls with + | (s1,e1)::(s2,e2)::rest -> + (* extents should be non-overlapping *) + if s1 $+ e1 > s2 then failwith "Bad list" + (* adjacent extents should be coalesced *) + else if s1 $+ e1=s2 then inner ((s1,e1 $+ e2)::rest) acc + else inner ((s2,e2)::rest) ((s1,e1)::acc) + | (s1,e1)::[] -> List.rev ((s1,e1)::acc) + | [] -> List.rev acc + in + inner l [] - let fold_left = List.fold_left + let fold_left = List.fold_left - let to_list x = x + let to_list x = x end diff --git a/lib/extentlistSet.mli b/lib/extentlistSet.mli index e46e29a8e51..6856d32a455 100644 --- a/lib/extentlistSet.mli +++ b/lib/extentlistSet.mli @@ -2,26 +2,26 @@ (** Elements must be 'Numbers': *) module type Number = sig - type t - val zero: t - val add : t -> t -> t - val sub : t -> t -> t + type t + val zero: t + val add : t -> t -> t + val sub : t -> t -> t end (** Representation of a Set *) module ExtentlistSet: functor (A : Number) -> sig - type extent = A.t * A.t - type t + type extent = A.t * A.t + type t - val empty : t + val empty : t - val union : t -> t -> t - val intersection : t -> t -> t - val difference : t -> t -> t + val union : t -> t -> t + val intersection : t -> t -> t + val difference : t -> t -> t - val of_list : extent list -> t - val to_list : t -> extent list - val fold_left : ('a -> extent -> 'a) -> 'a -> t -> 'a + val of_list : extent list -> t + val to_list : t -> extent list + val fold_left : ('a -> extent -> 'a) -> 'a -> t -> 'a end diff --git a/lib/filenameext.ml b/lib/filenameext.ml index eb15bc6773e..6160372d177 100644 --- a/lib/filenameext.ml +++ b/lib/filenameext.ml @@ -26,5 +26,5 @@ let temp_file_in_dir otherfile = in keep_trying () - - + + diff --git a/lib/fring.ml b/lib/fring.ml index 2a7439161f0..c3efd30290a 100644 --- a/lib/fring.ml +++ b/lib/fring.ml @@ -15,66 +15,66 @@ type t = { size: int; mutable current: int; data: (float,Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t ; } let make size init = - let ring = - { size = size; current = size - 1; data = Bigarray.Array1.create Bigarray.float32 Bigarray.c_layout size; } - in - Bigarray.Array1.fill ring.data init; - ring + let ring = + { size = size; current = size - 1; data = Bigarray.Array1.create Bigarray.float32 Bigarray.c_layout size; } + in + Bigarray.Array1.fill ring.data init; + ring let copy x = - let y = make x.size 0. in - Bigarray.Array1.blit x.data y.data; - y.current <- x.current; - y + let y = make x.size 0. in + Bigarray.Array1.blit x.data y.data; + y.current <- x.current; + y let length ring = ring.size let push ring e = - ring.current <- ring.current + 1; - if ring.current = ring.size then - ring.current <- 0; - Bigarray.Array1.set ring.data ring.current e + ring.current <- ring.current + 1; + if ring.current = ring.size then + ring.current <- 0; + Bigarray.Array1.set ring.data ring.current e let peek ring i = - if i >= ring.size then - raise (Invalid_argument "peek: index"); - let index = - let offset = ring.current - i in - if offset >= 0 then offset else ring.size + offset in - Bigarray.Array1.get ring.data index + if i >= ring.size then + raise (Invalid_argument "peek: index"); + let index = + let offset = ring.current - i in + if offset >= 0 then offset else ring.size + offset in + Bigarray.Array1.get ring.data index let top ring = Bigarray.Array1.get ring.data ring.current let iter_nb ring f nb = - if nb > ring.size then - raise (Invalid_argument "iter_nb: nb"); - (* FIXME: OPTIMIZE ME with 2 Array.iter ? *) - for i = 0 to nb - 1 - do - f (peek ring i) - done + if nb > ring.size then + raise (Invalid_argument "iter_nb: nb"); + (* FIXME: OPTIMIZE ME with 2 Array.iter ? *) + for i = 0 to nb - 1 + do + f (peek ring i) + done (* iter directly on all element without using the index *) let iter f a = - for i=0 to Bigarray.Array1.dim a - 1 do - f (Bigarray.Array1.get a i) - done + for i=0 to Bigarray.Array1.dim a - 1 do + f (Bigarray.Array1.get a i) + done let raw_iter ring f = - iter f ring.data + iter f ring.data let iter ring f = iter_nb ring f (ring.size) let get_nb ring nb = - if nb > ring.size then - raise (Invalid_argument "get_nb: nb"); - let a = Array.create nb (top ring) in - for i = 1 to nb - 1 - do - (* FIXME: OPTIMIZE ME with 2 Array.blit *) - a.(i) <- peek ring i - done; - a + if nb > ring.size then + raise (Invalid_argument "get_nb: nb"); + let a = Array.create nb (top ring) in + for i = 1 to nb - 1 + do + (* FIXME: OPTIMIZE ME with 2 Array.blit *) + a.(i) <- peek ring i + done; + a let get ring = get_nb ring (ring.size) diff --git a/lib/fring.mli b/lib/fring.mli index d7569ccc85b..bb653795638 100644 --- a/lib/fring.mli +++ b/lib/fring.mli @@ -12,7 +12,7 @@ * GNU Lesser General Public License for more details. *) (** Ring structures *) - + type t = { size : int; mutable current : int; diff --git a/lib/hashtblext.ml b/lib/hashtblext.ml index c1eb01beb5c..a89833e5fe4 100644 --- a/lib/hashtblext.ml +++ b/lib/hashtblext.ml @@ -13,30 +13,30 @@ *) let to_list tbl = - Hashtbl.fold (fun k v acc -> (k, v) :: acc) tbl [] + Hashtbl.fold (fun k v acc -> (k, v) :: acc) tbl [] (* this is not a fold ... *) let fold_keys tbl = - Hashtbl.fold (fun k _ acc -> k :: acc) tbl [] + Hashtbl.fold (fun k _ acc -> k :: acc) tbl [] (* ... neither is this *) let fold_values tbl = - Hashtbl.fold (fun _ v acc -> v :: acc) tbl [] + Hashtbl.fold (fun _ v acc -> v :: acc) tbl [] let add_empty tbl k v = - if not (Hashtbl.mem tbl k) then - Hashtbl.add tbl k v + if not (Hashtbl.mem tbl k) then + Hashtbl.add tbl k v let add_list tbl l = - List.iter (fun (k, v) -> Hashtbl.add tbl k v) l + List.iter (fun (k, v) -> Hashtbl.add tbl k v) l let remove_other_keys tbl valid_keys = - let keys = fold_keys tbl in - let maybe_remove k = - if not (List.mem k valid_keys) then Hashtbl.remove tbl k in - List.iter maybe_remove keys + let keys = fold_keys tbl in + let maybe_remove k = + if not (List.mem k valid_keys) then Hashtbl.remove tbl k in + List.iter maybe_remove keys let of_list l = - let tbl = Hashtbl.create (List.length l) in - add_list tbl l; - tbl + let tbl = Hashtbl.create (List.length l) in + add_list tbl l; + tbl diff --git a/lib/hashtblext.mli b/lib/hashtblext.mli index 0741741593b..0c4a017288a 100644 --- a/lib/hashtblext.mli +++ b/lib/hashtblext.mli @@ -11,15 +11,15 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) - val to_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list +val to_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list (* this is not a fold ... *) - val fold_keys : ('a, 'b) Hashtbl.t -> 'a list +val fold_keys : ('a, 'b) Hashtbl.t -> 'a list (* ... neither is this *) - val fold_values : ('a, 'b) Hashtbl.t -> 'b list +val fold_values : ('a, 'b) Hashtbl.t -> 'b list - val add_empty : ('a, 'b) Hashtbl.t -> 'a -> 'b -> unit - val add_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list -> unit - val remove_other_keys : ('a, 'b) Hashtbl.t -> 'a list -> unit - val of_list : ('a * 'b) list -> ('a, 'b) Hashtbl.t +val add_empty : ('a, 'b) Hashtbl.t -> 'a -> 'b -> unit +val add_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list -> unit +val remove_other_keys : ('a, 'b) Hashtbl.t -> 'a list -> unit +val of_list : ('a * 'b) list -> ('a, 'b) Hashtbl.t diff --git a/lib/int64ext.ml b/lib/int64ext.ml index 27c3442671a..0c0cacd0dfa 100644 --- a/lib/int64ext.ml +++ b/lib/int64ext.ml @@ -1,17 +1,17 @@ module Int64 = struct - module Operators = struct + module Operators = struct - let ( +++ ) = Int64.add - let ( --- ) = Int64.sub - let ( *** ) = Int64.mul - let ( /// ) = Int64.div - let ( &&& ) = Int64.logand - let ( ||| ) = Int64.logor - let ( <<< ) = Int64.shift_left - let ( >>> ) = Int64.shift_right_logical - let ( !!! ) = Int64.lognot + let ( +++ ) = Int64.add + let ( --- ) = Int64.sub + let ( *** ) = Int64.mul + let ( /// ) = Int64.div + let ( &&& ) = Int64.logand + let ( ||| ) = Int64.logor + let ( <<< ) = Int64.shift_left + let ( >>> ) = Int64.shift_right_logical + let ( !!! ) = Int64.lognot - end + end end diff --git a/lib/int64ext.mli b/lib/int64ext.mli index c8441f54f6c..c8fce2266dd 100644 --- a/lib/int64ext.mli +++ b/lib/int64ext.mli @@ -1,17 +1,17 @@ module Int64 : sig - module Operators : sig + module Operators : sig - val ( +++ ) : int64 -> int64 -> int64 - val ( --- ) : int64 -> int64 -> int64 - val ( *** ) : int64 -> int64 -> int64 - val ( /// ) : int64 -> int64 -> int64 - val ( &&& ) : int64 -> int64 -> int64 - val ( ||| ) : int64 -> int64 -> int64 - val ( <<< ) : int64 -> int -> int64 - val ( >>> ) : int64 -> int -> int64 - val ( !!! ) : int64 -> int64 + val ( +++ ) : int64 -> int64 -> int64 + val ( --- ) : int64 -> int64 -> int64 + val ( *** ) : int64 -> int64 -> int64 + val ( /// ) : int64 -> int64 -> int64 + val ( &&& ) : int64 -> int64 -> int64 + val ( ||| ) : int64 -> int64 -> int64 + val ( <<< ) : int64 -> int -> int64 + val ( >>> ) : int64 -> int -> int64 + val ( !!! ) : int64 -> int64 - end + end end \ No newline at end of file diff --git a/lib/lazyList.ml b/lib/lazyList.ml index b25b06b84e3..8b91934bc29 100644 --- a/lib/lazyList.ml +++ b/lib/lazyList.ml @@ -1,20 +1,20 @@ (* A lazy-list implementation *) type 'a elt = - | Empty - | Cons of 'a * 'a t + | Empty + | Cons of 'a * 'a t and 'a t = 'a elt lazy_t let rec map f xs = lazy(match Lazy.force xs with - | Empty -> Empty - | Cons(x, xs) -> Cons(f x, map f xs)) - + | Empty -> Empty + | Cons(x, xs) -> Cons(f x, map f xs)) + let rec take n xs = lazy(match n, Lazy.force xs with - | 0, _ -> Empty - | _, Empty -> raise Not_found - | n, Cons(x, xs) -> Cons(x, take (n - 1) xs)) - + | 0, _ -> Empty + | _, Empty -> raise Not_found + | n, Cons(x, xs) -> Cons(x, take (n - 1) xs)) + let rec iter f xs = match Lazy.force xs with - | Empty -> () - | Cons(x, xs) -> f x; iter f xs + | Empty -> () + | Cons(x, xs) -> f x; iter f xs diff --git a/lib/listext.ml b/lib/listext.ml index 57f5baddadb..5000867d7c1 100644 --- a/lib/listext.ml +++ b/lib/listext.ml @@ -14,219 +14,219 @@ open Fun module List = struct include List -module Monad = Monad.M1.Make (struct + module Monad = Monad.M1.Make (struct - type 'a m = 'a list + type 'a m = 'a list - let bind list f = - let rec inner result = function - | x :: xs -> inner (List.rev_append (f x) result) xs - | [] -> List.rev result - in - inner [] list + let bind list f = + let rec inner result = function + | x :: xs -> inner (List.rev_append (f x) result) xs + | [] -> List.rev result + in + inner [] list - let return x = [x] + let return x = [x] -end) + end) -(** Turn a list into a set *) -let rec setify = function - | [] -> [] - | (x::xs) -> if mem x xs then setify xs else x::(setify xs) - -let subset s1 s2 = List.fold_left (&&) true (List.map (fun s->List.mem s s2) s1) -let set_equiv s1 s2 = (subset s1 s2) && (subset s2 s1) + (** Turn a list into a set *) + let rec setify = function + | [] -> [] + | (x::xs) -> if mem x xs then setify xs else x::(setify xs) + + let subset s1 s2 = List.fold_left (&&) true (List.map (fun s->List.mem s s2) s1) + let set_equiv s1 s2 = (subset s1 s2) && (subset s2 s1) -let iteri f list = ignore (fold_left (fun i x -> f i x; i+1) 0 list) -let iteri_right f list = ignore (fold_right (fun x i -> f i x; i+1) list 0) + let iteri f list = ignore (fold_left (fun i x -> f i x; i+1) 0 list) + let iteri_right f list = ignore (fold_right (fun x i -> f i x; i+1) list 0) -let rec inv_assoc k = function - | [] -> raise Not_found - | (v, k') :: _ when k = k' -> v - | _ :: t -> inv_assoc k t + let rec inv_assoc k = function + | [] -> raise Not_found + | (v, k') :: _ when k = k' -> v + | _ :: t -> inv_assoc k t -(* Tail-recursive map. *) -let map_tr f l = rev (rev_map f l) + (* Tail-recursive map. *) + let map_tr f l = rev (rev_map f l) -let count pred l = - fold_left (fun count e -> count + if pred e then 1 else 0) 0 l + let count pred l = + fold_left (fun count e -> count + if pred e then 1 else 0) 0 l -let position pred l = - let aux (i, is) e = i + 1, if pred e then i :: is else is in - snd (fold_left aux (0, []) l) - -let mapi f l = - let rec aux n = function - | h :: t -> let h = f n h in h :: aux (n + 1) t - | [] -> [] in - aux 0 l - -let rev_mapi f l = - let rec aux n accu = function - | h :: t -> aux (n + 1) (f n h :: accu) t - | [] -> accu in - aux 0 [] l - -let mapi_tr f l = rev (rev_mapi f l) - -let rec chop i l = match i, l with - | 0, l -> [], l - | i, h :: t -> (fun (fr, ba) -> h :: fr, ba) (chop (i - 1) t) - | _ -> invalid_arg "chop" - -let rev_chop i l = - let rec aux i fr ba = match i, fr, ba with - | 0, fr, ba -> (fr, ba) - | i, fr, h :: t -> aux (i - 1) (h :: fr) t - | _ -> invalid_arg "rev_chop" in - aux i [] l + let position pred l = + let aux (i, is) e = i + 1, if pred e then i :: is else is in + snd (fold_left aux (0, []) l) + + let mapi f l = + let rec aux n = function + | h :: t -> let h = f n h in h :: aux (n + 1) t + | [] -> [] in + aux 0 l + + let rev_mapi f l = + let rec aux n accu = function + | h :: t -> aux (n + 1) (f n h :: accu) t + | [] -> accu in + aux 0 [] l + + let mapi_tr f l = rev (rev_mapi f l) + + let rec chop i l = match i, l with + | 0, l -> [], l + | i, h :: t -> (fun (fr, ba) -> h :: fr, ba) (chop (i - 1) t) + | _ -> invalid_arg "chop" + + let rev_chop i l = + let rec aux i fr ba = match i, fr, ba with + | 0, fr, ba -> (fr, ba) + | i, fr, h :: t -> aux (i - 1) (h :: fr) t + | _ -> invalid_arg "rev_chop" in + aux i [] l -let chop_tr i l = - (fun (fr, ba) -> rev fr, ba) (rev_chop i l) + let chop_tr i l = + (fun (fr, ba) -> rev fr, ba) (rev_chop i l) -let rec dice m l = match chop m l with - | l, [] -> [l] - | l1, l2 -> l1 :: dice m l2 - -let sub i j l = - fst (chop_tr (j - i) (snd (rev_chop i l))) - -let remove i l = match rev_chop i l with - | rfr, _ :: t -> rev_append rfr t - | _ -> invalid_arg "remove" - -let extract i l = match rev_chop i l with - | rfr, h :: t -> h, rev_append rfr t - | _ -> invalid_arg "extract" - -let insert i e l = match rev_chop i l with - rfr, ba -> rev_append rfr (e :: ba) - -let replace i e l = match rev_chop i l with - | rfr, _ :: t -> rev_append rfr (e :: t) - | _ -> invalid_arg "replace" - -let morph i f l = match rev_chop i l with - | rfr, h :: t -> rev_append rfr (f h :: t) - | _ -> invalid_arg "morph" - -let rec between e = function - | [] -> [] - | [h] -> [h] - | h :: t -> h :: e :: between e t - - -let between_tr e l = - let rec aux accu e = function - | [] -> rev accu - | [h] -> rev (h :: accu) - | h :: t -> aux (e :: h :: accu) e t in - aux [] e l - -let randomize l = - let extract_rand l = extract (Random.int (length l)) l in - let rec aux accu = function - | [] -> accu - | l -> (fun (h, t) -> aux (h :: accu) t) (extract_rand l) in - aux [] l - -let rec distribute e = function - | (h :: t) as l -> - (e :: l) :: (map (fun x -> h :: x) (distribute e t)) - | [] -> [ [ e ] ] - -let rec permute = function - | e :: rest -> flatten (map (distribute e) (permute rest)) - | [] -> [ [] ] - -let rec aux_rle_eq eq l2 x n = function - | [] -> rev ((x, n) :: l2) - | h :: t when eq x h -> aux_rle_eq eq l2 x (n + 1) t - | h :: t -> aux_rle_eq eq ((x, n) :: l2) h 1 t - -let rle_eq eq l = - match l with [] -> [] | h :: t -> aux_rle_eq eq [] h 1 t - -let rle l = rle_eq ( = ) l - -let unrle l = - let rec aux2 accu i c = match i with - | 0 -> accu - | i when i>0 -> aux2 (c :: accu) (i - 1) c - | _ -> invalid_arg "unrle" in - let rec aux accu = function - | [] -> rev accu - | (i, c) :: t -> aux (aux2 accu i c) t in - aux [] l - -let inner fold_left2 base f l1 l2 g = - fold_left2 (fun accu e1 e2 -> g accu (f e1 e2)) base l1 l2 - -let rec is_sorted compare list = - match list with - | x :: y :: list -> - if compare x y <= 0 - then is_sorted compare (y :: list) - else false - | _ -> - true - -let intersect xs ys = List.filter (fun x -> List.mem x ys) xs - -let set_difference a b = List.filter (fun x -> not(List.mem x b)) a - -let assoc_default k l d = - if List.mem_assoc k l then List.assoc k l else d - -let map_assoc_with_key op al = - List.map (fun (k, v1) -> (k, op k v1)) al - -(* Like the Lisp cons *) -let cons a b = a :: b - -(* Could use fold_left to get the same value, but that would necessarily go through the whole list everytime, instead of the first n items, only. *) -(* ToDo: This is complicated enough to warrant a test. *) -(* Is it wise to fail silently on negative values? (They are treated as zero, here.) - Pro: Would mask fewer bugs. - Con: Less robust. -*) -let take n list = - let rec helper i acc list = - if i <= 0 || list = [] - then acc - else helper (i-1) (List.hd list :: acc) (List.tl list) - in List.rev $ helper n [] list - -(* Thanks to sharing we only use linear space. (Roughly double the space needed for the spine of the original list) *) -let rec tails = function - | [] -> [[]] - | (_::xs) as l -> l :: tails xs - -let safe_hd = function - | a::_ -> Some a - | [] -> None - -let replace_assoc key new_value existing = - (key, new_value) :: (List.filter (fun (k, _) -> k <> key) existing) - -let update_assoc update existing = - update @ (List.filter (fun (k, _) -> not (List.mem_assoc k update)) existing) - -let make_assoc op l = map (fun key -> key, op key) l - -let unbox_list a = List.map Opt.unbox (List.filter Opt.is_boxed a) - -let filter_map f list = - (unbox_list +++ map) f list - -let restrict_with_default default keys al = - make_assoc (fun k -> assoc_default k al default) keys - -let range lower = - let rec aux accu upper = - if lower >= upper - then accu - else aux (upper-1::accu) (upper-1) in - aux [] + let rec dice m l = match chop m l with + | l, [] -> [l] + | l1, l2 -> l1 :: dice m l2 + + let sub i j l = + fst (chop_tr (j - i) (snd (rev_chop i l))) + + let remove i l = match rev_chop i l with + | rfr, _ :: t -> rev_append rfr t + | _ -> invalid_arg "remove" + + let extract i l = match rev_chop i l with + | rfr, h :: t -> h, rev_append rfr t + | _ -> invalid_arg "extract" + + let insert i e l = match rev_chop i l with + rfr, ba -> rev_append rfr (e :: ba) + + let replace i e l = match rev_chop i l with + | rfr, _ :: t -> rev_append rfr (e :: t) + | _ -> invalid_arg "replace" + + let morph i f l = match rev_chop i l with + | rfr, h :: t -> rev_append rfr (f h :: t) + | _ -> invalid_arg "morph" + + let rec between e = function + | [] -> [] + | [h] -> [h] + | h :: t -> h :: e :: between e t + + + let between_tr e l = + let rec aux accu e = function + | [] -> rev accu + | [h] -> rev (h :: accu) + | h :: t -> aux (e :: h :: accu) e t in + aux [] e l + + let randomize l = + let extract_rand l = extract (Random.int (length l)) l in + let rec aux accu = function + | [] -> accu + | l -> (fun (h, t) -> aux (h :: accu) t) (extract_rand l) in + aux [] l + + let rec distribute e = function + | (h :: t) as l -> + (e :: l) :: (map (fun x -> h :: x) (distribute e t)) + | [] -> [ [ e ] ] + + let rec permute = function + | e :: rest -> flatten (map (distribute e) (permute rest)) + | [] -> [ [] ] + + let rec aux_rle_eq eq l2 x n = function + | [] -> rev ((x, n) :: l2) + | h :: t when eq x h -> aux_rle_eq eq l2 x (n + 1) t + | h :: t -> aux_rle_eq eq ((x, n) :: l2) h 1 t + + let rle_eq eq l = + match l with [] -> [] | h :: t -> aux_rle_eq eq [] h 1 t + + let rle l = rle_eq ( = ) l + + let unrle l = + let rec aux2 accu i c = match i with + | 0 -> accu + | i when i>0 -> aux2 (c :: accu) (i - 1) c + | _ -> invalid_arg "unrle" in + let rec aux accu = function + | [] -> rev accu + | (i, c) :: t -> aux (aux2 accu i c) t in + aux [] l + + let inner fold_left2 base f l1 l2 g = + fold_left2 (fun accu e1 e2 -> g accu (f e1 e2)) base l1 l2 + + let rec is_sorted compare list = + match list with + | x :: y :: list -> + if compare x y <= 0 + then is_sorted compare (y :: list) + else false + | _ -> + true + + let intersect xs ys = List.filter (fun x -> List.mem x ys) xs + + let set_difference a b = List.filter (fun x -> not(List.mem x b)) a + + let assoc_default k l d = + if List.mem_assoc k l then List.assoc k l else d + + let map_assoc_with_key op al = + List.map (fun (k, v1) -> (k, op k v1)) al + + (* Like the Lisp cons *) + let cons a b = a :: b + + (* Could use fold_left to get the same value, but that would necessarily go through the whole list everytime, instead of the first n items, only. *) + (* ToDo: This is complicated enough to warrant a test. *) + (* Is it wise to fail silently on negative values? (They are treated as zero, here.) + Pro: Would mask fewer bugs. + Con: Less robust. + *) + let take n list = + let rec helper i acc list = + if i <= 0 || list = [] + then acc + else helper (i-1) (List.hd list :: acc) (List.tl list) + in List.rev $ helper n [] list + + (* Thanks to sharing we only use linear space. (Roughly double the space needed for the spine of the original list) *) + let rec tails = function + | [] -> [[]] + | (_::xs) as l -> l :: tails xs + + let safe_hd = function + | a::_ -> Some a + | [] -> None + + let replace_assoc key new_value existing = + (key, new_value) :: (List.filter (fun (k, _) -> k <> key) existing) + + let update_assoc update existing = + update @ (List.filter (fun (k, _) -> not (List.mem_assoc k update)) existing) + + let make_assoc op l = map (fun key -> key, op key) l + + let unbox_list a = List.map Opt.unbox (List.filter Opt.is_boxed a) + + let filter_map f list = + (unbox_list +++ map) f list + + let restrict_with_default default keys al = + make_assoc (fun k -> assoc_default k al default) keys + + let range lower = + let rec aux accu upper = + if lower >= upper + then accu + else aux (upper-1::accu) (upper-1) in + aux [] end diff --git a/lib/listext.mli b/lib/listext.mli index ab141d5b694..98cce700016 100644 --- a/lib/listext.mli +++ b/lib/listext.mli @@ -13,199 +13,199 @@ *) module List : sig - module Monad : sig include Monad.M1.MONAD with type 'a m = 'a list end - val setify : 'a list -> 'a list - val subset : 'a list -> 'a list -> bool - val set_equiv : 'a list -> 'a list -> bool - val length : 'a list -> int - val hd : 'a list -> 'a - val tl : 'a list -> 'a list - val nth : 'a list -> int -> 'a - val rev : 'a list -> 'a list - val append : 'a list -> 'a list -> 'a list - val rev_append : 'a list -> 'a list -> 'a list - val concat : 'a list list -> 'a list - val flatten : 'a list list -> 'a list - val iter : ('a -> unit) -> 'a list -> unit - val map : ('a -> 'b) -> 'a list -> 'b list - val rev_map : ('a -> 'b) -> 'a list -> 'b list - val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a - val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b - val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit - val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list - val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list - val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a - val fold_right2 : - ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c - val for_all : ('a -> bool) -> 'a list -> bool - val exists : ('a -> bool) -> 'a list -> bool - val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool - val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool - val mem : 'a -> 'a list -> bool - val memq : 'a -> 'a list -> bool - val find : ('a -> bool) -> 'a list -> 'a - val filter : ('a -> bool) -> 'a list -> 'a list - val find_all : ('a -> bool) -> 'a list -> 'a list - val partition : ('a -> bool) -> 'a list -> 'a list * 'a list - val assoc : 'a -> ('a * 'b) list -> 'b - val assq : 'a -> ('a * 'b) list -> 'b - val mem_assoc : 'a -> ('a * 'b) list -> bool - val mem_assq : 'a -> ('a * 'b) list -> bool - val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list - val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list - val split : ('a * 'b) list -> 'a list * 'b list - val combine : 'a list -> 'b list -> ('a * 'b) list - val sort : ('a -> 'a -> int) -> 'a list -> 'a list - val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list - val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list - val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list - - (** Perform a lookup on an association list of (value, key) pairs. *) - val inv_assoc : 'a -> ('b * 'a) list -> 'b - - (** A tail-recursive map. *) - val map_tr : ('a -> 'b) -> 'a list -> 'b list - - (** Count the number of list elements matching the given predicate. *) - val count : ('a -> bool) -> 'a list -> int - - (** Find the indices of all elements matching the given predicate. *) - val position : ('a -> bool) -> 'a list -> int list - - (** Map the given function over a list, supplying the integer - index as well as the element value. *) - val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list - - val iteri : (int -> 'a -> unit) -> 'a list -> unit - - val iteri_right : (int -> 'a -> unit) -> 'a list -> unit - - (** Map the given function over a list in reverse order. *) - val rev_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list - - (** Tail-recursive [mapi]. *) - val mapi_tr : (int -> 'a -> 'b) -> 'a list -> 'b list - - (** Split a list at the given index to give a pair of lists. *) - val chop : int -> 'a list -> 'a list * 'a list - - (** Split a list at the given index to give a pair of lists, the first in - reverse order. *) - val rev_chop : int -> 'a list -> 'a list * 'a list - - (** Tail-recursive [chop]. *) - val chop_tr : int -> 'a list -> 'a list * 'a list - - (** Split a list into lists with the given number of elements. *) - val dice : int -> 'a list -> 'a list list - - (** Extract the sub-list between the given indices. *) - val sub : int -> int -> 'a list -> 'a list - - (** Remove the element at the given index. *) - val remove : int -> 'a list -> 'a list - - (** Extract the element at the given index, returning the element and the - list without that element. *) - val extract : int -> 'a list -> 'a * 'a list - - (** Insert the given element at the given index. *) - val insert : int -> 'a -> 'a list -> 'a list - - (** Replace the element at the given index with the given value. *) - val replace : int -> 'a -> 'a list -> 'a list - - (** Apply the given function to the element at the given index. *) - val morph : int -> ('a -> 'a) -> 'a list -> 'a list - - (** Insert the element [e] between every pair of adjacent elements in the - given list. *) - val between : 'a -> 'a list -> 'a list - - (** Tail-recursive [between]. *) - val between_tr : 'a -> 'a list -> 'a list - - (** Generate a random permutation of the given list. *) - val randomize : 'a list -> 'a list - - (** Distribute the given element over the given list, returning a list of - lists with the new element in each position. *) - val distribute : 'a -> 'a list -> 'a list list - - (** Generate all permutations of the given list. *) - val permute : 'a list -> 'a list list + module Monad : sig include Monad.M1.MONAD with type 'a m = 'a list end + val setify : 'a list -> 'a list + val subset : 'a list -> 'a list -> bool + val set_equiv : 'a list -> 'a list -> bool + val length : 'a list -> int + val hd : 'a list -> 'a + val tl : 'a list -> 'a list + val nth : 'a list -> int -> 'a + val rev : 'a list -> 'a list + val append : 'a list -> 'a list -> 'a list + val rev_append : 'a list -> 'a list -> 'a list + val concat : 'a list list -> 'a list + val flatten : 'a list list -> 'a list + val iter : ('a -> unit) -> 'a list -> unit + val map : ('a -> 'b) -> 'a list -> 'b list + val rev_map : ('a -> 'b) -> 'a list -> 'b list + val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a + val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b + val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit + val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a + val fold_right2 : + ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c + val for_all : ('a -> bool) -> 'a list -> bool + val exists : ('a -> bool) -> 'a list -> bool + val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + val mem : 'a -> 'a list -> bool + val memq : 'a -> 'a list -> bool + val find : ('a -> bool) -> 'a list -> 'a + val filter : ('a -> bool) -> 'a list -> 'a list + val find_all : ('a -> bool) -> 'a list -> 'a list + val partition : ('a -> bool) -> 'a list -> 'a list * 'a list + val assoc : 'a -> ('a * 'b) list -> 'b + val assq : 'a -> ('a * 'b) list -> 'b + val mem_assoc : 'a -> ('a * 'b) list -> bool + val mem_assq : 'a -> ('a * 'b) list -> bool + val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list + val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list + val split : ('a * 'b) list -> 'a list * 'b list + val combine : 'a list -> 'b list -> ('a * 'b) list + val sort : ('a -> 'a -> int) -> 'a list -> 'a list + val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list + val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list + val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list + + (** Perform a lookup on an association list of (value, key) pairs. *) + val inv_assoc : 'a -> ('b * 'a) list -> 'b + + (** A tail-recursive map. *) + val map_tr : ('a -> 'b) -> 'a list -> 'b list + + (** Count the number of list elements matching the given predicate. *) + val count : ('a -> bool) -> 'a list -> int + + (** Find the indices of all elements matching the given predicate. *) + val position : ('a -> bool) -> 'a list -> int list + + (** Map the given function over a list, supplying the integer + index as well as the element value. *) + val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list + + val iteri : (int -> 'a -> unit) -> 'a list -> unit + + val iteri_right : (int -> 'a -> unit) -> 'a list -> unit + + (** Map the given function over a list in reverse order. *) + val rev_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list + + (** Tail-recursive [mapi]. *) + val mapi_tr : (int -> 'a -> 'b) -> 'a list -> 'b list + + (** Split a list at the given index to give a pair of lists. *) + val chop : int -> 'a list -> 'a list * 'a list + + (** Split a list at the given index to give a pair of lists, the first in + reverse order. *) + val rev_chop : int -> 'a list -> 'a list * 'a list + + (** Tail-recursive [chop]. *) + val chop_tr : int -> 'a list -> 'a list * 'a list + + (** Split a list into lists with the given number of elements. *) + val dice : int -> 'a list -> 'a list list + + (** Extract the sub-list between the given indices. *) + val sub : int -> int -> 'a list -> 'a list + + (** Remove the element at the given index. *) + val remove : int -> 'a list -> 'a list + + (** Extract the element at the given index, returning the element and the + list without that element. *) + val extract : int -> 'a list -> 'a * 'a list + + (** Insert the given element at the given index. *) + val insert : int -> 'a -> 'a list -> 'a list + + (** Replace the element at the given index with the given value. *) + val replace : int -> 'a -> 'a list -> 'a list + + (** Apply the given function to the element at the given index. *) + val morph : int -> ('a -> 'a) -> 'a list -> 'a list + + (** Insert the element [e] between every pair of adjacent elements in the + given list. *) + val between : 'a -> 'a list -> 'a list + + (** Tail-recursive [between]. *) + val between_tr : 'a -> 'a list -> 'a list + + (** Generate a random permutation of the given list. *) + val randomize : 'a list -> 'a list + + (** Distribute the given element over the given list, returning a list of + lists with the new element in each position. *) + val distribute : 'a -> 'a list -> 'a list list + + (** Generate all permutations of the given list. *) + val permute : 'a list -> 'a list list - (** Run-length encode the given list using the given equality function. *) - val rle_eq : ('a -> 'a -> bool) -> 'a list -> ('a * int) list + (** Run-length encode the given list using the given equality function. *) + val rle_eq : ('a -> 'a -> bool) -> 'a list -> ('a * int) list - (** Run-length encode the given list using built-in equality. *) - val rle : 'a list -> ('a * int) list + (** Run-length encode the given list using built-in equality. *) + val rle : 'a list -> ('a * int) list - (** Decode a run-length encoded list. *) - val unrle : (int * 'a) list -> 'a list + (** Decode a run-length encoded list. *) + val unrle : (int * 'a) list -> 'a list - (** Compute the inner product of two lists. *) - val inner : - (('a -> 'b -> 'c -> 'd) -> 'e -> 'f -> 'g -> 'h) -> - 'e -> ('b -> 'c -> 'i) -> 'f -> 'g -> ('a -> 'i -> 'd) -> 'h + (** Compute the inner product of two lists. *) + val inner : + (('a -> 'b -> 'c -> 'd) -> 'e -> 'f -> 'g -> 'h) -> + 'e -> ('b -> 'c -> 'i) -> 'f -> 'g -> ('a -> 'i -> 'd) -> 'h - (** Applies a function f that generates optional values, to each - of the items in a list A [a1; ...; am], generating a new list of - non-optional values B [b1; ...; bn], with m >= n. For each value - a in list A, list B contains a corresponding value b if and only - if the application of (f a) results in Some b. *) - val filter_map : ('a -> 'b option) -> 'a list -> 'b list + (** Applies a function f that generates optional values, to each + of the items in a list A [a1; ...; am], generating a new list of + non-optional values B [b1; ...; bn], with m >= n. For each value + a in list A, list B contains a corresponding value b if and only + if the application of (f a) results in Some b. *) + val filter_map : ('a -> 'b option) -> 'a list -> 'b list - (** Returns true if and only if the given list is in sorted order - according to the given comparison function. *) - val is_sorted : ('a -> 'a -> int) -> 'a list -> bool + (** Returns true if and only if the given list is in sorted order + according to the given comparison function. *) + val is_sorted : ('a -> 'a -> int) -> 'a list -> bool - (** Returns the intersection of two lists. *) - val intersect : 'a list -> 'a list -> 'a list + (** Returns the intersection of two lists. *) + val intersect : 'a list -> 'a list -> 'a list - (** Returns the set difference of two lists *) - val set_difference : 'a list -> 'a list -> 'a list + (** Returns the set difference of two lists *) + val set_difference : 'a list -> 'a list -> 'a list - (** Act as List.assoc, but return the given default value if the - key is not in the list. *) - val assoc_default : 'a -> ('a * 'b) list -> 'b -> 'b + (** Act as List.assoc, but return the given default value if the + key is not in the list. *) + val assoc_default : 'a -> ('a * 'b) list -> 'b -> 'b - (** [map_assoc_with_key op al] transforms every value in [al] based on the - key and the value using [op]. *) - val map_assoc_with_key : ('k -> 'v1 -> 'v2) -> ('k * 'v1) list -> ('k * 'v2) list + (** [map_assoc_with_key op al] transforms every value in [al] based on the + key and the value using [op]. *) + val map_assoc_with_key : ('k -> 'v1 -> 'v2) -> ('k * 'v1) list -> ('k * 'v2) list - (* Like Lisp cons*) - val cons : 'a -> 'a list -> 'a list + (* Like Lisp cons*) + val cons : 'a -> 'a list -> 'a list - (** [take n list] returns the first [n] elements of [list] (or less if list - is shorter).*) - val take : int -> 'a list -> 'a list + (** [take n list] returns the first [n] elements of [list] (or less if list + is shorter).*) + val take : int -> 'a list -> 'a list - val tails : 'a list -> ('a list) list - val safe_hd : 'a list -> 'a option + val tails : 'a list -> ('a list) list + val safe_hd : 'a list -> 'a option - (** Replace the value belonging to a key in an association list. Adds the key/value pair - * if it does not yet exist in the list. If the same key occurs multiple time in the original - * list, all occurances are removed and replaced by a single new key/value pair. - * This function is useful is the assoc list is used as a lightweight map/hashtable/dictonary. *) - val replace_assoc : 'a -> 'b -> ('a * 'b) list -> ('a * 'b) list + (** Replace the value belonging to a key in an association list. Adds the key/value pair + * if it does not yet exist in the list. If the same key occurs multiple time in the original + * list, all occurances are removed and replaced by a single new key/value pair. + * This function is useful is the assoc list is used as a lightweight map/hashtable/dictonary. *) + val replace_assoc : 'a -> 'b -> ('a * 'b) list -> ('a * 'b) list - (** Includes everything from [update] and all key/value pairs from [existing] for - * which the key does not exist in [update]. In other words, it is like [replace_assoc] - * but then given a whole assoc list of updates rather than a single key/value pair. *) - val update_assoc : ('a * 'b) list -> ('a * 'b) list -> ('a * 'b) list + (** Includes everything from [update] and all key/value pairs from [existing] for + * which the key does not exist in [update]. In other words, it is like [replace_assoc] + * but then given a whole assoc list of updates rather than a single key/value pair. *) + val update_assoc : ('a * 'b) list -> ('a * 'b) list -> ('a * 'b) list - val make_assoc : ('a -> 'b) -> 'a list -> ('a * 'b) list + val make_assoc : ('a -> 'b) -> 'a list -> ('a * 'b) list - (** Unbox all values from the option list. *) - val unbox_list : 'a option list -> 'a list + (** Unbox all values from the option list. *) + val unbox_list : 'a option list -> 'a list - (** [restrict_with_default default keys al] makes a new association map - from [keys] to previous values for [keys] in [al]. If a key is not found - in [al], the [default] is used. *) - val restrict_with_default : 'v -> 'k list -> ('k * 'v) list -> ('k * 'v) list + (** [restrict_with_default default keys al] makes a new association map + from [keys] to previous values for [keys] in [al]. If a key is not found + in [al], the [default] is used. *) + val restrict_with_default : 'v -> 'k list -> ('k * 'v) list -> ('k * 'v) list - (** range lower upper = [lower; lower + 1; ...; upper - 1] - Returns the empty list if lower >= upper. *) - val range : int -> int -> int list + (** range lower upper = [lower; lower + 1; ...; upper - 1] + Returns the empty list if lower >= upper. *) + val range : int -> int -> int list end diff --git a/lib/mapext.ml b/lib/mapext.ml index 8f20866d7a4..636e46c9ecb 100644 --- a/lib/mapext.ml +++ b/lib/mapext.ml @@ -1,47 +1,47 @@ module type S = - sig - type key - type +'a t - val empty: 'a t - val is_empty: 'a t -> bool - val add: key -> 'a -> 'a t -> 'a t - val find: key -> 'a t -> 'a - val remove: key -> 'a t -> 'a t - val mem: key -> 'a t -> bool - val iter: (key -> 'a -> unit) -> 'a t -> unit - val map: ('a -> 'b) -> 'a t -> 'b t - val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t - val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int - val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - - val fromHash : (key, 'a) Hashtbl.t -> 'a t - - val filter : ('a -> bool) -> 'a t -> 'a t - - (* values: gives the list of values of the map. *) - val values : 'a t -> 'a list - - val fromListWith : ('a -> 'a -> 'a) -> (key * 'a) list -> 'a t - val adjust : ('a -> 'a) -> key -> 'a t -> 'a t - - end +sig + type key + type +'a t + val empty: 'a t + val is_empty: 'a t -> bool + val add: key -> 'a -> 'a t -> 'a t + val find: key -> 'a t -> 'a + val remove: key -> 'a t -> 'a t + val mem: key -> 'a t -> bool + val iter: (key -> 'a -> unit) -> 'a t -> unit + val map: ('a -> 'b) -> 'a t -> 'b t + val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + + val fromHash : (key, 'a) Hashtbl.t -> 'a t + + val filter : ('a -> bool) -> 'a t -> 'a t + + (* values: gives the list of values of the map. *) + val values : 'a t -> 'a list + + val fromListWith : ('a -> 'a -> 'a) -> (key * 'a) list -> 'a t + val adjust : ('a -> 'a) -> key -> 'a t -> 'a t + +end module Make(Ord: Map.OrderedType) = struct - include Map.Make (Ord) - - let fromHash h = Hashtbl.fold add h empty - let filter pred m = fold (fun k v acc -> (if pred v then add k v else Fun.id) acc) m empty - (* values: gives the list of values of the map. *) - let values m = fold (Fun.const Listext.List.cons) m [] - - let fromListWith op list = List.fold_left (fun map (k,v) -> - add k (if mem k map - then op v (find k map) - else v) map) - empty list - let adjust op k m = try add k (op (find k m)) m with Not_found -> m - - + include Map.Make (Ord) + + let fromHash h = Hashtbl.fold add h empty + let filter pred m = fold (fun k v acc -> (if pred v then add k v else Fun.id) acc) m empty + (* values: gives the list of values of the map. *) + let values m = fold (Fun.const Listext.List.cons) m [] + + let fromListWith op list = List.fold_left (fun map (k,v) -> + add k (if mem k map + then op v (find k map) + else v) map) + empty list + let adjust op k m = try add k (op (find k m)) m with Not_found -> m + + end diff --git a/lib/mapext.mli b/lib/mapext.mli index 9613768104e..e408d428ada 100644 --- a/lib/mapext.mli +++ b/lib/mapext.mli @@ -1,31 +1,31 @@ module type S = - sig - type key - type +'a t - val empty: 'a t - val is_empty: 'a t -> bool - val add: key -> 'a -> 'a t -> 'a t - val find: key -> 'a t -> 'a - val remove: key -> 'a t -> 'a t - val mem: key -> 'a t -> bool - val iter: (key -> 'a -> unit) -> 'a t -> unit - val map: ('a -> 'b) -> 'a t -> 'b t - val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t - val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int - val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool +sig + type key + type +'a t + val empty: 'a t + val is_empty: 'a t -> bool + val add: key -> 'a -> 'a t -> 'a t + val find: key -> 'a t -> 'a + val remove: key -> 'a t -> 'a t + val mem: key -> 'a t -> bool + val iter: (key -> 'a -> unit) -> 'a t -> unit + val map: ('a -> 'b) -> 'a t -> 'b t + val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - val fromHash : (key, 'a) Hashtbl.t -> 'a t - val filter : ('a -> bool) -> 'a t -> 'a t + val fromHash : (key, 'a) Hashtbl.t -> 'a t + val filter : ('a -> bool) -> 'a t -> 'a t - (* values: gives the list of values of the map. *) - val values : 'a t -> 'a list + (* values: gives the list of values of the map. *) + val values : 'a t -> 'a list - val fromListWith : ('a -> 'a -> 'a) -> (key * 'a) list -> 'a t - (* Update a value at a specific key with the result of the - provided function. When the key is not a member of the map, the - original map is returned. *) - val adjust : ('a -> 'a) -> key -> 'a t -> 'a t - end + val fromListWith : ('a -> 'a -> 'a) -> (key * 'a) list -> 'a t + (* Update a value at a specific key with the result of the + provided function. When the key is not a member of the map, the + original map is returned. *) + val adjust : ('a -> 'a) -> key -> 'a t -> 'a t +end module Make (Ord : Map.OrderedType) : S with type key = Ord.t diff --git a/lib/monad.ml b/lib/monad.ml index aaf2bbbab33..250adfdd632 100644 --- a/lib/monad.ml +++ b/lib/monad.ml @@ -15,56 +15,56 @@ (** 1-parameter monads. *) module M1 = struct - module type BASE = - sig - type 'a m - val bind : 'a m -> ('a -> 'b m) -> 'b m - val return : 'a -> 'a m - end + module type BASE = + sig + type 'a m + val bind : 'a m -> ('a -> 'b m) -> 'b m + val return : 'a -> 'a m + end - module type MONAD = - sig - type 'a m - val (>>=) : 'a m -> ('a -> 'b m) -> 'b m - val bind : 'a m -> ('a -> 'b m) -> 'b m - val return : 'a -> 'a m - end + module type MONAD = + sig + type 'a m + val (>>=) : 'a m -> ('a -> 'b m) -> 'b m + val bind : 'a m -> ('a -> 'b m) -> 'b m + val return : 'a -> 'a m + end - module Make (B : BASE) : MONAD with type 'a m = 'a B.m = - struct - type 'a m = 'a B.m - let (>>=) = B.bind - let bind = B.bind - let return = B.return - end + module Make (B : BASE) : MONAD with type 'a m = 'a B.m = + struct + type 'a m = 'a B.m + let (>>=) = B.bind + let bind = B.bind + let return = B.return + end end (** 2-parameter monads. *) module M2 = struct - module type BASE = - sig - type ('a, 'x) m - val bind : ('a, 'x) m -> ('a -> ('b, 'x) m) -> ('b, 'x) m - val return : 'a -> ('a, 'x) m - end + module type BASE = + sig + type ('a, 'x) m + val bind : ('a, 'x) m -> ('a -> ('b, 'x) m) -> ('b, 'x) m + val return : 'a -> ('a, 'x) m + end - module type MONAD = - sig - type ('a, 'x) m - val (>>=) : ('a, 'x) m -> ('a -> ('b, 'x) m) -> ('b, 'x) m - val bind : ('a, 'x) m -> ('a -> ('b, 'x) m) -> ('b, 'x) m - val return : 'a -> ('a, 'x) m - end + module type MONAD = + sig + type ('a, 'x) m + val (>>=) : ('a, 'x) m -> ('a -> ('b, 'x) m) -> ('b, 'x) m + val bind : ('a, 'x) m -> ('a -> ('b, 'x) m) -> ('b, 'x) m + val return : 'a -> ('a, 'x) m + end - module Make (B : BASE) : MONAD with type ('a, 'x) m = ('a, 'x) B.m = - struct - type ('a, 'x) m = ('a, 'x) B.m - let (>>=) = B.bind - let bind = B.bind - let return = B.return - end + module Make (B : BASE) : MONAD with type ('a, 'x) m = ('a, 'x) B.m = + struct + type ('a, 'x) m = ('a, 'x) B.m + let (>>=) = B.bind + let bind = B.bind + let return = B.return + end end diff --git a/lib/monad.mli b/lib/monad.mli index 7bce3a96a6a..2630d83534a 100644 --- a/lib/monad.mli +++ b/lib/monad.mli @@ -15,56 +15,56 @@ (** 1-parameter monads. *) module M1 : sig - module type BASE = - sig - type 'a m - val bind : 'a m -> ('a -> 'b m) -> 'b m - val return : 'a -> 'a m - end + module type BASE = + sig + type 'a m + val bind : 'a m -> ('a -> 'b m) -> 'b m + val return : 'a -> 'a m + end - module type MONAD = - sig - type 'a m - val ( >>= ) : 'a m -> ('a -> 'b m) -> 'b m - val bind : 'a m -> ('a -> 'b m) -> 'b m - val return : 'a -> 'a m - end + module type MONAD = + sig + type 'a m + val ( >>= ) : 'a m -> ('a -> 'b m) -> 'b m + val bind : 'a m -> ('a -> 'b m) -> 'b m + val return : 'a -> 'a m + end - module Make : functor (B : BASE) -> - sig - type 'a m = 'a B.m - val ( >>= ) : 'a m -> ('a -> 'b m) -> 'b m - val bind : 'a m -> ('a -> 'b m) -> 'b m - val return : 'a -> 'a m - end + module Make : functor (B : BASE) -> + sig + type 'a m = 'a B.m + val ( >>= ) : 'a m -> ('a -> 'b m) -> 'b m + val bind : 'a m -> ('a -> 'b m) -> 'b m + val return : 'a -> 'a m + end end (** 2-parameter monads. *) module M2 : sig - module type BASE = - sig - type ('a, 'b) m - val bind : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m - val return : 'a -> ('a, 'b) m - end + module type BASE = + sig + type ('a, 'b) m + val bind : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m + val return : 'a -> ('a, 'b) m + end - module type MONAD = - sig - type ('a, 'b) m - val ( >>= ) : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m - val bind : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m - val return : 'a -> ('a, 'b) m - end + module type MONAD = + sig + type ('a, 'b) m + val ( >>= ) : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m + val bind : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m + val return : 'a -> ('a, 'b) m + end - module Make : functor (B : BASE) -> - sig - type ('a, 'b) m = ('a, 'b) B.m - val ( >>= ) : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m - val bind : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m - val return : 'a -> ('a, 'b) m - end + module Make : functor (B : BASE) -> + sig + type ('a, 'b) m = ('a, 'b) B.m + val ( >>= ) : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m + val bind : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m + val return : 'a -> ('a, 'b) m + end end diff --git a/lib/opt.ml b/lib/opt.ml index fc5171aba47..68e37462b53 100644 --- a/lib/opt.ml +++ b/lib/opt.ml @@ -16,65 +16,65 @@ * to the standard library instead? (Although it would not suffice, * since it's not a super-set of our `opt'.) * (http://code.google.com/p/ocaml-extlib/) - *) +*) module Monad = Monad.M1.Make (struct - type 'a m = 'a option + type 'a m = 'a option - let bind option f = - match option with - | None -> None - | Some result -> f result + let bind option f = + match option with + | None -> None + | Some result -> f result - let return x = Some x + let return x = Some x -end) + end) let iter f = function - | Some x -> f x - | None -> () + | Some x -> f x + | None -> () let map f = function - | Some x -> Some(f x) - | None -> None + | Some x -> Some(f x) + | None -> None let default d = function - | Some x -> x - | None -> d + | Some x -> x + | None -> d let unbox = function - | Some x -> x - | None -> raise Not_found + | Some x -> x + | None -> raise Not_found let is_boxed = function - | Some _ -> true - | None -> false + | Some _ -> true + | None -> false let is_some = is_boxed let is_none = function - | Some _ -> false - | None -> true + | Some _ -> false + | None -> true let to_list = function - | Some x -> [x] - | None -> [] + | Some x -> [x] + | None -> [] let fold_left f accu = function - | Some x -> f accu x - | None -> accu + | Some x -> f accu x + | None -> accu let fold_right f opt accu = - match opt with - | Some x -> f x accu - | None -> accu + match opt with + | Some x -> f x accu + | None -> accu let join = function - | Some (Some a) -> Some a - | _ -> None + | Some (Some a) -> Some a + | _ -> None let of_exception f = - try Some (f ()) - with _ -> None + try Some (f ()) + with _ -> None diff --git a/lib/pervasiveext.ml b/lib/pervasiveext.ml index 1066203de3d..ebe2146b032 100644 --- a/lib/pervasiveext.ml +++ b/lib/pervasiveext.ml @@ -13,24 +13,24 @@ *) (** apply the clean_f function after fct function has been called. * Even if fct raises an exception, clean_f is applied - *) +*) let finally fct clean_f = - let result = - try - fct (); - with exn -> - Backtrace.is_important exn; - clean_f (); - raise exn in - clean_f (); - result + let result = + try + fct (); + with exn -> + Backtrace.is_important exn; + clean_f (); + raise exn in + clean_f (); + result (* Those should go into the Opt module: *) let maybe_with_default d f v = - match v with None -> d | Some x -> f x + match v with None -> d | Some x -> f x (** if v is not none, apply f on it and return some value else return none. *) let may f v = maybe_with_default None (fun x -> Some (f x)) v @@ -43,7 +43,7 @@ let maybe f v = maybe_with_default () f v (** if bool is false then we intercept and quiten any exception *) let reraise_if bool fct = - try fct () with exn -> if bool then raise exn else () + try fct () with exn -> if bool then raise exn else () (** execute fct ignoring exceptions *) let ignore_exn fct = try fct () with _ -> () diff --git a/lib/qring.ml b/lib/qring.ml index 84c55b909fe..de9e6df0be4 100644 --- a/lib/qring.ml +++ b/lib/qring.ml @@ -12,11 +12,11 @@ * GNU Lesser General Public License for more details. *) type t = { - sz: int; - data: string; - mutable prod: int; - mutable cons: int; - mutable pwrap: bool; + sz: int; + data: string; + mutable prod: int; + mutable cons: int; + mutable pwrap: bool; } exception Data_limit @@ -25,117 +25,117 @@ exception Full let make sz = { sz = sz; data = String.create sz; prod = 0; cons = 0; pwrap = false } let to_consume ring = - if ring.pwrap then - ring.sz - (ring.cons - ring.prod) - else - ring.prod - ring.cons + if ring.pwrap then + ring.sz - (ring.cons - ring.prod) + else + ring.prod - ring.cons let to_fill ring = - if ring.pwrap then - ring.cons - ring.prod - else - ring.cons + (ring.sz - ring.prod) + if ring.pwrap then + ring.cons - ring.prod + else + ring.cons + (ring.sz - ring.prod) let is_full ring = ring.pwrap && ring.prod = ring.cons let is_empty ring = not ring.pwrap && ring.prod = ring.cons let adv_cons ring i = - ring.cons <- ring.cons + i; - if ring.cons >= ring.sz then ( - ring.cons <- ring.cons - ring.sz; - ring.pwrap <- false; - ) + ring.cons <- ring.cons + i; + if ring.cons >= ring.sz then ( + ring.cons <- ring.cons - ring.sz; + ring.pwrap <- false; + ) let adv_prod ring i = - ring.prod <- ring.prod + i; - if ring.prod >= ring.sz then ( - ring.prod <- ring.prod - ring.sz; - ring.pwrap <- true; - ) + ring.prod <- ring.prod + i; + if ring.prod >= ring.sz then ( + ring.prod <- ring.prod - ring.sz; + ring.pwrap <- true; + ) let consume ring sz = - let max = to_consume ring in - let sz = - if sz > 0 then - if sz > max then max else sz - else - if max + sz > 0 then max + sz else 0 - in - let out = String.create sz in - if ring.pwrap then ( - let left_end = ring.sz - ring.cons in - if sz > left_end then ( - String.blit ring.data ring.cons out 0 left_end; - String.blit ring.data 0 out left_end (sz - left_end); - ) else - String.blit ring.data ring.cons out 0 sz; - ) else - String.blit ring.data ring.cons out 0 sz; - adv_cons ring sz; - out + let max = to_consume ring in + let sz = + if sz > 0 then + if sz > max then max else sz + else + if max + sz > 0 then max + sz else 0 + in + let out = String.create sz in + if ring.pwrap then ( + let left_end = ring.sz - ring.cons in + if sz > left_end then ( + String.blit ring.data ring.cons out 0 left_end; + String.blit ring.data 0 out left_end (sz - left_end); + ) else + String.blit ring.data ring.cons out 0 sz; + ) else + String.blit ring.data ring.cons out 0 sz; + adv_cons ring sz; + out let consume_all ring = consume ring (max_int) let skip ring n = - let max = to_consume ring in - let n = if n > max then max else n in - adv_cons ring n + let max = to_consume ring in + let n = if n > max then max else n in + adv_cons ring n let feed_data ring data = - let len = String.length data in - let max = to_fill ring in - if len > max then - raise Data_limit; - if ring.prod + len > ring.sz then ( - let firstblitsz = ring.sz - ring.prod in - String.blit data 0 ring.data ring.prod firstblitsz; - String.blit data firstblitsz ring.data 0 (len - firstblitsz); - ) else - String.blit data 0 ring.data ring.prod len; - adv_prod ring len; - () + let len = String.length data in + let max = to_fill ring in + if len > max then + raise Data_limit; + if ring.prod + len > ring.sz then ( + let firstblitsz = ring.sz - ring.prod in + String.blit data 0 ring.data ring.prod firstblitsz; + String.blit data firstblitsz ring.data 0 (len - firstblitsz); + ) else + String.blit data 0 ring.data ring.prod len; + adv_prod ring len; + () (* read and search directly to the qring. * since we have give a continuous buffer, we limit our read length to the * maximum continous length instead of the full length of the qring left. * after the read, piggyback into the new data. - *) +*) let read_search ring fread fsearch len = - let prod = ring.prod in - let maxlen = - if ring.pwrap - then ring.cons - ring.prod - else ring.sz - ring.prod - in - if maxlen = 0 then - raise Full; - let len = if maxlen < len then maxlen else len in - let n = fread ring.data prod len in - if n > 0 then ( - adv_prod ring n; - fsearch ring.data prod n - ); - n + let prod = ring.prod in + let maxlen = + if ring.pwrap + then ring.cons - ring.prod + else ring.sz - ring.prod + in + if maxlen = 0 then + raise Full; + let len = if maxlen < len then maxlen else len in + let n = fread ring.data prod len in + if n > 0 then ( + adv_prod ring n; + fsearch ring.data prod n + ); + n let search ring c = - let search_from_to f t = - let found = ref false in - let i = ref f in - while not !found && !i < t - do - if ring.data.[!i] = c then - found := true - else - incr i - done; - if not !found then - raise Not_found; - !i - f - in - if is_empty ring then - raise Not_found; - if ring.pwrap then ( - try search_from_to ring.cons ring.sz - with Not_found -> search_from_to 0 ring.prod - ) else - search_from_to ring.cons ring.prod + let search_from_to f t = + let found = ref false in + let i = ref f in + while not !found && !i < t + do + if ring.data.[!i] = c then + found := true + else + incr i + done; + if not !found then + raise Not_found; + !i - f + in + if is_empty ring then + raise Not_found; + if ring.pwrap then ( + try search_from_to ring.cons ring.sz + with Not_found -> search_from_to 0 ring.prod + ) else + search_from_to ring.cons ring.prod diff --git a/lib/qring.mli b/lib/qring.mli index 7708d85b056..480dbf10fae 100644 --- a/lib/qring.mli +++ b/lib/qring.mli @@ -12,11 +12,11 @@ * GNU Lesser General Public License for more details. *) type t = { - sz: int; - data: string; - mutable prod: int; - mutable cons: int; - mutable pwrap: bool; + sz: int; + data: string; + mutable prod: int; + mutable cons: int; + mutable pwrap: bool; } exception Data_limit @@ -36,6 +36,6 @@ val skip : t -> int -> unit val feed_data : t -> string -> unit val read_search : t -> (string -> int -> int -> int) - -> (string -> int -> int -> unit) -> int - -> int + -> (string -> int -> int -> unit) -> int + -> int val search : t -> char -> int diff --git a/lib/range.ml b/lib/range.ml index 1aa889a4d4a..531acd88fab 100644 --- a/lib/range.ml +++ b/lib/range.ml @@ -14,28 +14,28 @@ type t = { l : int; u : int } let make l u = - if l <= u then { l = l; u = u } else invalid_arg "Range.make" + if l <= u then { l = l; u = u } else invalid_arg "Range.make" let get r = r.l, r.u let mem i r = r.l <= i && i < r.u let rec fold_left_aux f accu l u = - if l < u then - fold_left_aux f (f accu l) (l + 1) u - else accu + if l < u then + fold_left_aux f (f accu l) (l + 1) u + else accu let fold_left f accu r = fold_left_aux f accu r.l r.u let rec fold_right_aux f l u accu = - if l < u then - let u = u - 1 in - fold_right_aux f l u (f u accu) - else - accu + if l < u then + let u = u - 1 in + fold_right_aux f l u (f u accu) + else + accu let fold_right f r accu = fold_right_aux f r.l r.u accu let to_list r = - fold_right (fun x y -> x :: y) r [] + fold_right (fun x y -> x :: y) r [] diff --git a/lib/ring.ml b/lib/ring.ml index 3fb032c56a9..47683c4e3d0 100644 --- a/lib/ring.ml +++ b/lib/ring.ml @@ -16,57 +16,57 @@ type 'a t = { size: int; mutable current: int; data: 'a array; } (** create a ring structure with size record. records inited to initval *) let make size initval = - { size = size; current = size - 1; data = Array.create size initval; } + { size = size; current = size - 1; data = Array.create size initval; } (** length of the ring *) let length ring = ring.size (** push into the ring one element *) let push ring e = - ring.current <- ring.current + 1; - if ring.current = ring.size then - ring.current <- 0; - ring.data.(ring.current) <- e + ring.current <- ring.current + 1; + if ring.current = ring.size then + ring.current <- 0; + ring.data.(ring.current) <- e (** get the ith old element from the ring *) let peek ring i = - if i >= ring.size then - raise (Invalid_argument "peek: index"); - let index = - let offset = ring.current - i in - if offset >= 0 then offset else ring.size + offset in - ring.data.(index) + if i >= ring.size then + raise (Invalid_argument "peek: index"); + let index = + let offset = ring.current - i in + if offset >= 0 then offset else ring.size + offset in + ring.data.(index) (** get the top element of the ring *) let top ring = ring.data.(ring.current) (** iterate over nb element of the ring, starting from the top *) let iter_nb ring f nb = - if nb > ring.size then - raise (Invalid_argument "iter_nb: nb"); - (* FIXME: OPTIMIZE ME with 2 Array.iter ? *) - for i = 0 to nb - 1 - do - f (peek ring i) - done + if nb > ring.size then + raise (Invalid_argument "iter_nb: nb"); + (* FIXME: OPTIMIZE ME with 2 Array.iter ? *) + for i = 0 to nb - 1 + do + f (peek ring i) + done (** iter directly on all element without using the index *) let raw_iter ring f = - Array.iter f ring.data + Array.iter f ring.data (** iterate over all element of the ring, starting from the top *) let iter ring f = iter_nb ring f (ring.size) (** get array of latest nb value *) let get_nb ring nb = - if nb > ring.size then - raise (Invalid_argument "get_nb: nb"); - let a = Array.create nb (top ring) in - for i = 1 to nb - 1 - do - (* FIXME: OPTIMIZE ME with 2 Array.blit *) - a.(i) <- peek ring i - done; - a + if nb > ring.size then + raise (Invalid_argument "get_nb: nb"); + let a = Array.create nb (top ring) in + for i = 1 to nb - 1 + do + (* FIXME: OPTIMIZE ME with 2 Array.blit *) + a.(i) <- peek ring i + done; + a let get ring = get_nb ring (ring.size) diff --git a/lib/threadext.ml b/lib/threadext.ml index 7dd0ca500f5..f00b4d6d933 100644 --- a/lib/threadext.ml +++ b/lib/threadext.ml @@ -13,309 +13,309 @@ *) module Mutex = struct - include Mutex - - (** execute the function f with the mutex hold *) - let execute lock f = - Mutex.lock lock; - let r = begin try f () with exn -> Mutex.unlock lock; raise exn end; in - Mutex.unlock lock; - r + include Mutex + + (** execute the function f with the mutex hold *) + let execute lock f = + Mutex.lock lock; + let r = begin try f () with exn -> Mutex.unlock lock; raise exn end; in + Mutex.unlock lock; + r end module Alarm = struct - type t = - { token: Mutex.t ; - mutable queue: (float * (unit -> unit)) list ; - mutable notifier: (Unix.file_descr * Unix.file_descr) option ; - } - - let create () = - { token = Mutex.create () ; - queue = [] ; - notifier = None ; - } - - let global_alarm = create () - - let rec watch alarm = - match alarm.notifier with - | None -> assert false - | Some (pipe_in, pipe_out) -> - while Thread.wait_timed_read pipe_in 0. do - ignore (Unix.read pipe_in " " 0 1) - done; - let next = Mutex.execute alarm.token - (fun () -> - let now = Unix.time () in - let nqueue = List.filter - (fun (clock, callback) -> - (* Create helper thread in case callback could block us *) - clock > now || (let _ = Thread.create callback () in false)) - alarm.queue in - alarm.queue <- nqueue; - match nqueue with - | [] -> - Unix.close pipe_out; - Unix.close pipe_in; - alarm.notifier <- None; - None - | (c, _) :: _ -> - Some c) in - match next with - | None -> Thread.exit () - | Some c -> - let now = Unix.time () in - if c > now then ignore (Thread.wait_timed_read pipe_in (c -. now)); - watch alarm - - let register ?(alarm = global_alarm) time callback = - Mutex.execute alarm.token - (fun () -> - let nqueue = (time, callback) :: alarm.queue in - alarm.queue <- List.sort (fun x1 x2 -> compare (fst x1) (fst x2)) nqueue; - match alarm.notifier with - | Some (_, pipe_out) -> - ignore (Unix.write pipe_out "X" 0 1) - | None -> - let pipe_in, pipe_out = Unix.pipe () in - alarm.notifier <- Some (pipe_in, pipe_out); - ignore (Thread.create watch alarm)) + type t = + { token: Mutex.t ; + mutable queue: (float * (unit -> unit)) list ; + mutable notifier: (Unix.file_descr * Unix.file_descr) option ; + } + + let create () = + { token = Mutex.create () ; + queue = [] ; + notifier = None ; + } + + let global_alarm = create () + + let rec watch alarm = + match alarm.notifier with + | None -> assert false + | Some (pipe_in, pipe_out) -> + while Thread.wait_timed_read pipe_in 0. do + ignore (Unix.read pipe_in " " 0 1) + done; + let next = Mutex.execute alarm.token + (fun () -> + let now = Unix.time () in + let nqueue = List.filter + (fun (clock, callback) -> + (* Create helper thread in case callback could block us *) + clock > now || (let _ = Thread.create callback () in false)) + alarm.queue in + alarm.queue <- nqueue; + match nqueue with + | [] -> + Unix.close pipe_out; + Unix.close pipe_in; + alarm.notifier <- None; + None + | (c, _) :: _ -> + Some c) in + match next with + | None -> Thread.exit () + | Some c -> + let now = Unix.time () in + if c > now then ignore (Thread.wait_timed_read pipe_in (c -. now)); + watch alarm + + let register ?(alarm = global_alarm) time callback = + Mutex.execute alarm.token + (fun () -> + let nqueue = (time, callback) :: alarm.queue in + alarm.queue <- List.sort (fun x1 x2 -> compare (fst x1) (fst x2)) nqueue; + match alarm.notifier with + | Some (_, pipe_out) -> + ignore (Unix.write pipe_out "X" 0 1) + | None -> + let pipe_in, pipe_out = Unix.pipe () in + alarm.notifier <- Some (pipe_in, pipe_out); + ignore (Thread.create watch alarm)) end module Thread = struct - type t = - | Running of Thread.t - | Pending of pthread - and pthread = float * int * Thread.t lazy_t - - type schedule = Now | Timeout of float | Indefinite - - type policy = - | AlwaysRun - | MaxCapacity of int * float option - | WaitCondition of (unit -> schedule) - - let count = ref 0 - - module PQueue = Set.Make(struct type t = pthread let compare = compare end) - - let running = ref 0 - - let pqueue = ref PQueue.empty - - (* This info can be deduced from pqueue, but having a specific int val allow - us to inspect it with lower cost and be lock free *) - let pending = ref 0 - - let running_threads () = !running - - let pending_threads () = !pending - - let scheduler_token = Mutex.create () - - let policy = ref AlwaysRun - - (* Should be protected by scheduler_token *) - let run_thread ((_, _, pt) as t) = - (* Might have run by other scheduling policy *) - if PQueue.mem t !pqueue then - (pqueue := PQueue.remove t !pqueue; decr pending); - if not (Lazy.lazy_is_val pt) then - let _ = Lazy.force pt in - incr running - - let fake_pivot = max_float, 0, lazy (Thread.create ignore ()) - let pivot = ref fake_pivot - let pre_pivot = ref max_int - - (* Should be protected by scheduler_token, this could be triggered either - because a thread finishes running and hence possibly provide an running - slot, or the scheduling policy has been updated hence more oppotunities - appear. *) - let rec run_pendings () = - if not (PQueue.is_empty !pqueue) then - let now = Unix.time() in - let (c, _, _) as t = PQueue.min_elt !pqueue in - (* Just in case policy has been changed *) - let to_run = match !policy with - | AlwaysRun -> true - | MaxCapacity (max_threads, _) -> c <= now || !running < max_threads - | WaitCondition f -> f () = Now in - if to_run then (run_thread t; run_pendings ()) - else (* extra logic to avoid starvation or wrongly programmed deadlock *) - let timeouts, exist, indefs = PQueue.split !pivot !pqueue in - if not exist || (PQueue.cardinal timeouts >= !pre_pivot - && (run_thread !pivot; true)) then - pivot := - if PQueue.is_empty indefs then fake_pivot - else PQueue.min_elt indefs; - pre_pivot := PQueue.cardinal timeouts - - let exit () = - Mutex.execute scheduler_token - (fun () -> decr running; run_pendings ()); - Thread.exit () - - let set_policy p = - Mutex.execute scheduler_token - (fun () -> - policy := p; - run_pendings ()) - - let create ?(schedule=Indefinite) f x = - let f' x = - Pervasiveext.finally - (fun () -> f x) - exit in - Mutex.execute scheduler_token - (fun () -> - run_pendings (); - let timeout = match schedule with - | Now -> 0. - | Timeout t -> t - | Indefinite -> max_float in - let timeout = - if timeout = 0. then 0. else - match !policy with - | AlwaysRun -> 0. - | MaxCapacity (max_threads, max_wait_opt) -> - if !running < max_threads && PQueue.is_empty !pqueue then 0. - else begin match max_wait_opt with - | None -> timeout - | Some t -> min timeout t end - | WaitCondition f -> match f () with - | Now -> 0. - | Timeout t -> min t timeout - | Indefinite -> timeout in - if timeout <= 0. then - let t = Thread.create f' x in - incr running; - Running t - else - let deadline = - if timeout < max_float then timeout +. Unix.time() - else max_float in - let pt = lazy (Thread.create f' x) in - incr count; - if !count = max_int then count := 0; - let t = (deadline, !count, pt) in - pqueue := PQueue.add t !pqueue; - incr pending; - if deadline < max_float then - Alarm.register deadline - (fun () -> Mutex.execute scheduler_token - (fun () -> run_thread t)); - (* It's fine that a pended thread might get scheduled later on so - that the information held in 't' becomes meaningless. This is - comparable to the case that a Thread.t finishes running and its - thread id still exits. - *) - Pending t) - - let self () = - (* When we get here, the thread must be running *) - Running (Thread.self ()) - - let id = function - | Running t -> Thread.id t - | Pending (_, id, _) -> - (* Pending thread have a negative id to avoid overlapping with running - thread id *) - -id - - let join = function - | Running t -> Thread.join t - | Pending ((_, _, pt) as t) -> - if not (Lazy.lazy_is_val pt) then begin - (* Give priority to those to be joined *) - Mutex.execute scheduler_token (fun () -> run_thread t); - assert (Lazy.lazy_is_val pt); - end; - Thread.join (Lazy.force pt) - - let kill = function - | Running t -> - (* Not implemented in stdlib *) - Thread.kill t - | Pending ((_, _, pt) as t) -> - if Lazy.lazy_is_val pt then - Thread.kill (Lazy.force pt) - else - Mutex.execute scheduler_token - (fun () -> - (* Just in case something happens before we grab the lock *) - if Lazy.lazy_is_val pt then Thread.kill (Lazy.force pt) - else (pqueue := PQueue.remove t !pqueue; decr pending)) - - let delay = Thread.delay - let exit = Thread.exit - let wait_read = Thread.wait_read - let wait_write = Thread.wait_write - let wait_timed_read = Thread.wait_timed_read - let wait_timed_write = Thread.wait_timed_write - let wait_pid = Thread.wait_pid - let select = Thread.select - let yield = Thread.yield - let sigmask = Thread.sigmask - let wait_signal = Thread.wait_signal + type t = + | Running of Thread.t + | Pending of pthread + and pthread = float * int * Thread.t lazy_t + + type schedule = Now | Timeout of float | Indefinite + + type policy = + | AlwaysRun + | MaxCapacity of int * float option + | WaitCondition of (unit -> schedule) + + let count = ref 0 + + module PQueue = Set.Make(struct type t = pthread let compare = compare end) + + let running = ref 0 + + let pqueue = ref PQueue.empty + + (* This info can be deduced from pqueue, but having a specific int val allow + us to inspect it with lower cost and be lock free *) + let pending = ref 0 + + let running_threads () = !running + + let pending_threads () = !pending + + let scheduler_token = Mutex.create () + + let policy = ref AlwaysRun + + (* Should be protected by scheduler_token *) + let run_thread ((_, _, pt) as t) = + (* Might have run by other scheduling policy *) + if PQueue.mem t !pqueue then + (pqueue := PQueue.remove t !pqueue; decr pending); + if not (Lazy.lazy_is_val pt) then + let _ = Lazy.force pt in + incr running + + let fake_pivot = max_float, 0, lazy (Thread.create ignore ()) + let pivot = ref fake_pivot + let pre_pivot = ref max_int + + (* Should be protected by scheduler_token, this could be triggered either + because a thread finishes running and hence possibly provide an running + slot, or the scheduling policy has been updated hence more oppotunities + appear. *) + let rec run_pendings () = + if not (PQueue.is_empty !pqueue) then + let now = Unix.time() in + let (c, _, _) as t = PQueue.min_elt !pqueue in + (* Just in case policy has been changed *) + let to_run = match !policy with + | AlwaysRun -> true + | MaxCapacity (max_threads, _) -> c <= now || !running < max_threads + | WaitCondition f -> f () = Now in + if to_run then (run_thread t; run_pendings ()) + else (* extra logic to avoid starvation or wrongly programmed deadlock *) + let timeouts, exist, indefs = PQueue.split !pivot !pqueue in + if not exist || (PQueue.cardinal timeouts >= !pre_pivot + && (run_thread !pivot; true)) then + pivot := + if PQueue.is_empty indefs then fake_pivot + else PQueue.min_elt indefs; + pre_pivot := PQueue.cardinal timeouts + + let exit () = + Mutex.execute scheduler_token + (fun () -> decr running; run_pendings ()); + Thread.exit () + + let set_policy p = + Mutex.execute scheduler_token + (fun () -> + policy := p; + run_pendings ()) + + let create ?(schedule=Indefinite) f x = + let f' x = + Pervasiveext.finally + (fun () -> f x) + exit in + Mutex.execute scheduler_token + (fun () -> + run_pendings (); + let timeout = match schedule with + | Now -> 0. + | Timeout t -> t + | Indefinite -> max_float in + let timeout = + if timeout = 0. then 0. else + match !policy with + | AlwaysRun -> 0. + | MaxCapacity (max_threads, max_wait_opt) -> + if !running < max_threads && PQueue.is_empty !pqueue then 0. + else begin match max_wait_opt with + | None -> timeout + | Some t -> min timeout t end + | WaitCondition f -> match f () with + | Now -> 0. + | Timeout t -> min t timeout + | Indefinite -> timeout in + if timeout <= 0. then + let t = Thread.create f' x in + incr running; + Running t + else + let deadline = + if timeout < max_float then timeout +. Unix.time() + else max_float in + let pt = lazy (Thread.create f' x) in + incr count; + if !count = max_int then count := 0; + let t = (deadline, !count, pt) in + pqueue := PQueue.add t !pqueue; + incr pending; + if deadline < max_float then + Alarm.register deadline + (fun () -> Mutex.execute scheduler_token + (fun () -> run_thread t)); + (* It's fine that a pended thread might get scheduled later on so + that the information held in 't' becomes meaningless. This is + comparable to the case that a Thread.t finishes running and its + thread id still exits. + *) + Pending t) + + let self () = + (* When we get here, the thread must be running *) + Running (Thread.self ()) + + let id = function + | Running t -> Thread.id t + | Pending (_, id, _) -> + (* Pending thread have a negative id to avoid overlapping with running + thread id *) + -id + + let join = function + | Running t -> Thread.join t + | Pending ((_, _, pt) as t) -> + if not (Lazy.lazy_is_val pt) then begin + (* Give priority to those to be joined *) + Mutex.execute scheduler_token (fun () -> run_thread t); + assert (Lazy.lazy_is_val pt); + end; + Thread.join (Lazy.force pt) + + let kill = function + | Running t -> + (* Not implemented in stdlib *) + Thread.kill t + | Pending ((_, _, pt) as t) -> + if Lazy.lazy_is_val pt then + Thread.kill (Lazy.force pt) + else + Mutex.execute scheduler_token + (fun () -> + (* Just in case something happens before we grab the lock *) + if Lazy.lazy_is_val pt then Thread.kill (Lazy.force pt) + else (pqueue := PQueue.remove t !pqueue; decr pending)) + + let delay = Thread.delay + let exit = Thread.exit + let wait_read = Thread.wait_read + let wait_write = Thread.wait_write + let wait_timed_read = Thread.wait_timed_read + let wait_timed_write = Thread.wait_timed_write + let wait_pid = Thread.wait_pid + let select = Thread.select + let yield = Thread.yield + let sigmask = Thread.sigmask + let wait_signal = Thread.wait_signal end (** create thread loops which periodically applies a function *) module Thread_loop : functor (Tr : sig type t val delay : unit -> float end) -> - sig - val start : Tr.t -> (unit -> unit) -> unit - val stop : Tr.t -> unit - val update : Tr.t -> (unit -> unit) -> unit - end + sig + val start : Tr.t -> (unit -> unit) -> unit + val stop : Tr.t -> unit + val update : Tr.t -> (unit -> unit) -> unit + end = functor (Tr: sig type t val delay : unit -> float end) -> struct exception Done_loop let ref_table : ((Tr.t,(Mutex.t * Thread.t * bool ref)) Hashtbl.t) = - Hashtbl.create 1 + Hashtbl.create 1 (** Create a thread which periodically applies a function to the reference specified, and exits cleanly when removed *) let start xref fn = - let mut = Mutex.create () in - let exit_var = ref false in - (* create thread which periodically applies the function *) - let tid = Thread.create (fun () -> - try while true do - Thread.delay (Tr.delay ()); - Mutex.execute mut (fun () -> + let mut = Mutex.create () in + let exit_var = ref false in + (* create thread which periodically applies the function *) + let tid = Thread.create (fun () -> + try while true do + Thread.delay (Tr.delay ()); + Mutex.execute mut (fun () -> if !exit_var then raise Done_loop; let () = fn () in () - ); + ); done; with Done_loop -> (); ) () in - (* create thread to manage the reference table and clean it up - safely once the delay thread is removed *) - let _ = Thread.create (fun () -> - Hashtbl.add ref_table xref (mut,tid,exit_var); - Thread.join tid; - List.iter (fun (_,t,_) -> - if tid = t then Hashtbl.remove ref_table xref + (* create thread to manage the reference table and clean it up + safely once the delay thread is removed *) + let _ = Thread.create (fun () -> + Hashtbl.add ref_table xref (mut,tid,exit_var); + Thread.join tid; + List.iter (fun (_,t,_) -> + if tid = t then Hashtbl.remove ref_table xref ) (Hashtbl.find_all ref_table xref) ) () in () (** Remove a reference from the thread table *) let stop xref = - try let mut,_,exit_ref = Hashtbl.find ref_table xref in - Mutex.execute mut (fun () -> exit_ref := true) - with Not_found -> () + try let mut,_,exit_ref = Hashtbl.find ref_table xref in + Mutex.execute mut (fun () -> exit_ref := true) + with Not_found -> () (** Replace a thread with another one *) let update xref fn = - stop xref; - start xref fn -end + stop xref; + start xref fn + end (** Parallel List.iter. Remembers all exceptions and returns an association list mapping input x to an exception. Applications of x which succeed will be missing from the returned list. *) @@ -326,18 +326,18 @@ let thread_iter_all_exns f xs = Thread.join (List.map (fun x -> - Thread.create - (fun () -> - try - f x - with e -> Mutex.execute m (fun () -> exns := (x, e) :: !exns) - ) - () + Thread.create + (fun () -> + try + f x + with e -> Mutex.execute m (fun () -> exns := (x, e) :: !exns) + ) + () ) xs); !exns (** Parallel List.iter. Remembers one exception (at random) and throws it in the - error case. *) + error case. *) let thread_iter f xs = match thread_iter_all_exns f xs with | [] -> () | (_, e) :: _ -> raise e @@ -368,45 +368,45 @@ module Delay = struct to_close := List.filter (fun x -> fd <> x) !to_close in Pervasiveext.finally (fun () -> - try - let pipe_out = Mutex.execute x.m - (fun () -> - if x.signalled then begin - x.signalled <- false; - raise Pre_signalled; - end; - let pipe_out, pipe_in = Unix.pipe () in - (* these will be unconditionally closed on exit *) - to_close := [ pipe_out; pipe_in ]; - x.pipe_out <- Some pipe_out; - x.pipe_in <- Some pipe_in; - x.signalled <- false; - pipe_out) in - let r, _, _ = Unix.select [ pipe_out ] [] [] seconds in - (* flush the single byte from the pipe *) - if r <> [] then ignore(Unix.read pipe_out (String.create 1) 0 1); - (* return true if we waited the full length of time, false if we were woken *) - r = [] - with Pre_signalled -> false + try + let pipe_out = Mutex.execute x.m + (fun () -> + if x.signalled then begin + x.signalled <- false; + raise Pre_signalled; + end; + let pipe_out, pipe_in = Unix.pipe () in + (* these will be unconditionally closed on exit *) + to_close := [ pipe_out; pipe_in ]; + x.pipe_out <- Some pipe_out; + x.pipe_in <- Some pipe_in; + x.signalled <- false; + pipe_out) in + let r, _, _ = Unix.select [ pipe_out ] [] [] seconds in + (* flush the single byte from the pipe *) + if r <> [] then ignore(Unix.read pipe_out (String.create 1) 0 1); + (* return true if we waited the full length of time, false if we were woken *) + r = [] + with Pre_signalled -> false ) (fun () -> - Mutex.execute x.m - (fun () -> - x.pipe_out <- None; - x.pipe_in <- None; - List.iter close' !to_close) + Mutex.execute x.m + (fun () -> + x.pipe_out <- None; + x.pipe_in <- None; + List.iter close' !to_close) ) let signal (x: t) = Mutex.execute x.m (fun () -> - match x.pipe_in with - | Some fd -> ignore(Unix.write fd "X" 0 1) - | None -> x.signalled <- true (* If the wait hasn't happened yet then store up the signal *) + match x.pipe_in with + | Some fd -> ignore(Unix.write fd "X" 0 1) + | None -> x.signalled <- true (* If the wait hasn't happened yet then store up the signal *) ) end let keep_alive () = - while true do - Thread.delay 20000. - done + while true do + Thread.delay 20000. + done diff --git a/lib/threadext.mli b/lib/threadext.mli index d4a12db153d..0c1393a3872 100644 --- a/lib/threadext.mli +++ b/lib/threadext.mli @@ -12,84 +12,84 @@ * GNU Lesser General Public License for more details. *) module Mutex : - sig - type t = Mutex.t - val create : unit -> t - val lock : t -> unit - val try_lock : t -> bool - val unlock : t -> unit - val execute : Mutex.t -> (unit -> 'a) -> 'a - end +sig + type t = Mutex.t + val create : unit -> t + val lock : t -> unit + val try_lock : t -> bool + val unlock : t -> unit + val execute : Mutex.t -> (unit -> 'a) -> 'a +end module Alarm : sig - type t - val create: unit -> t - val register: ?alarm:t -> float -> (unit -> unit) -> unit + type t + val create: unit -> t + val register: ?alarm:t -> float -> (unit -> unit) -> unit end module Thread : sig - type t + type t - (* Global policy on deciding whether threads should start immediately, can - be refined by specific thread creation function with the schedule - parameter. *) - type policy = - | AlwaysRun (* always start the threads immediately *) - | MaxCapacity of int * float option - (* Static configuration on the largest number of active threads, and - optionally max wait time for queued threads *) - | WaitCondition of (unit -> schedule) - (* Dynamic configuration to be tested whnever creating a new thread, - None means do not wait, Some t means wait at most t seconds. *) + (* Global policy on deciding whether threads should start immediately, can + be refined by specific thread creation function with the schedule + parameter. *) + type policy = + | AlwaysRun (* always start the threads immediately *) + | MaxCapacity of int * float option + (* Static configuration on the largest number of active threads, and + optionally max wait time for queued threads *) + | WaitCondition of (unit -> schedule) + (* Dynamic configuration to be tested whnever creating a new thread, + None means do not wait, Some t means wait at most t seconds. *) - (* Schedule policy on each particular thread. This will get considered together - with the global policy, taking whichever earlier among the two. *) - and schedule = - | Now (* Run the threads right now *) - | Timeout of float (* Run the threads at latest x seconds *) - | Indefinite (* Don't care, i.e. timeout = forever *) + (* Schedule policy on each particular thread. This will get considered together + with the global policy, taking whichever earlier among the two. *) + and schedule = + | Now (* Run the threads right now *) + | Timeout of float (* Run the threads at latest x seconds *) + | Indefinite (* Don't care, i.e. timeout = forever *) - val scheduler_token: Mutex.t + val scheduler_token: Mutex.t - val running_threads: unit -> int + val running_threads: unit -> int - val pending_threads: unit -> int + val pending_threads: unit -> int - (* Default policy is AlwaysRun, the same as standard thread semantics *) - val set_policy: policy -> unit + (* Default policy is AlwaysRun, the same as standard thread semantics *) + val set_policy: policy -> unit - include module type of Thread with type t := t + include module type of Thread with type t := t - (* The default schedule is Indefinite, i.e. to let the global policy in control *) - val create: ?schedule:schedule -> ('a -> 'b) -> 'a -> t + (* The default schedule is Indefinite, i.e. to let the global policy in control *) + val create: ?schedule:schedule -> ('a -> 'b) -> 'a -> t end module Thread_loop : functor (Tr : sig type t val delay : unit -> float end) -> - sig - val start : Tr.t -> (unit -> unit) -> unit - val stop : Tr.t -> unit - val update : Tr.t -> (unit -> unit) -> unit - end + sig + val start : Tr.t -> (unit -> unit) -> unit + val stop : Tr.t -> unit + val update : Tr.t -> (unit -> unit) -> unit + end val thread_iter_all_exns: ('a -> unit) -> 'a list -> ('a * exn) list val thread_iter: ('a -> unit) -> 'a list -> unit module Delay : - sig - type t - val make : unit -> t - (** Blocks the calling thread for a given period of time with the option of - returning early if someone calls 'signal'. Returns true if the full time - period elapsed and false if signalled. Note that multple 'signals' are - coalesced; 'signals' sent before 'wait' is called are not lost. *) +sig + type t + val make : unit -> t + (** Blocks the calling thread for a given period of time with the option of + returning early if someone calls 'signal'. Returns true if the full time + period elapsed and false if signalled. Note that multple 'signals' are + coalesced; 'signals' sent before 'wait' is called are not lost. *) - val wait : t -> float -> bool - (** Sends a signal to a waiting thread. See 'wait' *) + val wait : t -> float -> bool + (** Sends a signal to a waiting thread. See 'wait' *) - val signal : t -> unit - end + val signal : t -> unit +end (** Keeps a thread alive without doing anything. Used e.g. in XML/RPC daemons. *) val keep_alive: unit -> unit diff --git a/lib/trie.ml b/lib/trie.ml index efd5aa91171..9e2f9d21adc 100644 --- a/lib/trie.ml +++ b/lib/trie.ml @@ -13,168 +13,168 @@ *) module Node = struct - type ('a,'b) t = { - key: 'a; - value: 'b option; - children: ('a,'b) t list; - } - - (* let create key value = { - key = key; - value = Some value; - children = []; - } *) - - let empty key = { - key = key; - value = None; - children = [] - } - - (* let get_key node = node.key *) - let get_value node = - match node.value with - | None -> raise Not_found - | Some value -> value - - (* let get_children node = node.children *) - - let set_value node value = - { node with value = Some value } - let set_children node children = - { node with children = children } - - (* let add_child node child = - { node with children = child :: node.children } *) + type ('a,'b) t = { + key: 'a; + value: 'b option; + children: ('a,'b) t list; + } + + (* let create key value = { + key = key; + value = Some value; + children = []; + } *) + + let empty key = { + key = key; + value = None; + children = [] + } + + (* let get_key node = node.key *) + let get_value node = + match node.value with + | None -> raise Not_found + | Some value -> value + + (* let get_children node = node.children *) + + let set_value node value = + { node with value = Some value } + let set_children node children = + { node with children = children } + + (* let add_child node child = + { node with children = child :: node.children } *) end type ('a,'b) t = ('a,'b) Node.t list let mem_node nodes key = - List.exists (fun n -> n.Node.key = key) nodes + List.exists (fun n -> n.Node.key = key) nodes let find_node nodes key = - List.find (fun n -> n.Node.key = key) nodes + List.find (fun n -> n.Node.key = key) nodes let replace_node nodes key node = - let rec aux = function - | [] -> [] - | h :: tl when h.Node.key = key -> node :: tl - | h :: tl -> h :: aux tl - in - aux nodes - + let rec aux = function + | [] -> [] + | h :: tl when h.Node.key = key -> node :: tl + | h :: tl -> h :: aux tl + in + aux nodes + let remove_node nodes key = - let rec aux = function - | [] -> raise Not_found - | h :: tl when h.Node.key = key -> tl - | h :: tl -> h :: aux tl - in - aux nodes + let rec aux = function + | [] -> raise Not_found + | h :: tl when h.Node.key = key -> tl + | h :: tl -> h :: aux tl + in + aux nodes let create () = [] let rec iter f tree = - let aux node = - f node.Node.key node.Node.value; - iter f node.Node.children - in - List.iter aux tree + let aux node = + f node.Node.key node.Node.value; + iter f node.Node.children + in + List.iter aux tree let rec map f tree = - let aux node = - let value = - match node.Node.value with - | None -> None - | Some value -> f value - in - { node with Node.value = value; Node.children = map f node.Node.children } - in - List.filter (fun n -> n.Node.value <> None || n.Node.children <> []) (List.map aux tree) + let aux node = + let value = + match node.Node.value with + | None -> None + | Some value -> f value + in + { node with Node.value = value; Node.children = map f node.Node.children } + in + List.filter (fun n -> n.Node.value <> None || n.Node.children <> []) (List.map aux tree) let rec fold f tree acc = - let aux accu node = - fold f node.Node.children (f node.Node.key node.Node.value accu) - in - List.fold_left aux acc tree + let aux accu node = + fold f node.Node.children (f node.Node.key node.Node.value accu) + in + List.fold_left aux acc tree (* return a sub-trie *) let rec sub_node tree = function - | [] -> raise Not_found - | h::t -> - if mem_node tree h - then begin - let node = find_node tree h in - if t = [] - then node - else sub_node node.Node.children t - end else - raise Not_found + | [] -> raise Not_found + | h::t -> + if mem_node tree h + then begin + let node = find_node tree h in + if t = [] + then node + else sub_node node.Node.children t + end else + raise Not_found let sub tree path = - try (sub_node tree path).Node.children - with Not_found -> [] + try (sub_node tree path).Node.children + with Not_found -> [] let find tree path = - Node.get_value (sub_node tree path) + Node.get_value (sub_node tree path) (* return false if the node doesn't exists or if it is not associated to any value *) let rec mem tree = function - | [] -> false - | h::t -> - mem_node tree h - && (let node = find_node tree h in - if t = [] - then node.Node.value <> None - else mem node.Node.children t) + | [] -> false + | h::t -> + mem_node tree h + && (let node = find_node tree h in + if t = [] + then node.Node.value <> None + else mem node.Node.children t) (* Iterate over the longest valid prefix *) let rec iter_path f tree = function - | [] -> () - | h::l -> - if mem_node tree h - then begin - let node = find_node tree h in - f node.Node.key node.Node.value; - iter_path f node.Node.children l - end + | [] -> () + | h::l -> + if mem_node tree h + then begin + let node = find_node tree h in + f node.Node.key node.Node.value; + iter_path f node.Node.children l + end let rec set_node node path value = - if path = [] - then Node.set_value node value - else begin - let children = set node.Node.children path value in - Node.set_children node children - end + if path = [] + then Node.set_value node value + else begin + let children = set node.Node.children path value in + Node.set_children node children + end and set tree path value = - match path with - | [] -> raise Not_found - | h::t -> - if mem_node tree h - then begin - let node = find_node tree h in - replace_node tree h (set_node node t value) - end else begin - let node = Node.empty h in - set_node node t value :: tree - end + match path with + | [] -> raise Not_found + | h::t -> + if mem_node tree h + then begin + let node = find_node tree h in + replace_node tree h (set_node node t value) + end else begin + let node = Node.empty h in + set_node node t value :: tree + end let rec unset tree = function - | [] -> tree - | h::t -> - if mem_node tree h - then begin - let node = find_node tree h in - let children = unset node.Node.children t in - let new_node = - if t = [] - then Node.set_children (Node.empty h) children - else Node.set_children node children - in - if children = [] && new_node.Node.value = None - then remove_node tree h - else replace_node tree h new_node - end else - raise Not_found + | [] -> tree + | h::t -> + if mem_node tree h + then begin + let node = find_node tree h in + let children = unset node.Node.children t in + let new_node = + if t = [] + then Node.set_children (Node.empty h) children + else Node.set_children node children + in + if children = [] && new_node.Node.value = None + then remove_node tree h + else replace_node tree h new_node + end else + raise Not_found diff --git a/lib/trie.mli b/lib/trie.mli index efc17971512..faa86300121 100644 --- a/lib/trie.mli +++ b/lib/trie.mli @@ -15,44 +15,44 @@ type ('a, 'b) t (** The type of tries. ['a list] is the type of keys, ['b] the type of values. - Internally, a trie is represented as a labeled tree, where node contains values - of type ['a * 'b option]. *) + Internally, a trie is represented as a labeled tree, where node contains values + of type ['a * 'b option]. *) val create : unit -> ('a,'b) t (** Creates an empty trie. *) val mem : ('a,'b) t -> 'a list -> bool (** [mem t k] returns true if a value is associated with the key [k] in the trie [t]. - Otherwise, it returns false. *) + Otherwise, it returns false. *) val find : ('a, 'b) t -> 'a list -> 'b (** [find t k] returns the value associated with the key [k] in the trie [t]. - Returns [Not_found] if no values are associated with [k] in [t]. *) + Returns [Not_found] if no values are associated with [k] in [t]. *) val set : ('a, 'b) t -> 'a list -> 'b -> ('a, 'b) t (** [set t k v] associates the value [v] with the key [k] in the trie [t]. *) val unset : ('a, 'b) t -> 'a list -> ('a, 'b) t (** [unset k v] removes the association of value [v] with the key [k] in the trie [t]. - Moreover, it automatically clean the trie, ie. it removes recursively - every nodes of [t] containing no values and having no chil. *) + Moreover, it automatically clean the trie, ie. it removes recursively + every nodes of [t] containing no values and having no chil. *) val iter : ('a -> 'b option -> unit) -> ('a, 'b) t -> unit (** [iter f t] applies the function [f] to every node of the trie [t]. - As nodes of the trie [t] do not necessary contains a value, the second argument of - [f] is an option type. *) + As nodes of the trie [t] do not necessary contains a value, the second argument of + [f] is an option type. *) val iter_path : ('a -> 'b option -> unit) -> ('a, 'b) t -> 'a list -> unit (** [iter_path f t p] iterates [f] over nodes associated with the path [p] in the trie [t]. - If [p] is not a valid path of [t], it iterates on the longest valid prefix of [p]. *) + If [p] is not a valid path of [t], it iterates on the longest valid prefix of [p]. *) val fold : ('a -> 'b option -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c (** [fold f t x] fold [f] over every nodes of [t], with [x] as initial value. *) val map : ('b -> 'c option) -> ('a,'b) t -> ('a,'c) t (** [map f t] maps [f] over every values stored in [t]. The return value of [f] is of type 'c option - as one may wants to remove value associated to a key. This function is not tail-recursive. *) + as one may wants to remove value associated to a key. This function is not tail-recursive. *) val sub : ('a, 'b) t -> 'a list -> ('a,'b) t (** [sub t p] returns the sub-trie associated with the path [p] in the trie [t]. - If [p] is not a valid path of [t], it returns an empty trie. *) + If [p] is not a valid path of [t], it returns an empty trie. *) diff --git a/lib/unixext.ml b/lib/unixext.ml index 49d5d98bed7..bf20270fbda 100644 --- a/lib/unixext.ml +++ b/lib/unixext.ml @@ -19,116 +19,116 @@ external _exit : int -> unit = "unix_exit" (** remove a file, but doesn't raise an exception if the file is already removed *) let unlink_safe file = - try Unix.unlink file with (* Unix.Unix_error (Unix.ENOENT, _ , _)*) _ -> () + try Unix.unlink file with (* Unix.Unix_error (Unix.ENOENT, _ , _)*) _ -> () (** create a directory but doesn't raise an exception if the directory already exist *) let mkdir_safe dir perm = - try Unix.mkdir dir perm with Unix.Unix_error (Unix.EEXIST, _, _) -> () + try Unix.mkdir dir perm with Unix.Unix_error (Unix.EEXIST, _, _) -> () (** create a directory, and create parent if doesn't exist *) let mkdir_rec dir perm = - let rec p_mkdir dir = - let p_name = Filename.dirname dir in - if p_name <> "/" && p_name <> "." - then p_mkdir p_name; - mkdir_safe dir perm in - p_mkdir dir + let rec p_mkdir dir = + let p_name = Filename.dirname dir in + if p_name <> "/" && p_name <> "." + then p_mkdir p_name; + mkdir_safe dir perm in + p_mkdir dir (** write a pidfile file *) let pidfile_write filename = - let fd = Unix.openfile filename - [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ] - 0o640 in - finally - (fun () -> - let pid = Unix.getpid () in - let buf = string_of_int pid ^ "\n" in - let len = String.length buf in - if Unix.write fd buf 0 len <> len - then failwith "pidfile_write failed"; - ) - (fun () -> Unix.close fd) + let fd = Unix.openfile filename + [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ] + 0o640 in + finally + (fun () -> + let pid = Unix.getpid () in + let buf = string_of_int pid ^ "\n" in + let len = String.length buf in + if Unix.write fd buf 0 len <> len + then failwith "pidfile_write failed"; + ) + (fun () -> Unix.close fd) (** read a pidfile file, return either Some pid or None *) let pidfile_read filename = - let fd = Unix.openfile filename [ Unix.O_RDONLY ] 0o640 in - finally - (fun () -> - try - let buf = String.create 80 in - let rd = Unix.read fd buf 0 (String.length buf) in - if rd = 0 then - failwith "pidfile_read failed"; - Scanf.sscanf (String.sub buf 0 rd) "%d" (fun i -> Some i) - with _ -> None) - (fun () -> Unix.close fd) + let fd = Unix.openfile filename [ Unix.O_RDONLY ] 0o640 in + finally + (fun () -> + try + let buf = String.create 80 in + let rd = Unix.read fd buf 0 (String.length buf) in + if rd = 0 then + failwith "pidfile_read failed"; + Scanf.sscanf (String.sub buf 0 rd) "%d" (fun i -> Some i) + with _ -> None) + (fun () -> Unix.close fd) (** daemonize a process *) (* !! Must call this before spawning any threads !! *) let daemonize () = - match Unix.fork () with - | 0 -> - if Unix.setsid () == -1 then - failwith "Unix.setsid failed"; - - begin match Unix.fork () with - | 0 -> - let nullfd = Unix.openfile "/dev/null" [ Unix.O_WRONLY ] 0 in - begin try - Unix.close Unix.stdin; - Unix.dup2 nullfd Unix.stdout; - Unix.dup2 nullfd Unix.stderr; - with exn -> Unix.close nullfd; raise exn - end; - Unix.close nullfd - | _ -> exit 0 - end - | _ -> exit 0 + match Unix.fork () with + | 0 -> + if Unix.setsid () == -1 then + failwith "Unix.setsid failed"; + + begin match Unix.fork () with + | 0 -> + let nullfd = Unix.openfile "/dev/null" [ Unix.O_WRONLY ] 0 in + begin try + Unix.close Unix.stdin; + Unix.dup2 nullfd Unix.stdout; + Unix.dup2 nullfd Unix.stderr; + with exn -> Unix.close nullfd; raise exn + end; + Unix.close nullfd + | _ -> exit 0 + end + | _ -> exit 0 exception Break let lines_fold f start input = - let accumulator = ref start in - let running = ref true in - while !running do - let line = - try Some (input_line input) - with End_of_file -> None - in - match line with - | Some line -> - begin - try accumulator := (f !accumulator line) - with Break -> running := false - end - | None -> - running := false - done; - !accumulator + let accumulator = ref start in + let running = ref true in + while !running do + let line = + try Some (input_line input) + with End_of_file -> None + in + match line with + | Some line -> + begin + try accumulator := (f !accumulator line) + with Break -> running := false + end + | None -> + running := false + done; + !accumulator let lines_iter f = lines_fold (fun () line -> ignore(f line)) () (** open a file, and make sure the close is always done *) let with_input_channel file f = - let input = open_in file in - finally - (fun () -> f input) - (fun () -> close_in input) + let input = open_in file in + finally + (fun () -> f input) + (fun () -> close_in input) (** open a file, and make sure the close is always done *) let with_file file mode perms f = - let fd = Unix.openfile file mode perms in - let r = - try f fd - with exn -> Unix.close fd; raise exn - in - Unix.close fd; - r + let fd = Unix.openfile file mode perms in + let r = + try f fd + with exn -> Unix.close fd; raise exn + in + Unix.close fd; + r let file_lines_fold f start file_path = with_input_channel file_path (lines_fold f start) let read_lines ~(path : string) : string list = - List.rev (file_lines_fold (fun acc line -> line::acc) [] path) + List.rev (file_lines_fold (fun acc line -> line::acc) [] path) let file_lines_iter f = file_lines_fold (fun () line -> ignore(f line)) () @@ -138,28 +138,28 @@ let readfile_line = file_lines_iter (** [fd_blocks_fold block_size f start fd] folds [f] over blocks (strings) from the fd [fd] with initial value [start] *) let fd_blocks_fold block_size f start fd = - let block = String.create block_size in - let rec fold acc = - let n = Unix.read fd block 0 block_size in - (* Consider making the interface explicitly use Substrings *) - let s = if n = block_size then block else String.sub block 0 n in - if n = 0 then acc else fold (f acc s) in - fold start + let block = String.create block_size in + let rec fold acc = + let n = Unix.read fd block 0 block_size in + (* Consider making the interface explicitly use Substrings *) + let s = if n = block_size then block else String.sub block 0 n in + if n = 0 then acc else fold (f acc s) in + fold start let with_directory dir f = - let dh = Unix.opendir dir in - let r = - try f dh - with exn -> Unix.closedir dh; raise exn - in - Unix.closedir dh; - r + let dh = Unix.opendir dir in + let r = + try f dh + with exn -> Unix.closedir dh; raise exn + in + Unix.closedir dh; + r let buffer_of_fd fd = - fd_blocks_fold 1024 (fun b s -> Buffer.add_string b s; b) (Buffer.create 1024) fd + fd_blocks_fold 1024 (fun b s -> Buffer.add_string b s; b) (Buffer.create 1024) fd let bigbuffer_of_fd fd = - fd_blocks_fold 1024 (fun b s -> Bigbuffer.append_string b s; b) (Bigbuffer.make ()) fd + fd_blocks_fold 1024 (fun b s -> Bigbuffer.append_string b s; b) (Bigbuffer.make ()) fd let string_of_fd fd = Buffer.contents (buffer_of_fd fd) @@ -176,249 +176,249 @@ let atomic_write_to_file fname perms f = Unix.chmod tmp perms; Pervasiveext.finally (fun () -> - let fd = Unix.openfile tmp [Unix.O_WRONLY; Unix.O_CREAT] perms (* ignored since the file exists *) in - let result = Pervasiveext.finally - (fun () -> f fd) - (fun () -> Unix.close fd) in - Unix.rename tmp fname; (* Nb this only happens if an exception wasn't raised in the application of f *) - result) + let fd = Unix.openfile tmp [Unix.O_WRONLY; Unix.O_CREAT] perms (* ignored since the file exists *) in + let result = Pervasiveext.finally + (fun () -> f fd) + (fun () -> Unix.close fd) in + Unix.rename tmp fname; (* Nb this only happens if an exception wasn't raised in the application of f *) + result) (fun () -> unlink_safe tmp) (** Atomically write a string to a file *) let write_string_to_file fname s = atomic_write_to_file fname 0o644 (fun fd -> - let len = String.length s in - let written = Unix.write fd s 0 len in - if written <> len then (failwith "Short write occured!")) + let len = String.length s in + let written = Unix.write fd s 0 len in + if written <> len then (failwith "Short write occured!")) let execv_get_output cmd args = - let (pipe_exit, pipe_entrance) = Unix.pipe () in - let r = try Unix.set_close_on_exec pipe_exit; true with _ -> false in - match Unix.fork () with - | 0 -> - Unix.dup2 pipe_entrance Unix.stdout; - Unix.close pipe_entrance; - if not r then - Unix.close pipe_exit; - begin try Unix.execv cmd args with _ -> exit 127 end - | pid -> - Unix.close pipe_entrance; - pid, pipe_exit + let (pipe_exit, pipe_entrance) = Unix.pipe () in + let r = try Unix.set_close_on_exec pipe_exit; true with _ -> false in + match Unix.fork () with + | 0 -> + Unix.dup2 pipe_entrance Unix.stdout; + Unix.close pipe_entrance; + if not r then + Unix.close pipe_exit; + begin try Unix.execv cmd args with _ -> exit 127 end + | pid -> + Unix.close pipe_entrance; + pid, pipe_exit let copy_file_internal ?limit reader writer = - let buffer = String.make 65536 '\000' in - let buffer_len = Int64.of_int (String.length buffer) in - let finished = ref false in - let total_bytes = ref 0L in - let limit = ref limit in - while not(!finished) do - let requested = min (Opt.default buffer_len !limit) buffer_len in - let num = reader buffer 0 (Int64.to_int requested) in - let num64 = Int64.of_int num in - - limit := Opt.map (fun x -> Int64.sub x num64) !limit; - ignore_int (writer buffer 0 num); - total_bytes := Int64.add !total_bytes num64; - finished := num = 0 || !limit = Some 0L; - done; - !total_bytes + let buffer = String.make 65536 '\000' in + let buffer_len = Int64.of_int (String.length buffer) in + let finished = ref false in + let total_bytes = ref 0L in + let limit = ref limit in + while not(!finished) do + let requested = min (Opt.default buffer_len !limit) buffer_len in + let num = reader buffer 0 (Int64.to_int requested) in + let num64 = Int64.of_int num in + + limit := Opt.map (fun x -> Int64.sub x num64) !limit; + ignore_int (writer buffer 0 num); + total_bytes := Int64.add !total_bytes num64; + finished := num = 0 || !limit = Some 0L; + done; + !total_bytes let copy_file ?limit ifd ofd = copy_file_internal ?limit (Unix.read ifd) (Unix.write ofd) let file_exists file_path = - try Unix.access file_path [Unix.F_OK]; true - with _ -> false + try Unix.access file_path [Unix.F_OK]; true + with _ -> false let touch_file file_path = - let fd = Unix.openfile file_path - [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_NOCTTY; Unix.O_NONBLOCK] 0o666 in - Unix.close fd; - Unix.utimes file_path 0.0 0.0 + let fd = Unix.openfile file_path + [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_NOCTTY; Unix.O_NONBLOCK] 0o666 in + Unix.close fd; + Unix.utimes file_path 0.0 0.0 let is_empty_file file_path = - try - let stats = Unix.stat file_path in - stats.Unix.st_size = 0 - with Unix.Unix_error (Unix.ENOENT, _, _) -> - false + try + let stats = Unix.stat file_path in + stats.Unix.st_size = 0 + with Unix.Unix_error (Unix.ENOENT, _, _) -> + false let delete_empty_file file_path = - if is_empty_file file_path - then (Sys.remove file_path; true) - else (false) + if is_empty_file file_path + then (Sys.remove file_path; true) + else (false) (** Create a new file descriptor, connect it to host:port and return it *) exception Host_not_found of string let open_connection_fd host port = - let open Unix in - let addrinfo = getaddrinfo host (string_of_int port) [AI_SOCKTYPE SOCK_STREAM] in - match addrinfo with - | [] -> - failwith (Printf.sprintf "Couldn't resolve hostname: %s" host) - | ai :: _ -> - let s = socket ai.ai_family ai.ai_socktype 0 in - try - connect s ai.ai_addr; - s - with e -> - close s; - raise e + let open Unix in + let addrinfo = getaddrinfo host (string_of_int port) [AI_SOCKTYPE SOCK_STREAM] in + match addrinfo with + | [] -> + failwith (Printf.sprintf "Couldn't resolve hostname: %s" host) + | ai :: _ -> + let s = socket ai.ai_family ai.ai_socktype 0 in + try + connect s ai.ai_addr; + s + with e -> + close s; + raise e let open_connection_unix_fd filename = - let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - try - let addr = Unix.ADDR_UNIX(filename) in - Unix.connect s addr; - s - with e -> Unix.close s; raise e + let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + try + let addr = Unix.ADDR_UNIX(filename) in + Unix.connect s addr; + s + with e -> Unix.close s; raise e module CBuf = struct - (** A circular buffer constructed from a string *) - type t = { - mutable buffer: string; - mutable len: int; (** bytes of valid data in [buffer] *) - mutable start: int; (** index of first valid byte in [buffer] *) - mutable r_closed: bool; (** true if no more data can be read due to EOF *) - mutable w_closed: bool; (** true if no more data can be written due to EOF *) - } - - let empty length = { - buffer = String.create length; - len = 0; - start = 0; - r_closed = false; - w_closed = false; - } - - let drop (x: t) n = - if n > x.len then failwith (Printf.sprintf "drop %d > %d" n x.len); - x.start <- (x.start + n) mod (String.length x.buffer); - x.len <- x.len - n - - let should_read (x: t) = - not x.r_closed && (x.len < (String.length x.buffer - 1)) - let should_write (x: t) = - not x.w_closed && (x.len > 0) - - let end_of_reads (x: t) = x.r_closed && x.len = 0 - let end_of_writes (x: t) = x.w_closed - - let write (x: t) fd = - (* Offset of the character after the substring *) - let next = min (String.length x.buffer) (x.start + x.len) in - let len = next - x.start in - let written = try Unix.single_write fd x.buffer x.start len with _ -> x.w_closed <- true; len in - drop x written - - let read (x: t) fd = - (* Offset of the next empty character *) - let next = (x.start + x.len) mod (String.length x.buffer) in - let len = min (String.length x.buffer - next) (String.length x.buffer - x.len) in - let read = Unix.read fd x.buffer next len in - if read = 0 then x.r_closed <- true; - x.len <- x.len + read - + (** A circular buffer constructed from a string *) + type t = { + mutable buffer: string; + mutable len: int; (** bytes of valid data in [buffer] *) + mutable start: int; (** index of first valid byte in [buffer] *) + mutable r_closed: bool; (** true if no more data can be read due to EOF *) + mutable w_closed: bool; (** true if no more data can be written due to EOF *) + } + + let empty length = { + buffer = String.create length; + len = 0; + start = 0; + r_closed = false; + w_closed = false; + } + + let drop (x: t) n = + if n > x.len then failwith (Printf.sprintf "drop %d > %d" n x.len); + x.start <- (x.start + n) mod (String.length x.buffer); + x.len <- x.len - n + + let should_read (x: t) = + not x.r_closed && (x.len < (String.length x.buffer - 1)) + let should_write (x: t) = + not x.w_closed && (x.len > 0) + + let end_of_reads (x: t) = x.r_closed && x.len = 0 + let end_of_writes (x: t) = x.w_closed + + let write (x: t) fd = + (* Offset of the character after the substring *) + let next = min (String.length x.buffer) (x.start + x.len) in + let len = next - x.start in + let written = try Unix.single_write fd x.buffer x.start len with _ -> x.w_closed <- true; len in + drop x written + + let read (x: t) fd = + (* Offset of the next empty character *) + let next = (x.start + x.len) mod (String.length x.buffer) in + let len = min (String.length x.buffer - next) (String.length x.buffer - x.len) in + let read = Unix.read fd x.buffer next len in + if read = 0 then x.r_closed <- true; + x.len <- x.len + read + end exception Process_still_alive let kill_and_wait ?(signal = Sys.sigterm) ?(timeout=10.) pid = - let proc_entry_exists pid = - try Unix.access (Printf.sprintf "/proc/%d" pid) [ Unix.F_OK ]; true - with _ -> false - in - if pid > 0 && proc_entry_exists pid then ( - let loop_time_waiting = 0.03 in - let left = ref timeout in - let readcmdline pid = - try string_of_file (Printf.sprintf "/proc/%d/cmdline" pid) - with _ -> "" - in - let reference = readcmdline pid and quit = ref false in - Unix.kill pid signal; - - (* We cannot do a waitpid here, since we might not be parent of - the process, so instead we are waiting for the /proc/%d to go - away. Also we verify that the cmdline stay the same if it's still here - to prevent the very very unlikely event that the pid get reused before - we notice it's gone *) - while proc_entry_exists pid && not !quit && !left > 0. - do - let cmdline = readcmdline pid in - if cmdline = reference then ( - (* still up, let's sleep a bit *) - ignore (Unix.select [] [] [] loop_time_waiting); - left := !left -. loop_time_waiting - ) else ( - (* not the same, it's gone ! *) - quit := true - ) - done; - if !left <= 0. then - raise Process_still_alive; - ) + let proc_entry_exists pid = + try Unix.access (Printf.sprintf "/proc/%d" pid) [ Unix.F_OK ]; true + with _ -> false + in + if pid > 0 && proc_entry_exists pid then ( + let loop_time_waiting = 0.03 in + let left = ref timeout in + let readcmdline pid = + try string_of_file (Printf.sprintf "/proc/%d/cmdline" pid) + with _ -> "" + in + let reference = readcmdline pid and quit = ref false in + Unix.kill pid signal; + + (* We cannot do a waitpid here, since we might not be parent of + the process, so instead we are waiting for the /proc/%d to go + away. Also we verify that the cmdline stay the same if it's still here + to prevent the very very unlikely event that the pid get reused before + we notice it's gone *) + while proc_entry_exists pid && not !quit && !left > 0. + do + let cmdline = readcmdline pid in + if cmdline = reference then ( + (* still up, let's sleep a bit *) + ignore (Unix.select [] [] [] loop_time_waiting); + left := !left -. loop_time_waiting + ) else ( + (* not the same, it's gone ! *) + quit := true + ) + done; + if !left <= 0. then + raise Process_still_alive; + ) let string_of_signal x = - let table = [ - Sys.sigabrt, "SIGABRT"; - Sys.sigalrm, "SIGALRM"; - Sys.sigfpe, "SIGFPE"; - Sys.sighup, "SIGHUP"; - Sys.sigill, "SIGILL"; - Sys.sigint, "SIGINT"; - Sys.sigkill, "SIGKILL"; - Sys.sigpipe, "SIGPIPE"; - Sys.sigquit, "SIGQUIT"; - Sys.sigsegv, "SIGSEGV"; - Sys.sigterm, "SIGTERM"; - Sys.sigusr1, "SIGUSR1"; - Sys.sigusr2, "SIGUSR2"; - Sys.sigchld, "SIGCHLD"; - Sys.sigcont, "SIGCONT"; - Sys.sigstop, "SIGSTOP"; - Sys.sigttin, "SIGTTIN"; - Sys.sigttou, "SIGTTOU"; - Sys.sigvtalrm, "SIGVTALRM"; - Sys.sigprof, "SIGPROF"; - ] in - if List.mem_assoc x table - then List.assoc x table - else (Printf.sprintf "(ocaml signal %d with an unknown name)" x) + let table = [ + Sys.sigabrt, "SIGABRT"; + Sys.sigalrm, "SIGALRM"; + Sys.sigfpe, "SIGFPE"; + Sys.sighup, "SIGHUP"; + Sys.sigill, "SIGILL"; + Sys.sigint, "SIGINT"; + Sys.sigkill, "SIGKILL"; + Sys.sigpipe, "SIGPIPE"; + Sys.sigquit, "SIGQUIT"; + Sys.sigsegv, "SIGSEGV"; + Sys.sigterm, "SIGTERM"; + Sys.sigusr1, "SIGUSR1"; + Sys.sigusr2, "SIGUSR2"; + Sys.sigchld, "SIGCHLD"; + Sys.sigcont, "SIGCONT"; + Sys.sigstop, "SIGSTOP"; + Sys.sigttin, "SIGTTIN"; + Sys.sigttou, "SIGTTOU"; + Sys.sigvtalrm, "SIGVTALRM"; + Sys.sigprof, "SIGPROF"; + ] in + if List.mem_assoc x table + then List.assoc x table + else (Printf.sprintf "(ocaml signal %d with an unknown name)" x) let proxy (a: Unix.file_descr) (b: Unix.file_descr) = - let size = 64 * 1024 in - (* [a'] is read from [a] and will be written to [b] *) - (* [b'] is read from [b] and will be written to [a] *) - let a' = CBuf.empty size and b' = CBuf.empty size in - Unix.set_nonblock a; - Unix.set_nonblock b; - - try - while true do - let r = (if CBuf.should_read a' then [ a ] else []) @ (if CBuf.should_read b' then [ b ] else []) in - let w = (if CBuf.should_write a' then [ b ] else []) @ (if CBuf.should_write b' then [ a ] else []) in - - (* If we can't make any progress (because fds have been closed), then stop *) - if r = [] && w = [] then raise End_of_file; - - let r, w, _ = Unix.select r w [] (-1.0) in - (* Do the writing before the reading *) - List.iter (fun fd -> if a = fd then CBuf.write b' a else CBuf.write a' b) w; - List.iter (fun fd -> if a = fd then CBuf.read a' a else CBuf.read b' b) r; - (* If there's nothing else to read or write then signal the other end *) - List.iter - (fun (buf, fd) -> - if CBuf.end_of_reads buf then Unix.shutdown fd Unix.SHUTDOWN_SEND; - if CBuf.end_of_writes buf then Unix.shutdown fd Unix.SHUTDOWN_RECEIVE - ) [ a', b; b', a ] - done - with _ -> - (try Unix.clear_nonblock a with _ -> ()); - (try Unix.clear_nonblock b with _ -> ()); - (try Unix.close a with _ -> ()); - (try Unix.close b with _ -> ()) + let size = 64 * 1024 in + (* [a'] is read from [a] and will be written to [b] *) + (* [b'] is read from [b] and will be written to [a] *) + let a' = CBuf.empty size and b' = CBuf.empty size in + Unix.set_nonblock a; + Unix.set_nonblock b; + + try + while true do + let r = (if CBuf.should_read a' then [ a ] else []) @ (if CBuf.should_read b' then [ b ] else []) in + let w = (if CBuf.should_write a' then [ b ] else []) @ (if CBuf.should_write b' then [ a ] else []) in + + (* If we can't make any progress (because fds have been closed), then stop *) + if r = [] && w = [] then raise End_of_file; + + let r, w, _ = Unix.select r w [] (-1.0) in + (* Do the writing before the reading *) + List.iter (fun fd -> if a = fd then CBuf.write b' a else CBuf.write a' b) w; + List.iter (fun fd -> if a = fd then CBuf.read a' a else CBuf.read b' b) r; + (* If there's nothing else to read or write then signal the other end *) + List.iter + (fun (buf, fd) -> + if CBuf.end_of_reads buf then Unix.shutdown fd Unix.SHUTDOWN_SEND; + if CBuf.end_of_writes buf then Unix.shutdown fd Unix.SHUTDOWN_RECEIVE + ) [ a', b; b', a ] + done + with _ -> + (try Unix.clear_nonblock a with _ -> ()); + (try Unix.clear_nonblock b with _ -> ()); + (try Unix.close a with _ -> ()); + (try Unix.close b with _ -> ()) let rec really_read fd string off n = if n=0 then () else @@ -432,43 +432,43 @@ let really_read_string fd length = buf let try_read_string ?limit fd = - let buf = Buffer.create 0 in - let chunk = match limit with None -> 4096 | Some x -> x in - let cache = String.make chunk '\000' in - let finished = ref false in - while not !finished do - let to_read = match limit with - | Some x -> min (x - (Buffer.length buf)) chunk - | None -> chunk in - let read_bytes = Unix.read fd cache 0 to_read in - Buffer.add_substring buf cache 0 read_bytes; - if read_bytes = 0 then finished := true - done; - Buffer.contents buf + let buf = Buffer.create 0 in + let chunk = match limit with None -> 4096 | Some x -> x in + let cache = String.make chunk '\000' in + let finished = ref false in + while not !finished do + let to_read = match limit with + | Some x -> min (x - (Buffer.length buf)) chunk + | None -> chunk in + let read_bytes = Unix.read fd cache 0 to_read in + Buffer.add_substring buf cache 0 read_bytes; + if read_bytes = 0 then finished := true + done; + Buffer.contents buf let really_read_bigbuffer fd bigbuf n = - let chunk = 4096 in - let s = String.make chunk '\000' in - let written = ref 0L in - while !written < n do - let remaining = Int64.sub n !written in - let to_write = min remaining (Int64.of_int chunk) in - really_read fd s 0 (Int64.to_int to_write); - Bigbuffer.append_substring bigbuf s 0 (Int64.to_int to_write); - written := Int64.add !written to_write; - done + let chunk = 4096 in + let s = String.make chunk '\000' in + let written = ref 0L in + while !written < n do + let remaining = Int64.sub n !written in + let to_write = min remaining (Int64.of_int chunk) in + really_read fd s 0 (Int64.to_int to_write); + Bigbuffer.append_substring bigbuf s 0 (Int64.to_int to_write); + written := Int64.add !written to_write; + done let really_write fd string off n = - let written = ref 0 in - while !written < n - do - let wr = Unix.write fd string (off + !written) (n - !written) in - written := wr + !written - done + let written = ref 0 in + while !written < n + do + let wr = Unix.write fd string (off + !written) (n - !written) in + written := wr + !written + done (* Ideally, really_write would be implemented with optional arguments ?(off=0) ?(len=String.length string) *) let really_write_string fd string = - really_write fd string 0 (String.length string) + really_write fd string 0 (String.length string) (* --------------------------------------------------------------------------------------- *) (* Functions to read and write to/from a file descriptor with a given latest response time *) @@ -536,25 +536,25 @@ let read_data_in_chunks (f : string -> int -> unit) ?(block_size = 1024) ?(max_b do_read 0 let spawnvp ?(pid_callback=(fun _ -> ())) cmd args = - match Unix.fork () with - | 0 -> - Unix.execvp cmd args - | pid -> - begin try pid_callback pid with _ -> () end; - snd (Unix.waitpid [] pid) + match Unix.fork () with + | 0 -> + Unix.execvp cmd args + | pid -> + begin try pid_callback pid with _ -> () end; + snd (Unix.waitpid [] pid) let double_fork f = - match Unix.fork () with - | 0 -> - begin match Unix.fork () with - (* NB: use _exit (calls C lib _exit directly) to avoid - calling at_exit handlers and flushing output channels - which wouild cause intermittent deadlocks if we - forked from a threaded program *) - | 0 -> (try f () with _ -> ()); _exit 0 - | _ -> _exit 0 - end - | pid -> ignore(Unix.waitpid [] pid) + match Unix.fork () with + | 0 -> + begin match Unix.fork () with + (* NB: use _exit (calls C lib _exit directly) to avoid + calling at_exit handlers and flushing output channels + which wouild cause intermittent deadlocks if we + forked from a threaded program *) + | 0 -> (try f () with _ -> ()); _exit 0 + | _ -> _exit 0 + end + | pid -> ignore(Unix.waitpid [] pid) external set_tcp_nodelay : Unix.file_descr -> bool -> unit = "stub_unixext_set_tcp_nodelay" external set_sock_keepalives : Unix.file_descr -> int -> int -> int -> unit = "stub_unixext_set_sock_keepalives" @@ -599,9 +599,9 @@ let resolve_dot_and_dotdot (path: string) : string = then Filename.concat "/" path (* no notion of a cwd *) else path in rev_split (abs_path x) in - + let to_string (x: string list) = List.fold_left Filename.concat "/" (List.rev x) in - + (* Process all "." and ".." references *) let rec remove_dots (n: int) (x: string list) = match x, n with @@ -619,26 +619,26 @@ let seek_to fd pos = (** Seek to an offset within a file descriptor, relative to the current cursor position *) let seek_rel fd diff = Unix.lseek fd diff Unix.SEEK_CUR - + (** Return the current cursor position within a file descriptor *) let current_cursor_pos fd = (* 'seek' to the current position, exploiting the return value from Unix.lseek as the new cursor position *) Unix.lseek fd 0 Unix.SEEK_CUR module Fdset = struct - type t - external of_list : Unix.file_descr list -> t = "stub_fdset_of_list" - external is_set : t -> Unix.file_descr -> bool = "stub_fdset_is_set" - external is_set_and_clear : t -> Unix.file_descr -> bool = "stub_fdset_is_set_and_clear" - external is_empty : t -> bool = "stub_fdset_is_empty" - external set : t -> Unix.file_descr -> unit = "stub_fdset_set" - external clear : t -> Unix.file_descr -> unit = "stub_fdset_clear" - external _select : t -> t -> t -> float -> t * t * t = "stub_fdset_select" - external _select_ro : t -> float -> t = "stub_fdset_select_ro" - external _select_wo : t -> float -> t = "stub_fdset_select_wo" - let select r w e t = _select r w e t - let select_ro r t = _select_ro r t - let select_wo w t = _select_wo w t + type t + external of_list : Unix.file_descr list -> t = "stub_fdset_of_list" + external is_set : t -> Unix.file_descr -> bool = "stub_fdset_is_set" + external is_set_and_clear : t -> Unix.file_descr -> bool = "stub_fdset_is_set_and_clear" + external is_empty : t -> bool = "stub_fdset_is_empty" + external set : t -> Unix.file_descr -> unit = "stub_fdset_set" + external clear : t -> Unix.file_descr -> unit = "stub_fdset_clear" + external _select : t -> t -> t -> float -> t * t * t = "stub_fdset_select" + external _select_ro : t -> float -> t = "stub_fdset_select_ro" + external _select_wo : t -> float -> t = "stub_fdset_select_wo" + let select r w e t = _select r w e t + let select_ro r t = _select_ro r t + let select_wo w t = _select_wo w t end let wait_for_path path delay timeout = @@ -651,7 +651,7 @@ let wait_for_path path delay timeout = inner (ttl - 1) in inner (timeout * 2) - + let _ = Callback.register_exception "unixext.unix_error" (Unix_error (0)) @@ -659,49 +659,49 @@ let send_fd = Fd_send_recv.send_fd let recv_fd = Fd_send_recv.recv_fd type statvfs_t = { - f_bsize : int64; - f_frsize : int64; - f_blocks : int64; - f_bfree : int64; - f_bavail : int64; - f_files : int64; - f_ffree : int64; - f_favail : int64; - f_fsid : int64; - f_flag : int64; - f_namemax : int64; + f_bsize : int64; + f_frsize : int64; + f_blocks : int64; + f_bfree : int64; + f_bavail : int64; + f_files : int64; + f_ffree : int64; + f_favail : int64; + f_fsid : int64; + f_flag : int64; + f_namemax : int64; } external statvfs : string -> statvfs_t = "stub_statvfs" (** Returns Some Unix.PF_INET or Some Unix.PF_INET6 if passed a valid IP address, otherwise returns None. *) let domain_of_addr str = - try - let addr = Unix.inet_addr_of_string str in - Some (Unix.domain_of_sockaddr (Unix.ADDR_INET (addr, 1))) - with _ -> None + try + let addr = Unix.inet_addr_of_string str in + Some (Unix.domain_of_sockaddr (Unix.ADDR_INET (addr, 1))) + with _ -> None module Direct = struct - type t = Unix.file_descr + type t = Unix.file_descr - external openfile : string -> Unix.open_flag list -> Unix.file_perm -> t = "stub_stdext_unix_open_direct" + external openfile : string -> Unix.open_flag list -> Unix.file_perm -> t = "stub_stdext_unix_open_direct" - let close = Unix.close + let close = Unix.close - let with_openfile path flags perms f = - let t = openfile path flags perms in - finally (fun () -> f t) (fun () -> close t) + let with_openfile path flags perms f = + let t = openfile path flags perms in + finally (fun () -> f t) (fun () -> close t) - external unsafe_write : t -> string -> int -> int -> int = "stub_stdext_unix_write" + external unsafe_write : t -> string -> int -> int -> int = "stub_stdext_unix_write" - let write fd buf ofs len = - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.write" - else unsafe_write fd buf ofs len + let write fd buf ofs len = + if ofs < 0 || len < 0 || ofs > String.length buf - len + then invalid_arg "Unix.write" + else unsafe_write fd buf ofs len - let copy_from_fd ?limit socket fd = copy_file_internal ?limit (Unix.read socket) (write fd) + let copy_from_fd ?limit socket fd = copy_file_internal ?limit (Unix.read socket) (write fd) - let fsync x = fsync x + let fsync x = fsync x - let lseek fd x cmd = Unix.LargeFile.lseek fd x cmd + let lseek fd x cmd = Unix.LargeFile.lseek fd x cmd end diff --git a/lib/unixext.mli b/lib/unixext.mli index f4daafc9659..ee99e879296 100644 --- a/lib/unixext.mli +++ b/lib/unixext.mli @@ -34,7 +34,7 @@ val lines_fold : ('a -> string -> 'a) -> 'a -> in_channel -> 'a val lines_iter : (string -> unit) -> in_channel -> unit (** Folds function [f] over every line in the file at [file_path] using the -starting value [start]. *) + starting value [start]. *) val file_lines_fold : ('a -> string -> 'a) -> 'a -> string -> 'a (** [read_lines path] returns a list of lines in the file at [path]. *) @@ -54,7 +54,7 @@ val readfile_line : (string -> 'a) -> string -> unit val buffer_of_fd : Unix.file_descr -> Buffer.t (** [bigbuffer_of_fd fd] returns a Bigbuffer.t containing all data read from [fd] up -to EOF *) + to EOF *) val bigbuffer_of_fd : Unix.file_descr -> Bigbuffer.t (** [string_of_fd fd] returns a string containing all data read from [fd] up to EOF *) @@ -133,17 +133,17 @@ val seek_rel : Unix.file_descr -> int -> int val current_cursor_pos : Unix.file_descr -> int module Fdset : sig - type t - external of_list : Unix.file_descr list -> t = "stub_fdset_of_list" - external is_set : t -> Unix.file_descr -> bool = "stub_fdset_is_set" - external is_set_and_clear : t -> Unix.file_descr -> bool = "stub_fdset_is_set_and_clear" - external is_empty : t -> bool = "stub_fdset_is_empty" - external set : t -> Unix.file_descr -> unit = "stub_fdset_set" - external clear : t -> Unix.file_descr -> unit = "stub_fdset_clear" - - val select : t -> t -> t -> float -> t * t * t - val select_ro : t -> float -> t - val select_wo : t -> float -> t + type t + external of_list : Unix.file_descr list -> t = "stub_fdset_of_list" + external is_set : t -> Unix.file_descr -> bool = "stub_fdset_is_set" + external is_set_and_clear : t -> Unix.file_descr -> bool = "stub_fdset_is_set_and_clear" + external is_empty : t -> bool = "stub_fdset_is_empty" + external set : t -> Unix.file_descr -> unit = "stub_fdset_set" + external clear : t -> Unix.file_descr -> unit = "stub_fdset_clear" + + val select : t -> t -> t -> float -> t * t * t + val select_ro : t -> float -> t + val select_wo : t -> float -> t end val wait_for_path : string -> (float -> unit) -> int -> unit @@ -152,17 +152,17 @@ val send_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> U val recv_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr * Unix.file_descr type statvfs_t = { - f_bsize : int64; - f_frsize : int64; - f_blocks : int64; - f_bfree : int64; - f_bavail : int64; - f_files : int64; - f_ffree : int64; - f_favail : int64; - f_fsid : int64; - f_flag : int64; - f_namemax : int64; + f_bsize : int64; + f_frsize : int64; + f_blocks : int64; + f_bfree : int64; + f_bavail : int64; + f_files : int64; + f_ffree : int64; + f_favail : int64; + f_fsid : int64; + f_flag : int64; + f_namemax : int64; } val statvfs : string -> statvfs_t @@ -171,30 +171,30 @@ val statvfs : string -> statvfs_t val domain_of_addr : string -> Unix.socket_domain option module Direct : sig - (** Perform I/O in O_DIRECT mode using 4KiB page-aligned buffers *) + (** Perform I/O in O_DIRECT mode using 4KiB page-aligned buffers *) - type t - (** represents a file open in O_DIRECT mode *) + type t + (** represents a file open in O_DIRECT mode *) - val openfile : string -> Unix.open_flag list -> Unix.file_perm -> t - (** [openfile name flags perm] behaves the same as [Unix.openfile] but includes the O_DIRECT flag *) + val openfile : string -> Unix.open_flag list -> Unix.file_perm -> t + (** [openfile name flags perm] behaves the same as [Unix.openfile] but includes the O_DIRECT flag *) - val close : t -> unit - (** [close t] closes [t], a file open in O_DIRECT mode *) + val close : t -> unit + (** [close t] closes [t], a file open in O_DIRECT mode *) - val with_openfile : string -> Unix.open_flag list -> Unix.file_perm -> (t -> 'a) -> 'a - (** [with_openfile name flags perm f] opens [name], applies the result to [f] and closes *) + val with_openfile : string -> Unix.open_flag list -> Unix.file_perm -> (t -> 'a) -> 'a + (** [with_openfile name flags perm f] opens [name], applies the result to [f] and closes *) - val write : t -> string -> int -> int -> int - (** [write t buf ofs len] writes [len] bytes at offset [ofs] from buffer [buf] to - [t] using page-aligned buffers. *) + val write : t -> string -> int -> int -> int + (** [write t buf ofs len] writes [len] bytes at offset [ofs] from buffer [buf] to + [t] using page-aligned buffers. *) - val copy_from_fd : ?limit:int64 -> Unix.file_descr -> t -> int64 - (** [copy_from_fd ?limit fd t] copies from [fd] to [t] up to [limit] *) + val copy_from_fd : ?limit:int64 -> Unix.file_descr -> t -> int64 + (** [copy_from_fd ?limit fd t] copies from [fd] to [t] up to [limit] *) - val fsync : t -> unit - (** [fsync t] commits all outstanding writes, throwing an error if necessary. *) + val fsync : t -> unit + (** [fsync t] commits all outstanding writes, throwing an error if necessary. *) - val lseek : t -> int64 -> Unix.seek_command -> int64 - (** [lseek t offset command]: see Unix.LargeFile.lseek *) + val lseek : t -> int64 -> Unix.seek_command -> int64 + (** [lseek t offset command]: see Unix.LargeFile.lseek *) end diff --git a/lib/vIO.ml b/lib/vIO.ml index 6e512285f58..e0debc656af 100644 --- a/lib/vIO.ml +++ b/lib/vIO.ml @@ -16,92 +16,92 @@ exception End_of_file exception Timeout type t = { - read: string -> int -> int -> int; - write: string -> int -> int -> int; - input_line: (?timeout: float option -> unit -> string) option; - flush: unit -> unit; - close: unit -> unit; - is_raw: bool; - selectable: Unix.file_descr option; + read: string -> int -> int -> int; + write: string -> int -> int -> int; + input_line: (?timeout: float option -> unit -> string) option; + flush: unit -> unit; + close: unit -> unit; + is_raw: bool; + selectable: Unix.file_descr option; } let do_rw_io f buf index len = - let left = ref len in - let index = ref index in - let end_of_file = ref false in - while !left > 0 && not !end_of_file - do - let ret = f buf !index !left in - if ret = 0 then - end_of_file := true - else if ret > 0 then ( - left := !left - ret; - index := !index + ret; - ) - done; - len - !left + let left = ref len in + let index = ref index in + let end_of_file = ref false in + while !left > 0 && not !end_of_file + do + let ret = f buf !index !left in + if ret = 0 then + end_of_file := true + else if ret > 0 then ( + left := !left - ret; + index := !index + ret; + ) + done; + len - !left let do_rw_io_timeout fd is_write f buf index len timeout = - let fdset = Unixext.Fdset.of_list [ fd ] in - let select = if is_write then Unixext.Fdset.select_wo else Unixext.Fdset.select_ro in + let fdset = Unixext.Fdset.of_list [ fd ] in + let select = if is_write then Unixext.Fdset.select_wo else Unixext.Fdset.select_ro in - let left = ref len in - let index = ref index in - let end_of_file = ref false in - while !left > 0 && not !end_of_file - do - let set = select fdset timeout in - if Unixext.Fdset.is_empty set then - raise Timeout; - let ret = f buf !index !left in - if ret = 0 then - end_of_file := true - else if ret > 0 then ( - left := !left - ret; - index := !index + ret; - ) - done; - len - !left + let left = ref len in + let index = ref index in + let end_of_file = ref false in + while !left > 0 && not !end_of_file + do + let set = select fdset timeout in + if Unixext.Fdset.is_empty set then + raise Timeout; + let ret = f buf !index !left in + if ret = 0 then + end_of_file := true + else if ret > 0 then ( + left := !left - ret; + index := !index + ret; + ) + done; + len - !left let read ?(timeout=None) con buf index len = - match timeout, con.selectable with - | _, None | None, Some _ -> do_rw_io con.read buf index len - | Some timeout, Some fd -> do_rw_io_timeout fd false con.read buf index len timeout + match timeout, con.selectable with + | _, None | None, Some _ -> do_rw_io con.read buf index len + | Some timeout, Some fd -> do_rw_io_timeout fd false con.read buf index len timeout let write ?(timeout=None) con buf index len = - match timeout, con.selectable with - | _, None | None, Some _ -> do_rw_io con.write buf index len - | Some timeout, Some fd -> do_rw_io_timeout fd true con.write buf index len timeout + match timeout, con.selectable with + | _, None | None, Some _ -> do_rw_io con.write buf index len + | Some timeout, Some fd -> do_rw_io_timeout fd true con.write buf index len timeout let read_string ?timeout con len = - let s = String.create len in - let ret = read ?timeout con s 0 len in - if ret < len then - raise End_of_file; - s + let s = String.create len in + let ret = read ?timeout con s 0 len in + if ret < len then + raise End_of_file; + s let write_string ?timeout con s = - let len = String.length s in - if write ?timeout con s 0 len < len then - raise End_of_file; - () + let len = String.length s in + if write ?timeout con s 0 len < len then + raise End_of_file; + () let input_line ?timeout con = - match con.input_line with - | None -> - let buffer = Buffer.create 80 in - let newline = ref false in - while not !newline - do - let s = " " in - let ret = read ?timeout con s 0 1 in - if ret = 0 then - raise End_of_file; - if s.[0] = '\n' then newline := true else Buffer.add_char buffer s.[0] - done; - Buffer.contents buffer - | Some f -> - f ?timeout () + match con.input_line with + | None -> + let buffer = Buffer.create 80 in + let newline = ref false in + while not !newline + do + let s = " " in + let ret = read ?timeout con s 0 1 in + if ret = 0 then + raise End_of_file; + if s.[0] = '\n' then newline := true else Buffer.add_char buffer s.[0] + done; + Buffer.contents buffer + | Some f -> + f ?timeout () let flush con = con.flush () let close con = con.close () diff --git a/lib/vIO.mli b/lib/vIO.mli index a313b0074e7..237a2745ce6 100644 --- a/lib/vIO.mli +++ b/lib/vIO.mli @@ -15,13 +15,13 @@ exception End_of_file exception Timeout type t = { - read : string -> int -> int -> int; - write : string -> int -> int -> int; - input_line : (?timeout: float option -> unit -> string) option; - flush : unit -> unit; - close : unit -> unit; - is_raw : bool; - selectable : Unix.file_descr option; + read : string -> int -> int -> int; + write : string -> int -> int -> int; + input_line : (?timeout: float option -> unit -> string) option; + flush : unit -> unit; + close : unit -> unit; + is_raw : bool; + selectable : Unix.file_descr option; } val read : ?timeout: float option -> t -> string -> int -> int -> int diff --git a/lib/xstringext.ml b/lib/xstringext.ml index d9d94cd3fc9..dbd3d460e7f 100644 --- a/lib/xstringext.ml +++ b/lib/xstringext.ml @@ -13,222 +13,222 @@ *) module String = struct include String -let of_char c = String.make 1 c - -let init n f = - let string = make n (f 0) in - for i=1 to n-1 do - string.[i] <- f i; - done; - string - -let map f string = - init (length string) (fun i -> f string.[i]) - -let rev_map f string = - let n = length string in - init n (fun i -> f string.[n - i - 1]) - -let rev_iter f string = - for i = length string - 1 downto 0 do - f (string.[i]) - done - -let fold_left f accu string = - let accu = ref accu in - for i = 0 to length string - 1 do - accu := f !accu string.[i] - done; - !accu - -let iteri f string = - for i = 0 to length string - 1 do - f i string.[i] - done - -let fold_right f string accu = - let accu = ref accu in - for i = length string - 1 downto 0 do - accu := f string.[i] !accu - done; - !accu - -let explode string = - fold_right (fun h t -> h :: t) string [] - -let implode list = - concat "" (List.map of_char list) - -(** True if string 'x' ends with suffix 'suffix' *) -let endswith suffix x = - let x_l = String.length x and suffix_l = String.length suffix in - suffix_l <= x_l && String.sub x (x_l - suffix_l) suffix_l = suffix - -(** True if string 'x' starts with prefix 'prefix' *) -let startswith prefix x = - let x_l = String.length x and prefix_l = String.length prefix in - prefix_l <= x_l && String.sub x 0 prefix_l = prefix - -(** Returns true for whitespace characters, false otherwise *) -let isspace = function - | ' ' | '\n' | '\r' | '\t' -> true - | _ -> false - -(** Removes all the characters from the ends of a string for which the predicate is true *) -let strip predicate string = - let rec remove = function - | [] -> [] - | c :: cs -> if predicate c then remove cs else c :: cs in - implode (List.rev (remove (List.rev (remove (explode string))))) - -let escaped ?rules string = match rules with - | None -> String.escaped string - | Some rules -> - let aux h t = (if List.mem_assoc h rules - then List.assoc h rules - else of_char h) :: t in - concat "" (fold_right aux string []) - -(** Take a predicate and a string, return a list of strings separated by -runs of characters where the predicate was true (excluding those characters from the result) *) -let split_f p str = - let not_p = fun x -> not (p x) in - let rec split_one p acc = function - | [] -> List.rev acc, [] - | c :: cs -> if p c then split_one p (c :: acc) cs else List.rev acc, c :: cs in - - let rec alternate acc drop chars = - if chars = [] then acc else - begin - let a, b = split_one (if drop then p else not_p) [] chars in - alternate (if drop then acc else a :: acc) (not drop) b - end in - List.rev (List.map implode (alternate [] true (explode str))) - -let index_opt s c = - let rec loop i = - if String.length s = i - then None - else - if s.[i] = c - then Some i - else loop (i + 1) in - loop 0 - -let rec split ?limit:(limit=(-1)) c s = - let i = match index_opt s c with | Some x -> x | None -> -1 in - let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in - if i = -1 || nlimit = 0 then - [ s ] - else - let a = String.sub s 0 i - and b = String.sub s (i + 1) (String.length s - i - 1) in - a :: (split ~limit: nlimit c b) - -let rtrim s = - let n = String.length s in + let of_char c = String.make 1 c + + let init n f = + let string = make n (f 0) in + for i=1 to n-1 do + string.[i] <- f i; + done; + string + + let map f string = + init (length string) (fun i -> f string.[i]) + + let rev_map f string = + let n = length string in + init n (fun i -> f string.[n - i - 1]) + + let rev_iter f string = + for i = length string - 1 downto 0 do + f (string.[i]) + done + + let fold_left f accu string = + let accu = ref accu in + for i = 0 to length string - 1 do + accu := f !accu string.[i] + done; + !accu + + let iteri f string = + for i = 0 to length string - 1 do + f i string.[i] + done + + let fold_right f string accu = + let accu = ref accu in + for i = length string - 1 downto 0 do + accu := f string.[i] !accu + done; + !accu + + let explode string = + fold_right (fun h t -> h :: t) string [] + + let implode list = + concat "" (List.map of_char list) + + (** True if string 'x' ends with suffix 'suffix' *) + let endswith suffix x = + let x_l = String.length x and suffix_l = String.length suffix in + suffix_l <= x_l && String.sub x (x_l - suffix_l) suffix_l = suffix + + (** True if string 'x' starts with prefix 'prefix' *) + let startswith prefix x = + let x_l = String.length x and prefix_l = String.length prefix in + prefix_l <= x_l && String.sub x 0 prefix_l = prefix + + (** Returns true for whitespace characters, false otherwise *) + let isspace = function + | ' ' | '\n' | '\r' | '\t' -> true + | _ -> false + + (** Removes all the characters from the ends of a string for which the predicate is true *) + let strip predicate string = + let rec remove = function + | [] -> [] + | c :: cs -> if predicate c then remove cs else c :: cs in + implode (List.rev (remove (List.rev (remove (explode string))))) + + let escaped ?rules string = match rules with + | None -> String.escaped string + | Some rules -> + let aux h t = (if List.mem_assoc h rules + then List.assoc h rules + else of_char h) :: t in + concat "" (fold_right aux string []) + + (** Take a predicate and a string, return a list of strings separated by + runs of characters where the predicate was true (excluding those characters from the result) *) + let split_f p str = + let not_p = fun x -> not (p x) in + let rec split_one p acc = function + | [] -> List.rev acc, [] + | c :: cs -> if p c then split_one p (c :: acc) cs else List.rev acc, c :: cs in + + let rec alternate acc drop chars = + if chars = [] then acc else + begin + let a, b = split_one (if drop then p else not_p) [] chars in + alternate (if drop then acc else a :: acc) (not drop) b + end in + List.rev (List.map implode (alternate [] true (explode str))) + + let index_opt s c = + let rec loop i = + if String.length s = i + then None + else + if s.[i] = c + then Some i + else loop (i + 1) in + loop 0 + + let rec split ?limit:(limit=(-1)) c s = + let i = match index_opt s c with | Some x -> x | None -> -1 in + let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in + if i = -1 || nlimit = 0 then + [ s ] + else + let a = String.sub s 0 i + and b = String.sub s (i + 1) (String.length s - i - 1) in + a :: (split ~limit: nlimit c b) + + let rtrim s = + let n = String.length s in if n > 0 && String.get s (n - 1) = '\n' then String.sub s 0 (n - 1) else s -(** has_substr str sub returns true if sub is a substring of str. Simple, naive, slow. *) -let has_substr str sub = - if String.length sub > String.length str then false else - begin - let result=ref false in - for start = 0 to (String.length str) - (String.length sub) do - if String.sub str start (String.length sub) = sub then result := true + (** has_substr str sub returns true if sub is a substring of str. Simple, naive, slow. *) + let has_substr str sub = + if String.length sub > String.length str then false else + begin + let result=ref false in + for start = 0 to (String.length str) - (String.length sub) do + if String.sub str start (String.length sub) = sub then result := true + done; + !result + end + + (** find all occurences of needle in haystack and return all their respective index *) + let find_all needle haystack = + let m = String.length needle and n = String.length haystack in + + if m > n then + [] + else ( + let i = ref 0 and found = ref [] in + while !i < (n - m + 1) + do + if (String.sub haystack !i m) = needle then ( + found := !i :: !found; + i := !i + m + ) else ( + incr i + ) done; - !result - end - -(** find all occurences of needle in haystack and return all their respective index *) -let find_all needle haystack = - let m = String.length needle and n = String.length haystack in - - if m > n then - [] - else ( - let i = ref 0 and found = ref [] in - while !i < (n - m + 1) - do - if (String.sub haystack !i m) = needle then ( - found := !i :: !found; - i := !i + m - ) else ( - incr i - ) - done; - List.rev !found - ) - -(* replace all @f substring in @s by @t *) -let replace f t s = - let indexes = find_all f s in - let n = List.length indexes in - if n > 0 then ( - let len_f = String.length f and len_t = String.length t in - let new_len = String.length s + (n * len_t) - (n * len_f) in - let new_s = String.make new_len '\000' in - let orig_offset = ref 0 and dest_offset = ref 0 in - List.iter (fun h -> - let len = h - !orig_offset in - String.blit s !orig_offset new_s !dest_offset len; - String.blit t 0 new_s (!dest_offset + len) len_t; - orig_offset := !orig_offset + len + len_f; - dest_offset := !dest_offset + len + len_t; - ) indexes; - String.blit s !orig_offset new_s !dest_offset (String.length s - !orig_offset); - new_s - ) else - s - -let filter_chars s valid = - let badchars = ref false in - let buf = Buffer.create 0 in - for i = 0 to String.length s - 1 - do - if !badchars then ( - if valid s.[i] then - Buffer.add_char buf s.[i] - ) else ( - if not (valid s.[i]) then ( - Buffer.add_substring buf s 0 i; - badchars := true - ) - ) - done; - if !badchars then Buffer.contents buf else s - -let map_unlikely s f = - let changed = ref false in - let m = ref 0 in - let buf = Buffer.create 0 in - for i = 0 to String.length s - 1 - do - match f s.[i] with - | None -> () - | Some n -> - changed := true; - Buffer.add_substring buf s !m (i - !m); - Buffer.add_string buf n; - m := i + 1 - done; - if !changed then ( - Buffer.add_substring buf s !m (String.length s - !m); - Buffer.contents buf - ) else - s - -let sub_to_end s start = - let length = String.length s in - String.sub s start (length - start) - -let sub_before c s = - String.sub s 0 (String.index s c) - -let sub_after c s = - sub_to_end s (String.index s c + 1) - + List.rev !found + ) + + (* replace all @f substring in @s by @t *) + let replace f t s = + let indexes = find_all f s in + let n = List.length indexes in + if n > 0 then ( + let len_f = String.length f and len_t = String.length t in + let new_len = String.length s + (n * len_t) - (n * len_f) in + let new_s = String.make new_len '\000' in + let orig_offset = ref 0 and dest_offset = ref 0 in + List.iter (fun h -> + let len = h - !orig_offset in + String.blit s !orig_offset new_s !dest_offset len; + String.blit t 0 new_s (!dest_offset + len) len_t; + orig_offset := !orig_offset + len + len_f; + dest_offset := !dest_offset + len + len_t; + ) indexes; + String.blit s !orig_offset new_s !dest_offset (String.length s - !orig_offset); + new_s + ) else + s + + let filter_chars s valid = + let badchars = ref false in + let buf = Buffer.create 0 in + for i = 0 to String.length s - 1 + do + if !badchars then ( + if valid s.[i] then + Buffer.add_char buf s.[i] + ) else ( + if not (valid s.[i]) then ( + Buffer.add_substring buf s 0 i; + badchars := true + ) + ) + done; + if !badchars then Buffer.contents buf else s + + let map_unlikely s f = + let changed = ref false in + let m = ref 0 in + let buf = Buffer.create 0 in + for i = 0 to String.length s - 1 + do + match f s.[i] with + | None -> () + | Some n -> + changed := true; + Buffer.add_substring buf s !m (i - !m); + Buffer.add_string buf n; + m := i + 1 + done; + if !changed then ( + Buffer.add_substring buf s !m (String.length s - !m); + Buffer.contents buf + ) else + s + + let sub_to_end s start = + let length = String.length s in + String.sub s start (length - start) + + let sub_before c s = + String.sub s 0 (String.index s c) + + let sub_after c s = + sub_to_end s (String.index s c + 1) + end diff --git a/lib/xstringext.mli b/lib/xstringext.mli index 2ea3c319939..4f419b4e4ac 100644 --- a/lib/xstringext.mli +++ b/lib/xstringext.mli @@ -12,88 +12,88 @@ * GNU Lesser General Public License for more details. *) module String : - sig - include module type of String +sig + include module type of String - val of_char : char -> string + val of_char : char -> string - (** Make a string of the given length with characters generated by the - given function. *) - val init : int -> (int -> char) -> string + (** Make a string of the given length with characters generated by the + given function. *) + val init : int -> (int -> char) -> string - (** Map a string to a string. *) - val map : (char -> char) -> string -> string + (** Map a string to a string. *) + val map : (char -> char) -> string -> string - (** Map a string to a string, applying the given function in reverse - order. *) - val rev_map : (char -> char) -> string -> string + (** Map a string to a string, applying the given function in reverse + order. *) + val rev_map : (char -> char) -> string -> string - (** Iterate over the characters in a string in reverse order. *) - val rev_iter : (char -> unit) -> string -> unit + (** Iterate over the characters in a string in reverse order. *) + val rev_iter : (char -> unit) -> string -> unit - (** Fold over the characters in a string. *) - val fold_left : ('a -> char -> 'a) -> 'a -> string -> 'a + (** Fold over the characters in a string. *) + val fold_left : ('a -> char -> 'a) -> 'a -> string -> 'a - (** Iterate over the characters with the character index in argument *) - val iteri : (int -> char -> unit) -> string -> unit + (** Iterate over the characters with the character index in argument *) + val iteri : (int -> char -> unit) -> string -> unit - (** Iterate over the characters in a string in reverse order. *) - val fold_right : (char -> 'a -> 'a) -> string -> 'a -> 'a + (** Iterate over the characters in a string in reverse order. *) + val fold_right : (char -> 'a -> 'a) -> string -> 'a -> 'a - (** Split a string into a list of characters. *) - val explode : string -> char list + (** Split a string into a list of characters. *) + val explode : string -> char list - (** Concatenate a list of characters into a string. *) - val implode : char list -> string + (** Concatenate a list of characters into a string. *) + val implode : char list -> string - (** True if string 'x' ends with suffix 'suffix' *) - val endswith : string -> string -> bool + (** True if string 'x' ends with suffix 'suffix' *) + val endswith : string -> string -> bool - (** True if string 'x' starts with prefix 'prefix' *) - val startswith : string -> string -> bool + (** True if string 'x' starts with prefix 'prefix' *) + val startswith : string -> string -> bool - (** True if the character is whitespace *) - val isspace : char -> bool + (** True if the character is whitespace *) + val isspace : char -> bool - (** Removes all the characters from the ends of a string for which the predicate is true *) - val strip : (char -> bool) -> string -> string + (** Removes all the characters from the ends of a string for which the predicate is true *) + val strip : (char -> bool) -> string -> string - (** Backward-compatible string escaping, defaulting to the built-in - OCaml string escaping but allowing an arbitrary mapping from characters - to strings. *) - val escaped : ?rules:(char * string) list -> string -> string + (** Backward-compatible string escaping, defaulting to the built-in + OCaml string escaping but allowing an arbitrary mapping from characters + to strings. *) + val escaped : ?rules:(char * string) list -> string -> string - (** Take a predicate and a string, return a list of strings separated by - runs of characters where the predicate was true *) - val split_f : (char -> bool) -> string -> string list + (** Take a predicate and a string, return a list of strings separated by + runs of characters where the predicate was true *) + val split_f : (char -> bool) -> string -> string list - (** split a string on a single char *) - val split : ?limit:int -> char -> string -> string list + (** split a string on a single char *) + val split : ?limit:int -> char -> string -> string list - (** FIXME document me|remove me if similar to strip *) - val rtrim : string -> string + (** FIXME document me|remove me if similar to strip *) + val rtrim : string -> string - (** True if sub is a substr of str *) - val has_substr : string -> string -> bool + (** True if sub is a substr of str *) + val has_substr : string -> string -> bool - (** find all occurences of needle in haystack and return all their respective index *) - val find_all : string -> string -> int list + (** find all occurences of needle in haystack and return all their respective index *) + val find_all : string -> string -> int list - (** replace all [f] substring in [s] by [t] *) - val replace : string -> string -> string -> string + (** replace all [f] substring in [s] by [t] *) + val replace : string -> string -> string -> string - (** filter chars from a string *) - val filter_chars : string -> (char -> bool) -> string + (** filter chars from a string *) + val filter_chars : string -> (char -> bool) -> string - (** map a string trying to fill the buffer by chunk *) - val map_unlikely : string -> (char -> string option) -> string + (** map a string trying to fill the buffer by chunk *) + val map_unlikely : string -> (char -> string option) -> string - (** a substring from the specified position to the end of the string *) - val sub_to_end : string -> int -> string - - (** a substring from the start of the string to the first occurrence of a given character, excluding the character *) - val sub_before : char -> string -> string - - (** a substring from the first occurrence of a given character to the end of the string, excluding the character *) - val sub_after : char -> string -> string - end + (** a substring from the specified position to the end of the string *) + val sub_to_end : string -> int -> string + + (** a substring from the start of the string to the first occurrence of a given character, excluding the character *) + val sub_before : char -> string -> string + + (** a substring from the first occurrence of a given character to the end of the string, excluding the character *) + val sub_after : char -> string -> string +end diff --git a/lib/zerocheck.ml b/lib/zerocheck.ml index 1adedc61a4e..1affe1c9fbe 100644 --- a/lib/zerocheck.ml +++ b/lib/zerocheck.ml @@ -17,32 +17,32 @@ external _find_a_nonzero : string -> int -> int -> int = "find_a_nonzero" external _find_a_zero : string -> int -> int -> int = "find_a_zero" let wrap f x len offset = - let remaining = len - offset in - if remaining <= 0 then raise (Invalid_argument "offset > length"); - let result = f x offset remaining in - if result = remaining then None else Some (result + offset) + let remaining = len - offset in + if remaining <= 0 then raise (Invalid_argument "offset > length"); + let result = f x offset remaining in + if result = remaining then None else Some (result + offset) let find_a_nonzero = wrap _find_a_nonzero let find_a_zero = wrap _find_a_zero type substring = { - buf: string; - offset: int; - len: int + buf: string; + offset: int; + len: int } let fold_over_nonzeros x len rounddown roundup f initial = - let rec inner acc offset = - if offset = len then acc - else - match find_a_nonzero x len offset with - | None -> acc (* no more *) - | Some s -> - let e = match find_a_zero x len s with - | None -> len - | Some e -> e in - let e = min len (roundup e) in - let s = max 0 (rounddown s) in - inner (f acc { buf = x; offset = s; len = e - s }) e in - inner initial 0 + let rec inner acc offset = + if offset = len then acc + else + match find_a_nonzero x len offset with + | None -> acc (* no more *) + | Some s -> + let e = match find_a_zero x len s with + | None -> len + | Some e -> e in + let e = min len (roundup e) in + let s = max 0 (rounddown s) in + inner (f acc { buf = x; offset = s; len = e - s }) e in + inner initial 0 diff --git a/lib/zerocheck.mli b/lib/zerocheck.mli index 0d92539e0a4..222e16c8151 100644 --- a/lib/zerocheck.mli +++ b/lib/zerocheck.mli @@ -28,14 +28,14 @@ val find_a_zero: string -> int -> int -> int option val find_a_nonzero: string -> int -> int -> int option type substring = { - buf: string; - offset: int; - len: int + buf: string; + offset: int; + len: int } (** [fold_over_nonzeros buf len rounddown roundup f initial] folds [f] over all (start, length) pairs of non-zero data in string [buf] up to [len]. - The start of each pair is rounded down with [rounddown] and + The start of each pair is rounded down with [rounddown] and the end offset of each pair is rounded up with [roundup] (e.g. to potential block boudaries. *) val fold_over_nonzeros: string -> int -> (int -> int) -> (int -> int) -> ('a -> substring -> 'a) -> 'a -> 'a diff --git a/lib_test/extentlistset_test.ml b/lib_test/extentlistset_test.ml index 3edef31f2c3..1e80781ed10 100644 --- a/lib_test/extentlistset_test.ml +++ b/lib_test/extentlistset_test.ml @@ -4,28 +4,28 @@ open Set_test (* We test using the integer domain only. *) module Intextentlist = ExtentlistSet.ExtentlistSet(struct - type t=int - let zero=0 - let add=(+) - let sub=(-) -end) + type t=int + let zero=0 + let add=(+) + let sub=(-) + end) open Intextentlist (* Sets are finite, up to cardinality [size] *) let size = 1000 module Tests = SetEqualities(struct - type t = Intextentlist.t - let universe = of_list [(0, size)] - let (+) = union - let (^) = intersection - let (-) = difference + type t = Intextentlist.t + let universe = of_list [(0, size)] + let (+) = union + let (^) = intersection + let (-) = difference - let not x = universe - x - let (=) x y = (x - y = empty) && (y - x = empty) - let extent_to_string (s, l) = Printf.sprintf "(%d, %d)" s l - let to_string xs = String.concat ", " (List.map extent_to_string (to_list xs)) -end) + let not x = universe - x + let (=) x y = (x - y = empty) && (y - x = empty) + let extent_to_string (s, l) = Printf.sprintf "(%d, %d)" s l + let to_string xs = String.concat ", " (List.map extent_to_string (to_list xs)) + end) (* Given a triple of inputs, check that all the set equalities hold *) let one (a, b, c) = List.iter (fun f -> f a b c) Tests.all @@ -55,10 +55,10 @@ type run = | Full of int let to_run_list xs = let rec inner acc index = function - | [] -> acc - | (x, y) :: xs -> inner (Full y :: (Empty (x - index)) :: acc) (x + y) xs in + | [] -> acc + | (x, y) :: xs -> inner (Full y :: (Empty (x - index)) :: acc) (x + y) xs in - List.rev (inner [] 0 xs) + List.rev (inner [] 0 xs) let _ = (* vhds have max size of 2 TiB, in 2 MiB blocks => 2**20 blocks *) @@ -75,14 +75,14 @@ let _ = Printf.printf "generated\n"; - let x = to_list worst_case in -Printf.printf "got a list\n"; - (* let y = Listext.List.map_tr hex x in *) -Printf.printf "got lots of strings\n"; + let x = to_list worst_case in + Printf.printf "got a list\n"; + (* let y = Listext.List.map_tr hex x in *) + Printf.printf "got lots of strings\n"; let s = to_string (to_list worst_case) in Printf.printf "Extent size=%d\n" (String.length s); - let string_of_run = function - | Empty x -> Printf.sprintf "-%d" x - | Full x -> Printf.sprintf "+%d" x in - let s' = String.concat ";" (Listext.List.map_tr string_of_run (to_run_list x)) in - Printf.printf "Runs size=%d\n" (String.length s') + let string_of_run = function + | Empty x -> Printf.sprintf "-%d" x + | Full x -> Printf.sprintf "+%d" x in + let s' = String.concat ";" (Listext.List.map_tr string_of_run (to_run_list x)) in + Printf.printf "Runs size=%d\n" (String.length s') diff --git a/lib_test/set_test.ml b/lib_test/set_test.ml index dd46c7ed2b0..611a77502aa 100644 --- a/lib_test/set_test.ml +++ b/lib_test/set_test.ml @@ -13,19 +13,19 @@ module SetEqualities(S: Set) = struct open S let w txt f a b c = - if Pervasives.not(f a b c) - then failwith (Printf.sprintf "%s a=%s b=%s c=%s" txt (S.to_string a) (S.to_string b) (S.to_string c)) - + if Pervasives.not(f a b c) + then failwith (Printf.sprintf "%s a=%s b=%s c=%s" txt (S.to_string a) (S.to_string b) (S.to_string c)) + let all = [ - w "commutative_1" (fun a b _ -> a + b = b + a); - w "commutative_2" (fun a b _ -> a ^ b = b ^ a); - w "associative_1" (fun a b c -> (a + b) + c = a + (b + c)); - w "associative_2" (fun a b c -> (a ^ b) ^ c = a ^ (b ^ c)); - w "distributive_1" (fun a b c -> a + (b ^ c) = (a + b) ^ (a + c)); - w "distributive_2" (fun a b c -> a ^ (b + c) = (a ^ b) + (a ^ c)); - w "complement_1" (fun a _ _ -> not (not a) = a); - w "demorgan_1" (fun a b _ -> not (a + b) = (not a) ^ (not b)); - w "demorgan_2" (fun a b _ -> not (a ^ b) = (not a) + (not b)); + w "commutative_1" (fun a b _ -> a + b = b + a); + w "commutative_2" (fun a b _ -> a ^ b = b ^ a); + w "associative_1" (fun a b c -> (a + b) + c = a + (b + c)); + w "associative_2" (fun a b c -> (a ^ b) ^ c = a ^ (b ^ c)); + w "distributive_1" (fun a b c -> a + (b ^ c) = (a + b) ^ (a + c)); + w "distributive_2" (fun a b c -> a ^ (b + c) = (a ^ b) + (a ^ c)); + w "complement_1" (fun a _ _ -> not (not a) = a); + w "demorgan_1" (fun a b _ -> not (a + b) = (not a) ^ (not b)); + w "demorgan_2" (fun a b _ -> not (a ^ b) = (not a) + (not b)); ] end diff --git a/lib_test/set_test.mli b/lib_test/set_test.mli index aef45f9c3a5..c09eec0528a 100644 --- a/lib_test/set_test.mli +++ b/lib_test/set_test.mli @@ -1,15 +1,15 @@ module type Set = - sig - type t - val ( + ) : t -> t -> t - val ( ^ ) : t -> t -> t - val ( - ) : t -> t -> t - val not : t -> t - val ( = ) : t -> t -> bool - val to_string : t -> string - end +sig + type t + val ( + ) : t -> t -> t + val ( ^ ) : t -> t -> t + val ( - ) : t -> t -> t + val not : t -> t + val ( = ) : t -> t -> bool + val to_string : t -> string +end module SetEqualities : functor (S : Set) -> - sig - val all : (S.t -> S.t -> S.t -> unit) list - end + sig + val all : (S.t -> S.t -> S.t -> unit) list + end From b3ff46eb0bdd52eaec32184f9614bd8a0463d670 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Fri, 28 Jul 2017 18:06:11 +0100 Subject: [PATCH 050/199] First batch of cleanup Signed-off-by: Marcello Seri --- lib/extentlistSet.ml | 106 ------------------- lib/extentlistSet.mli | 27 ----- lib/qring.ml | 141 -------------------------- lib/qring.mli | 41 -------- lib/trie.ml | 180 --------------------------------- lib/trie.mli | 58 ----------- lib/vIO.ml | 107 -------------------- lib/vIO.mli | 33 ------ lib_test/extentlistset_test.ml | 88 ---------------- lib_test/jbuild | 9 -- lib_test/set_test.ml | 31 ------ lib_test/set_test.mli | 15 --- stdext.opam | 1 - 13 files changed, 837 deletions(-) delete mode 100644 lib/extentlistSet.ml delete mode 100644 lib/extentlistSet.mli delete mode 100644 lib/qring.ml delete mode 100644 lib/qring.mli delete mode 100644 lib/trie.ml delete mode 100644 lib/trie.mli delete mode 100644 lib/vIO.ml delete mode 100644 lib/vIO.mli delete mode 100644 lib_test/extentlistset_test.ml delete mode 100644 lib_test/jbuild delete mode 100644 lib_test/set_test.ml delete mode 100644 lib_test/set_test.mli diff --git a/lib/extentlistSet.ml b/lib/extentlistSet.ml deleted file mode 100644 index d4dd3ccf5d4..00000000000 --- a/lib/extentlistSet.ml +++ /dev/null @@ -1,106 +0,0 @@ - -module type Number = sig - type t - val zero: t - val add : t -> t -> t - val sub : t -> t -> t -end - -module ExtentlistSet (A : Number) = -struct - type extent = A.t * A.t - type t = extent list - - let ($+) = A.add - let ($-) = A.sub - - let empty = [] - - let sort list : t = - List.sort (fun x y -> compare (fst x) (fst y)) list - - let remove_zeroes = List.filter (fun (_, y) -> y <> A.zero) - - let union (list1: t) (list2: t) : t = - let combined = sort (list1 @ list2) in - let rec inner l acc = - match l with - | (s1,e1)::(s2,e2)::ls -> - let extent1_end = s1 $+ e1 in - if extent1_end < s2 then - inner ((s2,e2)::ls) ((s1,e1)::acc) - else - let extent2_end = s2 $+ e2 in - if extent1_end > extent2_end then - inner ((s1,e1)::ls) acc - else - inner ((s1,s2 $+ e2 $- s1)::ls) acc - | (s1,e1)::[] -> (s1,e1)::acc - | [] -> [] - in List.rev (inner combined []) - - let intersection (list1: t) (list2: t) = - let rec inner l1 l2 acc = - match (l1,l2) with - | (s1,e1)::l1s , (s2,e2)::l2s -> - if s1 > s2 then inner l2 l1 acc else - if s1 $+ e1 < s2 then inner l1s l2 acc else - if s1 < s2 then inner ((s2,e1 $+ s1 $- s2)::l1s) l2 acc else - (* s1=s2 *) - if e1 < e2 then - inner l1s ((s2 $+ e1,e2 $- e1)::l2s) ((s1,e1)::acc) - else if e1 > e2 then - inner ((s1 $+ e2,e1 $- e2)::l1s) l2s ((s2,e2)::acc) - else (* e1=e2 *) - inner l1s l2s ((s1,e1)::acc) - | _ -> List.rev acc - in - remove_zeroes(inner list1 list2 []) - - let difference (list1: t) (list2: t) : t = - let rec inner l1 l2 acc = - match (l1,l2) with - | (s1,e1)::l1s , (s2,e2)::l2s -> - if s1 s2 then - inner ((s2,s1 $+ e1 $- s2)::l1s) l2 ((s1,s2 $- s1)::acc) - else - inner l1s l2 ((s1,e1)::acc) - end else if s1>s2 then begin - if s2 $+ e2 > s1 then - inner l1 ((s1,s2 $+ e2 $- s1)::l2s) acc - else - inner l1 l2s acc - end else begin - (* s1=s2 *) - if e1 > e2 then - inner ((s1 $+ e2,e1 $- e2)::l1s) l2s acc - else if e1 < e2 then - inner l1s ((s2 $+ e1,e2 $- e1)::l2s) acc - else - inner l1s l2s acc - end - | l1s, [] -> (List.rev acc) @ l1s - | [], _ -> List.rev acc - in - remove_zeroes(inner list1 list2 []) - - let of_list (list: extent list) : t = - let l = sort list in - let rec inner ls acc = - match ls with - | (s1,e1)::(s2,e2)::rest -> - (* extents should be non-overlapping *) - if s1 $+ e1 > s2 then failwith "Bad list" - (* adjacent extents should be coalesced *) - else if s1 $+ e1=s2 then inner ((s1,e1 $+ e2)::rest) acc - else inner ((s2,e2)::rest) ((s1,e1)::acc) - | (s1,e1)::[] -> List.rev ((s1,e1)::acc) - | [] -> List.rev acc - in - inner l [] - - let fold_left = List.fold_left - - let to_list x = x -end diff --git a/lib/extentlistSet.mli b/lib/extentlistSet.mli deleted file mode 100644 index 6856d32a455..00000000000 --- a/lib/extentlistSet.mli +++ /dev/null @@ -1,27 +0,0 @@ -(** A module to represent sets of elements as (start, length) pairs. *) - -(** Elements must be 'Numbers': *) -module type Number = sig - type t - val zero: t - val add : t -> t -> t - val sub : t -> t -> t - -end - -(** Representation of a Set *) -module ExtentlistSet: functor (A : Number) -> sig - type extent = A.t * A.t - type t - - val empty : t - - val union : t -> t -> t - val intersection : t -> t -> t - val difference : t -> t -> t - - val of_list : extent list -> t - val to_list : t -> extent list - val fold_left : ('a -> extent -> 'a) -> 'a -> t -> 'a -end - diff --git a/lib/qring.ml b/lib/qring.ml deleted file mode 100644 index de9e6df0be4..00000000000 --- a/lib/qring.ml +++ /dev/null @@ -1,141 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -type t = { - sz: int; - data: string; - mutable prod: int; - mutable cons: int; - mutable pwrap: bool; -} - -exception Data_limit -exception Full - -let make sz = { sz = sz; data = String.create sz; prod = 0; cons = 0; pwrap = false } - -let to_consume ring = - if ring.pwrap then - ring.sz - (ring.cons - ring.prod) - else - ring.prod - ring.cons - -let to_fill ring = - if ring.pwrap then - ring.cons - ring.prod - else - ring.cons + (ring.sz - ring.prod) - -let is_full ring = ring.pwrap && ring.prod = ring.cons -let is_empty ring = not ring.pwrap && ring.prod = ring.cons - -let adv_cons ring i = - ring.cons <- ring.cons + i; - if ring.cons >= ring.sz then ( - ring.cons <- ring.cons - ring.sz; - ring.pwrap <- false; - ) - -let adv_prod ring i = - ring.prod <- ring.prod + i; - if ring.prod >= ring.sz then ( - ring.prod <- ring.prod - ring.sz; - ring.pwrap <- true; - ) - -let consume ring sz = - let max = to_consume ring in - let sz = - if sz > 0 then - if sz > max then max else sz - else - if max + sz > 0 then max + sz else 0 - in - let out = String.create sz in - if ring.pwrap then ( - let left_end = ring.sz - ring.cons in - if sz > left_end then ( - String.blit ring.data ring.cons out 0 left_end; - String.blit ring.data 0 out left_end (sz - left_end); - ) else - String.blit ring.data ring.cons out 0 sz; - ) else - String.blit ring.data ring.cons out 0 sz; - adv_cons ring sz; - out - -let consume_all ring = consume ring (max_int) - -let skip ring n = - let max = to_consume ring in - let n = if n > max then max else n in - adv_cons ring n - -let feed_data ring data = - let len = String.length data in - let max = to_fill ring in - if len > max then - raise Data_limit; - if ring.prod + len > ring.sz then ( - let firstblitsz = ring.sz - ring.prod in - String.blit data 0 ring.data ring.prod firstblitsz; - String.blit data firstblitsz ring.data 0 (len - firstblitsz); - ) else - String.blit data 0 ring.data ring.prod len; - adv_prod ring len; - () - -(* read and search directly to the qring. - * since we have give a continuous buffer, we limit our read length to the - * maximum continous length instead of the full length of the qring left. - * after the read, piggyback into the new data. -*) -let read_search ring fread fsearch len = - let prod = ring.prod in - let maxlen = - if ring.pwrap - then ring.cons - ring.prod - else ring.sz - ring.prod - in - if maxlen = 0 then - raise Full; - let len = if maxlen < len then maxlen else len in - let n = fread ring.data prod len in - if n > 0 then ( - adv_prod ring n; - fsearch ring.data prod n - ); - n - -let search ring c = - let search_from_to f t = - let found = ref false in - let i = ref f in - while not !found && !i < t - do - if ring.data.[!i] = c then - found := true - else - incr i - done; - if not !found then - raise Not_found; - !i - f - in - if is_empty ring then - raise Not_found; - if ring.pwrap then ( - try search_from_to ring.cons ring.sz - with Not_found -> search_from_to 0 ring.prod - ) else - search_from_to ring.cons ring.prod diff --git a/lib/qring.mli b/lib/qring.mli deleted file mode 100644 index 480dbf10fae..00000000000 --- a/lib/qring.mli +++ /dev/null @@ -1,41 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -type t = { - sz: int; - data: string; - mutable prod: int; - mutable cons: int; - mutable pwrap: bool; -} - -exception Data_limit -exception Full - -val make : int -> t - -val to_consume : t -> int -val to_fill : t -> int - -val is_full : t -> bool -val is_empty : t -> bool - -val consume : t -> int -> string -val consume_all : t -> string -val skip : t -> int -> unit - -val feed_data : t -> string -> unit -val read_search : t -> (string -> int -> int -> int) - -> (string -> int -> int -> unit) -> int - -> int -val search : t -> char -> int diff --git a/lib/trie.ml b/lib/trie.ml deleted file mode 100644 index 9e2f9d21adc..00000000000 --- a/lib/trie.ml +++ /dev/null @@ -1,180 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -module Node = -struct - type ('a,'b) t = { - key: 'a; - value: 'b option; - children: ('a,'b) t list; - } - - (* let create key value = { - key = key; - value = Some value; - children = []; - } *) - - let empty key = { - key = key; - value = None; - children = [] - } - - (* let get_key node = node.key *) - let get_value node = - match node.value with - | None -> raise Not_found - | Some value -> value - - (* let get_children node = node.children *) - - let set_value node value = - { node with value = Some value } - let set_children node children = - { node with children = children } - - (* let add_child node child = - { node with children = child :: node.children } *) -end - -type ('a,'b) t = ('a,'b) Node.t list - -let mem_node nodes key = - List.exists (fun n -> n.Node.key = key) nodes - -let find_node nodes key = - List.find (fun n -> n.Node.key = key) nodes - -let replace_node nodes key node = - let rec aux = function - | [] -> [] - | h :: tl when h.Node.key = key -> node :: tl - | h :: tl -> h :: aux tl - in - aux nodes - -let remove_node nodes key = - let rec aux = function - | [] -> raise Not_found - | h :: tl when h.Node.key = key -> tl - | h :: tl -> h :: aux tl - in - aux nodes - -let create () = [] - -let rec iter f tree = - let aux node = - f node.Node.key node.Node.value; - iter f node.Node.children - in - List.iter aux tree - -let rec map f tree = - let aux node = - let value = - match node.Node.value with - | None -> None - | Some value -> f value - in - { node with Node.value = value; Node.children = map f node.Node.children } - in - List.filter (fun n -> n.Node.value <> None || n.Node.children <> []) (List.map aux tree) - -let rec fold f tree acc = - let aux accu node = - fold f node.Node.children (f node.Node.key node.Node.value accu) - in - List.fold_left aux acc tree - -(* return a sub-trie *) -let rec sub_node tree = function - | [] -> raise Not_found - | h::t -> - if mem_node tree h - then begin - let node = find_node tree h in - if t = [] - then node - else sub_node node.Node.children t - end else - raise Not_found - -let sub tree path = - try (sub_node tree path).Node.children - with Not_found -> [] - -let find tree path = - Node.get_value (sub_node tree path) - -(* return false if the node doesn't exists or if it is not associated to any value *) -let rec mem tree = function - | [] -> false - | h::t -> - mem_node tree h - && (let node = find_node tree h in - if t = [] - then node.Node.value <> None - else mem node.Node.children t) - -(* Iterate over the longest valid prefix *) -let rec iter_path f tree = function - | [] -> () - | h::l -> - if mem_node tree h - then begin - let node = find_node tree h in - f node.Node.key node.Node.value; - iter_path f node.Node.children l - end - -let rec set_node node path value = - if path = [] - then Node.set_value node value - else begin - let children = set node.Node.children path value in - Node.set_children node children - end - -and set tree path value = - match path with - | [] -> raise Not_found - | h::t -> - if mem_node tree h - then begin - let node = find_node tree h in - replace_node tree h (set_node node t value) - end else begin - let node = Node.empty h in - set_node node t value :: tree - end - -let rec unset tree = function - | [] -> tree - | h::t -> - if mem_node tree h - then begin - let node = find_node tree h in - let children = unset node.Node.children t in - let new_node = - if t = [] - then Node.set_children (Node.empty h) children - else Node.set_children node children - in - if children = [] && new_node.Node.value = None - then remove_node tree h - else replace_node tree h new_node - end else - raise Not_found - diff --git a/lib/trie.mli b/lib/trie.mli deleted file mode 100644 index faa86300121..00000000000 --- a/lib/trie.mli +++ /dev/null @@ -1,58 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -(** Basic Implementation of polymorphic tries (ie. prefix trees) *) - -type ('a, 'b) t -(** The type of tries. ['a list] is the type of keys, ['b] the type of values. - Internally, a trie is represented as a labeled tree, where node contains values - of type ['a * 'b option]. *) - -val create : unit -> ('a,'b) t -(** Creates an empty trie. *) - -val mem : ('a,'b) t -> 'a list -> bool -(** [mem t k] returns true if a value is associated with the key [k] in the trie [t]. - Otherwise, it returns false. *) - -val find : ('a, 'b) t -> 'a list -> 'b -(** [find t k] returns the value associated with the key [k] in the trie [t]. - Returns [Not_found] if no values are associated with [k] in [t]. *) - -val set : ('a, 'b) t -> 'a list -> 'b -> ('a, 'b) t -(** [set t k v] associates the value [v] with the key [k] in the trie [t]. *) - -val unset : ('a, 'b) t -> 'a list -> ('a, 'b) t -(** [unset k v] removes the association of value [v] with the key [k] in the trie [t]. - Moreover, it automatically clean the trie, ie. it removes recursively - every nodes of [t] containing no values and having no chil. *) - -val iter : ('a -> 'b option -> unit) -> ('a, 'b) t -> unit -(** [iter f t] applies the function [f] to every node of the trie [t]. - As nodes of the trie [t] do not necessary contains a value, the second argument of - [f] is an option type. *) - -val iter_path : ('a -> 'b option -> unit) -> ('a, 'b) t -> 'a list -> unit -(** [iter_path f t p] iterates [f] over nodes associated with the path [p] in the trie [t]. - If [p] is not a valid path of [t], it iterates on the longest valid prefix of [p]. *) - -val fold : ('a -> 'b option -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c -(** [fold f t x] fold [f] over every nodes of [t], with [x] as initial value. *) - -val map : ('b -> 'c option) -> ('a,'b) t -> ('a,'c) t -(** [map f t] maps [f] over every values stored in [t]. The return value of [f] is of type 'c option - as one may wants to remove value associated to a key. This function is not tail-recursive. *) - -val sub : ('a, 'b) t -> 'a list -> ('a,'b) t -(** [sub t p] returns the sub-trie associated with the path [p] in the trie [t]. - If [p] is not a valid path of [t], it returns an empty trie. *) diff --git a/lib/vIO.ml b/lib/vIO.ml deleted file mode 100644 index e0debc656af..00000000000 --- a/lib/vIO.ml +++ /dev/null @@ -1,107 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -exception End_of_file -exception Timeout - -type t = { - read: string -> int -> int -> int; - write: string -> int -> int -> int; - input_line: (?timeout: float option -> unit -> string) option; - flush: unit -> unit; - close: unit -> unit; - is_raw: bool; - selectable: Unix.file_descr option; -} - -let do_rw_io f buf index len = - let left = ref len in - let index = ref index in - let end_of_file = ref false in - while !left > 0 && not !end_of_file - do - let ret = f buf !index !left in - if ret = 0 then - end_of_file := true - else if ret > 0 then ( - left := !left - ret; - index := !index + ret; - ) - done; - len - !left - -let do_rw_io_timeout fd is_write f buf index len timeout = - let fdset = Unixext.Fdset.of_list [ fd ] in - let select = if is_write then Unixext.Fdset.select_wo else Unixext.Fdset.select_ro in - - let left = ref len in - let index = ref index in - let end_of_file = ref false in - while !left > 0 && not !end_of_file - do - let set = select fdset timeout in - if Unixext.Fdset.is_empty set then - raise Timeout; - let ret = f buf !index !left in - if ret = 0 then - end_of_file := true - else if ret > 0 then ( - left := !left - ret; - index := !index + ret; - ) - done; - len - !left - -let read ?(timeout=None) con buf index len = - match timeout, con.selectable with - | _, None | None, Some _ -> do_rw_io con.read buf index len - | Some timeout, Some fd -> do_rw_io_timeout fd false con.read buf index len timeout - -let write ?(timeout=None) con buf index len = - match timeout, con.selectable with - | _, None | None, Some _ -> do_rw_io con.write buf index len - | Some timeout, Some fd -> do_rw_io_timeout fd true con.write buf index len timeout - -let read_string ?timeout con len = - let s = String.create len in - let ret = read ?timeout con s 0 len in - if ret < len then - raise End_of_file; - s - -let write_string ?timeout con s = - let len = String.length s in - if write ?timeout con s 0 len < len then - raise End_of_file; - () - -let input_line ?timeout con = - match con.input_line with - | None -> - let buffer = Buffer.create 80 in - let newline = ref false in - while not !newline - do - let s = " " in - let ret = read ?timeout con s 0 1 in - if ret = 0 then - raise End_of_file; - if s.[0] = '\n' then newline := true else Buffer.add_char buffer s.[0] - done; - Buffer.contents buffer - | Some f -> - f ?timeout () - -let flush con = con.flush () -let close con = con.close () diff --git a/lib/vIO.mli b/lib/vIO.mli deleted file mode 100644 index 237a2745ce6..00000000000 --- a/lib/vIO.mli +++ /dev/null @@ -1,33 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -exception End_of_file -exception Timeout - -type t = { - read : string -> int -> int -> int; - write : string -> int -> int -> int; - input_line : (?timeout: float option -> unit -> string) option; - flush : unit -> unit; - close : unit -> unit; - is_raw : bool; - selectable : Unix.file_descr option; -} - -val read : ?timeout: float option -> t -> string -> int -> int -> int -val write : ?timeout: float option -> t -> string -> int -> int -> int -val read_string : ?timeout: float option -> t -> int -> string -val write_string : ?timeout: float option -> t -> string -> unit -val input_line : ?timeout: float option -> t -> string -val flush : t -> unit -val close : t -> unit diff --git a/lib_test/extentlistset_test.ml b/lib_test/extentlistset_test.ml deleted file mode 100644 index 1e80781ed10..00000000000 --- a/lib_test/extentlistset_test.ml +++ /dev/null @@ -1,88 +0,0 @@ -(* We will check if a list of set equalities hold over random inputs *) -open Stdext -open Set_test - -(* We test using the integer domain only. *) -module Intextentlist = ExtentlistSet.ExtentlistSet(struct - type t=int - let zero=0 - let add=(+) - let sub=(-) - end) -open Intextentlist - -(* Sets are finite, up to cardinality [size] *) -let size = 1000 - -module Tests = SetEqualities(struct - type t = Intextentlist.t - let universe = of_list [(0, size)] - let (+) = union - let (^) = intersection - let (-) = difference - - let not x = universe - x - let (=) x y = (x - y = empty) && (y - x = empty) - let extent_to_string (s, l) = Printf.sprintf "(%d, %d)" s l - let to_string xs = String.concat ", " (List.map extent_to_string (to_list xs)) - end) -(* Given a triple of inputs, check that all the set equalities hold *) -let one (a, b, c) = List.iter (fun f -> f a b c) Tests.all - -open LazyList - -(** [make p s e] return an extentlist starting at [s], ending before [e] where - an integer x is covered by the extentlist iff [p x] *) -let make p s e = - let rec ints acc a b = if a < b then ints (a :: acc) (a + 1) b else acc in - of_list (List.fold_left (fun acc x -> if p x then (x, 1)::acc else acc) [] (ints [] s e)) - -(* A lazy-list of random triples (a, b, c)*) -let random_inputs = - let one () = make (fun _ -> Random.bool ()) 0 (size - 1) in - (* Create triples of random inputs for the checker *) - let three () = one (), one (), one () in - let rec f () = lazy (Cons(three (), f ())) in - f () - -let _ = - let n = 1000 in - iter (fun _ -> ()) (take n (map one random_inputs)); - Printf.printf "%d random sets of maximum size %d checked.\n" n size - -type run = - | Empty of int - | Full of int -let to_run_list xs = - let rec inner acc index = function - | [] -> acc - | (x, y) :: xs -> inner (Full y :: (Empty (x - index)) :: acc) (x + y) xs in - - List.rev (inner [] 0 xs) - -let _ = - (* vhds have max size of 2 TiB, in 2 MiB blocks => 2**20 blocks *) - (* The BAT consists of up to 2**20 blocks in any order *) - (* Worst case for us is as many singleton blocks as possible, which *) - (* can't be coalesced because they don't have neighbours. The maximum *) - (* number of blocks is achieved with the allocation pattern 10101010... *) - (* i.e. 2**19 singleton blocks. *) - - (* As a bitmap we would have 2**19 / 2**3 = 2**16 bytes (64kbit) *) - let worst_case = make (fun x -> x mod 2 = 1) 0 (1024*1024/2/12) in - let hex (a, b) = Printf.sprintf "%x,%x" a b in - let to_string xs = "[" ^ (String.concat ";" (Listext.List.map_tr hex xs)) ^ "]" in - - - Printf.printf "generated\n"; - let x = to_list worst_case in - Printf.printf "got a list\n"; - (* let y = Listext.List.map_tr hex x in *) - Printf.printf "got lots of strings\n"; - let s = to_string (to_list worst_case) in - Printf.printf "Extent size=%d\n" (String.length s); - let string_of_run = function - | Empty x -> Printf.sprintf "-%d" x - | Full x -> Printf.sprintf "+%d" x in - let s' = String.concat ";" (Listext.List.map_tr string_of_run (to_run_list x)) in - Printf.printf "Runs size=%d\n" (String.length s') diff --git a/lib_test/jbuild b/lib_test/jbuild deleted file mode 100644 index 21e0b19fde5..00000000000 --- a/lib_test/jbuild +++ /dev/null @@ -1,9 +0,0 @@ -(executable - ((name extentlistset_test) - (libraries (stdext)))) - -(alias - ((name runtest) - (deps (extentlistset_test.exe)) - (action (run ${<})))) - diff --git a/lib_test/set_test.ml b/lib_test/set_test.ml deleted file mode 100644 index 611a77502aa..00000000000 --- a/lib_test/set_test.ml +++ /dev/null @@ -1,31 +0,0 @@ -module type Set = sig - type t - val (+): t -> t -> t (* union *) - val (^): t -> t -> t (* intersection *) - val (-): t -> t -> t (* difference *) - val not: t -> t (* complement *) - val (=): t -> t -> bool - - val to_string: t -> string -end - -module SetEqualities(S: Set) = struct - open S - - let w txt f a b c = - if Pervasives.not(f a b c) - then failwith (Printf.sprintf "%s a=%s b=%s c=%s" txt (S.to_string a) (S.to_string b) (S.to_string c)) - - let all = [ - w "commutative_1" (fun a b _ -> a + b = b + a); - w "commutative_2" (fun a b _ -> a ^ b = b ^ a); - w "associative_1" (fun a b c -> (a + b) + c = a + (b + c)); - w "associative_2" (fun a b c -> (a ^ b) ^ c = a ^ (b ^ c)); - w "distributive_1" (fun a b c -> a + (b ^ c) = (a + b) ^ (a + c)); - w "distributive_2" (fun a b c -> a ^ (b + c) = (a ^ b) + (a ^ c)); - w "complement_1" (fun a _ _ -> not (not a) = a); - w "demorgan_1" (fun a b _ -> not (a + b) = (not a) ^ (not b)); - w "demorgan_2" (fun a b _ -> not (a ^ b) = (not a) + (not b)); - ] -end - diff --git a/lib_test/set_test.mli b/lib_test/set_test.mli deleted file mode 100644 index c09eec0528a..00000000000 --- a/lib_test/set_test.mli +++ /dev/null @@ -1,15 +0,0 @@ -module type Set = -sig - type t - val ( + ) : t -> t -> t - val ( ^ ) : t -> t -> t - val ( - ) : t -> t -> t - val not : t -> t - val ( = ) : t -> t -> bool - val to_string : t -> string -end -module SetEqualities : - functor (S : Set) -> - sig - val all : (S.t -> S.t -> S.t -> unit) list - end diff --git a/stdext.opam b/stdext.opam index 1d4365fce5f..7b5aaa9683d 100644 --- a/stdext.opam +++ b/stdext.opam @@ -7,7 +7,6 @@ homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] -build-test: [[ "jbuilder" "runtest" "-p" name "-j" jobs ]] depends: [ "jbuilder" {build} From d31492adcfc892686f98aa745645595a5e594b7a Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Mon, 31 Jul 2017 12:23:20 +0100 Subject: [PATCH 051/199] Remove arrayext, int64ext, lazylist, mapext Signed-off-by: Marcello Seri --- lib/arrayext.ml | 59 ----------------------------------------- lib/arrayext.mli | 68 ------------------------------------------------ lib/int64ext.ml | 17 ------------ lib/int64ext.mli | 17 ------------ lib/lazyList.ml | 20 -------------- lib/lazyList.mli | 16 ------------ lib/mapext.ml | 47 --------------------------------- lib/mapext.mli | 31 ---------------------- 8 files changed, 275 deletions(-) delete mode 100644 lib/arrayext.ml delete mode 100644 lib/arrayext.mli delete mode 100644 lib/int64ext.ml delete mode 100644 lib/int64ext.mli delete mode 100644 lib/lazyList.ml delete mode 100644 lib/lazyList.mli delete mode 100644 lib/mapext.ml delete mode 100644 lib/mapext.mli diff --git a/lib/arrayext.ml b/lib/arrayext.ml deleted file mode 100644 index d783f9d8b14..00000000000 --- a/lib/arrayext.ml +++ /dev/null @@ -1,59 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -module Array = struct include Array - - (* Useful for vector addition. *) - let map2 f a b = - let len = length a in - if len <> length b then invalid_arg "map2"; - init len (fun i -> f a.(i) b.(i)) - - (* Useful for vector dot product. *) - let fold_left2 f x a b = - let len = length a in - if len <> length b then invalid_arg "fold_left2"; - let r = ref x in - for i = 0 to len - 1 do - r := f !r a.(i) b.(i) - done; - !r - - (* Useful for vector dot product. *) - let fold_right2 f a b x = - let len = length a in - if len <> length b then invalid_arg "fold_right2"; - let r = ref x in - for i = len - 1 downto 0 do - r := f a.(i) b.(i) !r - done; - !r - - let index e a = - let len = length a in - let rec check i = - if len <= i then -1 - else if get a i = e then i - else check (i + 1) - in check 0 - - let inner fold_left2 base f l1 l2 g = - fold_left2 (fun accu e1 e2 -> g accu (f e1 e2)) base l1 l2 - - let mem e a = - index e a <> -1 - - let remove n a = - append (sub a 0 n) (sub a (n+1) (length a - n - 1)) - -end diff --git a/lib/arrayext.mli b/lib/arrayext.mli deleted file mode 100644 index bf2fcd3207d..00000000000 --- a/lib/arrayext.mli +++ /dev/null @@ -1,68 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -module Array : -sig - external length : 'a array -> int = "%array_length" - external get : 'a array -> int -> 'a = "%array_safe_get" - external set : 'a array -> int -> 'a -> unit = "%array_safe_set" - external make : int -> 'a -> 'a array = "caml_make_vect" - external create : int -> 'a -> 'a array = "caml_make_vect" - val init : int -> (int -> 'a) -> 'a array - val make_matrix : int -> int -> 'a -> 'a array array - val create_matrix : int -> int -> 'a -> 'a array array - val append : 'a array -> 'a array -> 'a array - val concat : 'a array list -> 'a array - val sub : 'a array -> int -> int -> 'a array - val copy : 'a array -> 'a array - val fill : 'a array -> int -> int -> 'a -> unit - val blit : 'a array -> int -> 'a array -> int -> int -> unit - val to_list : 'a array -> 'a list - val of_list : 'a list -> 'a array - val iter : ('a -> unit) -> 'a array -> unit - val map : ('a -> 'b) -> 'a array -> 'b array - val iteri : (int -> 'a -> unit) -> 'a array -> unit - val mapi : (int -> 'a -> 'b) -> 'a array -> 'b array - val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a - val fold_right : ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b - val sort : ('a -> 'a -> int) -> 'a array -> unit - val stable_sort : ('a -> 'a -> int) -> 'a array -> unit - val fast_sort : ('a -> 'a -> int) -> 'a array -> unit - external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get" - external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" - - (** Map a function over a pair of arrays simultaneously. *) - val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array - - (** Fold a function over a pair of arrays simultaneously. *) - val fold_left2 : - ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a - - (** Fold a function over a pair of arrays simultaneously. *) - val fold_right2 : - ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c - - (** Get first index of an element in the array, or -1. *) - val index : 'a -> 'a array -> int - - (** Compute the inner product of two arrays. *) - val inner : - (('a -> 'b -> 'c -> 'd) -> 'e -> 'f -> 'g -> 'h) -> - 'e -> ('b -> 'c -> 'i) -> 'f -> 'g -> ('a -> 'i -> 'd) -> 'h - - (** Check if an element appears in the array. *) - val mem : 'a -> 'a array -> bool - - (** Remove the element at specified position from the array. *) - val remove : int -> 'a array -> 'a array -end diff --git a/lib/int64ext.ml b/lib/int64ext.ml deleted file mode 100644 index 0c0cacd0dfa..00000000000 --- a/lib/int64ext.ml +++ /dev/null @@ -1,17 +0,0 @@ -module Int64 = struct - - module Operators = struct - - let ( +++ ) = Int64.add - let ( --- ) = Int64.sub - let ( *** ) = Int64.mul - let ( /// ) = Int64.div - let ( &&& ) = Int64.logand - let ( ||| ) = Int64.logor - let ( <<< ) = Int64.shift_left - let ( >>> ) = Int64.shift_right_logical - let ( !!! ) = Int64.lognot - - end - -end diff --git a/lib/int64ext.mli b/lib/int64ext.mli deleted file mode 100644 index c8fce2266dd..00000000000 --- a/lib/int64ext.mli +++ /dev/null @@ -1,17 +0,0 @@ -module Int64 : sig - - module Operators : sig - - val ( +++ ) : int64 -> int64 -> int64 - val ( --- ) : int64 -> int64 -> int64 - val ( *** ) : int64 -> int64 -> int64 - val ( /// ) : int64 -> int64 -> int64 - val ( &&& ) : int64 -> int64 -> int64 - val ( ||| ) : int64 -> int64 -> int64 - val ( <<< ) : int64 -> int -> int64 - val ( >>> ) : int64 -> int -> int64 - val ( !!! ) : int64 -> int64 - - end - -end \ No newline at end of file diff --git a/lib/lazyList.ml b/lib/lazyList.ml deleted file mode 100644 index 8b91934bc29..00000000000 --- a/lib/lazyList.ml +++ /dev/null @@ -1,20 +0,0 @@ -(* A lazy-list implementation *) - -type 'a elt = - | Empty - | Cons of 'a * 'a t -and 'a t = 'a elt lazy_t - -let rec map f xs = lazy(match Lazy.force xs with - | Empty -> Empty - | Cons(x, xs) -> Cons(f x, map f xs)) - -let rec take n xs = lazy(match n, Lazy.force xs with - | 0, _ -> Empty - | _, Empty -> raise Not_found - | n, Cons(x, xs) -> Cons(x, take (n - 1) xs)) - -let rec iter f xs = match Lazy.force xs with - | Empty -> () - | Cons(x, xs) -> f x; iter f xs - diff --git a/lib/lazyList.mli b/lib/lazyList.mli deleted file mode 100644 index 29752afba13..00000000000 --- a/lib/lazyList.mli +++ /dev/null @@ -1,16 +0,0 @@ -(** A lazy-list *) - -(** A forced lazy list element *) -type 'a elt = Empty | Cons of 'a * 'a t - -(** A lazy list *) -and 'a t = 'a elt lazy_t - -(** [map f xs] returns the list [f 1; f 2; ...; f n] *) -val map : ('a -> 'b) -> 'a t -> 'b t - -(** [take n xs] returns the list truncated to the first [n] elements *) -val take : int -> 'a t -> 'a t - -(** [iter f xs] applies every list element to [f] *) -val iter : ('a -> unit) -> 'a t -> unit diff --git a/lib/mapext.ml b/lib/mapext.ml deleted file mode 100644 index 636e46c9ecb..00000000000 --- a/lib/mapext.ml +++ /dev/null @@ -1,47 +0,0 @@ - -module type S = -sig - type key - type +'a t - val empty: 'a t - val is_empty: 'a t -> bool - val add: key -> 'a -> 'a t -> 'a t - val find: key -> 'a t -> 'a - val remove: key -> 'a t -> 'a t - val mem: key -> 'a t -> bool - val iter: (key -> 'a -> unit) -> 'a t -> unit - val map: ('a -> 'b) -> 'a t -> 'b t - val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t - val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int - val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - - val fromHash : (key, 'a) Hashtbl.t -> 'a t - - val filter : ('a -> bool) -> 'a t -> 'a t - - (* values: gives the list of values of the map. *) - val values : 'a t -> 'a list - - val fromListWith : ('a -> 'a -> 'a) -> (key * 'a) list -> 'a t - val adjust : ('a -> 'a) -> key -> 'a t -> 'a t - -end - -module Make(Ord: Map.OrderedType) = struct - include Map.Make (Ord) - - let fromHash h = Hashtbl.fold add h empty - let filter pred m = fold (fun k v acc -> (if pred v then add k v else Fun.id) acc) m empty - (* values: gives the list of values of the map. *) - let values m = fold (Fun.const Listext.List.cons) m [] - - let fromListWith op list = List.fold_left (fun map (k,v) -> - add k (if mem k map - then op v (find k map) - else v) map) - empty list - let adjust op k m = try add k (op (find k m)) m with Not_found -> m - - -end diff --git a/lib/mapext.mli b/lib/mapext.mli deleted file mode 100644 index e408d428ada..00000000000 --- a/lib/mapext.mli +++ /dev/null @@ -1,31 +0,0 @@ -module type S = -sig - type key - type +'a t - val empty: 'a t - val is_empty: 'a t -> bool - val add: key -> 'a -> 'a t -> 'a t - val find: key -> 'a t -> 'a - val remove: key -> 'a t -> 'a t - val mem: key -> 'a t -> bool - val iter: (key -> 'a -> unit) -> 'a t -> unit - val map: ('a -> 'b) -> 'a t -> 'b t - val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t - val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int - val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - - val fromHash : (key, 'a) Hashtbl.t -> 'a t - val filter : ('a -> bool) -> 'a t -> 'a t - - (* values: gives the list of values of the map. *) - val values : 'a t -> 'a list - - val fromListWith : ('a -> 'a -> 'a) -> (key * 'a) list -> 'a t - (* Update a value at a specific key with the result of the - provided function. When the key is not a member of the map, the - original map is returned. *) - val adjust : ('a -> 'a) -> key -> 'a t -> 'a t -end - -module Make (Ord : Map.OrderedType) : S with type key = Ord.t From d1d9eb79a5c9047f219af19fc6faac82e7358991 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Mon, 31 Jul 2017 13:59:55 +0100 Subject: [PATCH 052/199] Remove config and ring modules Signed-off-by: Marcello Seri --- lib/config.ml | 116 ------------------------------------------------- lib/config.mli | 27 ------------ lib/ring.ml | 72 ------------------------------ lib/ring.mli | 24 ---------- 4 files changed, 239 deletions(-) delete mode 100644 lib/config.ml delete mode 100644 lib/config.mli delete mode 100644 lib/ring.ml delete mode 100644 lib/ring.mli diff --git a/lib/config.ml b/lib/config.ml deleted file mode 100644 index 988e0fdf82d..00000000000 --- a/lib/config.ml +++ /dev/null @@ -1,116 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -type ty = - | Set_bool of bool ref - | Set_int of int ref - | Set_string of string ref - | Set_float of float ref - | Unit of (unit -> unit) - | Bool of (bool -> unit) - | Int of (int -> unit) - | String of (string -> unit) - | Float of (float -> unit) - -exception Error of (string * string) list - -let trim_start lc s = - let len = String.length s and i = ref 0 in - while !i < len && (List.mem s.[!i] lc) - do - incr i - done; - if !i < len then String.sub s !i (len - !i) else "" - -let trim_end lc s = - let i = ref (String.length s - 1) in - while !i > 0 && (List.mem s.[!i] lc) - do - decr i - done; - if !i >= 0 then String.sub s 0 (!i + 1) else "" - -let rec split ?limit:(limit=(-1)) c s = - let i = try String.index s c with Not_found -> -1 in - let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in - if i = -1 || nlimit = 0 then - [ s ] - else - let a = String.sub s 0 i - and b = String.sub s (i + 1) (String.length s - i - 1) in - a :: (split ~limit: nlimit c b) - -let parse_line stream = - let lc = [ ' '; '\t' ] in - let trim_spaces s = trim_end lc (trim_start lc s) in - let to_config s = - match split ~limit:2 '=' s with - | k :: v :: [] -> Some (trim_end lc k, trim_start lc v) - | _ -> None in - let rec read_filter_line () = - try - let line = trim_spaces (input_line stream) in - if String.length line > 0 && line.[0] <> '#' then - match to_config line with - | None -> read_filter_line () - | Some x -> x :: read_filter_line () - else - read_filter_line () - with - End_of_file -> [] in - read_filter_line () - -let parse filename = - let stream = open_in filename in - let cf = parse_line stream in - close_in stream; - cf - -exception IntErr -exception FloatErr -exception BoolErr - -let validate cf expected other = - let err = ref [] in - let append x = err := x :: !err in - let int_of_string v = try int_of_string v with Failure _ -> raise IntErr in - let float_of_string v = try float_of_string v with Failure _ -> raise FloatErr in - let bool_of_string v = try bool_of_string v with Failure _ -> raise BoolErr in - List.iter (fun (k, v) -> - try - if not (List.mem_assoc k expected) then - other k v - else let ty = List.assoc k expected in - match ty with - | Unit f -> f () - | Bool f -> f (bool_of_string v) - | String f -> f v - | Int f -> f (int_of_string v) - | Float f -> f (float_of_string v) - | Set_bool r -> r := (bool_of_string v) - | Set_string r -> r := v - | Set_int r -> r := int_of_string v - | Set_float r -> r := (float_of_string v) - with - | Not_found -> append (k, "unknown key") - | IntErr -> append (k, "expect int arg") - | BoolErr -> append (k, "expect bool arg") - | FloatErr -> append (k, "expect float arg") - | exn -> append (k, Printexc.to_string exn) - ) cf; - if !err != [] then raise (Error !err) - -(** read a filename, parse and validate, and return the errors if any *) -let read filename expected other = - let cf = parse filename in - validate cf expected other diff --git a/lib/config.mli b/lib/config.mli deleted file mode 100644 index 55c1a9b3661..00000000000 --- a/lib/config.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -exception Error of (string * string) list - -type ty = - | Set_bool of bool ref - | Set_int of int ref - | Set_string of string ref - | Set_float of float ref - | Unit of (unit -> unit) - | Bool of (bool -> unit) - | Int of (int -> unit) - | String of (string -> unit) - | Float of (float -> unit) - -val read: string -> (string * ty) list -> (string -> string -> unit) -> unit diff --git a/lib/ring.ml b/lib/ring.ml deleted file mode 100644 index 47683c4e3d0..00000000000 --- a/lib/ring.ml +++ /dev/null @@ -1,72 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -type 'a t = { size: int; mutable current: int; data: 'a array; } - -(** create a ring structure with size record. records inited to initval *) -let make size initval = - { size = size; current = size - 1; data = Array.create size initval; } - -(** length of the ring *) -let length ring = ring.size - -(** push into the ring one element *) -let push ring e = - ring.current <- ring.current + 1; - if ring.current = ring.size then - ring.current <- 0; - ring.data.(ring.current) <- e - -(** get the ith old element from the ring *) -let peek ring i = - if i >= ring.size then - raise (Invalid_argument "peek: index"); - let index = - let offset = ring.current - i in - if offset >= 0 then offset else ring.size + offset in - ring.data.(index) - -(** get the top element of the ring *) -let top ring = ring.data.(ring.current) - -(** iterate over nb element of the ring, starting from the top *) -let iter_nb ring f nb = - if nb > ring.size then - raise (Invalid_argument "iter_nb: nb"); - (* FIXME: OPTIMIZE ME with 2 Array.iter ? *) - for i = 0 to nb - 1 - do - f (peek ring i) - done - -(** iter directly on all element without using the index *) -let raw_iter ring f = - Array.iter f ring.data - -(** iterate over all element of the ring, starting from the top *) -let iter ring f = iter_nb ring f (ring.size) - -(** get array of latest nb value *) -let get_nb ring nb = - if nb > ring.size then - raise (Invalid_argument "get_nb: nb"); - let a = Array.create nb (top ring) in - for i = 1 to nb - 1 - do - (* FIXME: OPTIMIZE ME with 2 Array.blit *) - a.(i) <- peek ring i - done; - a - -let get ring = get_nb ring (ring.size) diff --git a/lib/ring.mli b/lib/ring.mli deleted file mode 100644 index c5cb4b0db64..00000000000 --- a/lib/ring.mli +++ /dev/null @@ -1,24 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -type 'a t = { size : int; mutable current : int; data : 'a array; } -val make : int -> 'a -> 'a t -val length : 'a t -> int -val push : 'a t -> 'a -> unit -val peek : 'a t -> int -> 'a -val top : 'a t -> 'a -val iter_nb : 'a t -> ('a -> unit) -> int -> unit -val raw_iter : 'a t -> ('a -> unit) -> unit -val iter : 'a t -> ('a -> unit) -> unit -val get_nb : 'a t -> int -> 'a array -val get : 'a t -> 'a array From 7a9ac51335afa421e0b4195302939c4249fb51cb Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Mon, 31 Jul 2017 14:16:19 +0100 Subject: [PATCH 053/199] Remove custom implementation of Base64, replace with ocaml-base64 Signed-off-by: Marcello Seri --- lib/base64.ml | 61 ++-------------------------------------------- lib/base64.mli | 20 --------------- lib/base64_main.ml | 28 --------------------- lib/jbuild | 7 +++--- stdext.opam | 1 + 5 files changed, 7 insertions(+), 110 deletions(-) delete mode 100644 lib/base64.mli delete mode 100644 lib/base64_main.ml diff --git a/lib/base64.ml b/lib/base64.ml index 54c121a908b..bde36e9f02a 100644 --- a/lib/base64.ml +++ b/lib/base64.ml @@ -11,62 +11,5 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -open Xstringext - -let code = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" -let padding = '=' - -let of_char x = if x = padding then 0 else String.index code x - -let to_char x = code.[x] - -let strip_whitespace s = - String.implode (List.filter (fun x->not (List.mem x [' ';'\t';'\n';'\r'])) (String.explode s)) - -let decode x = - let x = strip_whitespace x in - let words = String.length x / 4 in - let padding = - if String.length x = 0 then 0 else ( - if x.[String.length x - 2] = padding - then 2 else (if x.[String.length x - 1] = padding then 1 else 0)) in - let output = String.make (words * 3 - padding) '\000' in - for i = 0 to words - 1 do - let a = of_char x.[4 * i + 0] - and b = of_char x.[4 * i + 1] - and c = of_char x.[4 * i + 2] - and d = of_char x.[4 * i + 3] in - let n = (a lsl 18) lor (b lsl 12) lor (c lsl 6) lor d in - let x = (n lsr 16) land 255 - and y = (n lsr 8) land 255 - and z = n land 255 in - output.[3 * i + 0] <- char_of_int x; - if i <> words - 1 || padding < 2 then output.[3 * i + 1] <- char_of_int y; - if i <> words - 1 || padding < 1 then output.[3 * i + 2] <- char_of_int z; - done; - output - -let encode x = - let length = String.length x in - let words = (length + 2) / 3 in (* rounded up *) - let padding = if length mod 3 = 0 then 0 else 3 - (length mod 3) in - let output = String.make (words * 4) '\000' in - let get i = if i >= length then 0 else int_of_char x.[i] in - for i = 0 to words - 1 do - let x = get (3 * i + 0) - and y = get (3 * i + 1) - and z = get (3 * i + 2) in - let n = (x lsl 16) lor (y lsl 8) lor z in - let a = (n lsr 18) land 63 - and b = (n lsr 12) land 63 - and c = (n lsr 6) land 63 - and d = n land 63 in - output.[4 * i + 0] <- to_char a; - output.[4 * i + 1] <- to_char b; - output.[4 * i + 2] <- to_char c; - output.[4 * i + 3] <- to_char d; - done; - for i = 1 to padding do - output.[String.length output - i] <- '='; - done; - output +let encode = B64.encode ?pad:None ?alphabet:None +let decode = B64.decode ?alphabet:None \ No newline at end of file diff --git a/lib/base64.mli b/lib/base64.mli deleted file mode 100644 index 46cc7c03dde..00000000000 --- a/lib/base64.mli +++ /dev/null @@ -1,20 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -(** decode a string encoded in base64. Will leave trailing NULLs on the string - padding it out to a multiple of 3 characters *) -val decode: string -> string - -(** encode a string into base64 *) -val encode: string -> string diff --git a/lib/base64_main.ml b/lib/base64_main.ml deleted file mode 100644 index 77e69fa873f..00000000000 --- a/lib/base64_main.ml +++ /dev/null @@ -1,28 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -open Base64 - -let usage () = - output_string stderr (Printf.sprintf "Usage: %s (encode|decode) string\n" Sys.argv.(0)); - exit 1 - -let _ = - if Array.length Sys.argv <> 3 then usage (); - match Sys.argv.(1) with - | "encode" -> - print_string (encode Sys.argv.(2)) - | "decode" -> - print_string (decode Sys.argv.(2)) - | _ -> - usage () diff --git a/lib/jbuild b/lib/jbuild index ff74acedc78..b883738905f 100644 --- a/lib/jbuild +++ b/lib/jbuild @@ -9,10 +9,11 @@ unixext_stubs unixext_write_stubs zerocheck_stub)) - (libraries (threads + (libraries (base64 + bigarray + fd-send-recv + threads uuidm unix - fd-send-recv - bigarray xapi-backtrace)) )) diff --git a/stdext.opam b/stdext.opam index 7b5aaa9683d..e6ca83428a1 100644 --- a/stdext.opam +++ b/stdext.opam @@ -13,6 +13,7 @@ depends: [ "base-bigarray" "base-threads" "base-unix" + "base64" "fd-send-recv" "uuidm" "xapi-backtrace" From d4753bc9570b4173d2468f1dba4caa06e996f360 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Mon, 31 Jul 2017 14:31:37 +0100 Subject: [PATCH 054/199] Remove unneded clib file Signed-off-by: Marcello Seri --- lib/libstdext_stubs.clib | 8 -------- 1 file changed, 8 deletions(-) delete mode 100644 lib/libstdext_stubs.clib diff --git a/lib/libstdext_stubs.clib b/lib/libstdext_stubs.clib deleted file mode 100644 index f61f7464884..00000000000 --- a/lib/libstdext_stubs.clib +++ /dev/null @@ -1,8 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: b4d5196086bdd5d02be639885c7103de) -blkgetsize_stubs.o -unixext_open_stubs.o -unixext_stubs.o -unixext_write_stubs.o -zerocheck_stub.o -# OASIS_STOP From c6bbf37835946b9f54c4d4c0bcb8021a2c5ef4e8 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Mon, 31 Jul 2017 15:43:16 +0100 Subject: [PATCH 055/199] Use upstream base64, but retain old 'strip_whitespace' behaviour The stripping code could be probably replaced by `Str.global_replace (Str.regexp "[\r\n\t ]") "" s` but I did not have time to measure the performance impact. Signed-off-by: Marcello Seri --- lib/base64.ml | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/lib/base64.ml b/lib/base64.ml index bde36e9f02a..0de527d9279 100644 --- a/lib/base64.ml +++ b/lib/base64.ml @@ -12,4 +12,22 @@ * GNU Lesser General Public License for more details. *) let encode = B64.encode ?pad:None ?alphabet:None -let decode = B64.decode ?alphabet:None \ No newline at end of file +let decode s = + let strip_whitespace s = + let fold_right f string accu = + let accu = ref accu in + for i = String.length string - 1 downto 0 do + accu := f string.[i] !accu + done; + !accu + in + let explode string = + fold_right (fun h t -> h :: t) string [] + in + let implode list = + let of_char c = String.make 1 c in + String.concat "" (List.map of_char list) + in + implode (List.filter (fun x->not (List.mem x [' ';'\t';'\n';'\r'])) (explode s)) + in + B64.decode ?alphabet:None (strip_whitespace s) \ No newline at end of file From a330eee12428d673386303551fb1715f9f51873d Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Mon, 31 Jul 2017 15:52:20 +0100 Subject: [PATCH 056/199] Remove use of Fun module Signed-off-by: Marcello Seri --- lib/either.ml | 5 ++--- lib/listext.ml | 6 +++--- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/lib/either.ml b/lib/either.ml index 32fbc9b7068..8d5ee5a5739 100644 --- a/lib/either.ml +++ b/lib/either.ml @@ -1,4 +1,3 @@ -open Pervasiveext open Listext type ('a,'b) t = Left of 'a | Right of 'b @@ -21,12 +20,12 @@ let right x = Right x let is_left = function | Left _ -> true | Right _ -> false -let is_right x = not ++ is_left $ x +let is_right x = not (is_left x) let to_option = function | Right x -> Some x | Left _ -> None -let cat_right l = List.unbox_list ++ List.map to_option $ l +let cat_right l = List.unbox_list (List.map to_option l) let join = function | Right (Right x) -> Right x diff --git a/lib/listext.ml b/lib/listext.ml index 5000867d7c1..9a69145fb5a 100644 --- a/lib/listext.ml +++ b/lib/listext.ml @@ -11,7 +11,7 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -open Fun + module List = struct include List module Monad = Monad.M1.Make (struct @@ -195,7 +195,7 @@ module List = struct include List if i <= 0 || list = [] then acc else helper (i-1) (List.hd list :: acc) (List.tl list) - in List.rev $ helper n [] list + in List.rev (helper n [] list) (* Thanks to sharing we only use linear space. (Roughly double the space needed for the spine of the original list) *) let rec tails = function @@ -217,7 +217,7 @@ module List = struct include List let unbox_list a = List.map Opt.unbox (List.filter Opt.is_boxed a) let filter_map f list = - (unbox_list +++ map) f list + unbox_list (map f list) let restrict_with_default default keys al = make_assoc (fun k -> assoc_default k al default) keys From d0767cb796ff85b61b34a6f2fb05e4140170f17b Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Mon, 31 Jul 2017 16:48:28 +0100 Subject: [PATCH 057/199] Improve standard compliance and sanitization implementation Signed-off-by: Marcello Seri --- lib/base64.ml | 30 +++++++++++++----------------- 1 file changed, 13 insertions(+), 17 deletions(-) diff --git a/lib/base64.ml b/lib/base64.ml index 0de527d9279..9af95f09bb8 100644 --- a/lib/base64.ml +++ b/lib/base64.ml @@ -13,21 +13,17 @@ *) let encode = B64.encode ?pad:None ?alphabet:None let decode s = - let strip_whitespace s = - let fold_right f string accu = - let accu = ref accu in - for i = String.length string - 1 downto 0 do - accu := f string.[i] !accu - done; - !accu - in - let explode string = - fold_right (fun h t -> h :: t) string [] - in - let implode list = - let of_char c = String.make 1 c in - String.concat "" (List.map of_char list) - in - implode (List.filter (fun x->not (List.mem x [' ';'\t';'\n';'\r'])) (explode s)) + let sanitize x = + (* ignore control characters: see RFC4648.1 and RFC4648.3 + * https://tools.ietf.org/html/rfc4648#section-3 + * Note: \t = \009, \n = \012, \r = \015, \s = \032 *) + let result = Buffer.create (String.length x) in + for i = 0 to String.length x - 1 do + if String.unsafe_get x i >= '\000' && String.unsafe_get x i <= '\032' + || String.unsafe_get x i = '\127' + then () + else Buffer.add_char result (String.unsafe_get x i) + done; + Buffer.contents result in - B64.decode ?alphabet:None (strip_whitespace s) \ No newline at end of file + B64.decode ?alphabet:None (sanitize s) \ No newline at end of file From d42e2b076bc4951d8f94c77a24a662e1078e09e0 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Tue, 1 Aug 2017 13:21:23 +0100 Subject: [PATCH 058/199] Stdext breakdown Signed-off-by: Marcello Seri --- lib/jbuild | 19 ------------- lib/{ => xapi-stdext-base64}/base64.ml | 0 lib/xapi-stdext-base64/jbuild | 7 +++++ lib/{ => xapi-stdext-bigbuffer}/bigbuffer.ml | 0 lib/{ => xapi-stdext-bigbuffer}/bigbuffer.mli | 0 lib/xapi-stdext-bigbuffer/jbuild | 6 +++++ lib/{ => xapi-stdext-date}/date.ml | 0 lib/{ => xapi-stdext-date}/date.mli | 0 lib/xapi-stdext-date/jbuild | 7 +++++ lib/{ => xapi-stdext-deprecated}/fun.ml | 0 lib/{ => xapi-stdext-deprecated}/fun.mli | 0 lib/xapi-stdext-deprecated/jbuild | 6 +++++ lib/{ => xapi-stdext-encodings}/encodings.ml | 0 lib/{ => xapi-stdext-encodings}/encodings.mli | 0 lib/xapi-stdext-encodings/jbuild | 6 +++++ lib/{ => xapi-stdext-fring}/fring.ml | 0 lib/{ => xapi-stdext-fring}/fring.mli | 0 lib/xapi-stdext-fring/jbuild | 7 +++++ lib/{ => xapi-stdext-monadic}/either.ml | 6 ++--- lib/{ => xapi-stdext-monadic}/either.mli | 0 lib/xapi-stdext-monadic/jbuild | 6 +++++ lib/{ => xapi-stdext-monadic}/monad.ml | 0 lib/{ => xapi-stdext-monadic}/monad.mli | 0 lib/{ => xapi-stdext-monadic}/opt.ml | 0 lib/{ => xapi-stdext-monadic}/opt.mli | 0 lib/xapi-stdext-pervasives/jbuild | 7 +++++ .../pervasiveext.ml | 2 +- .../pervasiveext.mli | 0 lib/xapi-stdext-range/jbuild | 6 +++++ lib/{ => xapi-stdext-range}/range.ml | 0 lib/{ => xapi-stdext-range}/range.mli | 0 lib/{ => xapi-stdext-std}/filenameext.ml | 0 lib/{ => xapi-stdext-std}/filenameext.mli | 0 lib/{ => xapi-stdext-std}/hashtblext.ml | 0 lib/{ => xapi-stdext-std}/hashtblext.mli | 0 lib/xapi-stdext-std/jbuild | 8 ++++++ lib/{ => xapi-stdext-std}/listext.ml | 6 +++-- lib/{ => xapi-stdext-std}/listext.mli | 2 +- lib/{ => xapi-stdext-std}/xstringext.ml | 0 lib/{ => xapi-stdext-std}/xstringext.mli | 0 lib/xapi-stdext-threads/jbuild | 9 +++++++ lib/{ => xapi-stdext-threads}/semaphore.ml | 0 lib/{ => xapi-stdext-threads}/semaphore.mli | 0 lib/{ => xapi-stdext-threads}/threadext.ml | 6 +++-- lib/{ => xapi-stdext-threads}/threadext.mli | 0 lib/{ => xapi-stdext-unix}/blkgetsize_stubs.c | 0 lib/xapi-stdext-unix/jbuild | 15 +++++++++++ lib/{ => xapi-stdext-unix}/unixext.ml | 9 ++++--- lib/{ => xapi-stdext-unix}/unixext.mli | 6 ++--- .../unixext_open_stubs.c | 0 lib/{ => xapi-stdext-unix}/unixext_stubs.c | 0 .../unixext_write_stubs.c | 0 lib/xapi-stdext-zerocheck/jbuild | 7 +++++ lib/{ => xapi-stdext-zerocheck}/zerocheck.ml | 0 lib/{ => xapi-stdext-zerocheck}/zerocheck.mli | 0 .../zerocheck_stub.c | 0 lib/xapi-stdext/jbuild | 22 +++++++++++++++ lib/xapi-stdext/stdext.ml | 27 +++++++++++++++++++ xapi-stdext-base64.opam | 14 ++++++++++ xapi-stdext-bigbuffer.opam | 13 +++++++++ xapi-stdext-date.opam | 14 ++++++++++ xapi-stdext-deprecated.opam | 13 +++++++++ xapi-stdext-encodings.opam | 13 +++++++++ xapi-stdext-fring.opam | 14 ++++++++++ xapi-stdext-monadic.opam | 13 +++++++++ xapi-stdext-pervasives.opam | 14 ++++++++++ xapi-stdext-range.opam | 13 +++++++++ xapi-stdext-std.opam | 15 +++++++++++ stdext.opam => xapi-stdext-threads.opam | 5 ---- xapi-stdext-unix.opam | 18 +++++++++++++ xapi-stdext-zerocheck.opam | 13 +++++++++ xapi-stdext.opam | 26 ++++++++++++++++++ 72 files changed, 361 insertions(+), 39 deletions(-) delete mode 100644 lib/jbuild rename lib/{ => xapi-stdext-base64}/base64.ml (100%) create mode 100644 lib/xapi-stdext-base64/jbuild rename lib/{ => xapi-stdext-bigbuffer}/bigbuffer.ml (100%) rename lib/{ => xapi-stdext-bigbuffer}/bigbuffer.mli (100%) create mode 100644 lib/xapi-stdext-bigbuffer/jbuild rename lib/{ => xapi-stdext-date}/date.ml (100%) rename lib/{ => xapi-stdext-date}/date.mli (100%) create mode 100644 lib/xapi-stdext-date/jbuild rename lib/{ => xapi-stdext-deprecated}/fun.ml (100%) rename lib/{ => xapi-stdext-deprecated}/fun.mli (100%) create mode 100644 lib/xapi-stdext-deprecated/jbuild rename lib/{ => xapi-stdext-encodings}/encodings.ml (100%) rename lib/{ => xapi-stdext-encodings}/encodings.mli (100%) create mode 100644 lib/xapi-stdext-encodings/jbuild rename lib/{ => xapi-stdext-fring}/fring.ml (100%) rename lib/{ => xapi-stdext-fring}/fring.mli (100%) create mode 100644 lib/xapi-stdext-fring/jbuild rename lib/{ => xapi-stdext-monadic}/either.ml (85%) rename lib/{ => xapi-stdext-monadic}/either.mli (100%) create mode 100644 lib/xapi-stdext-monadic/jbuild rename lib/{ => xapi-stdext-monadic}/monad.ml (100%) rename lib/{ => xapi-stdext-monadic}/monad.mli (100%) rename lib/{ => xapi-stdext-monadic}/opt.ml (100%) rename lib/{ => xapi-stdext-monadic}/opt.mli (100%) create mode 100644 lib/xapi-stdext-pervasives/jbuild rename lib/{ => xapi-stdext-pervasives}/pervasiveext.ml (98%) rename lib/{ => xapi-stdext-pervasives}/pervasiveext.mli (100%) create mode 100644 lib/xapi-stdext-range/jbuild rename lib/{ => xapi-stdext-range}/range.ml (100%) rename lib/{ => xapi-stdext-range}/range.mli (100%) rename lib/{ => xapi-stdext-std}/filenameext.ml (100%) rename lib/{ => xapi-stdext-std}/filenameext.mli (100%) rename lib/{ => xapi-stdext-std}/hashtblext.ml (100%) rename lib/{ => xapi-stdext-std}/hashtblext.mli (100%) create mode 100644 lib/xapi-stdext-std/jbuild rename lib/{ => xapi-stdext-std}/listext.ml (97%) rename lib/{ => xapi-stdext-std}/listext.mli (98%) rename lib/{ => xapi-stdext-std}/xstringext.ml (100%) rename lib/{ => xapi-stdext-std}/xstringext.mli (100%) create mode 100644 lib/xapi-stdext-threads/jbuild rename lib/{ => xapi-stdext-threads}/semaphore.ml (100%) rename lib/{ => xapi-stdext-threads}/semaphore.mli (100%) rename lib/{ => xapi-stdext-threads}/threadext.ml (98%) rename lib/{ => xapi-stdext-threads}/threadext.mli (100%) rename lib/{ => xapi-stdext-unix}/blkgetsize_stubs.c (100%) create mode 100644 lib/xapi-stdext-unix/jbuild rename lib/{ => xapi-stdext-unix}/unixext.ml (99%) rename lib/{ => xapi-stdext-unix}/unixext.mli (97%) rename lib/{ => xapi-stdext-unix}/unixext_open_stubs.c (100%) rename lib/{ => xapi-stdext-unix}/unixext_stubs.c (100%) rename lib/{ => xapi-stdext-unix}/unixext_write_stubs.c (100%) create mode 100644 lib/xapi-stdext-zerocheck/jbuild rename lib/{ => xapi-stdext-zerocheck}/zerocheck.ml (100%) rename lib/{ => xapi-stdext-zerocheck}/zerocheck.mli (100%) rename lib/{ => xapi-stdext-zerocheck}/zerocheck_stub.c (100%) create mode 100644 lib/xapi-stdext/jbuild create mode 100644 lib/xapi-stdext/stdext.ml create mode 100644 xapi-stdext-base64.opam create mode 100644 xapi-stdext-bigbuffer.opam create mode 100644 xapi-stdext-date.opam create mode 100644 xapi-stdext-deprecated.opam create mode 100644 xapi-stdext-encodings.opam create mode 100644 xapi-stdext-fring.opam create mode 100644 xapi-stdext-monadic.opam create mode 100644 xapi-stdext-pervasives.opam create mode 100644 xapi-stdext-range.opam create mode 100644 xapi-stdext-std.opam rename stdext.opam => xapi-stdext-threads.opam (84%) create mode 100644 xapi-stdext-unix.opam create mode 100644 xapi-stdext-zerocheck.opam create mode 100644 xapi-stdext.opam diff --git a/lib/jbuild b/lib/jbuild deleted file mode 100644 index b883738905f..00000000000 --- a/lib/jbuild +++ /dev/null @@ -1,19 +0,0 @@ -(jbuild_version 1) - -(library ( - (name stdext) - (public_name stdext) - (flags (:standard -w -3)) - (c_names (blkgetsize_stubs - unixext_open_stubs - unixext_stubs - unixext_write_stubs - zerocheck_stub)) - (libraries (base64 - bigarray - fd-send-recv - threads - uuidm - unix - xapi-backtrace)) - )) diff --git a/lib/base64.ml b/lib/xapi-stdext-base64/base64.ml similarity index 100% rename from lib/base64.ml rename to lib/xapi-stdext-base64/base64.ml diff --git a/lib/xapi-stdext-base64/jbuild b/lib/xapi-stdext-base64/jbuild new file mode 100644 index 00000000000..cbdee36ee69 --- /dev/null +++ b/lib/xapi-stdext-base64/jbuild @@ -0,0 +1,7 @@ +(jbuild_version 1) + +(library + ((name xapi_stdext_base64) + (public_name xapi-stdext-base64) + (libraries (base64)) + )) diff --git a/lib/bigbuffer.ml b/lib/xapi-stdext-bigbuffer/bigbuffer.ml similarity index 100% rename from lib/bigbuffer.ml rename to lib/xapi-stdext-bigbuffer/bigbuffer.ml diff --git a/lib/bigbuffer.mli b/lib/xapi-stdext-bigbuffer/bigbuffer.mli similarity index 100% rename from lib/bigbuffer.mli rename to lib/xapi-stdext-bigbuffer/bigbuffer.mli diff --git a/lib/xapi-stdext-bigbuffer/jbuild b/lib/xapi-stdext-bigbuffer/jbuild new file mode 100644 index 00000000000..ab0bb66be93 --- /dev/null +++ b/lib/xapi-stdext-bigbuffer/jbuild @@ -0,0 +1,6 @@ +(jbuild_version 1) + +(library + ((name xapi_stdext_bigbuffer) + (public_name xapi-stdext-bigbuffer) + )) diff --git a/lib/date.ml b/lib/xapi-stdext-date/date.ml similarity index 100% rename from lib/date.ml rename to lib/xapi-stdext-date/date.ml diff --git a/lib/date.mli b/lib/xapi-stdext-date/date.mli similarity index 100% rename from lib/date.mli rename to lib/xapi-stdext-date/date.mli diff --git a/lib/xapi-stdext-date/jbuild b/lib/xapi-stdext-date/jbuild new file mode 100644 index 00000000000..24c3784c76f --- /dev/null +++ b/lib/xapi-stdext-date/jbuild @@ -0,0 +1,7 @@ +(jbuild_version 1) + +(library + ((name xapi_stdext_date) + (public_name xapi-stdext-date) + (libraries (unix)) + )) diff --git a/lib/fun.ml b/lib/xapi-stdext-deprecated/fun.ml similarity index 100% rename from lib/fun.ml rename to lib/xapi-stdext-deprecated/fun.ml diff --git a/lib/fun.mli b/lib/xapi-stdext-deprecated/fun.mli similarity index 100% rename from lib/fun.mli rename to lib/xapi-stdext-deprecated/fun.mli diff --git a/lib/xapi-stdext-deprecated/jbuild b/lib/xapi-stdext-deprecated/jbuild new file mode 100644 index 00000000000..a4ef03d6d6c --- /dev/null +++ b/lib/xapi-stdext-deprecated/jbuild @@ -0,0 +1,6 @@ +(jbuild_version 1) + +(library + ((name xapi_stdext_deprecated) + (public_name xapi-stdext-deprecated) + )) diff --git a/lib/encodings.ml b/lib/xapi-stdext-encodings/encodings.ml similarity index 100% rename from lib/encodings.ml rename to lib/xapi-stdext-encodings/encodings.ml diff --git a/lib/encodings.mli b/lib/xapi-stdext-encodings/encodings.mli similarity index 100% rename from lib/encodings.mli rename to lib/xapi-stdext-encodings/encodings.mli diff --git a/lib/xapi-stdext-encodings/jbuild b/lib/xapi-stdext-encodings/jbuild new file mode 100644 index 00000000000..db744723858 --- /dev/null +++ b/lib/xapi-stdext-encodings/jbuild @@ -0,0 +1,6 @@ +(jbuild_version 1) + +(library + ((name xapi_stdext_encodings) + (public_name xapi-stdext-encodings) + )) diff --git a/lib/fring.ml b/lib/xapi-stdext-fring/fring.ml similarity index 100% rename from lib/fring.ml rename to lib/xapi-stdext-fring/fring.ml diff --git a/lib/fring.mli b/lib/xapi-stdext-fring/fring.mli similarity index 100% rename from lib/fring.mli rename to lib/xapi-stdext-fring/fring.mli diff --git a/lib/xapi-stdext-fring/jbuild b/lib/xapi-stdext-fring/jbuild new file mode 100644 index 00000000000..56c0da717d6 --- /dev/null +++ b/lib/xapi-stdext-fring/jbuild @@ -0,0 +1,7 @@ +(jbuild_version 1) + +(library + ((public_name xapi-stdext-fring) + (name xapi_stdext_fring) + (libraries (bigarray)) + )) \ No newline at end of file diff --git a/lib/either.ml b/lib/xapi-stdext-monadic/either.ml similarity index 85% rename from lib/either.ml rename to lib/xapi-stdext-monadic/either.ml index 8d5ee5a5739..08dd728299c 100644 --- a/lib/either.ml +++ b/lib/xapi-stdext-monadic/either.ml @@ -1,5 +1,3 @@ -open Listext - type ('a,'b) t = Left of 'a | Right of 'b module Monad = Monad.M2.Make (struct @@ -25,7 +23,9 @@ let to_option = function | Right x -> Some x | Left _ -> None -let cat_right l = List.unbox_list (List.map to_option l) +let cat_right l = + let unbox_list a = List.map Opt.unbox (List.filter Opt.is_boxed a) in + unbox_list (List.map to_option l) let join = function | Right (Right x) -> Right x diff --git a/lib/either.mli b/lib/xapi-stdext-monadic/either.mli similarity index 100% rename from lib/either.mli rename to lib/xapi-stdext-monadic/either.mli diff --git a/lib/xapi-stdext-monadic/jbuild b/lib/xapi-stdext-monadic/jbuild new file mode 100644 index 00000000000..07303874bda --- /dev/null +++ b/lib/xapi-stdext-monadic/jbuild @@ -0,0 +1,6 @@ +(jbuild_version 1) + +(library ( + (public_name xapi-stdext-monadic) + (name xapi_stdext_monadic) + )) diff --git a/lib/monad.ml b/lib/xapi-stdext-monadic/monad.ml similarity index 100% rename from lib/monad.ml rename to lib/xapi-stdext-monadic/monad.ml diff --git a/lib/monad.mli b/lib/xapi-stdext-monadic/monad.mli similarity index 100% rename from lib/monad.mli rename to lib/xapi-stdext-monadic/monad.mli diff --git a/lib/opt.ml b/lib/xapi-stdext-monadic/opt.ml similarity index 100% rename from lib/opt.ml rename to lib/xapi-stdext-monadic/opt.ml diff --git a/lib/opt.mli b/lib/xapi-stdext-monadic/opt.mli similarity index 100% rename from lib/opt.mli rename to lib/xapi-stdext-monadic/opt.mli diff --git a/lib/xapi-stdext-pervasives/jbuild b/lib/xapi-stdext-pervasives/jbuild new file mode 100644 index 00000000000..10cd0efbd89 --- /dev/null +++ b/lib/xapi-stdext-pervasives/jbuild @@ -0,0 +1,7 @@ +(jbuild_version 1) + +(library ( + (name xapi_stdext_pervasives) + (public_name xapi-stdext-pervasives) + (libraries (xapi-backtrace)) + )) diff --git a/lib/pervasiveext.ml b/lib/xapi-stdext-pervasives/pervasiveext.ml similarity index 98% rename from lib/pervasiveext.ml rename to lib/xapi-stdext-pervasives/pervasiveext.ml index ebe2146b032..21322693098 100644 --- a/lib/pervasiveext.ml +++ b/lib/xapi-stdext-pervasives/pervasiveext.ml @@ -58,7 +58,7 @@ let ignore_bool v = let (_: bool) = v in () (* To avoid some parens: *) (* composition of functions: *) -let (++) f g x = Fun.comp f g x +let (++) f g x = f (g x) (* and application *) let ($) f a = f a diff --git a/lib/pervasiveext.mli b/lib/xapi-stdext-pervasives/pervasiveext.mli similarity index 100% rename from lib/pervasiveext.mli rename to lib/xapi-stdext-pervasives/pervasiveext.mli diff --git a/lib/xapi-stdext-range/jbuild b/lib/xapi-stdext-range/jbuild new file mode 100644 index 00000000000..2dda5f268da --- /dev/null +++ b/lib/xapi-stdext-range/jbuild @@ -0,0 +1,6 @@ +(jbuild_version 1) + +(library + ((name xapi_stdext_range) + (public_name xapi-stdext-range) + )) diff --git a/lib/range.ml b/lib/xapi-stdext-range/range.ml similarity index 100% rename from lib/range.ml rename to lib/xapi-stdext-range/range.ml diff --git a/lib/range.mli b/lib/xapi-stdext-range/range.mli similarity index 100% rename from lib/range.mli rename to lib/xapi-stdext-range/range.mli diff --git a/lib/filenameext.ml b/lib/xapi-stdext-std/filenameext.ml similarity index 100% rename from lib/filenameext.ml rename to lib/xapi-stdext-std/filenameext.ml diff --git a/lib/filenameext.mli b/lib/xapi-stdext-std/filenameext.mli similarity index 100% rename from lib/filenameext.mli rename to lib/xapi-stdext-std/filenameext.mli diff --git a/lib/hashtblext.ml b/lib/xapi-stdext-std/hashtblext.ml similarity index 100% rename from lib/hashtblext.ml rename to lib/xapi-stdext-std/hashtblext.ml diff --git a/lib/hashtblext.mli b/lib/xapi-stdext-std/hashtblext.mli similarity index 100% rename from lib/hashtblext.mli rename to lib/xapi-stdext-std/hashtblext.mli diff --git a/lib/xapi-stdext-std/jbuild b/lib/xapi-stdext-std/jbuild new file mode 100644 index 00000000000..7be3867d8a1 --- /dev/null +++ b/lib/xapi-stdext-std/jbuild @@ -0,0 +1,8 @@ +(jbuild_version 1) + +(library +((public_name xapi-stdext-std) + (name xapi_stdext_std) + (libraries (uuidm + xapi-stdext-monadic)) + )) diff --git a/lib/listext.ml b/lib/xapi-stdext-std/listext.ml similarity index 97% rename from lib/listext.ml rename to lib/xapi-stdext-std/listext.ml index 9a69145fb5a..173c813f797 100644 --- a/lib/listext.ml +++ b/lib/xapi-stdext-std/listext.ml @@ -14,7 +14,7 @@ module List = struct include List - module Monad = Monad.M1.Make (struct + module Monad = Xapi_stdext_monadic.Monad.M1.Make (struct type 'a m = 'a list @@ -214,7 +214,9 @@ module List = struct include List let make_assoc op l = map (fun key -> key, op key) l - let unbox_list a = List.map Opt.unbox (List.filter Opt.is_boxed a) + let unbox_list a = + let module Opt = Xapi_stdext_monadic.Opt in + List.map Opt.unbox (List.filter Opt.is_boxed a) let filter_map f list = unbox_list (map f list) diff --git a/lib/listext.mli b/lib/xapi-stdext-std/listext.mli similarity index 98% rename from lib/listext.mli rename to lib/xapi-stdext-std/listext.mli index 98cce700016..c200d84c1f1 100644 --- a/lib/listext.mli +++ b/lib/xapi-stdext-std/listext.mli @@ -13,7 +13,7 @@ *) module List : sig - module Monad : sig include Monad.M1.MONAD with type 'a m = 'a list end + module Monad : sig include Xapi_stdext_monadic.Monad.M1.MONAD with type 'a m = 'a list end val setify : 'a list -> 'a list val subset : 'a list -> 'a list -> bool val set_equiv : 'a list -> 'a list -> bool diff --git a/lib/xstringext.ml b/lib/xapi-stdext-std/xstringext.ml similarity index 100% rename from lib/xstringext.ml rename to lib/xapi-stdext-std/xstringext.ml diff --git a/lib/xstringext.mli b/lib/xapi-stdext-std/xstringext.mli similarity index 100% rename from lib/xstringext.mli rename to lib/xapi-stdext-std/xstringext.mli diff --git a/lib/xapi-stdext-threads/jbuild b/lib/xapi-stdext-threads/jbuild new file mode 100644 index 00000000000..9bee4adc5d0 --- /dev/null +++ b/lib/xapi-stdext-threads/jbuild @@ -0,0 +1,9 @@ +(jbuild_version 1) + +(library ( + (public_name xapi-stdext-threads) + (name xapi_stdext_threads) + (libraries (threads + unix + xapi-stdext-pervasives)) + )) diff --git a/lib/semaphore.ml b/lib/xapi-stdext-threads/semaphore.ml similarity index 100% rename from lib/semaphore.ml rename to lib/xapi-stdext-threads/semaphore.ml diff --git a/lib/semaphore.mli b/lib/xapi-stdext-threads/semaphore.mli similarity index 100% rename from lib/semaphore.mli rename to lib/xapi-stdext-threads/semaphore.mli diff --git a/lib/threadext.ml b/lib/xapi-stdext-threads/threadext.ml similarity index 98% rename from lib/threadext.ml rename to lib/xapi-stdext-threads/threadext.ml index f00b4d6d933..79468d62ed6 100644 --- a/lib/threadext.ml +++ b/lib/xapi-stdext-threads/threadext.ml @@ -167,8 +167,9 @@ module Thread = struct run_pendings ()) let create ?(schedule=Indefinite) f x = + let finally = Xapi_stdext_pervasives.Pervasiveext.finally in let f' x = - Pervasiveext.finally + finally (fun () -> f x) exit in Mutex.execute scheduler_token @@ -362,11 +363,12 @@ module Delay = struct exception Pre_signalled let wait (x: t) (seconds: float) = + let finally = Xapi_stdext_pervasives.Pervasiveext.finally in let to_close = ref [ ] in let close' fd = if List.mem fd !to_close then Unix.close fd; to_close := List.filter (fun x -> fd <> x) !to_close in - Pervasiveext.finally + finally (fun () -> try let pipe_out = Mutex.execute x.m diff --git a/lib/threadext.mli b/lib/xapi-stdext-threads/threadext.mli similarity index 100% rename from lib/threadext.mli rename to lib/xapi-stdext-threads/threadext.mli diff --git a/lib/blkgetsize_stubs.c b/lib/xapi-stdext-unix/blkgetsize_stubs.c similarity index 100% rename from lib/blkgetsize_stubs.c rename to lib/xapi-stdext-unix/blkgetsize_stubs.c diff --git a/lib/xapi-stdext-unix/jbuild b/lib/xapi-stdext-unix/jbuild new file mode 100644 index 00000000000..54ed757365c --- /dev/null +++ b/lib/xapi-stdext-unix/jbuild @@ -0,0 +1,15 @@ +(jbuild_version 1) + +(library +((name xapi_stdext_unix) + (public_name xapi-stdext-unix) + (c_names (blkgetsize_stubs + unixext_open_stubs + unixext_stubs + unixext_write_stubs)) + (libraries (fd-send-recv + unix + xapi-stdext-bigbuffer + xapi-stdext-pervasives + xapi-stdext-std)) + )) diff --git a/lib/unixext.ml b/lib/xapi-stdext-unix/unixext.ml similarity index 99% rename from lib/unixext.ml rename to lib/xapi-stdext-unix/unixext.ml index bf20270fbda..6b3896d0775 100644 --- a/lib/unixext.ml +++ b/lib/xapi-stdext-unix/unixext.ml @@ -11,7 +11,8 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -open Pervasiveext +open Xapi_stdext_pervasives.Pervasiveext +module Bigbuffer = Xapi_stdext_bigbuffer.Bigbuffer exception Unix_error of int @@ -172,12 +173,13 @@ let string_of_file file_path = Buffer.contents (buffer_of_file file_path) (** Opens a temp file, applies the fd to the function, when the function completes, renames the file as required. *) let atomic_write_to_file fname perms f = + let module Filenameext = Xapi_stdext_std.Filenameext in let tmp = Filenameext.temp_file_in_dir fname in Unix.chmod tmp perms; - Pervasiveext.finally + finally (fun () -> let fd = Unix.openfile tmp [Unix.O_WRONLY; Unix.O_CREAT] perms (* ignored since the file exists *) in - let result = Pervasiveext.finally + let result = finally (fun () -> f fd) (fun () -> Unix.close fd) in Unix.rename tmp fname; (* Nb this only happens if an exception wasn't raised in the application of f *) @@ -208,6 +210,7 @@ let execv_get_output cmd args = pid, pipe_exit let copy_file_internal ?limit reader writer = + let module Opt = Xapi_stdext_monadic.Opt in let buffer = String.make 65536 '\000' in let buffer_len = Int64.of_int (String.length buffer) in let finished = ref false in diff --git a/lib/unixext.mli b/lib/xapi-stdext-unix/unixext.mli similarity index 97% rename from lib/unixext.mli rename to lib/xapi-stdext-unix/unixext.mli index ee99e879296..a070837c4e9 100644 --- a/lib/unixext.mli +++ b/lib/xapi-stdext-unix/unixext.mli @@ -55,7 +55,7 @@ val buffer_of_fd : Unix.file_descr -> Buffer.t (** [bigbuffer_of_fd fd] returns a Bigbuffer.t containing all data read from [fd] up to EOF *) -val bigbuffer_of_fd : Unix.file_descr -> Bigbuffer.t +val bigbuffer_of_fd : Unix.file_descr -> Xapi_stdext_bigbuffer.Bigbuffer.t (** [string_of_fd fd] returns a string containing all data read from [fd] up to EOF *) val string_of_fd : Unix.file_descr -> string @@ -64,7 +64,7 @@ val string_of_fd : Unix.file_descr -> string val buffer_of_file : string -> Buffer.t (** [bigbuffer_of_file file] returns a Bigbuffer.t containing the contents of [file] *) -val bigbuffer_of_file : string -> Bigbuffer.t +val bigbuffer_of_file : string -> Xapi_stdext_bigbuffer.Bigbuffer.t (** [string_of_file file] returns a string containing the contents of [file] *) val string_of_file : string -> string @@ -104,7 +104,7 @@ val string_of_signal : int -> string val proxy : Unix.file_descr -> Unix.file_descr -> unit val really_read : Unix.file_descr -> string -> int -> int -> unit val really_read_string : Unix.file_descr -> int -> string -val really_read_bigbuffer : Unix.file_descr -> Bigbuffer.t -> int64 -> unit +val really_read_bigbuffer : Unix.file_descr -> Xapi_stdext_bigbuffer.Bigbuffer.t -> int64 -> unit val really_write : Unix.file_descr -> string -> int -> int -> unit val really_write_string : Unix.file_descr -> string -> unit val try_read_string : ?limit: int -> Unix.file_descr -> string diff --git a/lib/unixext_open_stubs.c b/lib/xapi-stdext-unix/unixext_open_stubs.c similarity index 100% rename from lib/unixext_open_stubs.c rename to lib/xapi-stdext-unix/unixext_open_stubs.c diff --git a/lib/unixext_stubs.c b/lib/xapi-stdext-unix/unixext_stubs.c similarity index 100% rename from lib/unixext_stubs.c rename to lib/xapi-stdext-unix/unixext_stubs.c diff --git a/lib/unixext_write_stubs.c b/lib/xapi-stdext-unix/unixext_write_stubs.c similarity index 100% rename from lib/unixext_write_stubs.c rename to lib/xapi-stdext-unix/unixext_write_stubs.c diff --git a/lib/xapi-stdext-zerocheck/jbuild b/lib/xapi-stdext-zerocheck/jbuild new file mode 100644 index 00000000000..a43204941fe --- /dev/null +++ b/lib/xapi-stdext-zerocheck/jbuild @@ -0,0 +1,7 @@ +(jbuild_version 1) + +(library ( + (public_name xapi-stdext-zerocheck) + (name xapi_stdext_zerocheck) + (c_names (zerocheck_stub)) + )) diff --git a/lib/zerocheck.ml b/lib/xapi-stdext-zerocheck/zerocheck.ml similarity index 100% rename from lib/zerocheck.ml rename to lib/xapi-stdext-zerocheck/zerocheck.ml diff --git a/lib/zerocheck.mli b/lib/xapi-stdext-zerocheck/zerocheck.mli similarity index 100% rename from lib/zerocheck.mli rename to lib/xapi-stdext-zerocheck/zerocheck.mli diff --git a/lib/zerocheck_stub.c b/lib/xapi-stdext-zerocheck/zerocheck_stub.c similarity index 100% rename from lib/zerocheck_stub.c rename to lib/xapi-stdext-zerocheck/zerocheck_stub.c diff --git a/lib/xapi-stdext/jbuild b/lib/xapi-stdext/jbuild new file mode 100644 index 00000000000..0d65bf9e08f --- /dev/null +++ b/lib/xapi-stdext/jbuild @@ -0,0 +1,22 @@ +(jbuild_version 1) + +(library + ((public_name xapi-stdext) + (name stdext) + (modules (stdext)) + (wrapped false) + (libraries (xapi-stdext-base64 + xapi-stdext-bigbuffer + xapi-stdext-date + xapi-stdext-deprecated + xapi-stdext-encodings + xapi-stdext-fring + xapi-stdext-monadic + xapi-stdext-pervasives + xapi-stdext-range + xapi-stdext-std + xapi-stdext-threads + xapi-stdext-unix + xapi-stdext-zerocheck)) + )) + diff --git a/lib/xapi-stdext/stdext.ml b/lib/xapi-stdext/stdext.ml new file mode 100644 index 00000000000..d904f25fccb --- /dev/null +++ b/lib/xapi-stdext/stdext.ml @@ -0,0 +1,27 @@ +(* New modules *) +module Base64 = Xapi_stdext_base64.Base64 +module Bigbuffer = Xapi_stdext_bigbuffer.Bigbuffer +module Date = Xapi_stdext_date.Date +module Encodings = Xapi_stdext_encodings.Encodings +module Fring = Xapi_stdext_fring.Fring +module Range = Xapi_stdext_range.Range + +(* Monadic modules *) +module Monad = Xapi_stdext_monadic.Monad +module Either = Xapi_stdext_monadic.Either (* Should be deprecated and replaced by Result *) +module Opt = Xapi_stdext_monadic.Opt + +(* Standard library extensions and additions*) +module Pervasiveext = Xapi_stdext_pervasives.Pervasiveext +module Filenameext = Xapi_stdext_std.Filenameext +module Listext = Xapi_stdext_std.Listext +module Xstringext = Xapi_stdext_std.Xstringext + +module Threadext = Xapi_stdext_threads.Threadext +module Semaphore = Xapi_stdext_threads.Semaphore + +module Unixext = Xapi_stdext_unix.Unixext +module Zerocheck = Xapi_stdext_zerocheck.Zerocheck + +(* To depracate asap *) +module Fun = Xapi_stdext_deprecated.Fun \ No newline at end of file diff --git a/xapi-stdext-base64.opam b/xapi-stdext-base64.opam new file mode 100644 index 00000000000..2a8ba83b23e --- /dev/null +++ b/xapi-stdext-base64.opam @@ -0,0 +1,14 @@ +opam-version: "1.2" +maintainer: "jonathan.ludlam@citrix.com" +authors: "xen-api@list.xen.org" +bug-reports: "https://github.com/xapi-project/stdext/issues" +dev-repo: "git://github.com/xapi-project/stdext.git" +homepage: "https://xapi-project.github.io/" +tags: [ "org:xapi-project" ] + +build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] + +depends: [ + "jbuilder" {build} + "base64" +] diff --git a/xapi-stdext-bigbuffer.opam b/xapi-stdext-bigbuffer.opam new file mode 100644 index 00000000000..b747c86b99d --- /dev/null +++ b/xapi-stdext-bigbuffer.opam @@ -0,0 +1,13 @@ +opam-version: "1.2" +maintainer: "jonathan.ludlam@citrix.com" +authors: "xen-api@list.xen.org" +bug-reports: "https://github.com/xapi-project/stdext/issues" +dev-repo: "git://github.com/xapi-project/stdext.git" +homepage: "https://xapi-project.github.io/" +tags: [ "org:xapi-project" ] + +build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] + +depends: [ + "jbuilder" {build} +] diff --git a/xapi-stdext-date.opam b/xapi-stdext-date.opam new file mode 100644 index 00000000000..e5e0300273c --- /dev/null +++ b/xapi-stdext-date.opam @@ -0,0 +1,14 @@ +opam-version: "1.2" +maintainer: "jonathan.ludlam@citrix.com" +authors: "xen-api@list.xen.org" +bug-reports: "https://github.com/xapi-project/stdext/issues" +dev-repo: "git://github.com/xapi-project/stdext.git" +homepage: "https://xapi-project.github.io/" +tags: [ "org:xapi-project" ] + +build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] + +depends: [ + "jbuilder" {build} + "base-unix" +] diff --git a/xapi-stdext-deprecated.opam b/xapi-stdext-deprecated.opam new file mode 100644 index 00000000000..b747c86b99d --- /dev/null +++ b/xapi-stdext-deprecated.opam @@ -0,0 +1,13 @@ +opam-version: "1.2" +maintainer: "jonathan.ludlam@citrix.com" +authors: "xen-api@list.xen.org" +bug-reports: "https://github.com/xapi-project/stdext/issues" +dev-repo: "git://github.com/xapi-project/stdext.git" +homepage: "https://xapi-project.github.io/" +tags: [ "org:xapi-project" ] + +build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] + +depends: [ + "jbuilder" {build} +] diff --git a/xapi-stdext-encodings.opam b/xapi-stdext-encodings.opam new file mode 100644 index 00000000000..b747c86b99d --- /dev/null +++ b/xapi-stdext-encodings.opam @@ -0,0 +1,13 @@ +opam-version: "1.2" +maintainer: "jonathan.ludlam@citrix.com" +authors: "xen-api@list.xen.org" +bug-reports: "https://github.com/xapi-project/stdext/issues" +dev-repo: "git://github.com/xapi-project/stdext.git" +homepage: "https://xapi-project.github.io/" +tags: [ "org:xapi-project" ] + +build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] + +depends: [ + "jbuilder" {build} +] diff --git a/xapi-stdext-fring.opam b/xapi-stdext-fring.opam new file mode 100644 index 00000000000..3ae84a89363 --- /dev/null +++ b/xapi-stdext-fring.opam @@ -0,0 +1,14 @@ +opam-version: "1.2" +maintainer: "jonathan.ludlam@citrix.com" +authors: "xen-api@list.xen.org" +bug-reports: "https://github.com/xapi-project/stdext/issues" +dev-repo: "git://github.com/xapi-project/stdext.git" +homepage: "https://xapi-project.github.io/" +tags: [ "org:xapi-project" ] + +build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] + +depends: [ + "jbuilder" {build} + "base-bigarray" +] diff --git a/xapi-stdext-monadic.opam b/xapi-stdext-monadic.opam new file mode 100644 index 00000000000..b747c86b99d --- /dev/null +++ b/xapi-stdext-monadic.opam @@ -0,0 +1,13 @@ +opam-version: "1.2" +maintainer: "jonathan.ludlam@citrix.com" +authors: "xen-api@list.xen.org" +bug-reports: "https://github.com/xapi-project/stdext/issues" +dev-repo: "git://github.com/xapi-project/stdext.git" +homepage: "https://xapi-project.github.io/" +tags: [ "org:xapi-project" ] + +build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] + +depends: [ + "jbuilder" {build} +] diff --git a/xapi-stdext-pervasives.opam b/xapi-stdext-pervasives.opam new file mode 100644 index 00000000000..027a7871ea9 --- /dev/null +++ b/xapi-stdext-pervasives.opam @@ -0,0 +1,14 @@ +opam-version: "1.2" +maintainer: "jonathan.ludlam@citrix.com" +authors: "xen-api@list.xen.org" +bug-reports: "https://github.com/xapi-project/stdext/issues" +dev-repo: "git://github.com/xapi-project/stdext.git" +homepage: "https://xapi-project.github.io/" +tags: [ "org:xapi-project" ] + +build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] + +depends: [ + "jbuilder" {build} + "xapi-backtrace" +] diff --git a/xapi-stdext-range.opam b/xapi-stdext-range.opam new file mode 100644 index 00000000000..b747c86b99d --- /dev/null +++ b/xapi-stdext-range.opam @@ -0,0 +1,13 @@ +opam-version: "1.2" +maintainer: "jonathan.ludlam@citrix.com" +authors: "xen-api@list.xen.org" +bug-reports: "https://github.com/xapi-project/stdext/issues" +dev-repo: "git://github.com/xapi-project/stdext.git" +homepage: "https://xapi-project.github.io/" +tags: [ "org:xapi-project" ] + +build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] + +depends: [ + "jbuilder" {build} +] diff --git a/xapi-stdext-std.opam b/xapi-stdext-std.opam new file mode 100644 index 00000000000..01b8c3cd6b7 --- /dev/null +++ b/xapi-stdext-std.opam @@ -0,0 +1,15 @@ +opam-version: "1.2" +maintainer: "jonathan.ludlam@citrix.com" +authors: "xen-api@list.xen.org" +bug-reports: "https://github.com/xapi-project/stdext/issues" +dev-repo: "git://github.com/xapi-project/stdext.git" +homepage: "https://xapi-project.github.io/" +tags: [ "org:xapi-project" ] + +build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] + +depends: [ + "jbuilder" {build} + "uuidm" + "xapi-stdext-monadic" +] diff --git a/stdext.opam b/xapi-stdext-threads.opam similarity index 84% rename from stdext.opam rename to xapi-stdext-threads.opam index e6ca83428a1..a35666a0166 100644 --- a/stdext.opam +++ b/xapi-stdext-threads.opam @@ -10,11 +10,6 @@ build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] depends: [ "jbuilder" {build} - "base-bigarray" "base-threads" "base-unix" - "base64" - "fd-send-recv" - "uuidm" - "xapi-backtrace" ] diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam new file mode 100644 index 00000000000..e109ed51804 --- /dev/null +++ b/xapi-stdext-unix.opam @@ -0,0 +1,18 @@ +opam-version: "1.2" +maintainer: "jonathan.ludlam@citrix.com" +authors: "xen-api@list.xen.org" +bug-reports: "https://github.com/xapi-project/stdext/issues" +dev-repo: "git://github.com/xapi-project/stdext.git" +homepage: "https://xapi-project.github.io/" +tags: [ "org:xapi-project" ] + +build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] + +depends: [ + "jbuilder" {build} + "base-unix" + "fd-send-recv" + "xapi-stdext-bigbuffer" + "xapi-stdext-pervasives" + "xapi-stdext-std" +] diff --git a/xapi-stdext-zerocheck.opam b/xapi-stdext-zerocheck.opam new file mode 100644 index 00000000000..b747c86b99d --- /dev/null +++ b/xapi-stdext-zerocheck.opam @@ -0,0 +1,13 @@ +opam-version: "1.2" +maintainer: "jonathan.ludlam@citrix.com" +authors: "xen-api@list.xen.org" +bug-reports: "https://github.com/xapi-project/stdext/issues" +dev-repo: "git://github.com/xapi-project/stdext.git" +homepage: "https://xapi-project.github.io/" +tags: [ "org:xapi-project" ] + +build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] + +depends: [ + "jbuilder" {build} +] diff --git a/xapi-stdext.opam b/xapi-stdext.opam new file mode 100644 index 00000000000..35fc2085c8f --- /dev/null +++ b/xapi-stdext.opam @@ -0,0 +1,26 @@ +opam-version: "1.2" +maintainer: "jonathan.ludlam@citrix.com" +authors: "xen-api@list.xen.org" +bug-reports: "https://github.com/xapi-project/stdext/issues" +dev-repo: "git://github.com/xapi-project/stdext.git" +homepage: "https://xapi-project.github.io/" +tags: [ "org:xapi-project" ] + +build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] + +depends: [ + "jbuilder" {build} + "xapi-stdext-base64" + "xapi-stdext-bigbuffer" + "xapi-stdext-date" + "xapi-stdext-deprecated" + "xapi-stdext-encodings" + "xapi-stdext-fring" + "xapi-stdext-monadic" + "xapi-stdext-pervasives" + "xapi-stdext-range" + "xapi-stdext-std" + "xapi-stdext-threads" + "xapi-stdext-unix" + "xapi-stdext-zerocheck" +] From 790ca8cf5070b366118f1ae7c2ccbc8b595e6744 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Tue, 1 Aug 2017 13:39:45 +0100 Subject: [PATCH 059/199] Deprecate all functions in fun.ml Signed-off-by: Marcello Seri --- lib/xapi-stdext-deprecated/fun.ml | 2 -- lib/xapi-stdext-deprecated/fun.mli | 24 ++++++++++-------------- 2 files changed, 10 insertions(+), 16 deletions(-) diff --git a/lib/xapi-stdext-deprecated/fun.ml b/lib/xapi-stdext-deprecated/fun.ml index d65fd2e4881..644f60c0b27 100644 --- a/lib/xapi-stdext-deprecated/fun.ml +++ b/lib/xapi-stdext-deprecated/fun.ml @@ -15,6 +15,4 @@ let (++) f g x = comp f g x let comp2 f g a b = f (g a b) let (+++) f g a b = comp2 f g a b -let (|>) a f = f a - let ($) f a = f a diff --git a/lib/xapi-stdext-deprecated/fun.mli b/lib/xapi-stdext-deprecated/fun.mli index a2e9bc5358a..c394cb92a2c 100644 --- a/lib/xapi-stdext-deprecated/fun.mli +++ b/lib/xapi-stdext-deprecated/fun.mli @@ -1,14 +1,10 @@ -val const : 'a -> 'b -> 'a -val uncurry : ('a -> 'b -> 'c) -> ('a * 'b) -> 'c -val id : 'a -> 'a -val flip : ('a -> 'b -> 'c) -> ('b -> 'a -> 'c) -val on : ('b -> 'b -> 'c) -> ('a -> 'b) -> 'a -> 'a -> 'c -val comp : ('b -> 'c) -> ('a -> 'b) -> ('a -> 'c) -val comp2 : ('b -> 'c) -> ('a1 -> 'a2 -> 'b) -> ('a1 -> 'a2 -> 'c) -val (+++) : ('c -> 'd) -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'd -val (++) : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c - -val (|>) : 'a -> ('a -> 'b) -> 'b -(** Forward pipe operator: facilitates left-to-right function composition. *) - -val ($) : ('a -> 'b) -> 'a -> 'b +val const : 'a -> 'b -> 'a [@@ocaml.deprecated] +val uncurry : ('a -> 'b -> 'c) -> ('a * 'b) -> 'c [@@ocaml.deprecated] +val id : 'a -> 'a [@@ocaml.deprecated] +val flip : ('a -> 'b -> 'c) -> ('b -> 'a -> 'c) [@@ocaml.deprecated] +val on : ('b -> 'b -> 'c) -> ('a -> 'b) -> 'a -> 'a -> 'c [@@ocaml.deprecated] +val comp : ('b -> 'c) -> ('a -> 'b) -> ('a -> 'c) [@@ocaml.deprecated] +val comp2 : ('b -> 'c) -> ('a1 -> 'a2 -> 'b) -> ('a1 -> 'a2 -> 'c) [@@ocaml.deprecated] +val (+++) : ('c -> 'd) -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'd [@@ocaml.deprecated] +val (++) : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c [@@ocaml.deprecated] +val ($) : ('a -> 'b) -> 'a -> 'b [@@ocaml.deprecated] From d90f908508e52bf6f1892e2554f1749c08d6a30e Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Tue, 1 Aug 2017 16:14:15 +0100 Subject: [PATCH 060/199] Remove unnecessary fring Signed-off-by: Marcello Seri --- lib/xapi-stdext-fring/fring.ml | 80 --------------------------------- lib/xapi-stdext-fring/fring.mli | 51 --------------------- lib/xapi-stdext-fring/jbuild | 7 --- lib/xapi-stdext/jbuild | 1 - lib/xapi-stdext/stdext.ml | 3 +- xapi-stdext.opam | 1 - 6 files changed, 1 insertion(+), 142 deletions(-) delete mode 100644 lib/xapi-stdext-fring/fring.ml delete mode 100644 lib/xapi-stdext-fring/fring.mli delete mode 100644 lib/xapi-stdext-fring/jbuild diff --git a/lib/xapi-stdext-fring/fring.ml b/lib/xapi-stdext-fring/fring.ml deleted file mode 100644 index c3efd30290a..00000000000 --- a/lib/xapi-stdext-fring/fring.ml +++ /dev/null @@ -1,80 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -type t = { size: int; mutable current: int; data: (float,Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t ; } - -let make size init = - let ring = - { size = size; current = size - 1; data = Bigarray.Array1.create Bigarray.float32 Bigarray.c_layout size; } - in - Bigarray.Array1.fill ring.data init; - ring - -let copy x = - let y = make x.size 0. in - Bigarray.Array1.blit x.data y.data; - y.current <- x.current; - y - -let length ring = ring.size - -let push ring e = - ring.current <- ring.current + 1; - if ring.current = ring.size then - ring.current <- 0; - Bigarray.Array1.set ring.data ring.current e - -let peek ring i = - if i >= ring.size then - raise (Invalid_argument "peek: index"); - let index = - let offset = ring.current - i in - if offset >= 0 then offset else ring.size + offset in - Bigarray.Array1.get ring.data index - -let top ring = Bigarray.Array1.get ring.data ring.current - -let iter_nb ring f nb = - if nb > ring.size then - raise (Invalid_argument "iter_nb: nb"); - (* FIXME: OPTIMIZE ME with 2 Array.iter ? *) - for i = 0 to nb - 1 - do - f (peek ring i) - done - -(* iter directly on all element without using the index *) -let iter f a = - for i=0 to Bigarray.Array1.dim a - 1 do - f (Bigarray.Array1.get a i) - done - -let raw_iter ring f = - iter f ring.data - -let iter ring f = iter_nb ring f (ring.size) - -let get_nb ring nb = - if nb > ring.size then - raise (Invalid_argument "get_nb: nb"); - let a = Array.create nb (top ring) in - for i = 1 to nb - 1 - do - (* FIXME: OPTIMIZE ME with 2 Array.blit *) - a.(i) <- peek ring i - done; - a - -let get ring = get_nb ring (ring.size) - diff --git a/lib/xapi-stdext-fring/fring.mli b/lib/xapi-stdext-fring/fring.mli deleted file mode 100644 index bb653795638..00000000000 --- a/lib/xapi-stdext-fring/fring.mli +++ /dev/null @@ -1,51 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -(** Ring structures *) - -type t = { - size : int; - mutable current : int; - data : (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t; -} - -(** create a ring structure with [size] record; records initialised to [init] *) -val make : int -> float -> t - -(** create a duplicate ring structure *) -val copy : t -> t - -(** length of the ring *) -val length : t -> int - -(** push into the ring one element *) -val push : t -> float -> unit - -(** get the i{^th} old element from the ring *) -val peek : t -> int -> float - -(** get the top element of the ring *) -val top : t -> float - -(** iterate over nb element of the ring, starting from the top *) -val iter_nb : t -> (float -> unit) -> int -> unit - -val raw_iter : t -> (float -> unit) -> unit - -(** iterate over all elements of the ring, starting from the top *) -val iter : t -> (float -> unit) -> unit - -(** get array of latest [nb] value *) -val get_nb : t -> int -> float array - -val get : t -> float array diff --git a/lib/xapi-stdext-fring/jbuild b/lib/xapi-stdext-fring/jbuild deleted file mode 100644 index 56c0da717d6..00000000000 --- a/lib/xapi-stdext-fring/jbuild +++ /dev/null @@ -1,7 +0,0 @@ -(jbuild_version 1) - -(library - ((public_name xapi-stdext-fring) - (name xapi_stdext_fring) - (libraries (bigarray)) - )) \ No newline at end of file diff --git a/lib/xapi-stdext/jbuild b/lib/xapi-stdext/jbuild index 0d65bf9e08f..fbc6fa70be0 100644 --- a/lib/xapi-stdext/jbuild +++ b/lib/xapi-stdext/jbuild @@ -10,7 +10,6 @@ xapi-stdext-date xapi-stdext-deprecated xapi-stdext-encodings - xapi-stdext-fring xapi-stdext-monadic xapi-stdext-pervasives xapi-stdext-range diff --git a/lib/xapi-stdext/stdext.ml b/lib/xapi-stdext/stdext.ml index d904f25fccb..398d0fb44ae 100644 --- a/lib/xapi-stdext/stdext.ml +++ b/lib/xapi-stdext/stdext.ml @@ -3,7 +3,6 @@ module Base64 = Xapi_stdext_base64.Base64 module Bigbuffer = Xapi_stdext_bigbuffer.Bigbuffer module Date = Xapi_stdext_date.Date module Encodings = Xapi_stdext_encodings.Encodings -module Fring = Xapi_stdext_fring.Fring module Range = Xapi_stdext_range.Range (* Monadic modules *) @@ -24,4 +23,4 @@ module Unixext = Xapi_stdext_unix.Unixext module Zerocheck = Xapi_stdext_zerocheck.Zerocheck (* To depracate asap *) -module Fun = Xapi_stdext_deprecated.Fun \ No newline at end of file +module Fun = Xapi_stdext_deprecated.Fun diff --git a/xapi-stdext.opam b/xapi-stdext.opam index 35fc2085c8f..46b23d9efb8 100644 --- a/xapi-stdext.opam +++ b/xapi-stdext.opam @@ -15,7 +15,6 @@ depends: [ "xapi-stdext-date" "xapi-stdext-deprecated" "xapi-stdext-encodings" - "xapi-stdext-fring" "xapi-stdext-monadic" "xapi-stdext-pervasives" "xapi-stdext-range" From 45360e41ceed082f15c6e582e87c6388f5738e52 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Wed, 2 Aug 2017 10:24:21 +0100 Subject: [PATCH 061/199] Use same sanitize implementation as in wsproxy Signed-off-by: Marcello Seri --- lib/xapi-stdext-base64/base64.ml | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/lib/xapi-stdext-base64/base64.ml b/lib/xapi-stdext-base64/base64.ml index 9af95f09bb8..a7b35042887 100644 --- a/lib/xapi-stdext-base64/base64.ml +++ b/lib/xapi-stdext-base64/base64.ml @@ -13,17 +13,17 @@ *) let encode = B64.encode ?pad:None ?alphabet:None let decode s = - let sanitize x = + let sanitize s = (* ignore control characters: see RFC4648.1 and RFC4648.3 - * https://tools.ietf.org/html/rfc4648#section-3 + * https://tools.ietf.org/html/rfc4648#section-3 * Note: \t = \009, \n = \012, \r = \015, \s = \032 *) - let result = Buffer.create (String.length x) in - for i = 0 to String.length x - 1 do - if String.unsafe_get x i >= '\000' && String.unsafe_get x i <= '\032' - || String.unsafe_get x i = '\127' - then () - else Buffer.add_char result (String.unsafe_get x i) + let result = Buffer.create (String.length s) in + for i = 0 to String.length s - 1 do + if (String.unsafe_get s i >= '\000' && String.unsafe_get s i <= '\032') + || String.unsafe_get s i = '\127' + then () + else Buffer.add_char result (String.unsafe_get s i) done; Buffer.contents result in - B64.decode ?alphabet:None (sanitize s) \ No newline at end of file + B64.decode ?alphabet:None (sanitize s) From 69463259031f663d826eeb9b52e46b89299e5774 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Wed, 2 Aug 2017 10:28:26 +0100 Subject: [PATCH 062/199] reindent jbuild files Signed-off-by: Marcello Seri --- lib/xapi-stdext-monadic/jbuild | 8 ++++---- lib/xapi-stdext-pervasives/jbuild | 10 +++++----- lib/xapi-stdext-std/jbuild | 12 ++++++------ lib/xapi-stdext-threads/jbuild | 14 +++++++------- lib/xapi-stdext-unix/jbuild | 26 +++++++++++++------------- lib/xapi-stdext-zerocheck/jbuild | 10 +++++----- 6 files changed, 40 insertions(+), 40 deletions(-) diff --git a/lib/xapi-stdext-monadic/jbuild b/lib/xapi-stdext-monadic/jbuild index 07303874bda..987d00edd39 100644 --- a/lib/xapi-stdext-monadic/jbuild +++ b/lib/xapi-stdext-monadic/jbuild @@ -1,6 +1,6 @@ (jbuild_version 1) -(library ( - (public_name xapi-stdext-monadic) - (name xapi_stdext_monadic) - )) +(library + ((public_name xapi-stdext-monadic) + (name xapi_stdext_monadic) + )) diff --git a/lib/xapi-stdext-pervasives/jbuild b/lib/xapi-stdext-pervasives/jbuild index 10cd0efbd89..548f2c516bf 100644 --- a/lib/xapi-stdext-pervasives/jbuild +++ b/lib/xapi-stdext-pervasives/jbuild @@ -1,7 +1,7 @@ (jbuild_version 1) -(library ( - (name xapi_stdext_pervasives) - (public_name xapi-stdext-pervasives) - (libraries (xapi-backtrace)) - )) +(library + ((name xapi_stdext_pervasives) + (public_name xapi-stdext-pervasives) + (libraries (xapi-backtrace)) + )) diff --git a/lib/xapi-stdext-std/jbuild b/lib/xapi-stdext-std/jbuild index 7be3867d8a1..52ec1d3d6aa 100644 --- a/lib/xapi-stdext-std/jbuild +++ b/lib/xapi-stdext-std/jbuild @@ -1,8 +1,8 @@ (jbuild_version 1) -(library -((public_name xapi-stdext-std) - (name xapi_stdext_std) - (libraries (uuidm - xapi-stdext-monadic)) - )) +(library + ((public_name xapi-stdext-std) + (name xapi_stdext_std) + (libraries (uuidm + xapi-stdext-monadic)) + )) diff --git a/lib/xapi-stdext-threads/jbuild b/lib/xapi-stdext-threads/jbuild index 9bee4adc5d0..643d4cf8d86 100644 --- a/lib/xapi-stdext-threads/jbuild +++ b/lib/xapi-stdext-threads/jbuild @@ -1,9 +1,9 @@ (jbuild_version 1) -(library ( - (public_name xapi-stdext-threads) - (name xapi_stdext_threads) - (libraries (threads - unix - xapi-stdext-pervasives)) - )) +(library + ((public_name xapi-stdext-threads) + (name xapi_stdext_threads) + (libraries (threads + unix + xapi-stdext-pervasives)) + )) diff --git a/lib/xapi-stdext-unix/jbuild b/lib/xapi-stdext-unix/jbuild index 54ed757365c..45c00b919e0 100644 --- a/lib/xapi-stdext-unix/jbuild +++ b/lib/xapi-stdext-unix/jbuild @@ -1,15 +1,15 @@ (jbuild_version 1) -(library -((name xapi_stdext_unix) - (public_name xapi-stdext-unix) - (c_names (blkgetsize_stubs - unixext_open_stubs - unixext_stubs - unixext_write_stubs)) - (libraries (fd-send-recv - unix - xapi-stdext-bigbuffer - xapi-stdext-pervasives - xapi-stdext-std)) - )) +(library + ((name xapi_stdext_unix) + (public_name xapi-stdext-unix) + (c_names (blkgetsize_stubs + unixext_open_stubs + unixext_stubs + unixext_write_stubs)) + (libraries (fd-send-recv + unix + xapi-stdext-bigbuffer + xapi-stdext-pervasives + xapi-stdext-std)) + )) diff --git a/lib/xapi-stdext-zerocheck/jbuild b/lib/xapi-stdext-zerocheck/jbuild index a43204941fe..51074336f76 100644 --- a/lib/xapi-stdext-zerocheck/jbuild +++ b/lib/xapi-stdext-zerocheck/jbuild @@ -1,7 +1,7 @@ (jbuild_version 1) -(library ( - (public_name xapi-stdext-zerocheck) - (name xapi_stdext_zerocheck) - (c_names (zerocheck_stub)) - )) +(library + ((public_name xapi-stdext-zerocheck) + (name xapi_stdext_zerocheck) + (c_names (zerocheck_stub)) + )) From 546d68ca3acc63fca2a2e1bb5cef09c3b05abab5 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Wed, 2 Aug 2017 11:51:22 +0100 Subject: [PATCH 063/199] Introduce Travis Signed-off-by: Marcello Seri --- .travis.yml | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 00000000000..dfd9c95cd65 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,15 @@ +language: c +sudo: false +services: + - docker +install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh +script: bash -ex ./.travis-docker.sh && make gh-pages +env: + global: + - PINS="xapi-stdext:. xapi-stdext-base64:. xapi-stdext-bigbuffer:. xapi-stdext-date:. xapi-stdext-deprecated:. xapi-stdext-encodings:. xapi-stdext-monadic:. xapi-stdext-pervasives:. xapi-stdext-range:. xapi-stdext-std:. xapi-stdext-threads:. xapi-stdext-unix:. xapi-stdext-zerocheck:." + matrix: + - PACKAGE=xapi-stdext DISTRO="debian-unstable" OCAML_VERSION=4.03.0 + - PACKAGE=xapi-stdext DISTRO="debian-unstable" OCAML_VERSION=4.04.2 + - PACKAGE=xapi-stdext DISTRO="debian-unstable" OCAML_VERSION=4.05.0 +branches: + only: master From 0888cc42617a28040278b02163765ea052d4b1d6 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Wed, 2 Aug 2017 14:17:55 +0100 Subject: [PATCH 064/199] Remove unused fring opam file Signed-off-by: Marcello Seri --- xapi-stdext-fring.opam | 14 -------------- 1 file changed, 14 deletions(-) delete mode 100644 xapi-stdext-fring.opam diff --git a/xapi-stdext-fring.opam b/xapi-stdext-fring.opam deleted file mode 100644 index 3ae84a89363..00000000000 --- a/xapi-stdext-fring.opam +++ /dev/null @@ -1,14 +0,0 @@ -opam-version: "1.2" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" -tags: [ "org:xapi-project" ] - -build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] - -depends: [ - "jbuilder" {build} - "base-bigarray" -] From a6e613da83b70be0ba212c89d016cabc40e3906c Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Wed, 2 Aug 2017 14:34:23 +0100 Subject: [PATCH 065/199] Prepare to release v3.0.0 Signed-off-by: Marcello Seri --- ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index 9a340a3afc5..71db89e4c30 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +3.0.0 (02-Aug-2017): +* Remove unused packages +* Refactor in a backward compatible wrapper and 12 new separate libraries (see https://github.com/xapi-project/stdext/pull/21) +* Port to jbuilder + 2.1.0 (20-Oct-2016): * New Semaphore module From 674a1c481a5ac55de91957dac924d2de02cde0a2 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Wed, 2 Aug 2017 15:12:01 +0100 Subject: [PATCH 066/199] threads: opamfile, add missing dependency Signed-off-by: Marcello Seri --- xapi-stdext-threads.opam | 1 + 1 file changed, 1 insertion(+) diff --git a/xapi-stdext-threads.opam b/xapi-stdext-threads.opam index a35666a0166..03b87fb1252 100644 --- a/xapi-stdext-threads.opam +++ b/xapi-stdext-threads.opam @@ -12,4 +12,5 @@ depends: [ "jbuilder" {build} "base-threads" "base-unix" + "xapi-stdext-pervasives" ] From 50ec829ba6737bef7fb98cfcd3f4f9f8af824505 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Wed, 2 Aug 2017 16:31:15 +0100 Subject: [PATCH 067/199] stdext: expose hashtblext Signed-off-by: Marcello Seri --- lib/xapi-stdext/stdext.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/xapi-stdext/stdext.ml b/lib/xapi-stdext/stdext.ml index 398d0fb44ae..2db4c473af1 100644 --- a/lib/xapi-stdext/stdext.ml +++ b/lib/xapi-stdext/stdext.ml @@ -13,6 +13,7 @@ module Opt = Xapi_stdext_monadic.Opt (* Standard library extensions and additions*) module Pervasiveext = Xapi_stdext_pervasives.Pervasiveext module Filenameext = Xapi_stdext_std.Filenameext +module Hashtblext = Xapi_stdext_std.Hashtblext module Listext = Xapi_stdext_std.Listext module Xstringext = Xapi_stdext_std.Xstringext From dcf5efd30812c60398f1c11c021400c6ac3369db Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Thu, 3 Aug 2017 09:12:02 +0100 Subject: [PATCH 068/199] Fix travis Signed-off-by: Marcello Seri --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index dfd9c95cd65..78160571ff1 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,7 +3,7 @@ sudo: false services: - docker install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh -script: bash -ex ./.travis-docker.sh && make gh-pages +script: bash -ex ./.travis-docker.sh env: global: - PINS="xapi-stdext:. xapi-stdext-base64:. xapi-stdext-bigbuffer:. xapi-stdext-date:. xapi-stdext-deprecated:. xapi-stdext-encodings:. xapi-stdext-monadic:. xapi-stdext-pervasives:. xapi-stdext-range:. xapi-stdext-std:. xapi-stdext-threads:. xapi-stdext-unix:. xapi-stdext-zerocheck:." From c19b2f7552d3835b619e684ded7ca279e7990069 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Thu, 3 Aug 2017 09:15:23 +0100 Subject: [PATCH 069/199] Delete .merlin file - now generated by jbuilder Signed-off-by: Marcello Seri --- .merlin | 3 --- 1 file changed, 3 deletions(-) delete mode 100644 .merlin diff --git a/.merlin b/.merlin deleted file mode 100644 index 401bbc9116d..00000000000 --- a/.merlin +++ /dev/null @@ -1,3 +0,0 @@ -PKG threads uuidm unix fd-send-recv bigarray xapi-backtrace -S lib -B _build/lib From f27f14d2ea8932f45b72583cec13e037c415a57d Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Thu, 3 Aug 2017 09:36:58 +0100 Subject: [PATCH 070/199] Make build with 4.05 optional Signed-off-by: Marcello Seri --- .travis.yml | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/.travis.yml b/.travis.yml index 78160571ff1..a9a98bee99d 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,10 +6,14 @@ install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/ma script: bash -ex ./.travis-docker.sh env: global: - - PINS="xapi-stdext:. xapi-stdext-base64:. xapi-stdext-bigbuffer:. xapi-stdext-date:. xapi-stdext-deprecated:. xapi-stdext-encodings:. xapi-stdext-monadic:. xapi-stdext-pervasives:. xapi-stdext-range:. xapi-stdext-std:. xapi-stdext-threads:. xapi-stdext-unix:. xapi-stdext-zerocheck:." + - PINS="xapi-stdext:. xapi-stdext-base64:. xapi-stdext-bigbuffer:. xapi-stdext-date:. xapi-stdext-deprecated:. xapi-stdext-encodings:. xapi-stdext-monadic:. xapi-stdext-pervasives:. xapi-stdext-range:. xapi-stdext-std:. xapi-stdext-threads:. xapi-stdext-unix:. xapi-stdext-zerocheck:." matrix: - - PACKAGE=xapi-stdext DISTRO="debian-unstable" OCAML_VERSION=4.03.0 - - PACKAGE=xapi-stdext DISTRO="debian-unstable" OCAML_VERSION=4.04.2 - - PACKAGE=xapi-stdext DISTRO="debian-unstable" OCAML_VERSION=4.05.0 + - PACKAGE=xapi-stdext DISTRO="debian-unstable" OCAML_VERSION=4.03.0 + - PACKAGE=xapi-stdext DISTRO="debian-unstable" OCAML_VERSION=4.04.2 + - PACKAGE=xapi-stdext DISTRO="debian-unstable" OCAML_VERSION=4.05.0 branches: only: master +matrix: + fast_finish: true + allow_failures: + - env: PACKAGE=xapi-stdext DISTRO="debian-unstable" OCAML_VERSION=4.05.0 From 1d501c6d85988019a96a5f219360a6f8acac2a60 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Tue, 13 Mar 2018 14:11:54 +0000 Subject: [PATCH 071/199] xapi-stdext-unix: remove bigbuffer dependency and port to safe-string Signed-off-by: Marcello Seri --- lib/xapi-stdext-unix/jbuild | 2 +- lib/xapi-stdext-unix/unixext.ml | 90 +++++++++++++------------------- lib/xapi-stdext-unix/unixext.mli | 22 ++++---- xapi-stdext-unix.opam | 1 - 4 files changed, 45 insertions(+), 70 deletions(-) diff --git a/lib/xapi-stdext-unix/jbuild b/lib/xapi-stdext-unix/jbuild index 45c00b919e0..8ef805e0e84 100644 --- a/lib/xapi-stdext-unix/jbuild +++ b/lib/xapi-stdext-unix/jbuild @@ -3,13 +3,13 @@ (library ((name xapi_stdext_unix) (public_name xapi-stdext-unix) + (flags (:standard -safe-string)) (c_names (blkgetsize_stubs unixext_open_stubs unixext_stubs unixext_write_stubs)) (libraries (fd-send-recv unix - xapi-stdext-bigbuffer xapi-stdext-pervasives xapi-stdext-std)) )) diff --git a/lib/xapi-stdext-unix/unixext.ml b/lib/xapi-stdext-unix/unixext.ml index 6b3896d0775..75f548e84cf 100644 --- a/lib/xapi-stdext-unix/unixext.ml +++ b/lib/xapi-stdext-unix/unixext.ml @@ -12,7 +12,6 @@ * GNU Lesser General Public License for more details. *) open Xapi_stdext_pervasives.Pervasiveext -module Bigbuffer = Xapi_stdext_bigbuffer.Bigbuffer exception Unix_error of int @@ -45,7 +44,7 @@ let pidfile_write filename = let pid = Unix.getpid () in let buf = string_of_int pid ^ "\n" in let len = String.length buf in - if Unix.write fd buf 0 len <> len + if Unix.write fd (Bytes.unsafe_of_string buf) 0 len <> len then failwith "pidfile_write failed"; ) (fun () -> Unix.close fd) @@ -56,11 +55,11 @@ let pidfile_read filename = finally (fun () -> try - let buf = String.create 80 in - let rd = Unix.read fd buf 0 (String.length buf) in + let buf = Bytes.create 80 in + let rd = Unix.read fd buf 0 (Bytes.length buf) in if rd = 0 then failwith "pidfile_read failed"; - Scanf.sscanf (String.sub buf 0 rd) "%d" (fun i -> Some i) + Scanf.sscanf (Bytes.sub_string buf 0 rd) "%d" (fun i -> Some i) with _ -> None) (fun () -> Unix.close fd) @@ -139,11 +138,11 @@ let readfile_line = file_lines_iter (** [fd_blocks_fold block_size f start fd] folds [f] over blocks (strings) from the fd [fd] with initial value [start] *) let fd_blocks_fold block_size f start fd = - let block = String.create block_size in - let rec fold acc = + let block = Bytes.create block_size in + let rec fold acc = let n = Unix.read fd block 0 block_size in (* Consider making the interface explicitly use Substrings *) - let s = if n = block_size then block else String.sub block 0 n in + let s = if n = block_size then block else Bytes.sub block 0 n in if n = 0 then acc else fold (f acc s) in fold start @@ -157,17 +156,12 @@ let with_directory dir f = r let buffer_of_fd fd = - fd_blocks_fold 1024 (fun b s -> Buffer.add_string b s; b) (Buffer.create 1024) fd - -let bigbuffer_of_fd fd = - fd_blocks_fold 1024 (fun b s -> Bigbuffer.append_string b s; b) (Bigbuffer.make ()) fd + fd_blocks_fold 1024 (fun b s -> Buffer.add_bytes b s; b) (Buffer.create 1024) fd let string_of_fd fd = Buffer.contents (buffer_of_fd fd) let buffer_of_file file_path = with_file file_path [ Unix.O_RDONLY ] 0 buffer_of_fd -let bigbuffer_of_file file_path = with_file file_path [ Unix.O_RDONLY ] 0 bigbuffer_of_fd - let string_of_file file_path = Buffer.contents (buffer_of_file file_path) (** Opens a temp file, applies the fd to the function, when the function completes, renames the file @@ -188,12 +182,13 @@ let atomic_write_to_file fname perms f = (** Atomically write a string to a file *) -let write_string_to_file fname s = +let write_bytes_to_file fname s = atomic_write_to_file fname 0o644 (fun fd -> - let len = String.length s in + let len = Bytes.length s in let written = Unix.write fd s 0 len in if written <> len then (failwith "Short write occured!")) +let write_string_to_file fname s = write_bytes_to_file fname (Bytes.unsafe_of_string s) let execv_get_output cmd args = let (pipe_exit, pipe_entrance) = Unix.pipe () in @@ -211,8 +206,8 @@ let execv_get_output cmd args = let copy_file_internal ?limit reader writer = let module Opt = Xapi_stdext_monadic.Opt in - let buffer = String.make 65536 '\000' in - let buffer_len = Int64.of_int (String.length buffer) in + let buffer = Bytes.make 65536 '\000' in + let buffer_len = Int64.of_int (Bytes.length buffer) in let finished = ref false in let total_bytes = ref 0L in let limit = ref limit in @@ -280,7 +275,7 @@ let open_connection_unix_fd filename = module CBuf = struct (** A circular buffer constructed from a string *) type t = { - mutable buffer: string; + mutable buffer: bytes; mutable len: int; (** bytes of valid data in [buffer] *) mutable start: int; (** index of first valid byte in [buffer] *) mutable r_closed: bool; (** true if no more data can be read due to EOF *) @@ -288,7 +283,7 @@ module CBuf = struct } let empty length = { - buffer = String.create length; + buffer = Bytes.create length; len = 0; start = 0; r_closed = false; @@ -297,11 +292,11 @@ module CBuf = struct let drop (x: t) n = if n > x.len then failwith (Printf.sprintf "drop %d > %d" n x.len); - x.start <- (x.start + n) mod (String.length x.buffer); + x.start <- (x.start + n) mod (Bytes.length x.buffer); x.len <- x.len - n let should_read (x: t) = - not x.r_closed && (x.len < (String.length x.buffer - 1)) + not x.r_closed && (x.len < (Bytes.length x.buffer - 1)) let should_write (x: t) = not x.w_closed && (x.len > 0) @@ -310,15 +305,15 @@ module CBuf = struct let write (x: t) fd = (* Offset of the character after the substring *) - let next = min (String.length x.buffer) (x.start + x.len) in + let next = min (Bytes.length x.buffer) (x.start + x.len) in let len = next - x.start in let written = try Unix.single_write fd x.buffer x.start len with _ -> x.w_closed <- true; len in drop x written let read (x: t) fd = (* Offset of the next empty character *) - let next = (x.start + x.len) mod (String.length x.buffer) in - let len = min (String.length x.buffer - next) (String.length x.buffer - x.len) in + let next = (x.start + x.len) mod (Bytes.length x.buffer) in + let len = min (Bytes.length x.buffer - next) (Bytes.length x.buffer - x.len) in let read = Unix.read fd x.buffer next len in if read = 0 then x.r_closed <- true; x.len <- x.len + read @@ -430,48 +425,33 @@ let rec really_read fd string off n = really_read fd string (off+m) (n-m) let really_read_string fd length = - let buf = String.make length '\000' in + let buf = Bytes.make length '\000' in really_read fd buf 0 length; - buf + Bytes.unsafe_to_string buf let try_read_string ?limit fd = let buf = Buffer.create 0 in let chunk = match limit with None -> 4096 | Some x -> x in - let cache = String.make chunk '\000' in + let cache = Bytes.make chunk '\000' in let finished = ref false in while not !finished do let to_read = match limit with | Some x -> min (x - (Buffer.length buf)) chunk | None -> chunk in let read_bytes = Unix.read fd cache 0 to_read in - Buffer.add_substring buf cache 0 read_bytes; + Buffer.add_subbytes buf cache 0 read_bytes; if read_bytes = 0 then finished := true done; Buffer.contents buf -let really_read_bigbuffer fd bigbuf n = - let chunk = 4096 in - let s = String.make chunk '\000' in - let written = ref 0L in - while !written < n do - let remaining = Int64.sub n !written in - let to_write = min remaining (Int64.of_int chunk) in - really_read fd s 0 (Int64.to_int to_write); - Bigbuffer.append_substring bigbuf s 0 (Int64.to_int to_write); - written := Int64.add !written to_write; - done - +(* This was equivalent to Unix.write - deprecating *) let really_write fd string off n = - let written = ref 0 in - while !written < n - do - let wr = Unix.write fd string (off + !written) (n - !written) in - written := wr + !written - done + Unix.write fd string off n |> ignore (* Ideally, really_write would be implemented with optional arguments ?(off=0) ?(len=String.length string) *) let really_write_string fd string = - really_write fd string 0 (String.length string) + let payload = Bytes.unsafe_of_string string in + Unix.write fd payload 0 (Bytes.length payload) |> ignore (* --------------------------------------------------------------------------------------- *) (* Functions to read and write to/from a file descriptor with a given latest response time *) @@ -503,7 +483,7 @@ let time_limited_write filedesc length data target_response_time = let time_limited_read filedesc length target_response_time = let total_bytes_to_read = length in let bytes_read = ref 0 in - let buf = String.make total_bytes_to_read '\000' in + let buf = Bytes.make total_bytes_to_read '\000' in let now = ref (Unix.gettimeofday()) in while !bytes_read < total_bytes_to_read && !now < target_response_time do let remaining_time = target_response_time -. !now in @@ -516,14 +496,14 @@ let time_limited_read filedesc length target_response_time = end; now := Unix.gettimeofday() done; - if !bytes_read = total_bytes_to_read then buf else (* we ran out of time *) raise Timeout + if !bytes_read = total_bytes_to_read then (Bytes.unsafe_to_string buf) else (* we ran out of time *) raise Timeout (* --------------------------------------------------------------------------------------- *) (* Read a given number of bytes of data from the fd, or stop at EOF, whichever comes first. *) (* A negative ~max_bytes indicates that all the data should be read from the fd until EOF. This is the default. *) let read_data_in_chunks (f : string -> int -> unit) ?(block_size = 1024) ?(max_bytes = -1) from_fd = - let buf = String.make block_size '\000' in + let buf = Bytes.make block_size '\000' in let rec do_read acc = let remaining_bytes = max_bytes - acc in if remaining_bytes = 0 then acc (* we've read the amount requested *) @@ -532,7 +512,7 @@ let read_data_in_chunks (f : string -> int -> unit) ?(block_size = 1024) ?(max_b let bytes_read = Unix.read from_fd buf 0 bytes_to_read in if bytes_read = 0 then acc (* we reached EOF *) else begin - f (String.sub buf 0 bytes_read) bytes_read; + f (Bytes.sub_string buf 0 bytes_read) bytes_read; do_read (acc + bytes_read) end end in @@ -695,11 +675,11 @@ module Direct = struct let t = openfile path flags perms in finally (fun () -> f t) (fun () -> close t) - external unsafe_write : t -> string -> int -> int -> int = "stub_stdext_unix_write" + external unsafe_write : t -> bytes -> int -> int -> int = "stub_stdext_unix_write" let write fd buf ofs len = - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.write" + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len + then invalid_arg "Unixext.write" else unsafe_write fd buf ofs len let copy_from_fd ?limit socket fd = copy_file_internal ?limit (Unix.read socket) (write fd) diff --git a/lib/xapi-stdext-unix/unixext.mli b/lib/xapi-stdext-unix/unixext.mli index a070837c4e9..3464a720784 100644 --- a/lib/xapi-stdext-unix/unixext.mli +++ b/lib/xapi-stdext-unix/unixext.mli @@ -45,7 +45,7 @@ val file_lines_iter : (string -> unit) -> string -> unit (** [fd_blocks_fold block_size f start fd] folds [f] over blocks (strings) from the fd [fd] with initial value [start] *) -val fd_blocks_fold: int -> ('a -> string -> 'a) -> 'a -> Unix.file_descr -> 'a +val fd_blocks_fold: int -> ('a -> bytes -> 'a) -> 'a -> Unix.file_descr -> 'a (** Alias for function [file_lines_iter]. *) val readfile_line : (string -> 'a) -> string -> unit @@ -53,24 +53,18 @@ val readfile_line : (string -> 'a) -> string -> unit (** [buffer_of_fd fd] returns a Buffer.t containing all data read from [fd] up to EOF *) val buffer_of_fd : Unix.file_descr -> Buffer.t -(** [bigbuffer_of_fd fd] returns a Bigbuffer.t containing all data read from [fd] up - to EOF *) -val bigbuffer_of_fd : Unix.file_descr -> Xapi_stdext_bigbuffer.Bigbuffer.t - (** [string_of_fd fd] returns a string containing all data read from [fd] up to EOF *) val string_of_fd : Unix.file_descr -> string (** [buffer_of_file file] returns a Buffer.t containing the contents of [file] *) val buffer_of_file : string -> Buffer.t -(** [bigbuffer_of_file file] returns a Bigbuffer.t containing the contents of [file] *) -val bigbuffer_of_file : string -> Xapi_stdext_bigbuffer.Bigbuffer.t - (** [string_of_file file] returns a string containing the contents of [file] *) val string_of_file : string -> string val atomic_write_to_file : string -> Unix.file_perm -> (Unix.file_descr -> 'a) -> 'a val write_string_to_file : string -> string -> unit +val write_bytes_to_file : string -> bytes -> unit val execv_get_output : string -> string array -> int * Unix.file_descr val copy_file : ?limit:int64 -> Unix.file_descr -> Unix.file_descr -> int64 @@ -102,14 +96,16 @@ val kill_and_wait : ?signal:int -> ?timeout:float -> int -> unit val string_of_signal : int -> string val proxy : Unix.file_descr -> Unix.file_descr -> unit -val really_read : Unix.file_descr -> string -> int -> int -> unit +val really_read : Unix.file_descr -> bytes -> int -> int -> unit val really_read_string : Unix.file_descr -> int -> string -val really_read_bigbuffer : Unix.file_descr -> Xapi_stdext_bigbuffer.Bigbuffer.t -> int64 -> unit -val really_write : Unix.file_descr -> string -> int -> int -> unit +(** [really_write] keeps repeating the write operation until all bytes + * have been written or an error occurs. This is the same behaviour of + * [Unix.write] that should be preferred instead. *) +val really_write : Unix.file_descr -> bytes -> int -> int -> unit [@@ocaml.deprecated] val really_write_string : Unix.file_descr -> string -> unit val try_read_string : ?limit: int -> Unix.file_descr -> string exception Timeout -val time_limited_write : Unix.file_descr -> int -> string -> float -> unit +val time_limited_write : Unix.file_descr -> int -> bytes -> float -> unit val time_limited_read : Unix.file_descr -> int -> float -> string val read_data_in_chunks : (string -> int -> unit) -> ?block_size:int -> ?max_bytes:int -> Unix.file_descr -> int val spawnvp : @@ -185,7 +181,7 @@ module Direct : sig val with_openfile : string -> Unix.open_flag list -> Unix.file_perm -> (t -> 'a) -> 'a (** [with_openfile name flags perm f] opens [name], applies the result to [f] and closes *) - val write : t -> string -> int -> int -> int + val write : t -> bytes -> int -> int -> int (** [write t buf ofs len] writes [len] bytes at offset [ofs] from buffer [buf] to [t] using page-aligned buffers. *) diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam index e109ed51804..4d30f1728e2 100644 --- a/xapi-stdext-unix.opam +++ b/xapi-stdext-unix.opam @@ -12,7 +12,6 @@ depends: [ "jbuilder" {build} "base-unix" "fd-send-recv" - "xapi-stdext-bigbuffer" "xapi-stdext-pervasives" "xapi-stdext-std" ] From 44d5191715fbbf653ad34b412afba685f08c7116 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Tue, 13 Mar 2018 14:12:54 +0000 Subject: [PATCH 072/199] xapi-stdext: remove bigbuffer and zerocheck Signed-off-by: Marcello Seri --- lib/xapi-stdext/jbuild | 1 - lib/xapi-stdext/stdext.ml | 1 - xapi-stdext.opam | 1 - 3 files changed, 3 deletions(-) diff --git a/lib/xapi-stdext/jbuild b/lib/xapi-stdext/jbuild index fbc6fa70be0..5c891338678 100644 --- a/lib/xapi-stdext/jbuild +++ b/lib/xapi-stdext/jbuild @@ -6,7 +6,6 @@ (modules (stdext)) (wrapped false) (libraries (xapi-stdext-base64 - xapi-stdext-bigbuffer xapi-stdext-date xapi-stdext-deprecated xapi-stdext-encodings diff --git a/lib/xapi-stdext/stdext.ml b/lib/xapi-stdext/stdext.ml index 2db4c473af1..acb3f84cfda 100644 --- a/lib/xapi-stdext/stdext.ml +++ b/lib/xapi-stdext/stdext.ml @@ -1,6 +1,5 @@ (* New modules *) module Base64 = Xapi_stdext_base64.Base64 -module Bigbuffer = Xapi_stdext_bigbuffer.Bigbuffer module Date = Xapi_stdext_date.Date module Encodings = Xapi_stdext_encodings.Encodings module Range = Xapi_stdext_range.Range diff --git a/xapi-stdext.opam b/xapi-stdext.opam index 46b23d9efb8..0c40570b63a 100644 --- a/xapi-stdext.opam +++ b/xapi-stdext.opam @@ -11,7 +11,6 @@ build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] depends: [ "jbuilder" {build} "xapi-stdext-base64" - "xapi-stdext-bigbuffer" "xapi-stdext-date" "xapi-stdext-deprecated" "xapi-stdext-encodings" From fbb7f191a07b51580b1b60542e48fcefc743313d Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Tue, 13 Mar 2018 14:13:19 +0000 Subject: [PATCH 073/199] xapi-stdext-base64: safe-string on Signed-off-by: Marcello Seri --- lib/xapi-stdext-base64/jbuild | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/xapi-stdext-base64/jbuild b/lib/xapi-stdext-base64/jbuild index cbdee36ee69..cb057cadd46 100644 --- a/lib/xapi-stdext-base64/jbuild +++ b/lib/xapi-stdext-base64/jbuild @@ -3,5 +3,6 @@ (library ((name xapi_stdext_base64) (public_name xapi-stdext-base64) + (flags (:standard -safe-string)) (libraries (base64)) )) From 5f4c3efbbb501b6fbdb17ec97bc0261cc0349656 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Tue, 13 Mar 2018 14:13:38 +0000 Subject: [PATCH 074/199] xapi-stdext-bigbuffer: deprecate + safe-string on Signed-off-by: Marcello Seri --- lib/xapi-stdext-bigbuffer/bigbuffer.ml | 16 ++++++++-------- lib/xapi-stdext-bigbuffer/bigbuffer.mli | 16 ++++++++-------- lib/xapi-stdext-bigbuffer/jbuild | 1 + 3 files changed, 17 insertions(+), 16 deletions(-) diff --git a/lib/xapi-stdext-bigbuffer/bigbuffer.ml b/lib/xapi-stdext-bigbuffer/bigbuffer.ml index 2f7517bd54f..512128b2b12 100644 --- a/lib/xapi-stdext-bigbuffer/bigbuffer.ml +++ b/lib/xapi-stdext-bigbuffer/bigbuffer.ml @@ -13,7 +13,7 @@ *) type t = { - mutable cells: string option array; + mutable cells: bytes option array; mutable index: int64; } @@ -29,7 +29,7 @@ let get bigbuf n = let cell_offset = Int64.to_int (Int64.rem n (Int64.of_int cell_size)) in match bigbuf.cells.(array_offset) with | None -> "".[0] - | Some buf -> buf.[cell_offset] + | Some buf -> Bytes.get buf cell_offset let rec append_substring bigbuf s offset len = let array_offset = Int64.to_int (Int64.div bigbuf.index (Int64.of_int cell_size)) in @@ -42,7 +42,7 @@ let rec append_substring bigbuf s offset len = let buf = match bigbuf.cells.(array_offset) with | None -> - let newbuf = String.create cell_size in + let newbuf = Bytes.create cell_size in bigbuf.cells.(array_offset) <- Some newbuf; newbuf | Some buf -> @@ -70,14 +70,14 @@ let to_fct bigbuf f = do match bigbuf.cells.(i) with | None -> (* should never happen *) () - | Some cell -> f cell + | Some cell -> f (Bytes.to_string cell) done; if(cell_offset > 0) then (* copy last cell *) begin match bigbuf.cells.(array_offset) with | None -> (* Should never happen (any more) *) () - | Some cell -> f (String.sub cell 0 cell_offset) + | Some cell -> f (Bytes.sub_string cell 0 cell_offset) end @@ -85,14 +85,14 @@ let to_string bigbuf = if bigbuf.index > (Int64.of_int Sys.max_string_length) then failwith "cannot allocate string big enough"; - let dest = String.create (Int64.to_int bigbuf.index) in + let dest = Bytes.create (Int64.to_int bigbuf.index) in let destoff = ref 0 in to_fct bigbuf (fun s -> let len = String.length s in - String.blit s 0 dest !destoff len; + Bytes.blit_string s 0 dest !destoff len; destoff := !destoff + len ); - dest + Bytes.unsafe_to_string dest let to_stream bigbuf outchan = to_fct bigbuf (fun s -> output_string outchan s) diff --git a/lib/xapi-stdext-bigbuffer/bigbuffer.mli b/lib/xapi-stdext-bigbuffer/bigbuffer.mli index b56764e0c58..dcb0f183018 100644 --- a/lib/xapi-stdext-bigbuffer/bigbuffer.mli +++ b/lib/xapi-stdext-bigbuffer/bigbuffer.mli @@ -12,14 +12,14 @@ * GNU Lesser General Public License for more details. *) type t -val make : unit -> t -val length : t -> int64 -val get : t -> int64 -> char -val append_substring : t -> string -> int -> int -> unit +val make : unit -> t [@@ocaml.deprecated] +val length : t -> int64 [@@ocaml.deprecated] +val get : t -> int64 -> char [@@ocaml.deprecated] +val append_substring : t -> string -> int -> int -> unit [@@ocaml.deprecated] (** [append_string b s] appends the string [x] to the big buffer [b] *) -val append_string : t -> string -> unit +val append_string : t -> string -> unit [@@ocaml.deprecated] -val to_fct : t -> (string -> unit) -> unit -val to_string : t -> string -val to_stream : t -> out_channel -> unit +val to_fct : t -> (string -> unit) -> unit [@@ocaml.deprecated] +val to_string : t -> string [@@ocaml.deprecated] +val to_stream : t -> out_channel -> unit [@@ocaml.deprecated] diff --git a/lib/xapi-stdext-bigbuffer/jbuild b/lib/xapi-stdext-bigbuffer/jbuild index ab0bb66be93..06c4ff4b547 100644 --- a/lib/xapi-stdext-bigbuffer/jbuild +++ b/lib/xapi-stdext-bigbuffer/jbuild @@ -3,4 +3,5 @@ (library ((name xapi_stdext_bigbuffer) (public_name xapi-stdext-bigbuffer) + (flags (:standard -safe-string)) )) From ef5a9856350866581ab8d8d26daef49483612291 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Tue, 13 Mar 2018 14:14:03 +0000 Subject: [PATCH 075/199] xapi-stdext-date: safe-string on Signed-off-by: Marcello Seri --- lib/xapi-stdext-date/jbuild | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/xapi-stdext-date/jbuild b/lib/xapi-stdext-date/jbuild index 24c3784c76f..0d624d418b7 100644 --- a/lib/xapi-stdext-date/jbuild +++ b/lib/xapi-stdext-date/jbuild @@ -3,5 +3,6 @@ (library ((name xapi_stdext_date) (public_name xapi-stdext-date) + (flags (:standard -safe-string)) (libraries (unix)) )) From 3e23339d36c19d75164eea86e1af5db3ec2d67e7 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Tue, 13 Mar 2018 14:14:21 +0000 Subject: [PATCH 076/199] xapi-stdext-encodings: safe-string on Signed-off-by: Marcello Seri --- lib/xapi-stdext-encodings/encodings.ml | 8 ++++---- lib/xapi-stdext-encodings/jbuild | 1 + 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/lib/xapi-stdext-encodings/encodings.ml b/lib/xapi-stdext-encodings/encodings.ml index 5086ff5881b..fe4c6526c5f 100644 --- a/lib/xapi-stdext-encodings/encodings.ml +++ b/lib/xapi-stdext-encodings/encodings.ml @@ -144,18 +144,18 @@ module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) = struct let encode_character value = UCS_validator.validate value; let width = width_required_for_ucs_value value in - let string = String.make width ' ' in + let b = Bytes.make width ' ' in (* Start by encoding the continuation bytes in reverse order. *) let rec encode_continuation_bytes remainder index = if index = 0 then remainder else let byte, remainder = encode_continuation_byte remainder in - string.[index] <- Char.chr (Int32.to_int byte); + Bytes.set b index @@ Char.chr (Int32.to_int byte); encode_continuation_bytes remainder (index - 1) in let remainder = encode_continuation_bytes value (width - 1) in (* Finish by encoding the header byte. *) let byte = encode_header_byte width remainder in - string.[0] <- Char.chr (Int32.to_int byte); - string + Bytes.set b 0 @@ Char.chr (Int32.to_int byte); + Bytes.unsafe_to_string b end diff --git a/lib/xapi-stdext-encodings/jbuild b/lib/xapi-stdext-encodings/jbuild index db744723858..8ef934d2446 100644 --- a/lib/xapi-stdext-encodings/jbuild +++ b/lib/xapi-stdext-encodings/jbuild @@ -3,4 +3,5 @@ (library ((name xapi_stdext_encodings) (public_name xapi-stdext-encodings) + (flags (:standard -safe-string)) )) From 6ebe37330249f7b4c6664db9f39cd8b1dbcde3a1 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Tue, 13 Mar 2018 14:14:36 +0000 Subject: [PATCH 077/199] xapi-stdext-monadic: safe-string on Signed-off-by: Marcello Seri --- lib/xapi-stdext-monadic/jbuild | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/xapi-stdext-monadic/jbuild b/lib/xapi-stdext-monadic/jbuild index 987d00edd39..ff88600cd98 100644 --- a/lib/xapi-stdext-monadic/jbuild +++ b/lib/xapi-stdext-monadic/jbuild @@ -3,4 +3,5 @@ (library ((public_name xapi-stdext-monadic) (name xapi_stdext_monadic) + (flags (:standard -safe-string)) )) From c96b362b455c99fe080f6e7b83cd9f598061c5aa Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Tue, 13 Mar 2018 14:14:55 +0000 Subject: [PATCH 078/199] xapi-stdext-threads: safe-string on Signed-off-by: Marcello Seri --- lib/xapi-stdext-threads/jbuild | 1 + lib/xapi-stdext-threads/threadext.ml | 18 +++++++++--------- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/lib/xapi-stdext-threads/jbuild b/lib/xapi-stdext-threads/jbuild index 643d4cf8d86..582c54e4036 100644 --- a/lib/xapi-stdext-threads/jbuild +++ b/lib/xapi-stdext-threads/jbuild @@ -3,6 +3,7 @@ (library ((public_name xapi-stdext-threads) (name xapi_stdext_threads) + (flags (:standard -safe-string)) (libraries (threads unix xapi-stdext-pervasives)) diff --git a/lib/xapi-stdext-threads/threadext.ml b/lib/xapi-stdext-threads/threadext.ml index 79468d62ed6..8af91066ca2 100644 --- a/lib/xapi-stdext-threads/threadext.ml +++ b/lib/xapi-stdext-threads/threadext.ml @@ -45,7 +45,7 @@ module Alarm = struct | None -> assert false | Some (pipe_in, pipe_out) -> while Thread.wait_timed_read pipe_in 0. do - ignore (Unix.read pipe_in " " 0 1) + ignore (Unix.read pipe_in (Bytes.create 1) 0 1) done; let next = Mutex.execute alarm.token (fun () -> @@ -78,7 +78,7 @@ module Alarm = struct alarm.queue <- List.sort (fun x1 x2 -> compare (fst x1) (fst x2)) nqueue; match alarm.notifier with | Some (_, pipe_out) -> - ignore (Unix.write pipe_out "X" 0 1) + ignore (Unix.write pipe_out (Bytes.of_string "X") 0 1) | None -> let pipe_in, pipe_out = Unix.pipe () in alarm.notifier <- Some (pipe_in, pipe_out); @@ -124,7 +124,7 @@ module Thread = struct (* Might have run by other scheduling policy *) if PQueue.mem t !pqueue then (pqueue := PQueue.remove t !pqueue; decr pending); - if not (Lazy.lazy_is_val pt) then + if not (Lazy.is_val pt) then let _ = Lazy.force pt in incr running @@ -231,10 +231,10 @@ module Thread = struct let join = function | Running t -> Thread.join t | Pending ((_, _, pt) as t) -> - if not (Lazy.lazy_is_val pt) then begin + if not (Lazy.is_val pt) then begin (* Give priority to those to be joined *) Mutex.execute scheduler_token (fun () -> run_thread t); - assert (Lazy.lazy_is_val pt); + assert (Lazy.is_val pt); end; Thread.join (Lazy.force pt) @@ -243,13 +243,13 @@ module Thread = struct (* Not implemented in stdlib *) Thread.kill t | Pending ((_, _, pt) as t) -> - if Lazy.lazy_is_val pt then + if Lazy.is_val pt then Thread.kill (Lazy.force pt) else Mutex.execute scheduler_token (fun () -> (* Just in case something happens before we grab the lock *) - if Lazy.lazy_is_val pt then Thread.kill (Lazy.force pt) + if Lazy.is_val pt then Thread.kill (Lazy.force pt) else (pqueue := PQueue.remove t !pqueue; decr pending)) let delay = Thread.delay @@ -386,7 +386,7 @@ module Delay = struct pipe_out) in let r, _, _ = Unix.select [ pipe_out ] [] [] seconds in (* flush the single byte from the pipe *) - if r <> [] then ignore(Unix.read pipe_out (String.create 1) 0 1); + if r <> [] then ignore(Unix.read pipe_out (Bytes.create 1) 0 1); (* return true if we waited the full length of time, false if we were woken *) r = [] with Pre_signalled -> false @@ -403,7 +403,7 @@ module Delay = struct Mutex.execute x.m (fun () -> match x.pipe_in with - | Some fd -> ignore(Unix.write fd "X" 0 1) + | Some fd -> ignore(Unix.write fd (Bytes.of_string "X") 0 1) | None -> x.signalled <- true (* If the wait hasn't happened yet then store up the signal *) ) end From a82667edb84a51f5b153aa9782f2375a185439f8 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Tue, 13 Mar 2018 14:15:03 +0000 Subject: [PATCH 079/199] xapi-stdext-std: safe-string on Signed-off-by: Marcello Seri --- lib/xapi-stdext-std/jbuild | 1 + lib/xapi-stdext-std/xstringext.ml | 16 ++++++++-------- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/lib/xapi-stdext-std/jbuild b/lib/xapi-stdext-std/jbuild index 52ec1d3d6aa..e9f0421f57a 100644 --- a/lib/xapi-stdext-std/jbuild +++ b/lib/xapi-stdext-std/jbuild @@ -3,6 +3,7 @@ (library ((public_name xapi-stdext-std) (name xapi_stdext_std) + (flags (:standard -safe-string)) (libraries (uuidm xapi-stdext-monadic)) )) diff --git a/lib/xapi-stdext-std/xstringext.ml b/lib/xapi-stdext-std/xstringext.ml index dbd3d460e7f..00b5cb7bad6 100644 --- a/lib/xapi-stdext-std/xstringext.ml +++ b/lib/xapi-stdext-std/xstringext.ml @@ -16,11 +16,11 @@ module String = struct include String let of_char c = String.make 1 c let init n f = - let string = make n (f 0) in + let b = Bytes.make n (f 0) in for i=1 to n-1 do - string.[i] <- f i; + Bytes.set b i (f i); done; - string + Bytes.unsafe_to_string b let map f string = init (length string) (fun i -> f string.[i]) @@ -170,17 +170,17 @@ module String = struct include String if n > 0 then ( let len_f = String.length f and len_t = String.length t in let new_len = String.length s + (n * len_t) - (n * len_f) in - let new_s = String.make new_len '\000' in + let new_s = Bytes.make new_len '\000' in let orig_offset = ref 0 and dest_offset = ref 0 in List.iter (fun h -> let len = h - !orig_offset in - String.blit s !orig_offset new_s !dest_offset len; - String.blit t 0 new_s (!dest_offset + len) len_t; + Bytes.blit_string s !orig_offset new_s !dest_offset len; + Bytes.blit_string t 0 new_s (!dest_offset + len) len_t; orig_offset := !orig_offset + len + len_f; dest_offset := !dest_offset + len + len_t; ) indexes; - String.blit s !orig_offset new_s !dest_offset (String.length s - !orig_offset); - new_s + Bytes.blit_string s !orig_offset new_s !dest_offset (String.length s - !orig_offset); + Bytes.unsafe_to_string new_s ) else s From 03a66041eac05f18232e86806118c54ce5f78b4f Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Tue, 13 Mar 2018 14:15:14 +0000 Subject: [PATCH 080/199] xapi-stdext-deprecated: safe-string on Signed-off-by: Marcello Seri --- lib/xapi-stdext-deprecated/jbuild | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/xapi-stdext-deprecated/jbuild b/lib/xapi-stdext-deprecated/jbuild index a4ef03d6d6c..17e3fc8b3e9 100644 --- a/lib/xapi-stdext-deprecated/jbuild +++ b/lib/xapi-stdext-deprecated/jbuild @@ -3,4 +3,5 @@ (library ((name xapi_stdext_deprecated) (public_name xapi-stdext-deprecated) + (flags (:standard -safe-string)) )) From fa6b1be418c7ed20a96a5c7f4354182a64aa5684 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Tue, 13 Mar 2018 14:15:25 +0000 Subject: [PATCH 081/199] xapi-stdext-pervasives: safe-string on Signed-off-by: Marcello Seri --- lib/xapi-stdext-pervasives/jbuild | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/xapi-stdext-pervasives/jbuild b/lib/xapi-stdext-pervasives/jbuild index 548f2c516bf..f840ecc2ca0 100644 --- a/lib/xapi-stdext-pervasives/jbuild +++ b/lib/xapi-stdext-pervasives/jbuild @@ -4,4 +4,5 @@ ((name xapi_stdext_pervasives) (public_name xapi-stdext-pervasives) (libraries (xapi-backtrace)) + (flags (:standard -safe-string)) )) From 746726798f5dbe9109c751e4ef3d51c010ac1b9f Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Tue, 13 Mar 2018 14:15:43 +0000 Subject: [PATCH 082/199] xapi-stdext-range: safe-string on Signed-off-by: Marcello Seri --- lib/xapi-stdext-range/jbuild | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/xapi-stdext-range/jbuild b/lib/xapi-stdext-range/jbuild index 2dda5f268da..d6941b744b9 100644 --- a/lib/xapi-stdext-range/jbuild +++ b/lib/xapi-stdext-range/jbuild @@ -3,4 +3,5 @@ (library ((name xapi_stdext_range) (public_name xapi-stdext-range) + (flags (:standard -safe-string)) )) From 4cc9b00f58e7fa7dd06ed40d0e467a8dc7c911e4 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Tue, 13 Mar 2018 14:15:53 +0000 Subject: [PATCH 083/199] xapi-stdext-zerocheck: safe-string on Signed-off-by: Marcello Seri --- lib/xapi-stdext-zerocheck/jbuild | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/xapi-stdext-zerocheck/jbuild b/lib/xapi-stdext-zerocheck/jbuild index 51074336f76..90bc5be432b 100644 --- a/lib/xapi-stdext-zerocheck/jbuild +++ b/lib/xapi-stdext-zerocheck/jbuild @@ -2,6 +2,7 @@ (library ((public_name xapi-stdext-zerocheck) + (flags (:standard -safe-string)) (name xapi_stdext_zerocheck) (c_names (zerocheck_stub)) )) From d38450c3ceb10b73b8aa9fdb6dc1bf03c3777cd6 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Tue, 13 Mar 2018 14:18:10 +0000 Subject: [PATCH 084/199] Travis: add revdeps for xs-opam Also enable revdeps and disable tests (as there is none to run anyways) Signed-off-by: Marcello Seri --- .travis.yml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index a9a98bee99d..9c7156b4cfd 100644 --- a/.travis.yml +++ b/.travis.yml @@ -7,10 +7,13 @@ script: bash -ex ./.travis-docker.sh env: global: - PINS="xapi-stdext:. xapi-stdext-base64:. xapi-stdext-bigbuffer:. xapi-stdext-date:. xapi-stdext-deprecated:. xapi-stdext-encodings:. xapi-stdext-monadic:. xapi-stdext-pervasives:. xapi-stdext-range:. xapi-stdext-std:. xapi-stdext-threads:. xapi-stdext-unix:. xapi-stdext-zerocheck:." + - DISTRO="centos-7" + - TESTS=false + - OPAMBUILDTEST=false matrix: - - PACKAGE=xapi-stdext DISTRO="debian-unstable" OCAML_VERSION=4.03.0 - - PACKAGE=xapi-stdext DISTRO="debian-unstable" OCAML_VERSION=4.04.2 - - PACKAGE=xapi-stdext DISTRO="debian-unstable" OCAML_VERSION=4.05.0 + - PACKAGE=xapi-stdext OCAML_VERSION=4.03.0 + - PACKAGE=xapi-stdext BASE_REMOTE="https://github.com/xapi-project/xs-opam" OCAML_VERSION=4.04.2 REVDEPS=true + - PACKAGE=xapi-stdext OCAML_VERSION=4.05.0 branches: only: master matrix: From a2ba7d40d5d87d1c5e15aea0e5cb5a78eccab170 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Tue, 13 Mar 2018 15:19:33 +0000 Subject: [PATCH 085/199] xapi-stdext/stdext: add backward compatibility fix, this was part of a xs-opam patch Signed-off-by: Marcello Seri --- .travis.yml | 3 ++- lib/xapi-stdext/jbuild | 2 +- stdext.opam | 24 ++++++++++++++++++++++++ xapi-stdext.opam | 17 +---------------- 4 files changed, 28 insertions(+), 18 deletions(-) create mode 100644 stdext.opam diff --git a/.travis.yml b/.travis.yml index 9c7156b4cfd..8512013e363 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,13 +6,14 @@ install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/ma script: bash -ex ./.travis-docker.sh env: global: - - PINS="xapi-stdext:. xapi-stdext-base64:. xapi-stdext-bigbuffer:. xapi-stdext-date:. xapi-stdext-deprecated:. xapi-stdext-encodings:. xapi-stdext-monadic:. xapi-stdext-pervasives:. xapi-stdext-range:. xapi-stdext-std:. xapi-stdext-threads:. xapi-stdext-unix:. xapi-stdext-zerocheck:." + - PINS="stdext:. xapi-stdext:. xapi-stdext-base64:. xapi-stdext-bigbuffer:. xapi-stdext-date:. xapi-stdext-deprecated:. xapi-stdext-encodings:. xapi-stdext-monadic:. xapi-stdext-pervasives:. xapi-stdext-range:. xapi-stdext-std:. xapi-stdext-threads:. xapi-stdext-unix:. xapi-stdext-zerocheck:." - DISTRO="centos-7" - TESTS=false - OPAMBUILDTEST=false matrix: - PACKAGE=xapi-stdext OCAML_VERSION=4.03.0 - PACKAGE=xapi-stdext BASE_REMOTE="https://github.com/xapi-project/xs-opam" OCAML_VERSION=4.04.2 REVDEPS=true + - PACKAGE=stdext BASE_REMOTE="https://github.com/xapi-project/xs-opam" OCAML_VERSION=4.04.2 REVDEPS=true - PACKAGE=xapi-stdext OCAML_VERSION=4.05.0 branches: only: master diff --git a/lib/xapi-stdext/jbuild b/lib/xapi-stdext/jbuild index 5c891338678..3d8cdad6f43 100644 --- a/lib/xapi-stdext/jbuild +++ b/lib/xapi-stdext/jbuild @@ -1,7 +1,7 @@ (jbuild_version 1) (library - ((public_name xapi-stdext) + ((public_name stdext) (name stdext) (modules (stdext)) (wrapped false) diff --git a/stdext.opam b/stdext.opam new file mode 100644 index 00000000000..0c40570b63a --- /dev/null +++ b/stdext.opam @@ -0,0 +1,24 @@ +opam-version: "1.2" +maintainer: "jonathan.ludlam@citrix.com" +authors: "xen-api@list.xen.org" +bug-reports: "https://github.com/xapi-project/stdext/issues" +dev-repo: "git://github.com/xapi-project/stdext.git" +homepage: "https://xapi-project.github.io/" +tags: [ "org:xapi-project" ] + +build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] + +depends: [ + "jbuilder" {build} + "xapi-stdext-base64" + "xapi-stdext-date" + "xapi-stdext-deprecated" + "xapi-stdext-encodings" + "xapi-stdext-monadic" + "xapi-stdext-pervasives" + "xapi-stdext-range" + "xapi-stdext-std" + "xapi-stdext-threads" + "xapi-stdext-unix" + "xapi-stdext-zerocheck" +] diff --git a/xapi-stdext.opam b/xapi-stdext.opam index 0c40570b63a..aa485e1e34b 100644 --- a/xapi-stdext.opam +++ b/xapi-stdext.opam @@ -6,19 +6,4 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] - -depends: [ - "jbuilder" {build} - "xapi-stdext-base64" - "xapi-stdext-date" - "xapi-stdext-deprecated" - "xapi-stdext-encodings" - "xapi-stdext-monadic" - "xapi-stdext-pervasives" - "xapi-stdext-range" - "xapi-stdext-std" - "xapi-stdext-threads" - "xapi-stdext-unix" - "xapi-stdext-zerocheck" -] +depends: [ "stdext" ] From 32de9294a0a87246c39d172e1350def4702a5875 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Tue, 13 Mar 2018 16:24:22 +0000 Subject: [PATCH 086/199] xapi-stdext-unix: improve code as per review Signed-off-by: Marcello Seri --- lib/xapi-stdext-unix/unixext.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/lib/xapi-stdext-unix/unixext.ml b/lib/xapi-stdext-unix/unixext.ml index 75f548e84cf..eeb526d992d 100644 --- a/lib/xapi-stdext-unix/unixext.ml +++ b/lib/xapi-stdext-unix/unixext.ml @@ -142,8 +142,8 @@ let fd_blocks_fold block_size f start fd = let rec fold acc = let n = Unix.read fd block 0 block_size in (* Consider making the interface explicitly use Substrings *) - let s = if n = block_size then block else Bytes.sub block 0 n in - if n = 0 then acc else fold (f acc s) in + let b = if n = block_size then block else Bytes.sub block 0 n in + if n = 0 then acc else fold (f acc b) in fold start let with_directory dir f = @@ -182,10 +182,10 @@ let atomic_write_to_file fname perms f = (** Atomically write a string to a file *) -let write_bytes_to_file fname s = +let write_bytes_to_file fname b = atomic_write_to_file fname 0o644 (fun fd -> - let len = Bytes.length s in - let written = Unix.write fd s 0 len in + let len = Bytes.length b in + let written = Unix.write fd b 0 len in if written <> len then (failwith "Short write occured!")) let write_string_to_file fname s = write_bytes_to_file fname (Bytes.unsafe_of_string s) From 2e2da9471c1b1ef5c23359b0abe988ef60b2eb2b Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Tue, 13 Mar 2018 16:24:28 +0000 Subject: [PATCH 087/199] xapi-stdext-std: improve code as per review Signed-off-by: Marcello Seri --- lib/xapi-stdext-std/xstringext.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/lib/xapi-stdext-std/xstringext.ml b/lib/xapi-stdext-std/xstringext.ml index 00b5cb7bad6..e1f34297810 100644 --- a/lib/xapi-stdext-std/xstringext.ml +++ b/lib/xapi-stdext-std/xstringext.ml @@ -170,17 +170,17 @@ module String = struct include String if n > 0 then ( let len_f = String.length f and len_t = String.length t in let new_len = String.length s + (n * len_t) - (n * len_f) in - let new_s = Bytes.make new_len '\000' in + let new_b = Bytes.make new_len '\000' in let orig_offset = ref 0 and dest_offset = ref 0 in List.iter (fun h -> let len = h - !orig_offset in - Bytes.blit_string s !orig_offset new_s !dest_offset len; - Bytes.blit_string t 0 new_s (!dest_offset + len) len_t; + Bytes.blit_string s !orig_offset new_b !dest_offset len; + Bytes.blit_string t 0 new_b (!dest_offset + len) len_t; orig_offset := !orig_offset + len + len_f; dest_offset := !dest_offset + len + len_t; ) indexes; - Bytes.blit_string s !orig_offset new_s !dest_offset (String.length s - !orig_offset); - Bytes.unsafe_to_string new_s + Bytes.blit_string s !orig_offset new_b !dest_offset (String.length s - !orig_offset); + Bytes.unsafe_to_string new_b ) else s From 537e62fa12698a5589af59580df902a38a45fafb Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Wed, 14 Mar 2018 11:08:32 +0000 Subject: [PATCH 088/199] remove -safe-string flag to esure compatibility with unported packages Signed-off-by: Marcello Seri --- lib/xapi-stdext-base64/jbuild | 1 - lib/xapi-stdext-bigbuffer/jbuild | 1 - lib/xapi-stdext-date/jbuild | 1 - lib/xapi-stdext-deprecated/jbuild | 1 - lib/xapi-stdext-encodings/jbuild | 1 - lib/xapi-stdext-monadic/jbuild | 1 - lib/xapi-stdext-pervasives/jbuild | 1 - lib/xapi-stdext-range/jbuild | 1 - lib/xapi-stdext-std/jbuild | 1 - lib/xapi-stdext-threads/jbuild | 1 - lib/xapi-stdext-unix/jbuild | 1 - lib/xapi-stdext-zerocheck/jbuild | 1 - 12 files changed, 12 deletions(-) diff --git a/lib/xapi-stdext-base64/jbuild b/lib/xapi-stdext-base64/jbuild index cb057cadd46..cbdee36ee69 100644 --- a/lib/xapi-stdext-base64/jbuild +++ b/lib/xapi-stdext-base64/jbuild @@ -3,6 +3,5 @@ (library ((name xapi_stdext_base64) (public_name xapi-stdext-base64) - (flags (:standard -safe-string)) (libraries (base64)) )) diff --git a/lib/xapi-stdext-bigbuffer/jbuild b/lib/xapi-stdext-bigbuffer/jbuild index 06c4ff4b547..ab0bb66be93 100644 --- a/lib/xapi-stdext-bigbuffer/jbuild +++ b/lib/xapi-stdext-bigbuffer/jbuild @@ -3,5 +3,4 @@ (library ((name xapi_stdext_bigbuffer) (public_name xapi-stdext-bigbuffer) - (flags (:standard -safe-string)) )) diff --git a/lib/xapi-stdext-date/jbuild b/lib/xapi-stdext-date/jbuild index 0d624d418b7..24c3784c76f 100644 --- a/lib/xapi-stdext-date/jbuild +++ b/lib/xapi-stdext-date/jbuild @@ -3,6 +3,5 @@ (library ((name xapi_stdext_date) (public_name xapi-stdext-date) - (flags (:standard -safe-string)) (libraries (unix)) )) diff --git a/lib/xapi-stdext-deprecated/jbuild b/lib/xapi-stdext-deprecated/jbuild index 17e3fc8b3e9..a4ef03d6d6c 100644 --- a/lib/xapi-stdext-deprecated/jbuild +++ b/lib/xapi-stdext-deprecated/jbuild @@ -3,5 +3,4 @@ (library ((name xapi_stdext_deprecated) (public_name xapi-stdext-deprecated) - (flags (:standard -safe-string)) )) diff --git a/lib/xapi-stdext-encodings/jbuild b/lib/xapi-stdext-encodings/jbuild index 8ef934d2446..db744723858 100644 --- a/lib/xapi-stdext-encodings/jbuild +++ b/lib/xapi-stdext-encodings/jbuild @@ -3,5 +3,4 @@ (library ((name xapi_stdext_encodings) (public_name xapi-stdext-encodings) - (flags (:standard -safe-string)) )) diff --git a/lib/xapi-stdext-monadic/jbuild b/lib/xapi-stdext-monadic/jbuild index ff88600cd98..987d00edd39 100644 --- a/lib/xapi-stdext-monadic/jbuild +++ b/lib/xapi-stdext-monadic/jbuild @@ -3,5 +3,4 @@ (library ((public_name xapi-stdext-monadic) (name xapi_stdext_monadic) - (flags (:standard -safe-string)) )) diff --git a/lib/xapi-stdext-pervasives/jbuild b/lib/xapi-stdext-pervasives/jbuild index f840ecc2ca0..548f2c516bf 100644 --- a/lib/xapi-stdext-pervasives/jbuild +++ b/lib/xapi-stdext-pervasives/jbuild @@ -4,5 +4,4 @@ ((name xapi_stdext_pervasives) (public_name xapi-stdext-pervasives) (libraries (xapi-backtrace)) - (flags (:standard -safe-string)) )) diff --git a/lib/xapi-stdext-range/jbuild b/lib/xapi-stdext-range/jbuild index d6941b744b9..2dda5f268da 100644 --- a/lib/xapi-stdext-range/jbuild +++ b/lib/xapi-stdext-range/jbuild @@ -3,5 +3,4 @@ (library ((name xapi_stdext_range) (public_name xapi-stdext-range) - (flags (:standard -safe-string)) )) diff --git a/lib/xapi-stdext-std/jbuild b/lib/xapi-stdext-std/jbuild index e9f0421f57a..52ec1d3d6aa 100644 --- a/lib/xapi-stdext-std/jbuild +++ b/lib/xapi-stdext-std/jbuild @@ -3,7 +3,6 @@ (library ((public_name xapi-stdext-std) (name xapi_stdext_std) - (flags (:standard -safe-string)) (libraries (uuidm xapi-stdext-monadic)) )) diff --git a/lib/xapi-stdext-threads/jbuild b/lib/xapi-stdext-threads/jbuild index 582c54e4036..643d4cf8d86 100644 --- a/lib/xapi-stdext-threads/jbuild +++ b/lib/xapi-stdext-threads/jbuild @@ -3,7 +3,6 @@ (library ((public_name xapi-stdext-threads) (name xapi_stdext_threads) - (flags (:standard -safe-string)) (libraries (threads unix xapi-stdext-pervasives)) diff --git a/lib/xapi-stdext-unix/jbuild b/lib/xapi-stdext-unix/jbuild index 8ef805e0e84..bb0bcf20bdf 100644 --- a/lib/xapi-stdext-unix/jbuild +++ b/lib/xapi-stdext-unix/jbuild @@ -3,7 +3,6 @@ (library ((name xapi_stdext_unix) (public_name xapi-stdext-unix) - (flags (:standard -safe-string)) (c_names (blkgetsize_stubs unixext_open_stubs unixext_stubs diff --git a/lib/xapi-stdext-zerocheck/jbuild b/lib/xapi-stdext-zerocheck/jbuild index 90bc5be432b..51074336f76 100644 --- a/lib/xapi-stdext-zerocheck/jbuild +++ b/lib/xapi-stdext-zerocheck/jbuild @@ -2,7 +2,6 @@ (library ((public_name xapi-stdext-zerocheck) - (flags (:standard -safe-string)) (name xapi_stdext_zerocheck) (c_names (zerocheck_stub)) )) From 21f67198bc743593b865a3f6892835374a7d6aa6 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Wed, 14 Mar 2018 11:10:04 +0000 Subject: [PATCH 089/199] .travis.yml: compile in 4.06 as well Signed-off-by: Marcello Seri --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 8512013e363..74313116d6f 100644 --- a/.travis.yml +++ b/.travis.yml @@ -11,13 +11,13 @@ env: - TESTS=false - OPAMBUILDTEST=false matrix: - - PACKAGE=xapi-stdext OCAML_VERSION=4.03.0 - PACKAGE=xapi-stdext BASE_REMOTE="https://github.com/xapi-project/xs-opam" OCAML_VERSION=4.04.2 REVDEPS=true - PACKAGE=stdext BASE_REMOTE="https://github.com/xapi-project/xs-opam" OCAML_VERSION=4.04.2 REVDEPS=true - PACKAGE=xapi-stdext OCAML_VERSION=4.05.0 + - PACKAGE=xapi-stdext OCAML_VERSION=4.06.0 branches: only: master matrix: fast_finish: true allow_failures: - - env: PACKAGE=xapi-stdext DISTRO="debian-unstable" OCAML_VERSION=4.05.0 + - env: PACKAGE=xapi-stdext OCAML_VERSION=4.06.0 From 250814788b8a49e3ce2da2b4376886b1052ba4d8 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Wed, 14 Mar 2018 11:51:23 +0000 Subject: [PATCH 090/199] .travis: further cleanup Signed-off-by: Marcello Seri --- .travis.yml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/.travis.yml b/.travis.yml index 74313116d6f..d384b19b2ee 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,11 +9,10 @@ env: - PINS="stdext:. xapi-stdext:. xapi-stdext-base64:. xapi-stdext-bigbuffer:. xapi-stdext-date:. xapi-stdext-deprecated:. xapi-stdext-encodings:. xapi-stdext-monadic:. xapi-stdext-pervasives:. xapi-stdext-range:. xapi-stdext-std:. xapi-stdext-threads:. xapi-stdext-unix:. xapi-stdext-zerocheck:." - DISTRO="centos-7" - TESTS=false - - OPAMBUILDTEST=false + - BASE_REMOTE="https://github.com/xapi-project/xs-opam" matrix: - - PACKAGE=xapi-stdext BASE_REMOTE="https://github.com/xapi-project/xs-opam" OCAML_VERSION=4.04.2 REVDEPS=true - - PACKAGE=stdext BASE_REMOTE="https://github.com/xapi-project/xs-opam" OCAML_VERSION=4.04.2 REVDEPS=true - - PACKAGE=xapi-stdext OCAML_VERSION=4.05.0 + - PACKAGE=xapi-stdext OCAML_VERSION=4.04.2 REVDEPS=true + - PACKAGE=stdext OCAML_VERSION=4.04.2 REVDEPS=true - PACKAGE=xapi-stdext OCAML_VERSION=4.06.0 branches: only: master From 22e68f845318a38a0cfbf0d3b39a5d69c40ddacc Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Thu, 15 Mar 2018 15:15:46 +0000 Subject: [PATCH 091/199] Prepare to release stdext 4.0.0 and xapi-stdext-{bigbuffer, encodings, std, threads, unix} 1.1.0 Signed-off-by: Marcello Seri --- ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index 71db89e4c30..aec19591daf 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +4.0.0 (15-Mar-2018): +* Make safe-string safe (xap-stdext-{bigbuffer, encodings, std, threads, unix} 1.1.0) +* Remove bigbuffer from the default stdext set of packages +* Use backward compatible naming for stdext xapi-stdext + 3.0.0 (02-Aug-2017): * Remove unused packages * Refactor in a backward compatible wrapper and 12 new separate libraries (see https://github.com/xapi-project/stdext/pull/21) From 713d5aacc5b7cfa122192d178e904d5338e46b4a Mon Sep 17 00:00:00 2001 From: Gabor Igloi Date: Thu, 12 Apr 2018 14:31:09 +0100 Subject: [PATCH 092/199] Move quicktest_encodings from xapi into a unit test Signed-off-by: Gabor Igloi --- .travis.yml | 13 +- lib/xapi-stdext-encodings/jbuild | 20 +- lib_test/jbuild | 11 + lib_test/suite.ml | 5 + lib_test/test_encodings.ml | 525 +++++++++++++++++++++++++++++++ xapi-stdext-encodings.opam | 2 + 6 files changed, 567 insertions(+), 9 deletions(-) create mode 100644 lib_test/jbuild create mode 100644 lib_test/suite.ml create mode 100644 lib_test/test_encodings.ml diff --git a/.travis.yml b/.travis.yml index d384b19b2ee..aae9bc664c2 100644 --- a/.travis.yml +++ b/.travis.yml @@ -2,20 +2,21 @@ language: c sudo: false services: - docker -install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh +install: + - wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh + - wget https://raw.githubusercontent.com/xapi-project/xapi-travis-scripts/master/coverage.sh script: bash -ex ./.travis-docker.sh env: global: - PINS="stdext:. xapi-stdext:. xapi-stdext-base64:. xapi-stdext-bigbuffer:. xapi-stdext-date:. xapi-stdext-deprecated:. xapi-stdext-encodings:. xapi-stdext-monadic:. xapi-stdext-pervasives:. xapi-stdext-range:. xapi-stdext-std:. xapi-stdext-threads:. xapi-stdext-unix:. xapi-stdext-zerocheck:." - - DISTRO="centos-7" - - TESTS=false + - DISTRO="ubuntu-16.04" + - TEST=false - BASE_REMOTE="https://github.com/xapi-project/xs-opam" matrix: - - PACKAGE=xapi-stdext OCAML_VERSION=4.04.2 REVDEPS=true + - PACKAGE=xapi-stdext OCAML_VERSION=4.04.2 REVDEPS=true \ + POST_INSTALL_HOOK="opam install alcotest; env TRAVIS=$TRAVIS TRAVIS_JOB_ID=$TRAVIS_JOB_ID bash -ex coverage.sh" - PACKAGE=stdext OCAML_VERSION=4.04.2 REVDEPS=true - PACKAGE=xapi-stdext OCAML_VERSION=4.06.0 -branches: - only: master matrix: fast_finish: true allow_failures: diff --git a/lib/xapi-stdext-encodings/jbuild b/lib/xapi-stdext-encodings/jbuild index db744723858..c02ad6f30ec 100644 --- a/lib/xapi-stdext-encodings/jbuild +++ b/lib/xapi-stdext-encodings/jbuild @@ -1,6 +1,20 @@ +(* -*- tuareg -*- *) +#require "unix" + +let coverage_rewriter ~full = + let is_coverage = try Unix.getenv "BISECT_ENABLE" = "YES" with Not_found -> false in + match is_coverage, full with + | true, true -> "(preprocess (pps (bisect_ppx -conditional)))" + | true, _ -> "bisect_ppx -conditional" + | _ -> "" + +let () = Printf.ksprintf Jbuild_plugin.V1.send {| (jbuild_version 1) (library - ((name xapi_stdext_encodings) - (public_name xapi-stdext-encodings) - )) + ((name xapi_stdext_encodings) + (public_name xapi-stdext-encodings) + %s + ) +) +|} (coverage_rewriter ~full:true) diff --git a/lib_test/jbuild b/lib_test/jbuild new file mode 100644 index 00000000000..6d2aafedc93 --- /dev/null +++ b/lib_test/jbuild @@ -0,0 +1,11 @@ +(executable + ((name suite) + (libraries + (alcotest + xapi_stdext_encodings)) + )) + +(alias + ((name runtest) + (deps (suite.exe)) + (action (run ${<})))) diff --git a/lib_test/suite.ml b/lib_test/suite.ml new file mode 100644 index 00000000000..13932e2b498 --- /dev/null +++ b/lib_test/suite.ml @@ -0,0 +1,5 @@ + +let () = + Alcotest.run + "suite" + [ "Test_encodings", Test_encodings.tests ] diff --git a/lib_test/test_encodings.ml b/lib_test/test_encodings.ml new file mode 100644 index 00000000000..f87396f4de7 --- /dev/null +++ b/lib_test/test_encodings.ml @@ -0,0 +1,525 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) +module E = Xapi_stdext_encodings.Encodings +(* Pull in the infix operators from Encodings used in this test *) +let (---), (+++), (<<<) = E.( (---), (+++), (<<<) ) + +(* === Mock exceptions ==================================================== *) + +(** Simulates a decoding error. *) +exception Decode_error + +(* === Mock types ===========================================================*) + +(** Generates mock character widths, in bytes. *) +module type WIDTH_GENERATOR = sig val next : unit -> int end + +(* === Mock UCS validators ================================================= *) + +(** A validator that always succeeds. *) +module Lenient_UCS_validator : E.UCS_VALIDATOR = struct + let validate value = () +end + +(* === Mock character decoders ============================================= *) + +(** A character decoder that logs every index it is called with. *) +module Logged_character_decoder (W : WIDTH_GENERATOR) = struct + + (** The indices already supplied to the decoder. *) + let indices = ref ([] : int list) + + (** Clears the list of indices. *) + let reset () = indices := [] + + (** Records the given index in the list of indices. *) + let decode_character string index = + let width = W.next () in + for index = index to index + width - 1 do + ignore (string.[index]) + done; + indices := (index :: !indices); + 0l, width + +end + +module Logged_1_byte_character_decoder = Logged_character_decoder + (struct let next () = 1 end) +module Logged_2_byte_character_decoder = Logged_character_decoder + (struct let next () = 2 end) +module Logged_n_byte_character_decoder = Logged_character_decoder + (struct let last = ref 0 let next () = incr last; !last end) + +(** A decoder that succeeds for all characters. *) +module Universal_character_decoder = struct + let decode_character string index = (0l, 1) +end + +(** A decoder that fails for all characters. *) +module Failing_character_decoder = struct + let decode_character string index = raise Decode_error +end + +(** A decoder that succeeds for all characters except the letter 'F'. *) +module Selective_character_decoder = struct + let decode_character string index = + if string.[index] = 'F' then raise Decode_error else (0l, 1) +end + +(* === Mock codecs ========================================================= *) + +module Lenient_UTF8_codec = E.UTF8_CODEC (Lenient_UCS_validator) + +(* === Mock string validators ============================================== *) + +module Logged_1_byte_character_string_validator = E.String_validator + (Logged_1_byte_character_decoder) +module Logged_2_byte_character_string_validator = E.String_validator + (Logged_2_byte_character_decoder) +module Logged_n_byte_character_string_validator = E.String_validator + (Logged_n_byte_character_decoder) + +(** A validator that accepts all strings. *) +module Universal_string_validator = E.String_validator + (Universal_character_decoder) + +(** A validator that rejects all strings. *) +module Failing_string_validator = E.String_validator + (Failing_character_decoder) + +(** A validator that rejects strings containing the character 'F'. *) +module Selective_string_validator = E.String_validator + (Selective_character_decoder) + +(* === Test helpers ======================================================== *) + +let assert_true = Alcotest.(check bool) "true" true +let assert_false = Alcotest.(check bool) "false" false +let check_indices = Alcotest.(check (list int)) "indices" + +let assert_raises_match exception_match fn = + try + fn (); + Alcotest.fail "assert_raises_match: failure expected" + with failure -> + if not (exception_match failure) + then raise failure + else () + +(* === Tests =============================================================== *) + +module String_validator = struct + + let test_is_valid () = + assert_true (Universal_string_validator.is_valid "" ); + assert_true (Universal_string_validator.is_valid "123456789"); + assert_true (Selective_string_validator.is_valid "" ); + assert_true (Selective_string_validator.is_valid "123456789"); + assert_false (Selective_string_validator.is_valid "F23456789"); + assert_false (Selective_string_validator.is_valid "1234F6789"); + assert_false (Selective_string_validator.is_valid "12345678F"); + assert_false (Selective_string_validator.is_valid "FFFFFFFFF") + + let test_longest_valid_prefix () = + Alcotest.(check string) "prefix" (Universal_string_validator.longest_valid_prefix "" ) "" ; + Alcotest.(check string) "prefix" (Universal_string_validator.longest_valid_prefix "123456789") "123456789"; + Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "" ) "" ; + Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "123456789") "123456789"; + Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "F23456789") "" ; + Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "1234F6789") "1234" ; + Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "12345678F") "12345678" ; + Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "FFFFFFFFF") "" + + let test_validate_with_1_byte_characters () = + Logged_1_byte_character_decoder.reset (); + Logged_1_byte_character_string_validator.validate "0123456789"; + Alcotest.(check (list int)) "indices" !Logged_1_byte_character_decoder.indices [9;8;7;6;5;4;3;2;1;0] + + let test_validate_with_2_byte_characters () = + Logged_2_byte_character_decoder.reset (); + Logged_2_byte_character_string_validator.validate "0123456789"; + Alcotest.(check (list int)) "indices" !Logged_2_byte_character_decoder.indices [8;6;4;2;0] + + let test_validate_with_n_byte_characters () = + Logged_n_byte_character_decoder.reset (); + Logged_n_byte_character_string_validator.validate "0123456789"; + check_indices !Logged_n_byte_character_decoder.indices [6;3;1;0] + + (** Tests that validation does not fail for an empty string. *) + let test_validate_with_empty_string () = + Logged_1_byte_character_decoder.reset (); + Logged_1_byte_character_string_validator.validate ""; + check_indices !Logged_1_byte_character_decoder.indices [] + + let test_validate_with_incomplete_string () = + Logged_2_byte_character_decoder.reset (); + Alcotest.check_raises + "Validation fails correctly for an incomplete string" + E.String_incomplete + (fun () -> Logged_2_byte_character_string_validator.validate "0") + + let test_validate_with_failing_decoders () = + Failing_string_validator.validate ""; + assert_raises_match + (function E.Validation_error (0, Decode_error) -> true | _ -> false) + (fun () -> Selective_string_validator.validate "F"); + assert_raises_match + (function E.Validation_error (0, Decode_error) -> true | _ -> false) + (fun () -> Selective_string_validator.validate "F12345678"); + assert_raises_match + (function E.Validation_error (4, Decode_error) -> true | _ -> false) + (fun () -> Selective_string_validator.validate "0123F5678"); + assert_raises_match + (function E.Validation_error (8, Decode_error) -> true | _ -> false) + (fun () -> Selective_string_validator.validate "01234567F"); + assert_raises_match + (function E.Validation_error (0, Decode_error) -> true | _ -> false) + (fun () -> Selective_string_validator.validate "FFFFFFFFF") + + let tests = + [ "test_is_valid", `Quick, test_is_valid + ; "test_longest_valid_prefix", `Quick, test_longest_valid_prefix + ; "test_validate_with_1_byte_characters", `Quick, test_validate_with_1_byte_characters + ; "test_validate_with_2_byte_characters", `Quick, test_validate_with_2_byte_characters + ; "test_validate_with_n_byte_characters", `Quick, test_validate_with_n_byte_characters + ; "test_validate_with_empty_string", `Quick, test_validate_with_empty_string + ; "test_validate_with_incomplete_string", `Quick, test_validate_with_incomplete_string + ; "test_validate_with_failing_decoders", `Quick, test_validate_with_failing_decoders + ] + +end + +module UCS = struct include E.UCS + + (** A list of UCS non-characters values, including: *) + (** a. non-characters within the basic multilingual plane; *) + (** b. non-characters at the end of the basic multilingual plane; *) + (** c. non-characters at the end of the private use area. *) + let non_characters = [ + 0x00fdd0l; 0x00fdefl; (* case a. *) + 0x00fffel; 0x00ffffl; (* case b. *) + 0x1ffffel; 0x1fffffl; (* case c. *) + ] + + (** A list of UCS character values located immediately before or *) + (** after UCS non-character values, including: *) + (** a. non-characters within the basic multilingual plane; *) + (** b. non-characters at the end of the basic multilingual plane; *) + (** c. non-characters at the end of the private use area. *) + let valid_characters_next_to_non_characters = [ + 0x00fdcfl; 0x00fdf0l; (* case a. *) + 0x00fffdl; 0x010000l; (* case b. *) + 0x1ffffdl; 0x200000l; (* case c. *) + ] + + let test_is_non_character () = + List.iter (fun value -> assert_true (is_non_character (value))) + non_characters; + List.iter (fun value -> assert_false (is_non_character (value))) + valid_characters_next_to_non_characters + + let test_is_out_of_range () = + assert_true (is_out_of_range (min_value --- 1l)); + assert_false (is_out_of_range (min_value)); + assert_false (is_out_of_range (max_value)); + assert_true (is_out_of_range (max_value +++ 1l)) + + let test_is_surrogate () = + assert_false (is_surrogate (0xd7ffl)); + assert_true (is_surrogate (0xd800l)); + assert_true (is_surrogate (0xdfffl)); + assert_false (is_surrogate (0xe000l)) + + let tests = + [ "test_is_non_character", `Quick, test_is_non_character + ; "test_is_out_of_range", `Quick, test_is_out_of_range + ; "test_is_surrogate", `Quick, test_is_surrogate + ] + +end + +module XML = struct include E.XML + + let test_is_forbidden_control_character () = + assert_true (is_forbidden_control_character (0x00l)); + assert_true (is_forbidden_control_character (0x19l)); + assert_false (is_forbidden_control_character (0x09l)); + assert_false (is_forbidden_control_character (0x0al)); + assert_false (is_forbidden_control_character (0x0dl)); + assert_false (is_forbidden_control_character (0x20l)) + + let tests = + [ "test_is_forbidden_control_character", `Quick, test_is_forbidden_control_character + ] + +end + +module UTF8_UCS_validator = struct include E.UTF8_UCS_validator + + let test_validate () = + let value = ref (UCS.min_value --- 1l) in + while !value <= (UCS.max_value +++ 1l) do + if UCS.is_out_of_range !value + then Alcotest.check_raises "should fail" + E.UCS_value_out_of_range + (fun () -> validate !value) + else + if UCS.is_non_character !value + || UCS.is_surrogate !value + then Alcotest.check_raises "should fail" + E.UCS_value_prohibited_in_UTF8 + (fun () -> validate !value) + else + validate !value; + value := !value +++ 1l + done + + let tests = + [ "test_vaidate", `Quick, test_validate + ] + +end + +(** Tests the XML-specific UTF-8 UCS validation function. *) +module XML_UTF8_UCS_validator = struct include E.XML_UTF8_UCS_validator + + let test_validate () = + let value = ref (UCS.min_value --- 1l) in + while !value <= (UCS.max_value +++ 1l) do + if UCS.is_out_of_range !value + then Alcotest.check_raises "should fail" E.UCS_value_out_of_range + (fun () -> validate !value) + else + if UCS.is_non_character !value + || UCS.is_surrogate !value + then Alcotest.check_raises "should fail" E.UCS_value_prohibited_in_UTF8 + (fun () -> validate !value) + else + if XML.is_forbidden_control_character !value + then Alcotest.check_raises "should fail" E.UCS_value_prohibited_in_XML + (fun () -> validate !value) + else + validate !value; + value := !value +++ 1l + done + + let tests = + [ "test_validate", `Quick, test_validate + ] + +end + +module UTF8_codec = struct include E.UTF8_codec + + (** A list of canonical encoding widths of UCS values, *) + (** represented by tuples of the form (v, w), where: *) + (** v = the UCS character value to be encoded; and *) + (** w = the width of the encoded character, in bytes. *) + let valid_ucs_value_widths = + [ + (1l , 1); ((1l <<< 7) --- 1l, 1); + (1l <<< 7, 2); ((1l <<< 11) --- 1l, 2); + (1l <<< 11, 3); ((1l <<< 16) --- 1l, 3); + (1l <<< 16, 4); ((1l <<< 21) --- 1l, 4); + ] + + let test_width_required_for_ucs_value () = + List.iter + (fun (value, width) -> + Alcotest.(check int) "same ints" (width_required_for_ucs_value value) width) + valid_ucs_value_widths + + (** A list of valid header byte decodings, represented by *) + (** tuples of the form (b, (v, w)), where: *) + (** b = a valid header byte; *) + (** v = the (partial) value contained within the byte; and *) + (** w = the total width of the encoded character, in bytes. *) + let valid_header_byte_decodings = + [ + (0b00000000, (0b00000000, 1)); + (0b00000001, (0b00000001, 1)); + (0b01111111, (0b01111111, 1)); + (0b11000000, (0b00000000, 2)); + (0b11000001, (0b00000001, 2)); + (0b11011111, (0b00011111, 2)); + (0b11100000, (0b00000000, 3)); + (0b11100001, (0b00000001, 3)); + (0b11101111, (0b00001111, 3)); + (0b11110000, (0b00000000, 4)); + (0b11110001, (0b00000001, 4)); + (0b11110111, (0b00000111, 4)); + ] + + (** A list of invalid header bytes that should not be decodable. *) + let invalid_header_bytes = + [ + 0b10000000; 0b10111111; + 0b11111000; 0b11111011; + 0b11111100; 0b11111101; + 0b11111110; 0b11111111; + ] + + let test_decode_header_byte_when_valid () = + List.iter + (fun (b, (v, w)) -> + Alcotest.(check (pair int int)) "same ints" (decode_header_byte b) (v, w)) + valid_header_byte_decodings + + let test_decode_header_byte_when_invalid () = + List.iter + (fun b -> + Alcotest.check_raises "should fail" E.UTF8_header_byte_invalid + (fun () -> decode_header_byte b |> ignore)) + invalid_header_bytes + + (** A list of valid continuation byte decodings, represented *) + (** by tuples of the form (b, v), where: *) + (** b = a valid continuation byte; and *) + (** v = the partial value contained within the byte. *) + let valid_continuation_byte_decodings = + [ + (0b10000000, 0b00000000); + (0b10000001, 0b00000001); + (0b10111110, 0b00111110); + (0b10111111, 0b00111111); + ] + + (** A list of invalid continuation bytes that should not be decodable. *) + let invalid_continuation_bytes = + [ + 0b00000000; 0b01111111; + 0b11000000; 0b11011111; + 0b11100000; 0b11101111; + 0b11110000; 0b11110111; + 0b11111000; 0b11111011; + 0b11111100; 0b11111101; + 0b11111111; 0b11111110; + ] + + let test_decode_continuation_byte_when_valid () = + List.iter + (fun (byte, value) -> + Alcotest.(check int) "same ints" (decode_continuation_byte byte) value) + valid_continuation_byte_decodings + + let test_decode_continuation_byte_when_invalid () = + List.iter + (fun byte -> + Alcotest.check_raises "should fail" E.UTF8_continuation_byte_invalid + (fun () -> decode_continuation_byte byte |> ignore)) + invalid_continuation_bytes + + (** A list of valid character decodings represented by *) + (** tuples of the form (s, (v, w)), where: *) + (** *) + (** s = a validly-encoded UTF-8 string; *) + (** v = the UCS value represented by the string; *) + (** (which may or may not be valid in its own right) *) + (** w = the width of the encoded string, in bytes. *) + (** *) + (** For each byte length b in [1...4], the list contains *) + (** decodings for: *) + (** *) + (** v_min = the smallest UCS value encodable in b bytes. *) + (** v_max = the greatest UCS value encodable in b bytes. *) + (** *) + let valid_character_decodings = [ + (* 7654321 *) + (* 0b0xxxxxxx *) (* 00000000000000xxxxxxx *) + "\x00" (* 0b00000000 *), (0b000000000000000000000l, 1); + "\x7f" (* 0b01111111 *), (0b000000000000001111111l, 1); + (* 10987654321 *) + (* 0b110xxxsx 0b10xxxxxx *) (* 0000000000xxxsxxxxxxx *) + "\xc2\x80" (* 0b11000010 0b10000000 *), (0b000000000000010000000l, 2); + "\xdf\xbf" (* 0b11011111 0b10111111 *), (0b000000000011111111111l, 2); + (* 6543210987654321 *) + (* 0b1110xxxx 0b10sxxxxx 0b10xxxxxx *) (* xxxxsxxxxxxxxxxx *) + "\xe0\xa0\x80" (* 0b11100000 0b10100000 0b10000000 *), (0b000000000100000000000l, 3); + "\xef\xbf\xbf" (* 0b11101111 0b10111111 0b10111111 *), (0b000001111111111111111l, 3); + (* 109876543210987654321 *) + (* 0b11110xxx 0b10xsxxxx 0b10xxxxxx 0b10xxxxxx *) (* xxxxsxxxxxxxxxxxxxxxx *) + "\xf0\x90\x80\x80" (* 0b11110000 0b10010000 0b10000000 0b10000000 *), (0b000010000000000000000l, 4); + "\xf7\xbf\xbf\xbf" (* 0b11110111 0b10111111 0b10111111 0b10111111 *), (0b111111111111111111111l, 4); + ] + + let test_decode_character_when_valid () = + List.iter + (fun (string, (value, width)) -> + Alcotest.(check (pair int32 int)) "same pair" + (Lenient_UTF8_codec.decode_character string 0) + (value, width)) + valid_character_decodings + + (** A list of strings containing overlong character encodings. *) + (** For each byte length b in [2...4], this list contains the *) + (** overlong encoding e (v), where v is the UCS value one less *) + (** than the smallest UCS value validly-encodable in b bytes. *) + let overlong_character_encodings = + [ + "\xc1\xbf" (* 0b11000001 0b10111111 *); + "\xe0\x9f\xbf" (* 0b11100000 0b10011111 0b10111111 *); + "\xf0\x8f\xbf\xbf" (* 0b11110000 0b10001111 0b10111111 0b10111111 *); + ] + + let test_decode_character_when_overlong () = + List.iter + (fun string -> + Alcotest.check_raises "should fail" E.UTF8_encoding_not_canonical + (fun () -> Lenient_UTF8_codec.decode_character string 0 |> ignore)) + overlong_character_encodings + + (** Encodes a valid UCS value and then decodes it again, testing: *) + (** a. that the encoded width is canonical for the given value. *) + (** b. that the decoded value is identical to the original value. *) + let test_encode_decode_cycle_for_value value = + let string = Lenient_UTF8_codec.encode_character value in + let decoded_value, decoded_width = + Lenient_UTF8_codec.decode_character string 0 in + let width = E.UTF8_codec.width_required_for_ucs_value value in + if (value <> decoded_value) then Alcotest.fail + (Printf.sprintf + "expected value %06lx but decoded value %06lx\n" + value decoded_value); + if (width <> decoded_width) then Alcotest.fail + (Printf.sprintf + "expected width %i but decoded width %i\n" + width decoded_width) + + let test_encode_decode_cycle () = + let value = ref UCS.min_value in + while !value <= UCS.max_value do + test_encode_decode_cycle_for_value !value; + value := Int32.add !value 1l; + done + + let tests = + [ "test_width_required_for_ucs_value", `Quick, test_width_required_for_ucs_value + ; "test_decode_header_byte_when_valid", `Quick, test_decode_header_byte_when_valid + ; "test_decode_header_byte_when_invalid", `Quick, test_decode_header_byte_when_invalid + ; "test_decode_continuation_byte_when_valid", `Quick, test_decode_continuation_byte_when_valid + ; "test_decode_continuation_byte_when_invalid", `Quick, test_decode_continuation_byte_when_invalid + ; "test_decode_character_when_valid", `Quick, test_decode_character_when_valid + ; "test_decode_character_when_overlong", `Quick, test_decode_character_when_overlong + ; "test_encode_decode_cycle", `Quick, test_encode_decode_cycle + ] + +end + +let tests = + UCS .tests @ + XML .tests @ + String_validator .tests @ + UTF8_UCS_validator .tests @ + XML_UTF8_UCS_validator.tests @ + UTF8_codec .tests diff --git a/xapi-stdext-encodings.opam b/xapi-stdext-encodings.opam index b747c86b99d..f01635bace0 100644 --- a/xapi-stdext-encodings.opam +++ b/xapi-stdext-encodings.opam @@ -7,7 +7,9 @@ homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] +build-test: ["jbuilder" "runtest" "-p" name "-j" jobs] depends: [ "jbuilder" {build} + "alcotest" {test} ] From 0e0f0109b7beb6d8a82cea041a5ab5e43be746ba Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Wed, 25 Apr 2018 09:47:39 +0100 Subject: [PATCH 093/199] really_write: remove deprecation and make robust against EINTR See discussion in https://ocaml.github.io/ocamlunix/ocamlunix.html#sec118 and https://github.com/xapi-project/xen-api/pull/3570 Signed-off-by: Marcello Seri --- lib/xapi-stdext-unix/unixext.ml | 28 ++++++++++++++++++++++++---- lib/xapi-stdext-unix/unixext.mli | 7 ++++--- 2 files changed, 28 insertions(+), 7 deletions(-) diff --git a/lib/xapi-stdext-unix/unixext.ml b/lib/xapi-stdext-unix/unixext.ml index eeb526d992d..0e6f7a08eaf 100644 --- a/lib/xapi-stdext-unix/unixext.ml +++ b/lib/xapi-stdext-unix/unixext.ml @@ -444,14 +444,34 @@ let try_read_string ?limit fd = done; Buffer.contents buf -(* This was equivalent to Unix.write - deprecating *) -let really_write fd string off n = - Unix.write fd string off n |> ignore +(* From https://ocaml.github.io/ocamlunix/ocamlunix.html#sec118 +The function write of the Unix module iterates the system call write until +all the requested bytes are effectively written. +val write : file_descr -> string -> int -> int -> int +However, when the descriptor is a pipe (or a socket, see chapter 6), writes +may block and the system call write may be interrupted by a signal. In this +case the OCaml call to Unix.write is interrupted and the error EINTR is raised. +The problem is that some of the data may already have been written by a +previous system call to write but the actual size that was transferred is +unknown and lost. This renders the function write of the Unix module useless +in the presence of signals. + +To address this problem, the Unix module also provides the “raw” system call +write under the name single_write. + +We can use multiple single_write calls to write exactly the requested +amount of data (but not atomically!). +*) +let rec restart_on_EINTR f x = + try f x with Unix.Unix_error (Unix.EINTR, _, _) -> restart_on_EINTR f x +and really_write fd buffer offset len = + let n = restart_on_EINTR (Unix.single_write fd buffer offset) len in + if n < len then really_write fd buffer (offset + n) (len - n);; (* Ideally, really_write would be implemented with optional arguments ?(off=0) ?(len=String.length string) *) let really_write_string fd string = let payload = Bytes.unsafe_of_string string in - Unix.write fd payload 0 (Bytes.length payload) |> ignore + really_write fd payload 0 (Bytes.length payload) (* --------------------------------------------------------------------------------------- *) (* Functions to read and write to/from a file descriptor with a given latest response time *) diff --git a/lib/xapi-stdext-unix/unixext.mli b/lib/xapi-stdext-unix/unixext.mli index 3464a720784..8752c3757f5 100644 --- a/lib/xapi-stdext-unix/unixext.mli +++ b/lib/xapi-stdext-unix/unixext.mli @@ -99,9 +99,10 @@ val proxy : Unix.file_descr -> Unix.file_descr -> unit val really_read : Unix.file_descr -> bytes -> int -> int -> unit val really_read_string : Unix.file_descr -> int -> string (** [really_write] keeps repeating the write operation until all bytes - * have been written or an error occurs. This is the same behaviour of - * [Unix.write] that should be preferred instead. *) -val really_write : Unix.file_descr -> bytes -> int -> int -> unit [@@ocaml.deprecated] + * have been written or an error occurs. This is not atomic but is + * robust against EINTR errors. + * See: https://ocaml.github.io/ocamlunix/ocamlunix.html#sec118 *) +val really_write : Unix.file_descr -> bytes -> int -> int -> unit val really_write_string : Unix.file_descr -> string -> unit val try_read_string : ?limit: int -> Unix.file_descr -> string exception Timeout From b98891ac316fcd41242a1a76a624f2dd9b00dad6 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Wed, 25 Apr 2018 09:48:27 +0100 Subject: [PATCH 094/199] unixext_open_stubs: fix use of uninitialised variable Signed-off-by: Marcello Seri --- lib/xapi-stdext-unix/unixext_open_stubs.c | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/lib/xapi-stdext-unix/unixext_open_stubs.c b/lib/xapi-stdext-unix/unixext_open_stubs.c index 35b58713fa3..af1f967f41d 100644 --- a/lib/xapi-stdext-unix/unixext_open_stubs.c +++ b/lib/xapi-stdext-unix/unixext_open_stubs.c @@ -44,7 +44,10 @@ static int open_flag_table[] = { CAMLprim value stub_stdext_unix_open_direct(value path, value flags, value perm) { CAMLparam3(path, flags, perm); - int fd, ret, cv_flags; + int fd, cv_flags; +#ifndef O_DIRECT + int ret; +#endif char * p; cv_flags = convert_flag_list(flags, open_flag_table); @@ -60,11 +63,13 @@ CAMLprim value stub_stdext_unix_open_direct(value path, value flags, value perm) #ifndef O_DIRECT if (fd != -1) ret = fcntl(fd, F_NOCACHE); -#endif +#endif leave_blocking_section(); stat_free(p); if (fd == -1) uerror("open", path); +#ifndef O_DIRECT if (ret == -1) uerror("fcntl", path); +#endif CAMLreturn (Val_int(fd)); } From 85f5556a328af9aa124d6902a8124c344a0593f4 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Wed, 25 Apr 2018 11:45:49 +0100 Subject: [PATCH 095/199] really_write: use single_write_substring and avoid an unsafe coercion Signed-off-by: Marcello Seri --- lib/xapi-stdext-unix/unixext.ml | 5 ++--- lib/xapi-stdext-unix/unixext.mli | 2 +- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/lib/xapi-stdext-unix/unixext.ml b/lib/xapi-stdext-unix/unixext.ml index 0e6f7a08eaf..fd931e6d8ce 100644 --- a/lib/xapi-stdext-unix/unixext.ml +++ b/lib/xapi-stdext-unix/unixext.ml @@ -465,13 +465,12 @@ amount of data (but not atomically!). let rec restart_on_EINTR f x = try f x with Unix.Unix_error (Unix.EINTR, _, _) -> restart_on_EINTR f x and really_write fd buffer offset len = - let n = restart_on_EINTR (Unix.single_write fd buffer offset) len in + let n = restart_on_EINTR (Unix.single_write_substring fd buffer offset) len in if n < len then really_write fd buffer (offset + n) (len - n);; (* Ideally, really_write would be implemented with optional arguments ?(off=0) ?(len=String.length string) *) let really_write_string fd string = - let payload = Bytes.unsafe_of_string string in - really_write fd payload 0 (Bytes.length payload) + really_write fd string 0 (String.length string) (* --------------------------------------------------------------------------------------- *) (* Functions to read and write to/from a file descriptor with a given latest response time *) diff --git a/lib/xapi-stdext-unix/unixext.mli b/lib/xapi-stdext-unix/unixext.mli index 8752c3757f5..d65047a95b2 100644 --- a/lib/xapi-stdext-unix/unixext.mli +++ b/lib/xapi-stdext-unix/unixext.mli @@ -102,7 +102,7 @@ val really_read_string : Unix.file_descr -> int -> string * have been written or an error occurs. This is not atomic but is * robust against EINTR errors. * See: https://ocaml.github.io/ocamlunix/ocamlunix.html#sec118 *) -val really_write : Unix.file_descr -> bytes -> int -> int -> unit +val really_write : Unix.file_descr -> string -> int -> int -> unit val really_write_string : Unix.file_descr -> string -> unit val try_read_string : ?limit: int -> Unix.file_descr -> string exception Timeout From 6fe6bef630b166a385d3959ec22ea3bb0f833cfa Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Wed, 25 Apr 2018 13:09:24 +0100 Subject: [PATCH 096/199] .travis.yml: don't run revdeps on the coverage build Signed-off-by: Marcello Seri --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index aae9bc664c2..fbe3589f99d 100644 --- a/.travis.yml +++ b/.travis.yml @@ -13,7 +13,7 @@ env: - TEST=false - BASE_REMOTE="https://github.com/xapi-project/xs-opam" matrix: - - PACKAGE=xapi-stdext OCAML_VERSION=4.04.2 REVDEPS=true \ + - PACKAGE=xapi-stdext OCAML_VERSION=4.04.2 \ POST_INSTALL_HOOK="opam install alcotest; env TRAVIS=$TRAVIS TRAVIS_JOB_ID=$TRAVIS_JOB_ID bash -ex coverage.sh" - PACKAGE=stdext OCAML_VERSION=4.04.2 REVDEPS=true - PACKAGE=xapi-stdext OCAML_VERSION=4.06.0 From 1b708d157937039ab70caf63cbd75527c70297d8 Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Thu, 24 May 2018 14:48:01 +0100 Subject: [PATCH 097/199] unixext: update interface to mimick the ocaml Unix one See e.g. https://github.com/ocaml/ocaml/blob/trunk/otherlibs/unix/unix.ml#L328-L332 Signed-off-by: Marcello Seri --- lib/xapi-stdext-unix/unixext.ml | 25 ++++++++++++++++++++----- lib/xapi-stdext-unix/unixext.mli | 14 +++++++++++--- 2 files changed, 31 insertions(+), 8 deletions(-) diff --git a/lib/xapi-stdext-unix/unixext.ml b/lib/xapi-stdext-unix/unixext.ml index fd931e6d8ce..d5fa475d30d 100644 --- a/lib/xapi-stdext-unix/unixext.ml +++ b/lib/xapi-stdext-unix/unixext.ml @@ -188,7 +188,8 @@ let write_bytes_to_file fname b = let written = Unix.write fd b 0 len in if written <> len then (failwith "Short write occured!")) -let write_string_to_file fname s = write_bytes_to_file fname (Bytes.unsafe_of_string s) +let write_string_to_file fname s = + write_bytes_to_file fname (Bytes.unsafe_of_string s) let execv_get_output cmd args = let (pipe_exit, pipe_entrance) = Unix.pipe () in @@ -480,7 +481,7 @@ exception Timeout (* Write as many bytes to a file descriptor as possible from data before a given clock time. *) (* Raises Timeout exception if the number of bytes written is less than the specified length. *) (* Writes into the file descriptor at the current cursor position. *) -let time_limited_write filedesc length data target_response_time = +let time_limited_write_internal (write : Unix.file_descr -> 'a -> int -> int -> int) filedesc length data target_response_time = let total_bytes_to_write = length in let bytes_written = ref 0 in let now = ref (Unix.gettimeofday()) in @@ -489,13 +490,20 @@ let time_limited_write filedesc length data target_response_time = let (_, ready_to_write, _) = Unix.select [] [filedesc] [] remaining_time in (* Note: there is a possibility that the storage could go away after the select and before the write, so the write would block. *) if List.mem filedesc ready_to_write then begin let bytes_to_write = total_bytes_to_write - !bytes_written in - let bytes = (try Unix.write filedesc data !bytes_written bytes_to_write with Unix.Unix_error(Unix.EAGAIN,_,_) | Unix.Unix_error(Unix.EWOULDBLOCK,_,_) -> 0) in (* write from buffer=data from offset=bytes_written, length=bytes_to_write *) + let bytes = (try write filedesc data !bytes_written bytes_to_write with Unix.Unix_error(Unix.EAGAIN,_,_) | Unix.Unix_error(Unix.EWOULDBLOCK,_,_) -> 0) in (* write from buffer=data from offset=bytes_written, length=bytes_to_write *) bytes_written := bytes + !bytes_written; end; now := Unix.gettimeofday() done; if !bytes_written = total_bytes_to_write then () else (* we ran out of time *) raise Timeout +let time_limited_write filedesc length data target_response_time = + time_limited_write_internal Unix.write filedesc length data target_response_time + +let time_limited_write_substring filedesc length data target_response_time = + time_limited_write_internal Unix.write_substring filedesc length data target_response_time + + (* Read as many bytes to a file descriptor as possible before a given clock time. *) (* Raises Timeout exception if the number of bytes read is less than the desired number. *) (* Reads from the file descriptor at the current cursor position. *) @@ -521,7 +529,7 @@ let time_limited_read filedesc length target_response_time = (* Read a given number of bytes of data from the fd, or stop at EOF, whichever comes first. *) (* A negative ~max_bytes indicates that all the data should be read from the fd until EOF. This is the default. *) -let read_data_in_chunks (f : string -> int -> unit) ?(block_size = 1024) ?(max_bytes = -1) from_fd = +let read_data_in_chunks_internal (sub : bytes -> int -> int -> 'a) (f : 'a -> int -> unit) ?(block_size = 1024) ?(max_bytes = -1) from_fd = let buf = Bytes.make block_size '\000' in let rec do_read acc = let remaining_bytes = max_bytes - acc in @@ -531,12 +539,18 @@ let read_data_in_chunks (f : string -> int -> unit) ?(block_size = 1024) ?(max_b let bytes_read = Unix.read from_fd buf 0 bytes_to_read in if bytes_read = 0 then acc (* we reached EOF *) else begin - f (Bytes.sub_string buf 0 bytes_read) bytes_read; + f (sub buf 0 bytes_read) bytes_read; do_read (acc + bytes_read) end end in do_read 0 +let read_data_in_string_chunks (f : string -> int -> unit) ?(block_size = 1024) ?(max_bytes = -1) from_fd = + read_data_in_chunks_internal Bytes.sub_string f ~block_size ~max_bytes from_fd + +let read_data_in_chunks (f : bytes -> int -> unit) ?(block_size = 1024) ?(max_bytes = -1) from_fd = + read_data_in_chunks_internal Bytes.sub f ~block_size ~max_bytes from_fd + let spawnvp ?(pid_callback=(fun _ -> ())) cmd args = match Unix.fork () with | 0 -> @@ -658,6 +672,7 @@ let wait_for_path path delay timeout = let _ = Callback.register_exception "unixext.unix_error" (Unix_error (0)) let send_fd = Fd_send_recv.send_fd +let send_fd_substring = Fd_send_recv.send_fd_substring let recv_fd = Fd_send_recv.recv_fd type statvfs_t = { diff --git a/lib/xapi-stdext-unix/unixext.mli b/lib/xapi-stdext-unix/unixext.mli index d65047a95b2..71c5dd8e835 100644 --- a/lib/xapi-stdext-unix/unixext.mli +++ b/lib/xapi-stdext-unix/unixext.mli @@ -63,7 +63,11 @@ val buffer_of_file : string -> Buffer.t val string_of_file : string -> string val atomic_write_to_file : string -> Unix.file_perm -> (Unix.file_descr -> 'a) -> 'a + +(** Atomically write a string to a file *) val write_string_to_file : string -> string -> unit + +(** Atomically write a bytes to a file *) val write_bytes_to_file : string -> bytes -> unit val execv_get_output : string -> string array -> int * Unix.file_descr val copy_file : ?limit:int64 -> Unix.file_descr -> Unix.file_descr -> int64 @@ -98,6 +102,7 @@ val string_of_signal : int -> string val proxy : Unix.file_descr -> Unix.file_descr -> unit val really_read : Unix.file_descr -> bytes -> int -> int -> unit val really_read_string : Unix.file_descr -> int -> string + (** [really_write] keeps repeating the write operation until all bytes * have been written or an error occurs. This is not atomic but is * robust against EINTR errors. @@ -107,8 +112,10 @@ val really_write_string : Unix.file_descr -> string -> unit val try_read_string : ?limit: int -> Unix.file_descr -> string exception Timeout val time_limited_write : Unix.file_descr -> int -> bytes -> float -> unit +val time_limited_write_substring : Unix.file_descr -> int -> string -> float -> unit val time_limited_read : Unix.file_descr -> int -> float -> string -val read_data_in_chunks : (string -> int -> unit) -> ?block_size:int -> ?max_bytes:int -> Unix.file_descr -> int +val read_data_in_string_chunks : (string -> int -> unit) -> ?block_size:int -> ?max_bytes:int -> Unix.file_descr -> int +val read_data_in_chunks : (bytes -> int -> unit) -> ?block_size:int -> ?max_bytes:int -> Unix.file_descr -> int val spawnvp : ?pid_callback:(int -> unit) -> string -> string array -> Unix.process_status @@ -145,8 +152,9 @@ end val wait_for_path : string -> (float -> unit) -> int -> unit -val send_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> Unix.file_descr -> int -val recv_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr * Unix.file_descr +val send_fd : Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> Unix.file_descr -> int +val send_fd_substring : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> Unix.file_descr -> int +val recv_fd : Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr * Unix.file_descr type statvfs_t = { f_bsize : int64; From 6fd0d53f99ad4ce60188e5ca086092a520697c9c Mon Sep 17 00:00:00 2001 From: Marcello Seri Date: Thu, 24 May 2018 15:37:50 +0100 Subject: [PATCH 098/199] xapi-stdext-unix: update opam file Signed-off-by: Marcello Seri --- xapi-stdext-unix.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam index 4d30f1728e2..f7fb55e9a63 100644 --- a/xapi-stdext-unix.opam +++ b/xapi-stdext-unix.opam @@ -11,7 +11,7 @@ build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] depends: [ "jbuilder" {build} "base-unix" - "fd-send-recv" + "fd-send-recv" {>= "2.0.0"} "xapi-stdext-pervasives" "xapi-stdext-std" ] From f00572e67b7cdc4f88e27e01db7ba9ddd8131e34 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 30 May 2018 14:59:42 +0100 Subject: [PATCH 099/199] CP-28365: do not loose the backtrace in Mutex.execute MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- lib/xapi-stdext-threads/threadext.ml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/lib/xapi-stdext-threads/threadext.ml b/lib/xapi-stdext-threads/threadext.ml index 8af91066ca2..d3f8300f7a7 100644 --- a/lib/xapi-stdext-threads/threadext.ml +++ b/lib/xapi-stdext-threads/threadext.ml @@ -18,7 +18,13 @@ module Mutex = struct (** execute the function f with the mutex hold *) let execute lock f = Mutex.lock lock; - let r = begin try f () with exn -> Mutex.unlock lock; raise exn end; in + let r = + try f () + with exn -> + Backtrace.is_important exn; + Mutex.unlock lock; + raise exn + in Mutex.unlock lock; r end From 2e5f211f7a380bf588964c377f8c75ff8a8d0ec8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 30 May 2018 15:07:36 +0100 Subject: [PATCH 100/199] CP-28365: do not loose backtraces in Mutex.execute MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `Backtrace.is_important` was not called. We have a `finally` function that does the proper thing wrt to backtraces, use it. xapi-stdext-pervasives is a dependency of xapi-stdext-threads already, so this does not introduce a new dependency. Signed-off-by: Edwin Török --- lib/xapi-stdext-threads/threadext.ml | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/lib/xapi-stdext-threads/threadext.ml b/lib/xapi-stdext-threads/threadext.ml index d3f8300f7a7..1249810f02d 100644 --- a/lib/xapi-stdext-threads/threadext.ml +++ b/lib/xapi-stdext-threads/threadext.ml @@ -18,15 +18,7 @@ module Mutex = struct (** execute the function f with the mutex hold *) let execute lock f = Mutex.lock lock; - let r = - try f () - with exn -> - Backtrace.is_important exn; - Mutex.unlock lock; - raise exn - in - Mutex.unlock lock; - r + Xapi_stdext_pervasives.Pervasiveext.finally f (fun () -> Mutex.unlock lock) end From 90178daacb817638486b21b5f3198f62a40828af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 30 May 2018 15:09:14 +0100 Subject: [PATCH 101/199] CP-28365: improve backtraces in with_file MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- lib/xapi-stdext-unix/unixext.ml | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/lib/xapi-stdext-unix/unixext.ml b/lib/xapi-stdext-unix/unixext.ml index d5fa475d30d..e49c672dce3 100644 --- a/lib/xapi-stdext-unix/unixext.ml +++ b/lib/xapi-stdext-unix/unixext.ml @@ -148,12 +148,9 @@ let fd_blocks_fold block_size f start fd = let with_directory dir f = let dh = Unix.opendir dir in - let r = - try f dh - with exn -> Unix.closedir dh; raise exn - in - Unix.closedir dh; - r + Xapi_stdext_pervasives.Pervasiveext.finally + (fun () -> f dh) + (fun () -> Unix.closedir dh) let buffer_of_fd fd = fd_blocks_fold 1024 (fun b s -> Buffer.add_bytes b s; b) (Buffer.create 1024) fd From 5401c045dee4bc17eac49cbc2469c71e51c66c09 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 30 May 2018 14:25:25 +0000 Subject: [PATCH 102/199] CP-28365: improve backtraces in daemonize MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit We've got a `with_file` in this same file, use it instead of reimplementing it, so we get the improved backtraces. Signed-off-by: Edwin Török --- lib/xapi-stdext-unix/unixext.ml | 29 ++++++++++++----------------- 1 file changed, 12 insertions(+), 17 deletions(-) diff --git a/lib/xapi-stdext-unix/unixext.ml b/lib/xapi-stdext-unix/unixext.ml index e49c672dce3..33084a058cc 100644 --- a/lib/xapi-stdext-unix/unixext.ml +++ b/lib/xapi-stdext-unix/unixext.ml @@ -63,6 +63,13 @@ let pidfile_read filename = with _ -> None) (fun () -> Unix.close fd) +(** open a file, and make sure the close is always done *) +let with_file file mode perms f = + let fd = Unix.openfile file mode perms in + Xapi_stdext_pervasives.Pervasiveext.finally + (fun () -> f fd) + (fun () -> Unix.close fd) + (** daemonize a process *) (* !! Must call this before spawning any threads !! *) let daemonize () = @@ -73,14 +80,11 @@ let daemonize () = begin match Unix.fork () with | 0 -> - let nullfd = Unix.openfile "/dev/null" [ Unix.O_WRONLY ] 0 in - begin try - Unix.close Unix.stdin; - Unix.dup2 nullfd Unix.stdout; - Unix.dup2 nullfd Unix.stderr; - with exn -> Unix.close nullfd; raise exn - end; - Unix.close nullfd + with_file "/dev/null" [ Unix.O_WRONLY ] 0 + (fun nullfd -> + Unix.close Unix.stdin; + Unix.dup2 nullfd Unix.stdout; + Unix.dup2 nullfd Unix.stderr) | _ -> exit 0 end | _ -> exit 0 @@ -115,15 +119,6 @@ let with_input_channel file f = (fun () -> f input) (fun () -> close_in input) -(** open a file, and make sure the close is always done *) -let with_file file mode perms f = - let fd = Unix.openfile file mode perms in - let r = - try f fd - with exn -> Unix.close fd; raise exn - in - Unix.close fd; - r let file_lines_fold f start file_path = with_input_channel file_path (lines_fold f start) From adba34e984cd5d5b93c937426c1155500ae7595f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 30 May 2018 14:26:29 +0000 Subject: [PATCH 103/199] CP-28365: improve backtraces in Unixext.open_connection* MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit We cannot use finally here, because the socket is only closed on failure. Signed-off-by: Edwin Török --- lib/xapi-stdext-unix/unixext.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/lib/xapi-stdext-unix/unixext.ml b/lib/xapi-stdext-unix/unixext.ml index 33084a058cc..6bbc6e86f70 100644 --- a/lib/xapi-stdext-unix/unixext.ml +++ b/lib/xapi-stdext-unix/unixext.ml @@ -254,6 +254,7 @@ let open_connection_fd host port = connect s ai.ai_addr; s with e -> + Backtrace.is_important e; close s; raise e @@ -263,7 +264,10 @@ let open_connection_unix_fd filename = let addr = Unix.ADDR_UNIX(filename) in Unix.connect s addr; s - with e -> Unix.close s; raise e + with e -> + Backtrace.is_important e; + Unix.close s; + raise e module CBuf = struct (** A circular buffer constructed from a string *) From b78eb0e1cfe646c7334243a32d9d9866e3b3cd2f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 30 May 2018 15:17:58 +0100 Subject: [PATCH 104/199] CP-28365: improve stacktraces in Semaphore.execute_with_weight MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- lib/xapi-stdext-threads/semaphore.ml | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/lib/xapi-stdext-threads/semaphore.ml b/lib/xapi-stdext-threads/semaphore.ml index 4f9bb365997..2f52a835df4 100644 --- a/lib/xapi-stdext-threads/semaphore.ml +++ b/lib/xapi-stdext-threads/semaphore.ml @@ -55,13 +55,8 @@ let release s k = let execute_with_weight s k f = acquire s k; - try - let x = f () in - release s k; - x - with e -> - release s k; - raise e + Xapi_stdext_pervasives.Pervasiveext.finally f + (fun () -> release s k) let execute s f = execute_with_weight s 1 f From fde0cf6e649e88716552b00f6f077a3757b4f114 Mon Sep 17 00:00:00 2001 From: Gabor Igloi Date: Thu, 28 Jun 2018 11:55:12 +0100 Subject: [PATCH 105/199] CA-292641: Use Logs to log cleanup exn instead of shadowing the original one with it Use the Logs library to report the cleanup exception we caught. This way, we don't have to depend on xcp-idl. In xcp-idl, a Logs reporter will be registered, which collects the log messages from Logs and reports them in the usual way. Signed-off-by: Gabor Igloi --- lib/xapi-stdext-pervasives/jbuild | 4 +++- lib/xapi-stdext-pervasives/pervasiveext.ml | 11 ++++++++++- xapi-stdext-pervasives.opam | 1 + 3 files changed, 14 insertions(+), 2 deletions(-) diff --git a/lib/xapi-stdext-pervasives/jbuild b/lib/xapi-stdext-pervasives/jbuild index 548f2c516bf..8280ad3145d 100644 --- a/lib/xapi-stdext-pervasives/jbuild +++ b/lib/xapi-stdext-pervasives/jbuild @@ -3,5 +3,7 @@ (library ((name xapi_stdext_pervasives) (public_name xapi-stdext-pervasives) - (libraries (xapi-backtrace)) + (libraries + (logs + xapi-backtrace)) )) diff --git a/lib/xapi-stdext-pervasives/pervasiveext.ml b/lib/xapi-stdext-pervasives/pervasiveext.ml index 21322693098..29277481f97 100644 --- a/lib/xapi-stdext-pervasives/pervasiveext.ml +++ b/lib/xapi-stdext-pervasives/pervasiveext.ml @@ -15,6 +15,8 @@ * Even if fct raises an exception, clean_f is applied *) +let src = Logs.Src.create "pervasiveext" ~doc:"logs from Xapi_stdext_pervasives.Pervasiveext" + let finally fct clean_f = let result = @@ -22,7 +24,14 @@ let finally fct clean_f = fct (); with exn -> Backtrace.is_important exn; - clean_f (); + begin + (* We catch and log exceptions raised by clean_f to avoid shadowing + the original exception raised by fct *) + try + clean_f (); + with cleanup_exn -> + Logs.warn ~src (fun m -> m "finally: Error while running cleanup after failure of main function: %s" (Printexc.to_string cleanup_exn)); + end; raise exn in clean_f (); result diff --git a/xapi-stdext-pervasives.opam b/xapi-stdext-pervasives.opam index 027a7871ea9..6d1d208f096 100644 --- a/xapi-stdext-pervasives.opam +++ b/xapi-stdext-pervasives.opam @@ -10,5 +10,6 @@ build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] depends: [ "jbuilder" {build} + "logs" "xapi-backtrace" ] From 3b3f070b2016e50e8349475195ebf3aa24a5bcb7 Mon Sep 17 00:00:00 2001 From: Gabor Igloi Date: Wed, 4 Jul 2018 17:30:30 +0100 Subject: [PATCH 106/199] Update .travis.yml after move to ocaml 4.06 Signed-off-by: Gabor Igloi --- .travis.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index fbe3589f99d..511bcdcd830 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,14 +9,14 @@ script: bash -ex ./.travis-docker.sh env: global: - PINS="stdext:. xapi-stdext:. xapi-stdext-base64:. xapi-stdext-bigbuffer:. xapi-stdext-date:. xapi-stdext-deprecated:. xapi-stdext-encodings:. xapi-stdext-monadic:. xapi-stdext-pervasives:. xapi-stdext-range:. xapi-stdext-std:. xapi-stdext-threads:. xapi-stdext-unix:. xapi-stdext-zerocheck:." + - OCAML_VERSION=4.06.0 - DISTRO="ubuntu-16.04" - TEST=false - BASE_REMOTE="https://github.com/xapi-project/xs-opam" matrix: - - PACKAGE=xapi-stdext OCAML_VERSION=4.04.2 \ + - PACKAGE=xapi-stdext \ POST_INSTALL_HOOK="opam install alcotest; env TRAVIS=$TRAVIS TRAVIS_JOB_ID=$TRAVIS_JOB_ID bash -ex coverage.sh" - - PACKAGE=stdext OCAML_VERSION=4.04.2 REVDEPS=true - - PACKAGE=xapi-stdext OCAML_VERSION=4.06.0 + - PACKAGE=stdext REVDEPS=true matrix: fast_finish: true allow_failures: From 66baac0731e5acae6516d64422e4edbaccd212b0 Mon Sep 17 00:00:00 2001 From: Gabor Igloi Date: Wed, 4 Jul 2018 18:24:20 +0100 Subject: [PATCH 107/199] Prepare to release 4.4.0 Signed-off-by: Gabor Igloi --- ChangeLog | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/ChangeLog b/ChangeLog index aec19591daf..b6ff032c6a2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,18 @@ +4.4.0 (05-Jul-2018): -- xapi-stdext-pervasives only +* CA-292641: Use Logs to log cleanup exn instead of shadowing the original one with it + +4.3.0 (30-May-2018): +* CP-28365: improve backtraces by using finally + +4.2.0 (25-May-2018): -- xapi-stdext-unix only +* unixext: update interface to mimick the ocaml Unix one + +4.1.0 (25-Apr-2018): -- xapi-stdext-unix only +* really_write: + - use single_write_substring and avoid an unsafe coercion + - remove deprecation and make robust against EINTR +* unixext_open_stubs: fix use of uninitialised variable + 4.0.0 (15-Mar-2018): * Make safe-string safe (xap-stdext-{bigbuffer, encodings, std, threads, unix} 1.1.0) * Remove bigbuffer from the default stdext set of packages From d83c54a9dae804c2f4ca7d5358f85373ecf3e3a6 Mon Sep 17 00:00:00 2001 From: Konstantina Chremmou Date: Fri, 18 Jan 2019 17:24:24 +0000 Subject: [PATCH 108/199] Replaced jbuild files with dune. Signed-off-by: Konstantina Chremmou --- .travis.yml | 4 ++-- Makefile | 19 +++++++++---------- dune-project | 1 + lib/xapi-stdext-base64/dune | 5 +++++ lib/xapi-stdext-base64/jbuild | 7 ------- lib/xapi-stdext-bigbuffer/dune | 4 ++++ lib/xapi-stdext-bigbuffer/jbuild | 6 ------ lib/xapi-stdext-date/dune | 5 +++++ lib/xapi-stdext-date/jbuild | 7 ------- lib/xapi-stdext-deprecated/dune | 4 ++++ lib/xapi-stdext-deprecated/jbuild | 6 ------ lib/xapi-stdext-encodings/dune | 14 ++++++++++++++ lib/xapi-stdext-encodings/jbuild | 20 -------------------- lib/xapi-stdext-monadic/dune | 4 ++++ lib/xapi-stdext-monadic/jbuild | 6 ------ lib/xapi-stdext-pervasives/dune | 7 +++++++ lib/xapi-stdext-pervasives/jbuild | 9 --------- lib/xapi-stdext-range/dune | 4 ++++ lib/xapi-stdext-range/jbuild | 6 ------ lib/xapi-stdext-std/dune | 7 +++++++ lib/xapi-stdext-std/jbuild | 8 -------- lib/xapi-stdext-threads/dune | 8 ++++++++ lib/xapi-stdext-threads/jbuild | 9 --------- lib/xapi-stdext-unix/dune | 14 ++++++++++++++ lib/xapi-stdext-unix/jbuild | 14 -------------- lib/xapi-stdext-zerocheck/dune | 5 +++++ lib/xapi-stdext-zerocheck/jbuild | 7 ------- lib/xapi-stdext/dune | 18 ++++++++++++++++++ lib/xapi-stdext/jbuild | 20 -------------------- lib_test/dune | 12 ++++++++++++ lib_test/jbuild | 11 ----------- stdext.opam | 15 ++++++++++++--- xapi-stdext-base64.opam | 11 ++++++++--- xapi-stdext-bigbuffer.opam | 11 ++++++++--- xapi-stdext-date.opam | 11 ++++++++--- xapi-stdext-deprecated.opam | 11 ++++++++--- xapi-stdext-encodings.opam | 13 ++++++++----- xapi-stdext-monadic.opam | 12 +++++++++--- xapi-stdext-pervasives.opam | 12 +++++++++--- xapi-stdext-range.opam | 11 ++++++++--- xapi-stdext-std.opam | 12 +++++++++--- xapi-stdext-threads.opam | 12 +++++++++--- xapi-stdext-unix.opam | 12 +++++++++--- xapi-stdext-zerocheck.opam | 11 ++++++++--- xapi-stdext.opam | 9 +++++++-- 45 files changed, 243 insertions(+), 191 deletions(-) create mode 100644 dune-project create mode 100644 lib/xapi-stdext-base64/dune delete mode 100644 lib/xapi-stdext-base64/jbuild create mode 100644 lib/xapi-stdext-bigbuffer/dune delete mode 100644 lib/xapi-stdext-bigbuffer/jbuild create mode 100644 lib/xapi-stdext-date/dune delete mode 100644 lib/xapi-stdext-date/jbuild create mode 100644 lib/xapi-stdext-deprecated/dune delete mode 100644 lib/xapi-stdext-deprecated/jbuild create mode 100644 lib/xapi-stdext-encodings/dune delete mode 100644 lib/xapi-stdext-encodings/jbuild create mode 100644 lib/xapi-stdext-monadic/dune delete mode 100644 lib/xapi-stdext-monadic/jbuild create mode 100644 lib/xapi-stdext-pervasives/dune delete mode 100644 lib/xapi-stdext-pervasives/jbuild create mode 100644 lib/xapi-stdext-range/dune delete mode 100644 lib/xapi-stdext-range/jbuild create mode 100644 lib/xapi-stdext-std/dune delete mode 100644 lib/xapi-stdext-std/jbuild create mode 100644 lib/xapi-stdext-threads/dune delete mode 100644 lib/xapi-stdext-threads/jbuild create mode 100644 lib/xapi-stdext-unix/dune delete mode 100644 lib/xapi-stdext-unix/jbuild create mode 100644 lib/xapi-stdext-zerocheck/dune delete mode 100644 lib/xapi-stdext-zerocheck/jbuild create mode 100644 lib/xapi-stdext/dune delete mode 100644 lib/xapi-stdext/jbuild create mode 100644 lib_test/dune delete mode 100644 lib_test/jbuild diff --git a/.travis.yml b/.travis.yml index 511bcdcd830..1984d45a63a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,7 +9,7 @@ script: bash -ex ./.travis-docker.sh env: global: - PINS="stdext:. xapi-stdext:. xapi-stdext-base64:. xapi-stdext-bigbuffer:. xapi-stdext-date:. xapi-stdext-deprecated:. xapi-stdext-encodings:. xapi-stdext-monadic:. xapi-stdext-pervasives:. xapi-stdext-range:. xapi-stdext-std:. xapi-stdext-threads:. xapi-stdext-unix:. xapi-stdext-zerocheck:." - - OCAML_VERSION=4.06.0 + - OCAML_VERSION=4.07 - DISTRO="ubuntu-16.04" - TEST=false - BASE_REMOTE="https://github.com/xapi-project/xs-opam" @@ -20,4 +20,4 @@ env: matrix: fast_finish: true allow_failures: - - env: PACKAGE=xapi-stdext OCAML_VERSION=4.06.0 + - env: PACKAGE=xapi-stdext OCAML_VERSION=4.07 diff --git a/Makefile b/Makefile index 38298ce7145..869934e782d 100644 --- a/Makefile +++ b/Makefile @@ -1,26 +1,25 @@ -.PHONY: build release install uninstall clean test doc reindent +PROFILE=release -build: - jbuilder build @install --dev +.PHONY: build install uninstall clean test doc reindent -release: - jbuilder build @install +build: + dune build @install --profile=$(PROFILE) install: - jbuilder install + dune install uninstall: - jbuilder uninstall + dune uninstall clean: - jbuilder clean + dune clean test: - jbuilder runtest + dune runtest --profile=$(PROFILE) # requires odoc doc: - jbuilder build @doc + dune build @doc --profile=$(PROFILE) reindent: ocp-indent --syntax cstruct -i **/*.ml* diff --git a/dune-project b/dune-project new file mode 100644 index 00000000000..f9337290c30 --- /dev/null +++ b/dune-project @@ -0,0 +1 @@ +(lang dune 1.4) diff --git a/lib/xapi-stdext-base64/dune b/lib/xapi-stdext-base64/dune new file mode 100644 index 00000000000..cbe9ad05511 --- /dev/null +++ b/lib/xapi-stdext-base64/dune @@ -0,0 +1,5 @@ +(library + (name xapi_stdext_base64) + (public_name xapi-stdext-base64) + (libraries base64) +) diff --git a/lib/xapi-stdext-base64/jbuild b/lib/xapi-stdext-base64/jbuild deleted file mode 100644 index cbdee36ee69..00000000000 --- a/lib/xapi-stdext-base64/jbuild +++ /dev/null @@ -1,7 +0,0 @@ -(jbuild_version 1) - -(library - ((name xapi_stdext_base64) - (public_name xapi-stdext-base64) - (libraries (base64)) - )) diff --git a/lib/xapi-stdext-bigbuffer/dune b/lib/xapi-stdext-bigbuffer/dune new file mode 100644 index 00000000000..7371a90039e --- /dev/null +++ b/lib/xapi-stdext-bigbuffer/dune @@ -0,0 +1,4 @@ +(library + (name xapi_stdext_bigbuffer) + (public_name xapi-stdext-bigbuffer) +) diff --git a/lib/xapi-stdext-bigbuffer/jbuild b/lib/xapi-stdext-bigbuffer/jbuild deleted file mode 100644 index ab0bb66be93..00000000000 --- a/lib/xapi-stdext-bigbuffer/jbuild +++ /dev/null @@ -1,6 +0,0 @@ -(jbuild_version 1) - -(library - ((name xapi_stdext_bigbuffer) - (public_name xapi-stdext-bigbuffer) - )) diff --git a/lib/xapi-stdext-date/dune b/lib/xapi-stdext-date/dune new file mode 100644 index 00000000000..bab6d638963 --- /dev/null +++ b/lib/xapi-stdext-date/dune @@ -0,0 +1,5 @@ +(library + (name xapi_stdext_date) + (public_name xapi-stdext-date) + (libraries unix) +) diff --git a/lib/xapi-stdext-date/jbuild b/lib/xapi-stdext-date/jbuild deleted file mode 100644 index 24c3784c76f..00000000000 --- a/lib/xapi-stdext-date/jbuild +++ /dev/null @@ -1,7 +0,0 @@ -(jbuild_version 1) - -(library - ((name xapi_stdext_date) - (public_name xapi-stdext-date) - (libraries (unix)) - )) diff --git a/lib/xapi-stdext-deprecated/dune b/lib/xapi-stdext-deprecated/dune new file mode 100644 index 00000000000..5f301254133 --- /dev/null +++ b/lib/xapi-stdext-deprecated/dune @@ -0,0 +1,4 @@ +(library + (name xapi_stdext_deprecated) + (public_name xapi-stdext-deprecated) +) diff --git a/lib/xapi-stdext-deprecated/jbuild b/lib/xapi-stdext-deprecated/jbuild deleted file mode 100644 index a4ef03d6d6c..00000000000 --- a/lib/xapi-stdext-deprecated/jbuild +++ /dev/null @@ -1,6 +0,0 @@ -(jbuild_version 1) - -(library - ((name xapi_stdext_deprecated) - (public_name xapi-stdext-deprecated) - )) diff --git a/lib/xapi-stdext-encodings/dune b/lib/xapi-stdext-encodings/dune new file mode 100644 index 00000000000..18baebe4081 --- /dev/null +++ b/lib/xapi-stdext-encodings/dune @@ -0,0 +1,14 @@ +(* -*- tuareg -*- *) +let coverage_rewriter = + match Sys.getenv "BISECT_ENABLE" with + | "YES" -> "(preprocess (pps bisect_ppx -conditional))" + | _ -> "" +| exception Not_found -> "" + +let () = Printf.ksprintf Jbuild_plugin.V1.send {| +(library + (name xapi_stdext_encodings) + (public_name xapi-stdext-encodings) + %s +) +|} coverage_rewriter diff --git a/lib/xapi-stdext-encodings/jbuild b/lib/xapi-stdext-encodings/jbuild deleted file mode 100644 index c02ad6f30ec..00000000000 --- a/lib/xapi-stdext-encodings/jbuild +++ /dev/null @@ -1,20 +0,0 @@ -(* -*- tuareg -*- *) -#require "unix" - -let coverage_rewriter ~full = - let is_coverage = try Unix.getenv "BISECT_ENABLE" = "YES" with Not_found -> false in - match is_coverage, full with - | true, true -> "(preprocess (pps (bisect_ppx -conditional)))" - | true, _ -> "bisect_ppx -conditional" - | _ -> "" - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| -(jbuild_version 1) - -(library - ((name xapi_stdext_encodings) - (public_name xapi-stdext-encodings) - %s - ) -) -|} (coverage_rewriter ~full:true) diff --git a/lib/xapi-stdext-monadic/dune b/lib/xapi-stdext-monadic/dune new file mode 100644 index 00000000000..a59f002a3ee --- /dev/null +++ b/lib/xapi-stdext-monadic/dune @@ -0,0 +1,4 @@ +(library + (public_name xapi-stdext-monadic) + (name xapi_stdext_monadic) +) diff --git a/lib/xapi-stdext-monadic/jbuild b/lib/xapi-stdext-monadic/jbuild deleted file mode 100644 index 987d00edd39..00000000000 --- a/lib/xapi-stdext-monadic/jbuild +++ /dev/null @@ -1,6 +0,0 @@ -(jbuild_version 1) - -(library - ((public_name xapi-stdext-monadic) - (name xapi_stdext_monadic) - )) diff --git a/lib/xapi-stdext-pervasives/dune b/lib/xapi-stdext-pervasives/dune new file mode 100644 index 00000000000..2a12545a2b9 --- /dev/null +++ b/lib/xapi-stdext-pervasives/dune @@ -0,0 +1,7 @@ +(library + (name xapi_stdext_pervasives) + (public_name xapi-stdext-pervasives) + (libraries + logs + xapi-backtrace) +) diff --git a/lib/xapi-stdext-pervasives/jbuild b/lib/xapi-stdext-pervasives/jbuild deleted file mode 100644 index 8280ad3145d..00000000000 --- a/lib/xapi-stdext-pervasives/jbuild +++ /dev/null @@ -1,9 +0,0 @@ -(jbuild_version 1) - -(library - ((name xapi_stdext_pervasives) - (public_name xapi-stdext-pervasives) - (libraries - (logs - xapi-backtrace)) - )) diff --git a/lib/xapi-stdext-range/dune b/lib/xapi-stdext-range/dune new file mode 100644 index 00000000000..7980c5c5776 --- /dev/null +++ b/lib/xapi-stdext-range/dune @@ -0,0 +1,4 @@ +(library + (name xapi_stdext_range) + (public_name xapi-stdext-range) +) diff --git a/lib/xapi-stdext-range/jbuild b/lib/xapi-stdext-range/jbuild deleted file mode 100644 index 2dda5f268da..00000000000 --- a/lib/xapi-stdext-range/jbuild +++ /dev/null @@ -1,6 +0,0 @@ -(jbuild_version 1) - -(library - ((name xapi_stdext_range) - (public_name xapi-stdext-range) - )) diff --git a/lib/xapi-stdext-std/dune b/lib/xapi-stdext-std/dune new file mode 100644 index 00000000000..c05d4afd3b6 --- /dev/null +++ b/lib/xapi-stdext-std/dune @@ -0,0 +1,7 @@ +(library + (public_name xapi-stdext-std) + (name xapi_stdext_std) + (libraries + uuidm + xapi-stdext-monadic) +) diff --git a/lib/xapi-stdext-std/jbuild b/lib/xapi-stdext-std/jbuild deleted file mode 100644 index 52ec1d3d6aa..00000000000 --- a/lib/xapi-stdext-std/jbuild +++ /dev/null @@ -1,8 +0,0 @@ -(jbuild_version 1) - -(library - ((public_name xapi-stdext-std) - (name xapi_stdext_std) - (libraries (uuidm - xapi-stdext-monadic)) - )) diff --git a/lib/xapi-stdext-threads/dune b/lib/xapi-stdext-threads/dune new file mode 100644 index 00000000000..ecf854e37d0 --- /dev/null +++ b/lib/xapi-stdext-threads/dune @@ -0,0 +1,8 @@ +(library + (public_name xapi-stdext-threads) + (name xapi_stdext_threads) + (libraries + threads + unix + xapi-stdext-pervasives) +) diff --git a/lib/xapi-stdext-threads/jbuild b/lib/xapi-stdext-threads/jbuild deleted file mode 100644 index 643d4cf8d86..00000000000 --- a/lib/xapi-stdext-threads/jbuild +++ /dev/null @@ -1,9 +0,0 @@ -(jbuild_version 1) - -(library - ((public_name xapi-stdext-threads) - (name xapi_stdext_threads) - (libraries (threads - unix - xapi-stdext-pervasives)) - )) diff --git a/lib/xapi-stdext-unix/dune b/lib/xapi-stdext-unix/dune new file mode 100644 index 00000000000..6e3a9f9385f --- /dev/null +++ b/lib/xapi-stdext-unix/dune @@ -0,0 +1,14 @@ +(library + (name xapi_stdext_unix) + (public_name xapi-stdext-unix) + (c_names + blkgetsize_stubs + unixext_open_stubs + unixext_stubs + unixext_write_stubs) + (libraries + fd-send-recv + unix + xapi-stdext-pervasives + xapi-stdext-std) +) diff --git a/lib/xapi-stdext-unix/jbuild b/lib/xapi-stdext-unix/jbuild deleted file mode 100644 index bb0bcf20bdf..00000000000 --- a/lib/xapi-stdext-unix/jbuild +++ /dev/null @@ -1,14 +0,0 @@ -(jbuild_version 1) - -(library - ((name xapi_stdext_unix) - (public_name xapi-stdext-unix) - (c_names (blkgetsize_stubs - unixext_open_stubs - unixext_stubs - unixext_write_stubs)) - (libraries (fd-send-recv - unix - xapi-stdext-pervasives - xapi-stdext-std)) - )) diff --git a/lib/xapi-stdext-zerocheck/dune b/lib/xapi-stdext-zerocheck/dune new file mode 100644 index 00000000000..ef68c063d5c --- /dev/null +++ b/lib/xapi-stdext-zerocheck/dune @@ -0,0 +1,5 @@ +(library + (public_name xapi-stdext-zerocheck) + (name xapi_stdext_zerocheck) + (c_names zerocheck_stub) +) diff --git a/lib/xapi-stdext-zerocheck/jbuild b/lib/xapi-stdext-zerocheck/jbuild deleted file mode 100644 index 51074336f76..00000000000 --- a/lib/xapi-stdext-zerocheck/jbuild +++ /dev/null @@ -1,7 +0,0 @@ -(jbuild_version 1) - -(library - ((public_name xapi-stdext-zerocheck) - (name xapi_stdext_zerocheck) - (c_names (zerocheck_stub)) - )) diff --git a/lib/xapi-stdext/dune b/lib/xapi-stdext/dune new file mode 100644 index 00000000000..950149989a6 --- /dev/null +++ b/lib/xapi-stdext/dune @@ -0,0 +1,18 @@ +(library + (public_name stdext) + (name stdext) + (modules stdext) + (wrapped false) + (libraries + xapi-stdext-base64 + xapi-stdext-date + xapi-stdext-deprecated + xapi-stdext-encodings + xapi-stdext-monadic + xapi-stdext-pervasives + xapi-stdext-range + xapi-stdext-std + xapi-stdext-threads + xapi-stdext-unix + xapi-stdext-zerocheck) +) diff --git a/lib/xapi-stdext/jbuild b/lib/xapi-stdext/jbuild deleted file mode 100644 index 3d8cdad6f43..00000000000 --- a/lib/xapi-stdext/jbuild +++ /dev/null @@ -1,20 +0,0 @@ -(jbuild_version 1) - -(library - ((public_name stdext) - (name stdext) - (modules (stdext)) - (wrapped false) - (libraries (xapi-stdext-base64 - xapi-stdext-date - xapi-stdext-deprecated - xapi-stdext-encodings - xapi-stdext-monadic - xapi-stdext-pervasives - xapi-stdext-range - xapi-stdext-std - xapi-stdext-threads - xapi-stdext-unix - xapi-stdext-zerocheck)) - )) - diff --git a/lib_test/dune b/lib_test/dune new file mode 100644 index 00000000000..b49deeb2370 --- /dev/null +++ b/lib_test/dune @@ -0,0 +1,12 @@ +(executable + (name suite) + (libraries + alcotest + xapi_stdext_encodings) +) + +(alias + (name runtest) + (deps (:x suite.exe)) + (action (run %{x})) +) diff --git a/lib_test/jbuild b/lib_test/jbuild deleted file mode 100644 index 6d2aafedc93..00000000000 --- a/lib_test/jbuild +++ /dev/null @@ -1,11 +0,0 @@ -(executable - ((name suite) - (libraries - (alcotest - xapi_stdext_encodings)) - )) - -(alias - ((name runtest) - (deps (suite.exe)) - (action (run ${<})))) diff --git a/stdext.opam b/stdext.opam index 0c40570b63a..bc43416e2f4 100644 --- a/stdext.opam +++ b/stdext.opam @@ -1,4 +1,4 @@ -opam-version: "1.2" +opam-version: "2.0" maintainer: "jonathan.ludlam@citrix.com" authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" @@ -6,10 +6,11 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] +build: [[ "dune" "build" "-p" name "-j" jobs ]] depends: [ - "jbuilder" {build} + "ocaml" + "dune" {build} "xapi-stdext-base64" "xapi-stdext-date" "xapi-stdext-deprecated" @@ -22,3 +23,11 @@ depends: [ "xapi-stdext-unix" "xapi-stdext-zerocheck" ] +synopsis: "A deprecated collection of utility functions" +description: """ +Backward compatibility wrapper, this is introduced along with +xapi-stdext-3.0.0 and will be removed once the oasis files of the +necessary packages have been updated. + +This library is provided for a transitionary period only. +No new code should use this library.""" diff --git a/xapi-stdext-base64.opam b/xapi-stdext-base64.opam index 2a8ba83b23e..be96a5795e2 100644 --- a/xapi-stdext-base64.opam +++ b/xapi-stdext-base64.opam @@ -1,4 +1,4 @@ -opam-version: "1.2" +opam-version: "2.0" maintainer: "jonathan.ludlam@citrix.com" authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" @@ -6,9 +6,14 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] +build: [[ "dune" "build" "-p" name "-j" jobs ]] depends: [ - "jbuilder" {build} + "ocaml" + "dune" {build} "base64" ] +synopsis: "A deprecated collection of utility functions - Base64 module" +description: """ +This library is provided for a transitionary period only. +No new code should use this library.""" diff --git a/xapi-stdext-bigbuffer.opam b/xapi-stdext-bigbuffer.opam index b747c86b99d..aac6e717f1b 100644 --- a/xapi-stdext-bigbuffer.opam +++ b/xapi-stdext-bigbuffer.opam @@ -1,4 +1,4 @@ -opam-version: "1.2" +opam-version: "2.0" maintainer: "jonathan.ludlam@citrix.com" authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" @@ -6,8 +6,13 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] +build: [[ "dune" "build" "-p" name "-j" jobs ]] depends: [ - "jbuilder" {build} + "ocaml" + "dune" {build} ] +synopsis: "A deprecated collection of utility functions - bigbuffer module" +description: """ +This library is provided for a transitionary period only. +No new code should use this library.""" diff --git a/xapi-stdext-date.opam b/xapi-stdext-date.opam index e5e0300273c..e4c64986eff 100644 --- a/xapi-stdext-date.opam +++ b/xapi-stdext-date.opam @@ -1,4 +1,4 @@ -opam-version: "1.2" +opam-version: "2.0" maintainer: "jonathan.ludlam@citrix.com" authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" @@ -6,9 +6,14 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] +build: [[ "dune" "build" "-p" name "-j" jobs ]] depends: [ - "jbuilder" {build} + "ocaml" + "dune" {build} "base-unix" ] +synopsis: "A deprecated collection of utility functions - Date module" +description: """ +This library is provided for a transitionary period only. +No new code should use this library.""" diff --git a/xapi-stdext-deprecated.opam b/xapi-stdext-deprecated.opam index b747c86b99d..1ff7b82a6a2 100644 --- a/xapi-stdext-deprecated.opam +++ b/xapi-stdext-deprecated.opam @@ -1,4 +1,4 @@ -opam-version: "1.2" +opam-version: "2.0" maintainer: "jonathan.ludlam@citrix.com" authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" @@ -6,8 +6,13 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] +build: [[ "dune" "build" "-p" name "-j" jobs ]] depends: [ - "jbuilder" {build} + "ocaml" + "dune" {build} ] +synopsis: "A deprecated collection of utility functions - Deprecated modules" +description: """ +This library is provided for a transitionary period only. +No new code should use this library.""" diff --git a/xapi-stdext-encodings.opam b/xapi-stdext-encodings.opam index f01635bace0..a42b701827d 100644 --- a/xapi-stdext-encodings.opam +++ b/xapi-stdext-encodings.opam @@ -1,4 +1,4 @@ -opam-version: "1.2" +opam-version: "2.0" maintainer: "jonathan.ludlam@citrix.com" authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" @@ -6,10 +6,13 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] -build-test: ["jbuilder" "runtest" "-p" name "-j" jobs] +build: [[ "dune" "build" "-p" name "-j" jobs ]] depends: [ - "jbuilder" {build} - "alcotest" {test} + "ocaml" + "dune" {build} ] +synopsis: "A deprecated collection of utility functions - Encodings module" +description: """ +This library is provided for a transitionary period only. +No new code should use this library.""" diff --git a/xapi-stdext-monadic.opam b/xapi-stdext-monadic.opam index b747c86b99d..ac1d465b221 100644 --- a/xapi-stdext-monadic.opam +++ b/xapi-stdext-monadic.opam @@ -1,4 +1,4 @@ -opam-version: "1.2" +opam-version: "2.0" maintainer: "jonathan.ludlam@citrix.com" authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" @@ -6,8 +6,14 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] +build: [[ "dune" "build" "-p" name "-j" jobs ]] depends: [ - "jbuilder" {build} + "ocaml" + "dune" {build} ] +synopsis: + "A deprecated collection of utility functions - Monadic modules (Monad, Listext, Either)" +description: """ +This library is provided for a transitionary period only. +No new code should use this library.""" diff --git a/xapi-stdext-pervasives.opam b/xapi-stdext-pervasives.opam index 6d1d208f096..2d61db939b9 100644 --- a/xapi-stdext-pervasives.opam +++ b/xapi-stdext-pervasives.opam @@ -1,4 +1,4 @@ -opam-version: "1.2" +opam-version: "2.0" maintainer: "jonathan.ludlam@citrix.com" authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" @@ -6,10 +6,16 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] +build: [[ "dune" "build" "-p" name "-j" jobs ]] depends: [ - "jbuilder" {build} + "ocaml" + "dune" {build} "logs" "xapi-backtrace" ] +synopsis: + "A deprecated collection of utility functions - Pervasives extension" +description: """ +This library is provided for a transitionary period only. +No new code should use this library.""" diff --git a/xapi-stdext-range.opam b/xapi-stdext-range.opam index b747c86b99d..e9eff09c027 100644 --- a/xapi-stdext-range.opam +++ b/xapi-stdext-range.opam @@ -1,4 +1,4 @@ -opam-version: "1.2" +opam-version: "2.0" maintainer: "jonathan.ludlam@citrix.com" authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" @@ -6,8 +6,13 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] +build: [[ "dune" "build" "-p" name "-j" jobs ]] depends: [ - "jbuilder" {build} + "ocaml" + "dune" {build} ] +synopsis: "A deprecated collection of utility functions - Range module" +description: """ +This library is provided for a transitionary period only. +No new code should use this library.""" diff --git a/xapi-stdext-std.opam b/xapi-stdext-std.opam index 01b8c3cd6b7..b5ae1dceb91 100644 --- a/xapi-stdext-std.opam +++ b/xapi-stdext-std.opam @@ -1,4 +1,4 @@ -opam-version: "1.2" +opam-version: "2.0" maintainer: "jonathan.ludlam@citrix.com" authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" @@ -6,10 +6,16 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] +build: [[ "dune" "build" "-p" name "-j" jobs ]] depends: [ - "jbuilder" {build} + "ocaml" + "dune" {build} "uuidm" "xapi-stdext-monadic" ] +synopsis: + "A deprecated collection of utility functions - Standard library extensions" +description: """ +This library is provided for a transitionary period only. +No new code should use this library.""" diff --git a/xapi-stdext-threads.opam b/xapi-stdext-threads.opam index 03b87fb1252..c4496192ae9 100644 --- a/xapi-stdext-threads.opam +++ b/xapi-stdext-threads.opam @@ -1,4 +1,4 @@ -opam-version: "1.2" +opam-version: "2.0" maintainer: "jonathan.ludlam@citrix.com" authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" @@ -6,11 +6,17 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] +build: [[ "dune" "build" "-p" name "-j" jobs ]] depends: [ - "jbuilder" {build} + "ocaml" + "dune" {build} "base-threads" "base-unix" "xapi-stdext-pervasives" ] +synopsis: + "A deprecated collection of utility functions - Threads extensions and Semaphore" +description: """ +This library is provided for a transitionary period only. +No new code should use this library.""" diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam index f7fb55e9a63..f8985bfd130 100644 --- a/xapi-stdext-unix.opam +++ b/xapi-stdext-unix.opam @@ -1,4 +1,4 @@ -opam-version: "1.2" +opam-version: "2.0" maintainer: "jonathan.ludlam@citrix.com" authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" @@ -6,12 +6,18 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] +build: [[ "dune" "build" "-p" name "-j" jobs ]] depends: [ - "jbuilder" {build} + "ocaml" + "dune" {build} "base-unix" "fd-send-recv" {>= "2.0.0"} "xapi-stdext-pervasives" "xapi-stdext-std" ] +synopsis: + "A deprecated collection of utility functions - Unix module extensions" +description: """ +This library is provided for a transitionary period only. +No new code should use this library.""" diff --git a/xapi-stdext-zerocheck.opam b/xapi-stdext-zerocheck.opam index b747c86b99d..49339481cdc 100644 --- a/xapi-stdext-zerocheck.opam +++ b/xapi-stdext-zerocheck.opam @@ -1,4 +1,4 @@ -opam-version: "1.2" +opam-version: "2.0" maintainer: "jonathan.ludlam@citrix.com" authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" @@ -6,8 +6,13 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [[ "jbuilder" "build" "-p" name "-j" jobs ]] +build: [[ "dune" "build" "-p" name "-j" jobs ]] depends: [ - "jbuilder" {build} + "ocaml" + "dune" {build} ] +synopsis: "A deprecated collection of utility functions - Zerocheck module" +description: """ +This library is provided for a transitionary period only. +No new code should use this library.""" diff --git a/xapi-stdext.opam b/xapi-stdext.opam index aa485e1e34b..aba8746e7fb 100644 --- a/xapi-stdext.opam +++ b/xapi-stdext.opam @@ -1,4 +1,4 @@ -opam-version: "1.2" +opam-version: "2.0" maintainer: "jonathan.ludlam@citrix.com" authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" @@ -6,4 +6,9 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -depends: [ "stdext" ] +depends: ["ocaml" "stdext"] +synopsis: "Deprecated xapi standard library extension" +description: """ +This is a dummy package to facilitate the migration to xapi-stdext 3.0.0 +of oasis-built packages, where several package were split out of the main +stdext package and the findlib name changed from stdext to xapi-stdext.""" From 9881dfb3d028a7d0411cf71e6ff8b62f4e2c5689 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Wed, 13 Mar 2019 16:05:58 +0000 Subject: [PATCH 109/199] CA-310525 fix C binding for statvfs We rarely see statvfs return 0 for bfree and suspect that this is a GC related problem. The existing implementation violates rule 6 in the OCaml manual https://caml.inria.fr/pub/docs/manual-ocaml/intfc.html#sec442 which mandates to use caml_modify when updating a field with an existing value. This commit handles this by using Store_field. See also the discussion at https://discuss.ocaml.org/t/finding-gc-problems-in-c-bindings/3453/2 Signed-off-by: Christian Lindig --- lib/xapi-stdext-unix/unixext_stubs.c | 36 ++++++++++------------------ 1 file changed, 13 insertions(+), 23 deletions(-) diff --git a/lib/xapi-stdext-unix/unixext_stubs.c b/lib/xapi-stdext-unix/unixext_stubs.c index af948060077..c65c34b1c47 100644 --- a/lib/xapi-stdext-unix/unixext_stubs.c +++ b/lib/xapi-stdext-unix/unixext_stubs.c @@ -315,36 +315,26 @@ CAMLprim value stub_fdset_is_empty(value set) CAMLprim value stub_statvfs(value filename) { CAMLparam1(filename); - CAMLlocal2(v,tmp); + CAMLlocal1(v); int ret; - int i; struct statvfs buf; ret = statvfs(String_val(filename), &buf); if(ret == -1) uerror("statvfs", Nothing); - tmp=caml_copy_int64(0); - - /* Allocate the thing to return and ensure each of the - fields is set to something valid before attempting - any further allocations */ - v=alloc_small(11,0); - for(i=0; i<11; i++) { - Field(v,i)=tmp; - } - - Field(v,0)=caml_copy_int64(buf.f_bsize); - Field(v,1)=caml_copy_int64(buf.f_frsize); - Field(v,2)=caml_copy_int64(buf.f_blocks); - Field(v,3)=caml_copy_int64(buf.f_bfree); - Field(v,4)=caml_copy_int64(buf.f_bavail); - Field(v,5)=caml_copy_int64(buf.f_files); - Field(v,6)=caml_copy_int64(buf.f_ffree); - Field(v,7)=caml_copy_int64(buf.f_favail); - Field(v,8)=caml_copy_int64(buf.f_fsid); - Field(v,9)=caml_copy_int64(buf.f_flag); - Field(v,10)=caml_copy_int64(buf.f_namemax); + v=caml_alloc(11,0); + Store_field(v, 0, caml_copy_int64(buf.f_bsize)); + Store_field(v, 1, caml_copy_int64(buf.f_frsize)); + Store_field(v, 2, caml_copy_int64(buf.f_blocks)); + Store_field(v, 3, caml_copy_int64(buf.f_bfree)); + Store_field(v, 4, caml_copy_int64(buf.f_bavail)); + Store_field(v, 5, caml_copy_int64(buf.f_files)); + Store_field(v, 6, caml_copy_int64(buf.f_ffree)); + Store_field(v, 7, caml_copy_int64(buf.f_favail)); + Store_field(v, 8, caml_copy_int64(buf.f_fsid)); + Store_field(v, 9, caml_copy_int64(buf.f_flag)); + Store_field(v,10, caml_copy_int64(buf.f_namemax)); CAMLreturn(v); } From b9877a041efcaba53ca2e3bcbf099d90eb242f60 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Wed, 13 Mar 2019 16:54:24 +0000 Subject: [PATCH 110/199] Update .travis.yml Signed-off-by: Christian Lindig --- .travis.yml | 25 +++++++------------------ 1 file changed, 7 insertions(+), 18 deletions(-) diff --git a/.travis.yml b/.travis.yml index 1984d45a63a..c1eadd59078 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,23 +1,12 @@ language: c -sudo: false -services: - - docker -install: - - wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh - - wget https://raw.githubusercontent.com/xapi-project/xapi-travis-scripts/master/coverage.sh -script: bash -ex ./.travis-docker.sh +sudo: required +service: docker +install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh +script: bash -ex .travis-docker.sh env: global: + - PACKAGE="xapi-stdext" - PINS="stdext:. xapi-stdext:. xapi-stdext-base64:. xapi-stdext-bigbuffer:. xapi-stdext-date:. xapi-stdext-deprecated:. xapi-stdext-encodings:. xapi-stdext-monadic:. xapi-stdext-pervasives:. xapi-stdext-range:. xapi-stdext-std:. xapi-stdext-threads:. xapi-stdext-unix:. xapi-stdext-zerocheck:." - - OCAML_VERSION=4.07 - - DISTRO="ubuntu-16.04" - - TEST=false - - BASE_REMOTE="https://github.com/xapi-project/xs-opam" + - BASE_REMOTE="https://github.com/xapi-project/xs-opam.git" matrix: - - PACKAGE=xapi-stdext \ - POST_INSTALL_HOOK="opam install alcotest; env TRAVIS=$TRAVIS TRAVIS_JOB_ID=$TRAVIS_JOB_ID bash -ex coverage.sh" - - PACKAGE=stdext REVDEPS=true -matrix: - fast_finish: true - allow_failures: - - env: PACKAGE=xapi-stdext OCAML_VERSION=4.07 + - DISTRO="debian-9-ocaml-4.07" From d353a2ae145b75f18e4aef144920c38f559bd6a6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 2 Apr 2019 11:32:32 +0100 Subject: [PATCH 111/199] CA-314001: release runtime lock around long running system calls MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit In CA-314001 VM import was running fsync, which caused all other threads in XAPI to be blocked, which in turn caused the HA xapi health checker to fence the host. We should release the runtime lock whenever we perform a syscall, especially those that perform I/O, since they can block for a long time (minutes) if there are a lot of dirty pages and the storage is slow. The change here follows the recommendations from the manual section 20.12.2 Parallel execution of long-running C code http://caml.inria.fr/pub/docs/manual-ocaml/intfc.html Signed-off-by: Edwin Török --- lib/xapi-stdext-unix/unixext_stubs.c | 26 +++++++++++++++++++++++--- 1 file changed, 23 insertions(+), 3 deletions(-) diff --git a/lib/xapi-stdext-unix/unixext_stubs.c b/lib/xapi-stdext-unix/unixext_stubs.c index c65c34b1c47..3afbdd31b1b 100644 --- a/lib/xapi-stdext-unix/unixext_stubs.c +++ b/lib/xapi-stdext-unix/unixext_stubs.c @@ -34,6 +34,7 @@ #include #include #include +#include /* Set the TCP_NODELAY flag on a Unix.file_descr */ CAMLprim value stub_unixext_set_tcp_nodelay (value fd, value bool) @@ -51,7 +52,12 @@ CAMLprim value stub_unixext_fsync (value fd) { CAMLparam1(fd); int c_fd = Int_val(fd); - if (fsync(c_fd) != 0) uerror("fsync", Nothing); + int rc; + + caml_release_runtime_system(); + rc = fsync(c_fd); + caml_acquire_runtime_system(); + if (rc != 0) uerror("fsync", Nothing); CAMLreturn(Val_unit); } @@ -62,8 +68,14 @@ CAMLprim value stub_unixext_blkgetsize64(value fd) CAMLparam1(fd); uint64_t size; int c_fd = Int_val(fd); + int rc; + + caml_release_runtime_system(); /* mirage-block-unix binding: */ - if (stdext_blkgetsize(c_fd, &size)) { + rc = stdext_blkgetsize(c_fd, &size); + caml_acquire_runtime_system(); + + if (rc) { uerror("ioctl(BLKGETSIZE64)", Nothing); } CAMLreturn(caml_copy_int64(size)); @@ -319,7 +331,15 @@ CAMLprim value stub_statvfs(value filename) int ret; struct statvfs buf; - ret = statvfs(String_val(filename), &buf); + /* We want to release the runtime lock, so we must copy + * all OCaml arguments. + * See the manual section 20.12.2 Parallel execution of long running C code */ + char *name = caml_stat_strdup(String_val(filename)); + + caml_release_runtime_system(); + ret = statvfs(name, &buf); + caml_stat_free(name); + caml_acquire_runtime_system(); if(ret == -1) uerror("statvfs", Nothing); From 083728fcbf3194da43fd694028221363157c241d Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 19 Mar 2019 09:17:43 +0000 Subject: [PATCH 112/199] CP-30756: Remove Base64 Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-base64/base64.ml | 29 ----------------------------- lib/xapi-stdext-base64/dune | 5 ----- lib/xapi-stdext/dune | 1 - lib/xapi-stdext/stdext.ml | 1 - stdext.opam | 1 - xapi-stdext-base64.opam | 19 ------------------- 6 files changed, 56 deletions(-) delete mode 100644 lib/xapi-stdext-base64/base64.ml delete mode 100644 lib/xapi-stdext-base64/dune delete mode 100644 xapi-stdext-base64.opam diff --git a/lib/xapi-stdext-base64/base64.ml b/lib/xapi-stdext-base64/base64.ml deleted file mode 100644 index a7b35042887..00000000000 --- a/lib/xapi-stdext-base64/base64.ml +++ /dev/null @@ -1,29 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -let encode = B64.encode ?pad:None ?alphabet:None -let decode s = - let sanitize s = - (* ignore control characters: see RFC4648.1 and RFC4648.3 - * https://tools.ietf.org/html/rfc4648#section-3 - * Note: \t = \009, \n = \012, \r = \015, \s = \032 *) - let result = Buffer.create (String.length s) in - for i = 0 to String.length s - 1 do - if (String.unsafe_get s i >= '\000' && String.unsafe_get s i <= '\032') - || String.unsafe_get s i = '\127' - then () - else Buffer.add_char result (String.unsafe_get s i) - done; - Buffer.contents result - in - B64.decode ?alphabet:None (sanitize s) diff --git a/lib/xapi-stdext-base64/dune b/lib/xapi-stdext-base64/dune deleted file mode 100644 index cbe9ad05511..00000000000 --- a/lib/xapi-stdext-base64/dune +++ /dev/null @@ -1,5 +0,0 @@ -(library - (name xapi_stdext_base64) - (public_name xapi-stdext-base64) - (libraries base64) -) diff --git a/lib/xapi-stdext/dune b/lib/xapi-stdext/dune index 950149989a6..352c5263203 100644 --- a/lib/xapi-stdext/dune +++ b/lib/xapi-stdext/dune @@ -4,7 +4,6 @@ (modules stdext) (wrapped false) (libraries - xapi-stdext-base64 xapi-stdext-date xapi-stdext-deprecated xapi-stdext-encodings diff --git a/lib/xapi-stdext/stdext.ml b/lib/xapi-stdext/stdext.ml index acb3f84cfda..bf4a4b72729 100644 --- a/lib/xapi-stdext/stdext.ml +++ b/lib/xapi-stdext/stdext.ml @@ -1,5 +1,4 @@ (* New modules *) -module Base64 = Xapi_stdext_base64.Base64 module Date = Xapi_stdext_date.Date module Encodings = Xapi_stdext_encodings.Encodings module Range = Xapi_stdext_range.Range diff --git a/stdext.opam b/stdext.opam index bc43416e2f4..860d11c1ebb 100644 --- a/stdext.opam +++ b/stdext.opam @@ -11,7 +11,6 @@ build: [[ "dune" "build" "-p" name "-j" jobs ]] depends: [ "ocaml" "dune" {build} - "xapi-stdext-base64" "xapi-stdext-date" "xapi-stdext-deprecated" "xapi-stdext-encodings" diff --git a/xapi-stdext-base64.opam b/xapi-stdext-base64.opam deleted file mode 100644 index be96a5795e2..00000000000 --- a/xapi-stdext-base64.opam +++ /dev/null @@ -1,19 +0,0 @@ -opam-version: "2.0" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" -tags: [ "org:xapi-project" ] - -build: [[ "dune" "build" "-p" name "-j" jobs ]] - -depends: [ - "ocaml" - "dune" {build} - "base64" -] -synopsis: "A deprecated collection of utility functions - Base64 module" -description: """ -This library is provided for a transitionary period only. -No new code should use this library.""" From 504ef673280145cc46dcb84f9f03a47301889c9b Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 7 Nov 2019 14:50:47 +0000 Subject: [PATCH 113/199] ci: do do not pin base64, it doesn't exist --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index c1eadd59078..1b6abc8795e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,7 +6,7 @@ script: bash -ex .travis-docker.sh env: global: - PACKAGE="xapi-stdext" - - PINS="stdext:. xapi-stdext:. xapi-stdext-base64:. xapi-stdext-bigbuffer:. xapi-stdext-date:. xapi-stdext-deprecated:. xapi-stdext-encodings:. xapi-stdext-monadic:. xapi-stdext-pervasives:. xapi-stdext-range:. xapi-stdext-std:. xapi-stdext-threads:. xapi-stdext-unix:. xapi-stdext-zerocheck:." + - PINS="stdext:. xapi-stdext:. xapi-stdext-bigbuffer:. xapi-stdext-date:. xapi-stdext-deprecated:. xapi-stdext-encodings:. xapi-stdext-monadic:. xapi-stdext-pervasives:. xapi-stdext-range:. xapi-stdext-std:. xapi-stdext-threads:. xapi-stdext-unix:. xapi-stdext-zerocheck:." - BASE_REMOTE="https://github.com/xapi-project/xs-opam.git" matrix: - DISTRO="debian-9-ocaml-4.07" From d2e4e42f74b6f355c63af0f155d3444601eb73f5 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 7 Nov 2019 14:53:24 +0000 Subject: [PATCH 114/199] ci: use environment vars from xs-opam Signed-off-by: Pau Ruiz Safont --- .travis.yml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.travis.yml b/.travis.yml index 1b6abc8795e..616e260b5fd 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,12 +1,12 @@ language: c sudo: required service: docker -install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh +install: + - wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh + - wget https://raw.githubusercontent.com/xapi-project/xs-opam/master/tools/xs-opam-ci.env + - source xs-opam-ci.env script: bash -ex .travis-docker.sh env: global: - PACKAGE="xapi-stdext" - PINS="stdext:. xapi-stdext:. xapi-stdext-bigbuffer:. xapi-stdext-date:. xapi-stdext-deprecated:. xapi-stdext-encodings:. xapi-stdext-monadic:. xapi-stdext-pervasives:. xapi-stdext-range:. xapi-stdext-std:. xapi-stdext-threads:. xapi-stdext-unix:. xapi-stdext-zerocheck:." - - BASE_REMOTE="https://github.com/xapi-project/xs-opam.git" - matrix: - - DISTRO="debian-9-ocaml-4.07" From 20119e02e9f51a7a39b883011fac5fb8ad1dc6c1 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 31 Jan 2020 13:40:44 +0000 Subject: [PATCH 115/199] CP-32686: Ensure durability with atomic_write_to_file This fixes the failures when trying to create write-protected files. Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-unix/unixext.ml | 33 ++++++++++++++++++-------------- lib/xapi-stdext-unix/unixext.mli | 5 ++++- 2 files changed, 23 insertions(+), 15 deletions(-) diff --git a/lib/xapi-stdext-unix/unixext.ml b/lib/xapi-stdext-unix/unixext.ml index 6bbc6e86f70..a8d9d9d9c62 100644 --- a/lib/xapi-stdext-unix/unixext.ml +++ b/lib/xapi-stdext-unix/unixext.ml @@ -156,21 +156,26 @@ let buffer_of_file file_path = with_file file_path [ Unix.O_RDONLY ] 0 buffer_of let string_of_file file_path = Buffer.contents (buffer_of_file file_path) -(** Opens a temp file, applies the fd to the function, when the function completes, renames the file - as required. *) +(** Write a file, ensures atomicity and durability. *) let atomic_write_to_file fname perms f = - let module Filenameext = Xapi_stdext_std.Filenameext in - let tmp = Filenameext.temp_file_in_dir fname in - Unix.chmod tmp perms; - finally - (fun () -> - let fd = Unix.openfile tmp [Unix.O_WRONLY; Unix.O_CREAT] perms (* ignored since the file exists *) in - let result = finally - (fun () -> f fd) - (fun () -> Unix.close fd) in - Unix.rename tmp fname; (* Nb this only happens if an exception wasn't raised in the application of f *) - result) - (fun () -> unlink_safe tmp) + let dir_path = Filename.dirname fname in + let tmp_path, tmp_chan = Filename.open_temp_file ~temp_dir:dir_path "" ".tmp" in + let tmp_fd = Unix.descr_of_out_channel tmp_chan in + + let write_tmp_file () = + let result = f tmp_fd in + Unix.fchmod tmp_fd perms; + Unix.fsync tmp_fd; + result + in + let write_and_persist () = + let result = finally write_tmp_file (fun () -> Unix.close tmp_fd) in + Unix.rename tmp_path fname; + (* sync parent directory to make sure the file is persisted *) + Unix.(fsync (openfile dir_path [O_RDONLY] 0)); + result + in + finally write_and_persist (fun () -> unlink_safe tmp_path) (** Atomically write a string to a file *) diff --git a/lib/xapi-stdext-unix/unixext.mli b/lib/xapi-stdext-unix/unixext.mli index 71c5dd8e835..cfb8196b92e 100644 --- a/lib/xapi-stdext-unix/unixext.mli +++ b/lib/xapi-stdext-unix/unixext.mli @@ -62,6 +62,9 @@ val buffer_of_file : string -> Buffer.t (** [string_of_file file] returns a string containing the contents of [file] *) val string_of_file : string -> string +(** [atomic_write_to_file] [fname] [perms] [f] writes a file to path [fname] + using the function [f] with permissions [perms]. In case of error during + the operation the file with the path [fname] is not modified at all. *) val atomic_write_to_file : string -> Unix.file_perm -> (Unix.file_descr -> 'a) -> 'a (** Atomically write a string to a file *) @@ -105,7 +108,7 @@ val really_read_string : Unix.file_descr -> int -> string (** [really_write] keeps repeating the write operation until all bytes * have been written or an error occurs. This is not atomic but is - * robust against EINTR errors. + * robust against EINTR errors. * See: https://ocaml.github.io/ocamlunix/ocamlunix.html#sec118 *) val really_write : Unix.file_descr -> string -> int -> int -> unit val really_write_string : Unix.file_descr -> string -> unit From c69c285c0b21f96828ab3b19a0dd18f934a55414 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 30 Jan 2020 18:01:14 +0000 Subject: [PATCH 116/199] maintenance: whitespace Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-unix/unixext.ml | 36 ++++++++++++++++----------------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/lib/xapi-stdext-unix/unixext.ml b/lib/xapi-stdext-unix/unixext.ml index a8d9d9d9c62..99c93874a7e 100644 --- a/lib/xapi-stdext-unix/unixext.ml +++ b/lib/xapi-stdext-unix/unixext.ml @@ -29,7 +29,7 @@ let mkdir_safe dir perm = let mkdir_rec dir perm = let rec p_mkdir dir = let p_name = Filename.dirname dir in - if p_name <> "/" && p_name <> "." + if p_name <> "/" && p_name <> "." then p_mkdir p_name; mkdir_safe dir perm in p_mkdir dir @@ -44,7 +44,7 @@ let pidfile_write filename = let pid = Unix.getpid () in let buf = string_of_int pid ^ "\n" in let len = String.length buf in - if Unix.write fd (Bytes.unsafe_of_string buf) 0 len <> len + if Unix.write fd (Bytes.unsafe_of_string buf) 0 len <> len then failwith "pidfile_write failed"; ) (fun () -> Unix.close fd) @@ -132,7 +132,7 @@ let readfile_line = file_lines_iter (** [fd_blocks_fold block_size f start fd] folds [f] over blocks (strings) from the fd [fd] with initial value [start] *) -let fd_blocks_fold block_size f start fd = +let fd_blocks_fold block_size f start fd = let block = Bytes.create block_size in let rec fold acc = let n = Unix.read fd block 0 block_size in @@ -147,7 +147,7 @@ let with_directory dir f = (fun () -> f dh) (fun () -> Unix.closedir dh) -let buffer_of_fd fd = +let buffer_of_fd fd = fd_blocks_fold 1024 (fun b s -> Buffer.add_bytes b s; b) (Buffer.create 1024) fd let string_of_fd fd = Buffer.contents (buffer_of_fd fd) @@ -250,8 +250,8 @@ exception Host_not_found of string let open_connection_fd host port = let open Unix in let addrinfo = getaddrinfo host (string_of_int port) [AI_SOCKTYPE SOCK_STREAM] in - match addrinfo with - | [] -> + match addrinfo with + | [] -> failwith (Printf.sprintf "Couldn't resolve hostname: %s" host) | ai :: _ -> let s = socket ai.ai_family ai.ai_socktype 0 in @@ -277,7 +277,7 @@ let open_connection_unix_fd filename = module CBuf = struct (** A circular buffer constructed from a string *) type t = { - mutable buffer: bytes; + mutable buffer: bytes; mutable len: int; (** bytes of valid data in [buffer] *) mutable start: int; (** index of first valid byte in [buffer] *) mutable r_closed: bool; (** true if no more data can be read due to EOF *) @@ -586,12 +586,12 @@ let file_descr_of_int (x: int) : Unix.file_descr = Obj.magic x (** Forcibly closes all open file descriptors except those explicitly passed in as arguments. Useful to avoid accidentally passing a file descriptor opened in another thread to a process being concurrently fork()ed (there's a race between open/set_close_on_exec). - NB this assumes that 'type Unix.file_descr = int' + NB this assumes that 'type Unix.file_descr = int' *) let close_all_fds_except (fds: Unix.file_descr list) = (* get at the file descriptor within *) let fds' = List.map int_of_file_descr fds in - let close' (x: int) = + let close' (x: int) = try Unix.close(file_descr_of_int x) with _ -> () in let highest_to_keep = List.fold_left max (-1) fds' in @@ -604,15 +604,15 @@ let close_all_fds_except (fds: Unix.file_descr list) = (** Remove "." and ".." from paths (NB doesn't attempt to resolve symlinks) *) -let resolve_dot_and_dotdot (path: string) : string = - let of_string (x: string): string list = - let rec rev_split path = - let basename = Filename.basename path +let resolve_dot_and_dotdot (path: string) : string = + let of_string (x: string): string list = + let rec rev_split path = + let basename = Filename.basename path and dirname = Filename.dirname path in let rest = if Filename.dirname dirname = dirname then [] else rev_split dirname in basename :: rest in - let abs_path path = - if Filename.is_relative path + let abs_path path = + if Filename.is_relative path then Filename.concat "/" path (* no notion of a cwd *) else path in rev_split (abs_path x) in @@ -620,7 +620,7 @@ let resolve_dot_and_dotdot (path: string) : string = let to_string (x: string list) = List.fold_left Filename.concat "/" (List.rev x) in (* Process all "." and ".." references *) - let rec remove_dots (n: int) (x: string list) = + let rec remove_dots (n: int) (x: string list) = match x, n with | [], _ -> [] | "." :: rest, _ -> remove_dots n rest (* throw away ".", don't count as parent for ".." *) @@ -640,7 +640,7 @@ let seek_rel fd diff = (** Return the current cursor position within a file descriptor *) let current_cursor_pos fd = (* 'seek' to the current position, exploiting the return value from Unix.lseek as the new cursor position *) - Unix.lseek fd 0 Unix.SEEK_CUR + Unix.lseek fd 0 Unix.SEEK_CUR module Fdset = struct type t @@ -661,7 +661,7 @@ end let wait_for_path path delay timeout = let rec inner ttl = if ttl=0 then failwith "No path!"; - try + try ignore(Unix.stat path) with _ -> delay 0.5; From e49c001927ee112838e173ef8d0711f77f1dc614 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 31 Jan 2020 16:48:07 +0000 Subject: [PATCH 117/199] fixup! CP-32686: Ensure durability with atomic_write_to_file --- lib/xapi-stdext-unix/unixext.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/xapi-stdext-unix/unixext.ml b/lib/xapi-stdext-unix/unixext.ml index 99c93874a7e..51d55d67c1c 100644 --- a/lib/xapi-stdext-unix/unixext.ml +++ b/lib/xapi-stdext-unix/unixext.ml @@ -169,7 +169,7 @@ let atomic_write_to_file fname perms f = result in let write_and_persist () = - let result = finally write_tmp_file (fun () -> Unix.close tmp_fd) in + let result = finally write_tmp_file (fun () -> Stdlib.close_out tmp_chan) in Unix.rename tmp_path fname; (* sync parent directory to make sure the file is persisted *) Unix.(fsync (openfile dir_path [O_RDONLY] 0)); From 17d580cf06b692788d616cebde5ab2c97135dbc3 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 31 Jan 2020 16:57:00 +0000 Subject: [PATCH 118/199] fixup! CP-32686: Ensure durability with atomic_write_to_file --- lib/xapi-stdext-unix/unixext.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/xapi-stdext-unix/unixext.ml b/lib/xapi-stdext-unix/unixext.ml index 51d55d67c1c..caed7a7eb8e 100644 --- a/lib/xapi-stdext-unix/unixext.ml +++ b/lib/xapi-stdext-unix/unixext.ml @@ -172,7 +172,8 @@ let atomic_write_to_file fname perms f = let result = finally write_tmp_file (fun () -> Stdlib.close_out tmp_chan) in Unix.rename tmp_path fname; (* sync parent directory to make sure the file is persisted *) - Unix.(fsync (openfile dir_path [O_RDONLY] 0)); + let dir_fd = Unix.openfile dir_path [O_RDONLY] 0 in + finally (fun () -> Unix.fsync dir_fd) (fun () -> Unix.close dir_fd); result in finally write_and_persist (fun () -> unlink_safe tmp_path) From e8e5d2eff91a4938ddfb61c550b596233ad702d9 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 10 Mar 2020 09:46:42 +0000 Subject: [PATCH 119/199] unixext: better description for write___to_file Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-unix/unixext.mli | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/lib/xapi-stdext-unix/unixext.mli b/lib/xapi-stdext-unix/unixext.mli index cfb8196b92e..4c167f6fafb 100644 --- a/lib/xapi-stdext-unix/unixext.mli +++ b/lib/xapi-stdext-unix/unixext.mli @@ -62,15 +62,17 @@ val buffer_of_file : string -> Buffer.t (** [string_of_file file] returns a string containing the contents of [file] *) val string_of_file : string -> string -(** [atomic_write_to_file] [fname] [perms] [f] writes a file to path [fname] +(** [atomic_write_to_file fname perms f] writes a file to path [fname] using the function [f] with permissions [perms]. In case of error during the operation the file with the path [fname] is not modified at all. *) val atomic_write_to_file : string -> Unix.file_perm -> (Unix.file_descr -> 'a) -> 'a -(** Atomically write a string to a file *) +(** [write_string_to_file fname contents] creates a file with path [fname] + with the string [contents] as its contents, atomically *) val write_string_to_file : string -> string -> unit -(** Atomically write a bytes to a file *) +(** [write_string_to_file fname contents] creates a file with path [fname] + with the buffer [contents] as its contents, atomically *) val write_bytes_to_file : string -> bytes -> unit val execv_get_output : string -> string array -> int * Unix.file_descr val copy_file : ?limit:int64 -> Unix.file_descr -> Unix.file_descr -> int64 From cb5f60dfc136dadd9a28d30a146f75288566a757 Mon Sep 17 00:00:00 2001 From: lippirk Date: Tue, 7 Apr 2020 11:06:38 +0100 Subject: [PATCH 120/199] CA-333908 accept YYYY-MM-DD date format We additionally accept iso8601 datetime strings in the form "YYYY-MM-DDThh:mm:ssZ". This is achieved by trying to parse using ptime first, and falling back on the old method for backwards compatibility. Signed-off-by: lippirk --- lib/xapi-stdext-date/date.ml | 100 +++++++++++++++++++++++----------- lib/xapi-stdext-date/date.mli | 6 +- lib/xapi-stdext-date/dune | 3 +- lib_test/dune | 3 +- lib_test/test_encodings.ml | 50 ++++++++++++++++- xapi-stdext-date.opam | 1 + 6 files changed, 126 insertions(+), 37 deletions(-) diff --git a/lib/xapi-stdext-date/date.ml b/lib/xapi-stdext-date/date.ml index 526fb304b70..b3f888d4b77 100644 --- a/lib/xapi-stdext-date/date.ml +++ b/lib/xapi-stdext-date/date.ml @@ -12,19 +12,9 @@ * GNU Lesser General Public License for more details. *) -type iso8601 = string +(* ==== RFC822 ==== *) type rfc822 = string -let of_float x = - let time = Unix.gmtime x in - Printf.sprintf "%04d%02d%02dT%02d:%02d:%02dZ" - (time.Unix.tm_year+1900) - (time.Unix.tm_mon+1) - time.Unix.tm_mday - time.Unix.tm_hour - time.Unix.tm_min - time.Unix.tm_sec - let months = [| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun"; "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec" |] let days = [| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |] @@ -38,35 +28,79 @@ let rfc822_of_float x = let rfc822_to_string x = x +(* ==== ISO8601/RFC3339 ==== *) + +(** the name doesn't make much sense anymore, but is kept for compatibility reasons *) +type iso8601 = + | UTC of Ptime.t (* rfc3339 - accepts only the date in YYYY-MM-DD format *) + | Legacy of string (* iso8601 - accepts both YYYYMMDD & YYYY-MM-DD *) + + let of_string x = + (** prefer to parse with ptime, but rfc3339 does not accept YYYYMMDD) + * we fallback on legacy parsing to accept iso8601 datetimes *) + match x |> Ptime.of_rfc3339 |> Ptime.rfc3339_error_to_msg with + | Error _ -> let assert_utc x = + try Scanf.sscanf x "%_[0-9]T%_[0-9]:%_[0-9]:%_[0-9]Z" () + with _ -> invalid_arg (Printf.sprintf "date.ml:of_string: %s" x) + in + assert_utc x; Legacy x + | Ok (t, tz, _) -> match tz with + | None | Some 0 -> UTC t + | Some _ -> invalid_arg (Printf.sprintf "date.ml:of_string: %s" x) + +let to_string = function + | Legacy x -> x + | UTC t -> Ptime.to_rfc3339 ~tz_offset_s:0 (* to ensure Z printed, rather than +00:00 *) + t + +let of_float x = + let time = Unix.gmtime x in + Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ" + (time.Unix.tm_year+1900) + (time.Unix.tm_mon+1) + time.Unix.tm_mday + time.Unix.tm_hour + time.Unix.tm_min + time.Unix.tm_sec |> of_string + (* Convert tm in localtime to calendar time, x *) -let to_float_localtime x = - Scanf.sscanf x "%04d%02d%02dT%02d:%02d:%02d" - (fun y mon d h min s -> - fst (Unix.mktime { Unix.tm_year = y - 1900; - tm_mon = mon - 1; - tm_mday = d; - tm_hour = h; - tm_min = min; - tm_sec = s; - (* These are ignored: *) - tm_wday = 0; tm_yday = 0; tm_isdst = true; - })) +let to_float_localtime x = + let datetime_to_float y mon d h min s = + fst Unix.(mktime { tm_year = y - 1900; + tm_mon = mon - 1; + tm_mday = d; + tm_hour = h; + tm_min = min; + tm_sec = s; + (* These are ignored: *) + tm_wday = 0; tm_yday = 0; tm_isdst = true; + }) + in + match x with + | UTC t -> + let ((y, mon, d), ((h, min, s), _)) = Ptime.to_date_time t in + datetime_to_float y mon d h min s + | Legacy x -> + try + Scanf.sscanf x "%04d%02d%02dT%02d:%02d:%02d" (fun y mon d h min s -> + datetime_to_float y mon d h min s + ) + with e -> invalid_arg (Printf.sprintf "date.ml:to_float_localtime: %s" x) (* Convert tm in UTC back into calendar time x (using offset between above UTC and localtime fns to determine offset between UTC and localtime, then correcting for this) *) let to_float x = - let t = Unix.time() in - let offset = (to_float_localtime (of_float t)) -. t in - (to_float_localtime x) -. offset + let t = Unix.time () in + let offset = (t |> of_float |> to_float_localtime) -. t in + to_float_localtime x -. offset -let to_string x = x -let of_string x = x - -let assert_utc x = - try - Scanf.sscanf x "%_[0-9]T%_[0-9]:%_[0-9]:%_[0-9]Z" () - with _ -> invalid_arg x +let assert_utc _ = () let never = of_float 0.0 + +let eq x y = match x, y with + | Legacy _, UTC _ | UTC _, Legacy _ -> false + | UTC x, UTC y -> x = y + | Legacy x, Legacy y -> x = y diff --git a/lib/xapi-stdext-date/date.mli b/lib/xapi-stdext-date/date.mli index 79a1d2b273e..9cf3d2f7190 100644 --- a/lib/xapi-stdext-date/date.mli +++ b/lib/xapi-stdext-date/date.mli @@ -27,12 +27,14 @@ val to_float : iso8601 -> float (** Convert date/time to an ISO 8601 formatted string. *) val to_string : iso8601 -> string -(** Convert ISO 8601 formatted string to a date/time value. *) +(** Convert ISO 8601 formatted string to a date/time value. + * Does not accept a timezone annotated datetime *) val of_string : string -> iso8601 (** Raises an Invalid_argument exception if the given date is not a UTC date. * A UTC date is an ISO 8601 strings that ends with the character 'Z'. *) val assert_utc : iso8601 -> unit +[@@deprecated "assertions performed inside constructors, so this fn does nothing"] (** Representation of the concept "never" (actually 00:00:00 UTC, 1 Jan 1970). *) val never: iso8601 @@ -47,3 +49,5 @@ val rfc822_of_float : float -> rfc822 (** Convert RFC 822 date/time to a formatted string. *) val rfc822_to_string : rfc822 -> string + +val eq : iso8601 -> iso8601 -> bool diff --git a/lib/xapi-stdext-date/dune b/lib/xapi-stdext-date/dune index bab6d638963..5904d2314ea 100644 --- a/lib/xapi-stdext-date/dune +++ b/lib/xapi-stdext-date/dune @@ -1,5 +1,6 @@ (library (name xapi_stdext_date) (public_name xapi-stdext-date) - (libraries unix) + (libraries unix + ptime) ) diff --git a/lib_test/dune b/lib_test/dune index b49deeb2370..00fb223d04c 100644 --- a/lib_test/dune +++ b/lib_test/dune @@ -2,7 +2,8 @@ (name suite) (libraries alcotest - xapi_stdext_encodings) + xapi_stdext_encodings + xapi_stdext_date) ) (alias diff --git a/lib_test/test_encodings.ml b/lib_test/test_encodings.ml index f87396f4de7..2f498bf16f0 100644 --- a/lib_test/test_encodings.ml +++ b/lib_test/test_encodings.ml @@ -516,10 +516,58 @@ module UTF8_codec = struct include E.UTF8_codec end +module Date = struct + open Xapi_stdext_date.Date + let check_float = Alcotest.(check @@ float 1e-2 ) + let check_float_neq = Alcotest.(check @@ neg @@ float 1e-2) + let check_string = Alcotest.(check string) + let check_true str = Alcotest.(check bool) str true + + let iso8601_tests = + let test_of_float_invertible () = + let non_int_time = 1586245987.70200706 in + let time = non_int_time |> Float.floor in + check_float "to_float inverts of_float" time (time |> of_float |> to_float); + check_true "of_float inverts to_float" @@ eq (time |> of_float) (time |> of_float |> to_float |> of_float); + check_float_neq "non-integers don't work" non_int_time (non_int_time |> of_float |> to_float) + in + + let test_of_string_invertible time () = + check_string "to_string inverts of_string" time (time |> of_string |> to_string); + check_true "of_string inverts to_string" (eq (time |> of_string) (time |> of_string |> to_string |> of_string)); + in + + let test_only_utc () = + let utc = "2020-12-20T18:10:19Z" in + let _ = of_string utc in (* UTC is valid *) + let non_utc = "2020-12-20T18:10:19+02:00" in + let exn = Invalid_argument "date.ml:of_string: 2020-12-20T18:10:19+02:00" in + Alcotest.check_raises "only UTC is accepted" exn (fun () -> of_string non_utc |> ignore) + in + + let test_ca333908 () = + let dash_time_str = "2020-04-07T08:28:32Z" in + let no_dash_time_str = "20200407T08:28:32Z" in + test_of_string_invertible dash_time_str (); + test_of_string_invertible no_dash_time_str (); + check_float "dash time and no dash time have same float repr" + (dash_time_str |> of_string |> to_float) + (no_dash_time_str |> of_string |> to_float) + in + + [ "test_of_float_invertible", `Quick, test_of_float_invertible + ; "test_only_utc", `Quick, test_only_utc + ; "test_ca333908", `Quick, test_ca333908 + ] + + let tests = iso8601_tests +end + let tests = UCS .tests @ XML .tests @ String_validator .tests @ UTF8_UCS_validator .tests @ XML_UTF8_UCS_validator.tests @ - UTF8_codec .tests + UTF8_codec .tests @ + Date .tests diff --git a/xapi-stdext-date.opam b/xapi-stdext-date.opam index e4c64986eff..c71d7ee35ff 100644 --- a/xapi-stdext-date.opam +++ b/xapi-stdext-date.opam @@ -12,6 +12,7 @@ depends: [ "ocaml" "dune" {build} "base-unix" + "ptime" ] synopsis: "A deprecated collection of utility functions - Date module" description: """ From 202a80df72c781f5012a79ae38b30d2081f78d4c Mon Sep 17 00:00:00 2001 From: lippirk Date: Thu, 23 Apr 2020 13:38:06 +0100 Subject: [PATCH 121/199] CA-338243 iso8601.to_string backwards compatibility cb5f60dfc136dadd9a28d30a146f75288566a757 meant that any datetimes which are parsable by ptime would be converting to strings containing dashes, but clients have previously expected datetimes coming from the toolstack to be in the form YYYYMMDDTHH:mm:ssZ. We fix this by removing dashes when converting a ptime datetime to a string. Signed-off-by: lippirk fixup! CA-338243 to_string backwards compatibility --- lib/xapi-stdext-date/date.ml | 4 ++-- lib/xapi-stdext-date/dune | 5 +++-- lib_test/test_encodings.ml | 23 ++++++++++++++--------- xapi-stdext-date.opam | 1 + 4 files changed, 20 insertions(+), 13 deletions(-) diff --git a/lib/xapi-stdext-date/date.ml b/lib/xapi-stdext-date/date.ml index b3f888d4b77..91c1ad36396 100644 --- a/lib/xapi-stdext-date/date.ml +++ b/lib/xapi-stdext-date/date.ml @@ -50,8 +50,8 @@ type iso8601 = let to_string = function | Legacy x -> x - | UTC t -> Ptime.to_rfc3339 ~tz_offset_s:0 (* to ensure Z printed, rather than +00:00 *) - t + | UTC t -> Ptime.to_rfc3339 ~tz_offset_s:0 (* to ensure Z printed, rather than +00:00 *) t |> + Astring.String.filter (fun char -> char <> '-') let of_float x = let time = Unix.gmtime x in diff --git a/lib/xapi-stdext-date/dune b/lib/xapi-stdext-date/dune index 5904d2314ea..bf043d6865e 100644 --- a/lib/xapi-stdext-date/dune +++ b/lib/xapi-stdext-date/dune @@ -1,6 +1,7 @@ (library (name xapi_stdext_date) (public_name xapi-stdext-date) - (libraries unix - ptime) + (libraries astring + ptime + unix) ) diff --git a/lib_test/test_encodings.ml b/lib_test/test_encodings.ml index 2f498bf16f0..811da32e3cd 100644 --- a/lib_test/test_encodings.ml +++ b/lib_test/test_encodings.ml @@ -522,6 +522,8 @@ module Date = struct let check_float_neq = Alcotest.(check @@ neg @@ float 1e-2) let check_string = Alcotest.(check string) let check_true str = Alcotest.(check bool) str true + let dash_time_str = "2020-04-07T08:28:32Z" + let no_dash_time_str = "20200407T08:28:32Z" let iso8601_tests = let test_of_float_invertible () = @@ -532,11 +534,6 @@ module Date = struct check_float_neq "non-integers don't work" non_int_time (non_int_time |> of_float |> to_float) in - let test_of_string_invertible time () = - check_string "to_string inverts of_string" time (time |> of_string |> to_string); - check_true "of_string inverts to_string" (eq (time |> of_string) (time |> of_string |> to_string |> of_string)); - in - let test_only_utc () = let utc = "2020-12-20T18:10:19Z" in let _ = of_string utc in (* UTC is valid *) @@ -546,18 +543,26 @@ module Date = struct in let test_ca333908 () = - let dash_time_str = "2020-04-07T08:28:32Z" in - let no_dash_time_str = "20200407T08:28:32Z" in - test_of_string_invertible dash_time_str (); - test_of_string_invertible no_dash_time_str (); check_float "dash time and no dash time have same float repr" (dash_time_str |> of_string |> to_float) (no_dash_time_str |> of_string |> to_float) in + let test_of_string_invertible_when_no_dashes () = + check_string "to_string inverts of_string" no_dash_time_str (no_dash_time_str |> of_string |> to_string); + check_true "of_string inverts to_string" (eq (no_dash_time_str |> of_string) (no_dash_time_str |> of_string |> to_string |> of_string)); + in + + (* CA-338243 - breaking backwards compatibility will break XC and XRT *) + let test_to_string_backwards_compatibility () = + check_string "to_string is backwards compatible" no_dash_time_str (dash_time_str |> of_string |> to_string); + in + [ "test_of_float_invertible", `Quick, test_of_float_invertible ; "test_only_utc", `Quick, test_only_utc ; "test_ca333908", `Quick, test_ca333908 + ; "test_of_string_invertible_when_no_dashes", `Quick, test_of_string_invertible_when_no_dashes + ; "test_to_string_backwards_compatibility", `Quick, test_to_string_backwards_compatibility ] let tests = iso8601_tests diff --git a/xapi-stdext-date.opam b/xapi-stdext-date.opam index c71d7ee35ff..ddee5fbb49e 100644 --- a/xapi-stdext-date.opam +++ b/xapi-stdext-date.opam @@ -11,6 +11,7 @@ build: [[ "dune" "build" "-p" name "-j" jobs ]] depends: [ "ocaml" "dune" {build} + "astring" "base-unix" "ptime" ] From 898cfa409d9ff4c52a43931285cb7d0054b9f8ce Mon Sep 17 00:00:00 2001 From: lippirk Date: Thu, 23 Apr 2020 18:05:09 +0100 Subject: [PATCH 122/199] CA-338243 remove legacy variant in iso8601 We can use ptime to parse any legacy dates by removing any dashes before passing to ptime. Signed-off-by: lippirk --- lib/xapi-stdext-date/date.ml | 51 ++++++++++++++---------------------- 1 file changed, 19 insertions(+), 32 deletions(-) diff --git a/lib/xapi-stdext-date/date.ml b/lib/xapi-stdext-date/date.ml index 91c1ad36396..fca7b9d0efd 100644 --- a/lib/xapi-stdext-date/date.ml +++ b/lib/xapi-stdext-date/date.ml @@ -30,28 +30,26 @@ let rfc822_to_string x = x (* ==== ISO8601/RFC3339 ==== *) -(** the name doesn't make much sense anymore, but is kept for compatibility reasons *) -type iso8601 = - | UTC of Ptime.t (* rfc3339 - accepts only the date in YYYY-MM-DD format *) - | Legacy of string (* iso8601 - accepts both YYYYMMDD & YYYY-MM-DD *) +type iso8601 = Ptime.t let of_string x = - (** prefer to parse with ptime, but rfc3339 does not accept YYYYMMDD) - * we fallback on legacy parsing to accept iso8601 datetimes *) + let x = + try + (* if x doesn't contain dashes, insert them, so that ptime can parse x *) + Scanf.sscanf x "%04d%02d%02dT%s" (fun y mon d rest -> + Printf.sprintf "%04d-%02d-%02dT%s" y mon d rest + ) + with _ -> x + in match x |> Ptime.of_rfc3339 |> Ptime.rfc3339_error_to_msg with - | Error _ -> let assert_utc x = - try Scanf.sscanf x "%_[0-9]T%_[0-9]:%_[0-9]:%_[0-9]Z" () - with _ -> invalid_arg (Printf.sprintf "date.ml:of_string: %s" x) - in - assert_utc x; Legacy x - | Ok (t, tz, _) -> match tz with - | None | Some 0 -> UTC t - | Some _ -> invalid_arg (Printf.sprintf "date.ml:of_string: %s" x) + | Error (`Msg e) -> invalid_arg (Printf.sprintf "date.ml:of_string: %s" e) + | Ok (t, tz, _) -> match tz with + | None | Some 0 -> t + | Some _ -> invalid_arg (Printf.sprintf "date.ml:of_string: %s" x) -let to_string = function - | Legacy x -> x - | UTC t -> Ptime.to_rfc3339 ~tz_offset_s:0 (* to ensure Z printed, rather than +00:00 *) t |> - Astring.String.filter (fun char -> char <> '-') +let to_string t = + Ptime.to_rfc3339 ~tz_offset_s:0 (* to ensure Z printed, rather than +00:00 *) t |> + Astring.String.filter (fun char -> char <> '-') (* remove dashes for backwards compatibility *) let of_float x = let time = Unix.gmtime x in @@ -76,16 +74,8 @@ let to_float_localtime x = tm_wday = 0; tm_yday = 0; tm_isdst = true; }) in - match x with - | UTC t -> - let ((y, mon, d), ((h, min, s), _)) = Ptime.to_date_time t in - datetime_to_float y mon d h min s - | Legacy x -> - try - Scanf.sscanf x "%04d%02d%02dT%02d:%02d:%02d" (fun y mon d h min s -> - datetime_to_float y mon d h min s - ) - with e -> invalid_arg (Printf.sprintf "date.ml:to_float_localtime: %s" x) + let ((y, mon, d), ((h, min, s), _)) = Ptime.to_date_time x in + datetime_to_float y mon d h min s (* Convert tm in UTC back into calendar time x (using offset between above UTC and localtime fns to determine offset between UTC and localtime, then @@ -100,7 +90,4 @@ let assert_utc _ = () let never = of_float 0.0 -let eq x y = match x, y with - | Legacy _, UTC _ | UTC _, Legacy _ -> false - | UTC x, UTC y -> x = y - | Legacy x, Legacy y -> x = y +let eq = Ptime.equal From 67826b769b552e10329081faa5cc294e7b1ca5be Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 22 May 2020 15:04:41 +0100 Subject: [PATCH 123/199] CP-33121: remove obsoleted modules and packages Made monads private so list can still use them. Signed-off-by: Pau Ruiz Safont --- .travis.yml | 2 +- lib/xapi-stdext-bigbuffer/bigbuffer.ml | 98 ------------------------- lib/xapi-stdext-bigbuffer/bigbuffer.mli | 25 ------- lib/xapi-stdext-bigbuffer/dune | 4 - lib/xapi-stdext-deprecated/dune | 4 - lib/xapi-stdext-deprecated/fun.ml | 18 ----- lib/xapi-stdext-deprecated/fun.mli | 10 --- lib/xapi-stdext-monadic/dune | 4 - lib/xapi-stdext-monadic/either.ml | 41 ----------- lib/xapi-stdext-monadic/either.mli | 21 ------ lib/xapi-stdext-monadic/monad.ml | 70 ------------------ lib/xapi-stdext-monadic/monad.mli | 70 ------------------ lib/xapi-stdext-monadic/opt.ml | 80 -------------------- lib/xapi-stdext-monadic/opt.mli | 27 ------- lib/xapi-stdext-range/dune | 4 - lib/xapi-stdext-range/range.ml | 41 ----------- lib/xapi-stdext-range/range.mli | 33 --------- lib/xapi-stdext-std/dune | 4 +- lib/xapi-stdext-std/filenameext.ml | 30 -------- lib/xapi-stdext-std/filenameext.mli | 14 ---- lib/xapi-stdext-std/hashtblext.ml | 42 ----------- lib/xapi-stdext-std/hashtblext.mli | 25 ------- lib/xapi-stdext-std/listext.ml | 19 +---- lib/xapi-stdext-std/listext.mli | 1 - lib/xapi-stdext-unix/unixext.ml | 5 +- lib/xapi-stdext/dune | 3 - lib/xapi-stdext/stdext.ml | 11 --- stdext.opam | 1 - xapi-stdext-bigbuffer.opam | 18 ----- xapi-stdext-deprecated.opam | 18 ----- xapi-stdext-monadic.opam | 19 ----- xapi-stdext-range.opam | 18 ----- xapi-stdext-std.opam | 1 - 33 files changed, 5 insertions(+), 776 deletions(-) delete mode 100644 lib/xapi-stdext-bigbuffer/bigbuffer.ml delete mode 100644 lib/xapi-stdext-bigbuffer/bigbuffer.mli delete mode 100644 lib/xapi-stdext-bigbuffer/dune delete mode 100644 lib/xapi-stdext-deprecated/dune delete mode 100644 lib/xapi-stdext-deprecated/fun.ml delete mode 100644 lib/xapi-stdext-deprecated/fun.mli delete mode 100644 lib/xapi-stdext-monadic/dune delete mode 100644 lib/xapi-stdext-monadic/either.ml delete mode 100644 lib/xapi-stdext-monadic/either.mli delete mode 100644 lib/xapi-stdext-monadic/monad.ml delete mode 100644 lib/xapi-stdext-monadic/monad.mli delete mode 100644 lib/xapi-stdext-monadic/opt.ml delete mode 100644 lib/xapi-stdext-monadic/opt.mli delete mode 100644 lib/xapi-stdext-range/dune delete mode 100644 lib/xapi-stdext-range/range.ml delete mode 100644 lib/xapi-stdext-range/range.mli delete mode 100644 lib/xapi-stdext-std/filenameext.ml delete mode 100644 lib/xapi-stdext-std/filenameext.mli delete mode 100644 lib/xapi-stdext-std/hashtblext.ml delete mode 100644 lib/xapi-stdext-std/hashtblext.mli delete mode 100644 xapi-stdext-bigbuffer.opam delete mode 100644 xapi-stdext-deprecated.opam delete mode 100644 xapi-stdext-monadic.opam delete mode 100644 xapi-stdext-range.opam diff --git a/.travis.yml b/.travis.yml index 616e260b5fd..87cbb784a04 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,4 +9,4 @@ script: bash -ex .travis-docker.sh env: global: - PACKAGE="xapi-stdext" - - PINS="stdext:. xapi-stdext:. xapi-stdext-bigbuffer:. xapi-stdext-date:. xapi-stdext-deprecated:. xapi-stdext-encodings:. xapi-stdext-monadic:. xapi-stdext-pervasives:. xapi-stdext-range:. xapi-stdext-std:. xapi-stdext-threads:. xapi-stdext-unix:. xapi-stdext-zerocheck:." + - PINS="stdext:. xapi-stdext:. xapi-stdext-date:. xapi-stdext-encodings:. xapi-stdext-pervasives:. xapi-stdext-std:. xapi-stdext-threads:. xapi-stdext-unix:. xapi-stdext-zerocheck:." diff --git a/lib/xapi-stdext-bigbuffer/bigbuffer.ml b/lib/xapi-stdext-bigbuffer/bigbuffer.ml deleted file mode 100644 index 512128b2b12..00000000000 --- a/lib/xapi-stdext-bigbuffer/bigbuffer.ml +++ /dev/null @@ -1,98 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -type t = { - mutable cells: bytes option array; - mutable index: int64; -} - -let cell_size = 4096 -let default_array_len = 16 - -let make () = { cells = Array.make default_array_len None; index = 0L } - -let length bigbuf = bigbuf.index - -let get bigbuf n = - let array_offset = Int64.to_int (Int64.div n (Int64.of_int cell_size)) in - let cell_offset = Int64.to_int (Int64.rem n (Int64.of_int cell_size)) in - match bigbuf.cells.(array_offset) with - | None -> "".[0] - | Some buf -> Bytes.get buf cell_offset - -let rec append_substring bigbuf s offset len = - let array_offset = Int64.to_int (Int64.div bigbuf.index (Int64.of_int cell_size)) in - let cell_offset = Int64.to_int (Int64.rem bigbuf.index (Int64.of_int cell_size)) in - - if Array.length bigbuf.cells <= array_offset then ( - (* we need to reallocate the array *) - bigbuf.cells <- Array.append bigbuf.cells (Array.make default_array_len None) - ); - - let buf = match bigbuf.cells.(array_offset) with - | None -> - let newbuf = Bytes.create cell_size in - bigbuf.cells.(array_offset) <- Some newbuf; - newbuf - | Some buf -> - buf - in - if len + cell_offset <= cell_size then ( - String.blit s offset buf cell_offset len; - bigbuf.index <- Int64.add bigbuf.index (Int64.of_int len); - ) else ( - let rlen = cell_size - cell_offset in - String.blit s offset buf cell_offset rlen; - bigbuf.index <- Int64.add bigbuf.index (Int64.of_int rlen); - append_substring bigbuf s (offset + rlen) (len - rlen) - ); - () - -let append_string b s = append_substring b s 0 (String.length s) - -let to_fct bigbuf f = - let array_offset = Int64.to_int (Int64.div bigbuf.index (Int64.of_int cell_size)) in - let cell_offset = Int64.to_int (Int64.rem bigbuf.index (Int64.of_int cell_size)) in - - (* copy all complete cells *) - for i = 0 to array_offset - 1 - do - match bigbuf.cells.(i) with - | None -> (* should never happen *) () - | Some cell -> f (Bytes.to_string cell) - done; - - if(cell_offset > 0) then - (* copy last cell *) - begin match bigbuf.cells.(array_offset) with - | None -> (* Should never happen (any more) *) () - | Some cell -> f (Bytes.sub_string cell 0 cell_offset) - end - - -let to_string bigbuf = - if bigbuf.index > (Int64.of_int Sys.max_string_length) then - failwith "cannot allocate string big enough"; - - let dest = Bytes.create (Int64.to_int bigbuf.index) in - let destoff = ref 0 in - to_fct bigbuf (fun s -> - let len = String.length s in - Bytes.blit_string s 0 dest !destoff len; - destoff := !destoff + len - ); - Bytes.unsafe_to_string dest - -let to_stream bigbuf outchan = - to_fct bigbuf (fun s -> output_string outchan s) diff --git a/lib/xapi-stdext-bigbuffer/bigbuffer.mli b/lib/xapi-stdext-bigbuffer/bigbuffer.mli deleted file mode 100644 index dcb0f183018..00000000000 --- a/lib/xapi-stdext-bigbuffer/bigbuffer.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -type t -val make : unit -> t [@@ocaml.deprecated] -val length : t -> int64 [@@ocaml.deprecated] -val get : t -> int64 -> char [@@ocaml.deprecated] -val append_substring : t -> string -> int -> int -> unit [@@ocaml.deprecated] - -(** [append_string b s] appends the string [x] to the big buffer [b] *) -val append_string : t -> string -> unit [@@ocaml.deprecated] - -val to_fct : t -> (string -> unit) -> unit [@@ocaml.deprecated] -val to_string : t -> string [@@ocaml.deprecated] -val to_stream : t -> out_channel -> unit [@@ocaml.deprecated] diff --git a/lib/xapi-stdext-bigbuffer/dune b/lib/xapi-stdext-bigbuffer/dune deleted file mode 100644 index 7371a90039e..00000000000 --- a/lib/xapi-stdext-bigbuffer/dune +++ /dev/null @@ -1,4 +0,0 @@ -(library - (name xapi_stdext_bigbuffer) - (public_name xapi-stdext-bigbuffer) -) diff --git a/lib/xapi-stdext-deprecated/dune b/lib/xapi-stdext-deprecated/dune deleted file mode 100644 index 5f301254133..00000000000 --- a/lib/xapi-stdext-deprecated/dune +++ /dev/null @@ -1,4 +0,0 @@ -(library - (name xapi_stdext_deprecated) - (public_name xapi-stdext-deprecated) -) diff --git a/lib/xapi-stdext-deprecated/fun.ml b/lib/xapi-stdext-deprecated/fun.ml deleted file mode 100644 index 644f60c0b27..00000000000 --- a/lib/xapi-stdext-deprecated/fun.ml +++ /dev/null @@ -1,18 +0,0 @@ -(* just forgets it's second argument: *) -let const a _ = a - -let uncurry f (a,b) = f a b - -let id a = a - -let flip f a b = f b a - -let on op f x y = op (f x) (f y) - -let comp f g x = f (g x) -let (++) f g x = comp f g x - -let comp2 f g a b = f (g a b) -let (+++) f g a b = comp2 f g a b - -let ($) f a = f a diff --git a/lib/xapi-stdext-deprecated/fun.mli b/lib/xapi-stdext-deprecated/fun.mli deleted file mode 100644 index c394cb92a2c..00000000000 --- a/lib/xapi-stdext-deprecated/fun.mli +++ /dev/null @@ -1,10 +0,0 @@ -val const : 'a -> 'b -> 'a [@@ocaml.deprecated] -val uncurry : ('a -> 'b -> 'c) -> ('a * 'b) -> 'c [@@ocaml.deprecated] -val id : 'a -> 'a [@@ocaml.deprecated] -val flip : ('a -> 'b -> 'c) -> ('b -> 'a -> 'c) [@@ocaml.deprecated] -val on : ('b -> 'b -> 'c) -> ('a -> 'b) -> 'a -> 'a -> 'c [@@ocaml.deprecated] -val comp : ('b -> 'c) -> ('a -> 'b) -> ('a -> 'c) [@@ocaml.deprecated] -val comp2 : ('b -> 'c) -> ('a1 -> 'a2 -> 'b) -> ('a1 -> 'a2 -> 'c) [@@ocaml.deprecated] -val (+++) : ('c -> 'd) -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'd [@@ocaml.deprecated] -val (++) : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c [@@ocaml.deprecated] -val ($) : ('a -> 'b) -> 'a -> 'b [@@ocaml.deprecated] diff --git a/lib/xapi-stdext-monadic/dune b/lib/xapi-stdext-monadic/dune deleted file mode 100644 index a59f002a3ee..00000000000 --- a/lib/xapi-stdext-monadic/dune +++ /dev/null @@ -1,4 +0,0 @@ -(library - (public_name xapi-stdext-monadic) - (name xapi_stdext_monadic) -) diff --git a/lib/xapi-stdext-monadic/either.ml b/lib/xapi-stdext-monadic/either.ml deleted file mode 100644 index 08dd728299c..00000000000 --- a/lib/xapi-stdext-monadic/either.ml +++ /dev/null @@ -1,41 +0,0 @@ -type ('a,'b) t = Left of 'a | Right of 'b - -module Monad = Monad.M2.Make (struct - - type ('a, 'b) m = ('b, 'a) t - - let bind value f = - match value with - | Left value -> Left value - | Right value -> f value - - let return value = Right value - - end) - -let left x = Left x -let right x = Right x -let is_left = function - | Left _ -> true - | Right _ -> false -let is_right x = not (is_left x) -let to_option = function - | Right x -> Some x - | Left _ -> None - -let cat_right l = - let unbox_list a = List.map Opt.unbox (List.filter Opt.is_boxed a) in - unbox_list (List.map to_option l) - -let join = function - | Right (Right x) -> Right x - | Left x -> Left (Left x) - | Right (Left x) -> Left (Right x) - -let swap = function - | Right x -> Left x - | Left x -> Right x - -let of_exception f = - try Right (f ()) - with e -> Left e diff --git a/lib/xapi-stdext-monadic/either.mli b/lib/xapi-stdext-monadic/either.mli deleted file mode 100644 index a603a559510..00000000000 --- a/lib/xapi-stdext-monadic/either.mli +++ /dev/null @@ -1,21 +0,0 @@ -(* Inspired by Haskell's Either, as a way to enhance option with - information about what went wrong. - - Right is commonly used for success - Left is commonly used for failure. -*) - -type ('a,'b) t = Left of 'a | Right of 'b -module Monad : sig include Monad.M2.MONAD with type ('a, 'b) m = ('b, 'a) t end - -val left : 'a -> ('a, 'b) t -val right: 'b -> ('a, 'b) t -val is_left: ('a, 'b) t -> bool -val is_right: ('a, 'b) t -> bool - -val cat_right: ('a, 'b) t list -> 'b list -(* Brings Right values closer to the surface. *) -val join: ('a, ('b, 'c) t) t -> (('a, 'b) t, 'c) t - -val swap : ('a, 'b) t -> ('b, 'a) t -val of_exception : (unit -> 'a) -> (exn, 'a) t diff --git a/lib/xapi-stdext-monadic/monad.ml b/lib/xapi-stdext-monadic/monad.ml deleted file mode 100644 index 250adfdd632..00000000000 --- a/lib/xapi-stdext-monadic/monad.ml +++ /dev/null @@ -1,70 +0,0 @@ -(* - * Copyright (C) 2010-2011 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -(** 1-parameter monads. *) -module M1 = struct - - module type BASE = - sig - type 'a m - val bind : 'a m -> ('a -> 'b m) -> 'b m - val return : 'a -> 'a m - end - - module type MONAD = - sig - type 'a m - val (>>=) : 'a m -> ('a -> 'b m) -> 'b m - val bind : 'a m -> ('a -> 'b m) -> 'b m - val return : 'a -> 'a m - end - - module Make (B : BASE) : MONAD with type 'a m = 'a B.m = - struct - type 'a m = 'a B.m - let (>>=) = B.bind - let bind = B.bind - let return = B.return - end - -end - -(** 2-parameter monads. *) -module M2 = struct - - module type BASE = - sig - type ('a, 'x) m - val bind : ('a, 'x) m -> ('a -> ('b, 'x) m) -> ('b, 'x) m - val return : 'a -> ('a, 'x) m - end - - module type MONAD = - sig - type ('a, 'x) m - val (>>=) : ('a, 'x) m -> ('a -> ('b, 'x) m) -> ('b, 'x) m - val bind : ('a, 'x) m -> ('a -> ('b, 'x) m) -> ('b, 'x) m - val return : 'a -> ('a, 'x) m - end - - module Make (B : BASE) : MONAD with type ('a, 'x) m = ('a, 'x) B.m = - struct - type ('a, 'x) m = ('a, 'x) B.m - let (>>=) = B.bind - let bind = B.bind - let return = B.return - end - -end - diff --git a/lib/xapi-stdext-monadic/monad.mli b/lib/xapi-stdext-monadic/monad.mli deleted file mode 100644 index 2630d83534a..00000000000 --- a/lib/xapi-stdext-monadic/monad.mli +++ /dev/null @@ -1,70 +0,0 @@ -(* - * Copyright (C) 2010-2011 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -(** 1-parameter monads. *) -module M1 : sig - - module type BASE = - sig - type 'a m - val bind : 'a m -> ('a -> 'b m) -> 'b m - val return : 'a -> 'a m - end - - module type MONAD = - sig - type 'a m - val ( >>= ) : 'a m -> ('a -> 'b m) -> 'b m - val bind : 'a m -> ('a -> 'b m) -> 'b m - val return : 'a -> 'a m - end - - module Make : functor (B : BASE) -> - sig - type 'a m = 'a B.m - val ( >>= ) : 'a m -> ('a -> 'b m) -> 'b m - val bind : 'a m -> ('a -> 'b m) -> 'b m - val return : 'a -> 'a m - end - -end - -(** 2-parameter monads. *) -module M2 : sig - - module type BASE = - sig - type ('a, 'b) m - val bind : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m - val return : 'a -> ('a, 'b) m - end - - module type MONAD = - sig - type ('a, 'b) m - val ( >>= ) : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m - val bind : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m - val return : 'a -> ('a, 'b) m - end - - module Make : functor (B : BASE) -> - sig - type ('a, 'b) m = ('a, 'b) B.m - val ( >>= ) : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m - val bind : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m - val return : 'a -> ('a, 'b) m - end - -end - diff --git a/lib/xapi-stdext-monadic/opt.ml b/lib/xapi-stdext-monadic/opt.ml deleted file mode 100644 index 68e37462b53..00000000000 --- a/lib/xapi-stdext-monadic/opt.ml +++ /dev/null @@ -1,80 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -(* Perhaps it's better to use `option' from the ocaml-extlib extension - * to the standard library instead? (Although it would not suffice, - * since it's not a super-set of our `opt'.) - * (http://code.google.com/p/ocaml-extlib/) -*) - -module Monad = Monad.M1.Make (struct - - type 'a m = 'a option - - let bind option f = - match option with - | None -> None - | Some result -> f result - - let return x = Some x - - end) - -let iter f = function - | Some x -> f x - | None -> () - -let map f = function - | Some x -> Some(f x) - | None -> None - -let default d = function - | Some x -> x - | None -> d - -let unbox = function - | Some x -> x - | None -> raise Not_found - -let is_boxed = function - | Some _ -> true - | None -> false - -let is_some = is_boxed - -let is_none = function - | Some _ -> false - | None -> true - -let to_list = function - | Some x -> [x] - | None -> [] - -let fold_left f accu = function - | Some x -> f accu x - | None -> accu - -let fold_right f opt accu = - match opt with - | Some x -> f x accu - | None -> accu - -let join = function - | Some (Some a) -> Some a - | _ -> None - -let of_exception f = - try Some (f ()) - with _ -> None - diff --git a/lib/xapi-stdext-monadic/opt.mli b/lib/xapi-stdext-monadic/opt.mli deleted file mode 100644 index 16ac7e59d5b..00000000000 --- a/lib/xapi-stdext-monadic/opt.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -module Monad : sig include Monad.M1.MONAD with type 'a m = 'a option end -val iter : ('a -> unit) -> 'a option -> unit -val map : ('a -> 'b) -> 'a option -> 'b option -val default : 'a -> 'a option -> 'a -val unbox : 'a option -> 'a -val is_boxed : 'a option -> bool -val is_some : 'a option -> bool -val is_none : 'a option -> bool -val to_list : 'a option -> 'a list -val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b option -> 'a -val fold_right : ('a -> 'b -> 'b) -> 'a option -> 'b -> 'b -val join : ('a option) option -> 'a option -val of_exception : (unit -> 'a) -> 'a option diff --git a/lib/xapi-stdext-range/dune b/lib/xapi-stdext-range/dune deleted file mode 100644 index 7980c5c5776..00000000000 --- a/lib/xapi-stdext-range/dune +++ /dev/null @@ -1,4 +0,0 @@ -(library - (name xapi_stdext_range) - (public_name xapi-stdext-range) -) diff --git a/lib/xapi-stdext-range/range.ml b/lib/xapi-stdext-range/range.ml deleted file mode 100644 index 531acd88fab..00000000000 --- a/lib/xapi-stdext-range/range.ml +++ /dev/null @@ -1,41 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -type t = { l : int; u : int } - -let make l u = - if l <= u then { l = l; u = u } else invalid_arg "Range.make" - -let get r = r.l, r.u - -let mem i r = r.l <= i && i < r.u - -let rec fold_left_aux f accu l u = - if l < u then - fold_left_aux f (f accu l) (l + 1) u - else accu - -let fold_left f accu r = fold_left_aux f accu r.l r.u - -let rec fold_right_aux f l u accu = - if l < u then - let u = u - 1 in - fold_right_aux f l u (f u accu) - else - accu - -let fold_right f r accu = fold_right_aux f r.l r.u accu - -let to_list r = - fold_right (fun x y -> x :: y) r [] - diff --git a/lib/xapi-stdext-range/range.mli b/lib/xapi-stdext-range/range.mli deleted file mode 100644 index 0b78d6444eb..00000000000 --- a/lib/xapi-stdext-range/range.mli +++ /dev/null @@ -1,33 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -type t - -(** Make a range. *) -val make : int -> int -> t - -(** Extract the start and end of the given range. *) -val get : t -> int * int - -(** Test the given int for membership in the given range. *) -val mem : int -> t -> bool - -(** Fold over a range, starting at the smallest int. *) -val fold_left : ('a -> int -> 'a) -> 'a -> t -> 'a - -(** Fold over a range, starting at the largest int. *) -val fold_right : (int -> 'a -> 'a) -> t -> 'a -> 'a - -(** Convert a range to a list of ascending integers *) -val to_list : t -> int list - diff --git a/lib/xapi-stdext-std/dune b/lib/xapi-stdext-std/dune index c05d4afd3b6..5b0dcf8704a 100644 --- a/lib/xapi-stdext-std/dune +++ b/lib/xapi-stdext-std/dune @@ -1,7 +1,5 @@ (library (public_name xapi-stdext-std) (name xapi_stdext_std) - (libraries - uuidm - xapi-stdext-monadic) + (libraries uuidm) ) diff --git a/lib/xapi-stdext-std/filenameext.ml b/lib/xapi-stdext-std/filenameext.ml deleted file mode 100644 index 6160372d177..00000000000 --- a/lib/xapi-stdext-std/filenameext.ml +++ /dev/null @@ -1,30 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -(** Makes a new file in the same directory as 'otherfile' *) -let temp_file_in_dir otherfile = - let base_dir = Filename.dirname otherfile in - let rec keep_trying () = - try - let uuid = Uuidm.to_string (Uuidm.create `V4) in - let newfile = base_dir ^ "/" ^ uuid in - Unix.close (Unix.openfile newfile [Unix.O_CREAT; Unix.O_TRUNC; Unix.O_EXCL] 0o600); - newfile - with - Unix.Unix_error (Unix.EEXIST, _, _) -> keep_trying () - in - keep_trying () - - - diff --git a/lib/xapi-stdext-std/filenameext.mli b/lib/xapi-stdext-std/filenameext.mli deleted file mode 100644 index 5529c3959a9..00000000000 --- a/lib/xapi-stdext-std/filenameext.mli +++ /dev/null @@ -1,14 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -val temp_file_in_dir : string -> string diff --git a/lib/xapi-stdext-std/hashtblext.ml b/lib/xapi-stdext-std/hashtblext.ml deleted file mode 100644 index a89833e5fe4..00000000000 --- a/lib/xapi-stdext-std/hashtblext.ml +++ /dev/null @@ -1,42 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) - -let to_list tbl = - Hashtbl.fold (fun k v acc -> (k, v) :: acc) tbl [] - -(* this is not a fold ... *) -let fold_keys tbl = - Hashtbl.fold (fun k _ acc -> k :: acc) tbl [] - -(* ... neither is this *) -let fold_values tbl = - Hashtbl.fold (fun _ v acc -> v :: acc) tbl [] - -let add_empty tbl k v = - if not (Hashtbl.mem tbl k) then - Hashtbl.add tbl k v - -let add_list tbl l = - List.iter (fun (k, v) -> Hashtbl.add tbl k v) l - -let remove_other_keys tbl valid_keys = - let keys = fold_keys tbl in - let maybe_remove k = - if not (List.mem k valid_keys) then Hashtbl.remove tbl k in - List.iter maybe_remove keys - -let of_list l = - let tbl = Hashtbl.create (List.length l) in - add_list tbl l; - tbl diff --git a/lib/xapi-stdext-std/hashtblext.mli b/lib/xapi-stdext-std/hashtblext.mli deleted file mode 100644 index 0c4a017288a..00000000000 --- a/lib/xapi-stdext-std/hashtblext.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -val to_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list - -(* this is not a fold ... *) -val fold_keys : ('a, 'b) Hashtbl.t -> 'a list - -(* ... neither is this *) -val fold_values : ('a, 'b) Hashtbl.t -> 'b list - -val add_empty : ('a, 'b) Hashtbl.t -> 'a -> 'b -> unit -val add_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list -> unit -val remove_other_keys : ('a, 'b) Hashtbl.t -> 'a list -> unit -val of_list : ('a * 'b) list -> ('a, 'b) Hashtbl.t diff --git a/lib/xapi-stdext-std/listext.ml b/lib/xapi-stdext-std/listext.ml index 173c813f797..49da8a68c88 100644 --- a/lib/xapi-stdext-std/listext.ml +++ b/lib/xapi-stdext-std/listext.ml @@ -14,21 +14,6 @@ module List = struct include List - module Monad = Xapi_stdext_monadic.Monad.M1.Make (struct - - type 'a m = 'a list - - let bind list f = - let rec inner result = function - | x :: xs -> inner (List.rev_append (f x) result) xs - | [] -> List.rev result - in - inner [] list - - let return x = [x] - - end) - (** Turn a list into a set *) let rec setify = function | [] -> [] @@ -214,9 +199,7 @@ module List = struct include List let make_assoc op l = map (fun key -> key, op key) l - let unbox_list a = - let module Opt = Xapi_stdext_monadic.Opt in - List.map Opt.unbox (List.filter Opt.is_boxed a) + let unbox_list l = List.filter_map Fun.id l let filter_map f list = unbox_list (map f list) diff --git a/lib/xapi-stdext-std/listext.mli b/lib/xapi-stdext-std/listext.mli index c200d84c1f1..0e7143efdf8 100644 --- a/lib/xapi-stdext-std/listext.mli +++ b/lib/xapi-stdext-std/listext.mli @@ -13,7 +13,6 @@ *) module List : sig - module Monad : sig include Xapi_stdext_monadic.Monad.M1.MONAD with type 'a m = 'a list end val setify : 'a list -> 'a list val subset : 'a list -> 'a list -> bool val set_equiv : 'a list -> 'a list -> bool diff --git a/lib/xapi-stdext-unix/unixext.ml b/lib/xapi-stdext-unix/unixext.ml index caed7a7eb8e..8a522e9c9c2 100644 --- a/lib/xapi-stdext-unix/unixext.ml +++ b/lib/xapi-stdext-unix/unixext.ml @@ -204,18 +204,17 @@ let execv_get_output cmd args = pid, pipe_exit let copy_file_internal ?limit reader writer = - let module Opt = Xapi_stdext_monadic.Opt in let buffer = Bytes.make 65536 '\000' in let buffer_len = Int64.of_int (Bytes.length buffer) in let finished = ref false in let total_bytes = ref 0L in let limit = ref limit in while not(!finished) do - let requested = min (Opt.default buffer_len !limit) buffer_len in + let requested = min (Option.value ~default:buffer_len !limit) buffer_len in let num = reader buffer 0 (Int64.to_int requested) in let num64 = Int64.of_int num in - limit := Opt.map (fun x -> Int64.sub x num64) !limit; + limit := Option.map (fun x -> Int64.sub x num64) !limit; ignore_int (writer buffer 0 num); total_bytes := Int64.add !total_bytes num64; finished := num = 0 || !limit = Some 0L; diff --git a/lib/xapi-stdext/dune b/lib/xapi-stdext/dune index 352c5263203..11bb5ed7538 100644 --- a/lib/xapi-stdext/dune +++ b/lib/xapi-stdext/dune @@ -5,11 +5,8 @@ (wrapped false) (libraries xapi-stdext-date - xapi-stdext-deprecated xapi-stdext-encodings - xapi-stdext-monadic xapi-stdext-pervasives - xapi-stdext-range xapi-stdext-std xapi-stdext-threads xapi-stdext-unix diff --git a/lib/xapi-stdext/stdext.ml b/lib/xapi-stdext/stdext.ml index bf4a4b72729..23c64cc0aa2 100644 --- a/lib/xapi-stdext/stdext.ml +++ b/lib/xapi-stdext/stdext.ml @@ -1,17 +1,9 @@ (* New modules *) module Date = Xapi_stdext_date.Date module Encodings = Xapi_stdext_encodings.Encodings -module Range = Xapi_stdext_range.Range - -(* Monadic modules *) -module Monad = Xapi_stdext_monadic.Monad -module Either = Xapi_stdext_monadic.Either (* Should be deprecated and replaced by Result *) -module Opt = Xapi_stdext_monadic.Opt (* Standard library extensions and additions*) module Pervasiveext = Xapi_stdext_pervasives.Pervasiveext -module Filenameext = Xapi_stdext_std.Filenameext -module Hashtblext = Xapi_stdext_std.Hashtblext module Listext = Xapi_stdext_std.Listext module Xstringext = Xapi_stdext_std.Xstringext @@ -20,6 +12,3 @@ module Semaphore = Xapi_stdext_threads.Semaphore module Unixext = Xapi_stdext_unix.Unixext module Zerocheck = Xapi_stdext_zerocheck.Zerocheck - -(* To depracate asap *) -module Fun = Xapi_stdext_deprecated.Fun diff --git a/stdext.opam b/stdext.opam index 860d11c1ebb..b0f182aaaa9 100644 --- a/stdext.opam +++ b/stdext.opam @@ -14,7 +14,6 @@ depends: [ "xapi-stdext-date" "xapi-stdext-deprecated" "xapi-stdext-encodings" - "xapi-stdext-monadic" "xapi-stdext-pervasives" "xapi-stdext-range" "xapi-stdext-std" diff --git a/xapi-stdext-bigbuffer.opam b/xapi-stdext-bigbuffer.opam deleted file mode 100644 index aac6e717f1b..00000000000 --- a/xapi-stdext-bigbuffer.opam +++ /dev/null @@ -1,18 +0,0 @@ -opam-version: "2.0" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" -tags: [ "org:xapi-project" ] - -build: [[ "dune" "build" "-p" name "-j" jobs ]] - -depends: [ - "ocaml" - "dune" {build} -] -synopsis: "A deprecated collection of utility functions - bigbuffer module" -description: """ -This library is provided for a transitionary period only. -No new code should use this library.""" diff --git a/xapi-stdext-deprecated.opam b/xapi-stdext-deprecated.opam deleted file mode 100644 index 1ff7b82a6a2..00000000000 --- a/xapi-stdext-deprecated.opam +++ /dev/null @@ -1,18 +0,0 @@ -opam-version: "2.0" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" -tags: [ "org:xapi-project" ] - -build: [[ "dune" "build" "-p" name "-j" jobs ]] - -depends: [ - "ocaml" - "dune" {build} -] -synopsis: "A deprecated collection of utility functions - Deprecated modules" -description: """ -This library is provided for a transitionary period only. -No new code should use this library.""" diff --git a/xapi-stdext-monadic.opam b/xapi-stdext-monadic.opam deleted file mode 100644 index ac1d465b221..00000000000 --- a/xapi-stdext-monadic.opam +++ /dev/null @@ -1,19 +0,0 @@ -opam-version: "2.0" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" -tags: [ "org:xapi-project" ] - -build: [[ "dune" "build" "-p" name "-j" jobs ]] - -depends: [ - "ocaml" - "dune" {build} -] -synopsis: - "A deprecated collection of utility functions - Monadic modules (Monad, Listext, Either)" -description: """ -This library is provided for a transitionary period only. -No new code should use this library.""" diff --git a/xapi-stdext-range.opam b/xapi-stdext-range.opam deleted file mode 100644 index e9eff09c027..00000000000 --- a/xapi-stdext-range.opam +++ /dev/null @@ -1,18 +0,0 @@ -opam-version: "2.0" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" -tags: [ "org:xapi-project" ] - -build: [[ "dune" "build" "-p" name "-j" jobs ]] - -depends: [ - "ocaml" - "dune" {build} -] -synopsis: "A deprecated collection of utility functions - Range module" -description: """ -This library is provided for a transitionary period only. -No new code should use this library.""" diff --git a/xapi-stdext-std.opam b/xapi-stdext-std.opam index b5ae1dceb91..e16c9b7ff51 100644 --- a/xapi-stdext-std.opam +++ b/xapi-stdext-std.opam @@ -12,7 +12,6 @@ depends: [ "ocaml" "dune" {build} "uuidm" - "xapi-stdext-monadic" ] synopsis: "A deprecated collection of utility functions - Standard library extensions" From 36cdf346f6167fb42e22aab8bcf79f36d88b58c6 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 22 May 2020 15:36:31 +0100 Subject: [PATCH 124/199] maintenance: prepare for ocamlformat Signed-off-by: Pau Ruiz Safont --- .ocamlformat | 9 ++++ Makefile | 6 +-- dune-project | 3 +- lib_test/test_encodings.ml | 85 +++++++++++++++++++------------------- 4 files changed, 56 insertions(+), 47 deletions(-) create mode 100644 .ocamlformat diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 00000000000..b4d356a7786 --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,9 @@ +profile=ocamlformat +version=0.14.1 +indicate-multiline-delimiters=closing-on-separate-line +if-then-else=fit-or-vertical +dock-collection-brackets=true +break-struct=natural +break-separators=before +break-infix=fit-or-vertical +break-infix-before-func=false diff --git a/Makefile b/Makefile index 869934e782d..1034b3efedf 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ PROFILE=release -.PHONY: build install uninstall clean test doc reindent +.PHONY: build install uninstall clean test doc format build: dune build @install --profile=$(PROFILE) @@ -21,5 +21,5 @@ test: doc: dune build @doc --profile=$(PROFILE) -reindent: - ocp-indent --syntax cstruct -i **/*.ml* +format: + dune build @fmt --auto-promote diff --git a/dune-project b/dune-project index f9337290c30..cd5e890aea7 100644 --- a/dune-project +++ b/dune-project @@ -1 +1,2 @@ -(lang dune 1.4) +(lang dune 1.11) +(using fmt 1.2 (enabled_for ocaml)) diff --git a/lib_test/test_encodings.ml b/lib_test/test_encodings.ml index 811da32e3cd..44ea86eca26 100644 --- a/lib_test/test_encodings.ml +++ b/lib_test/test_encodings.ml @@ -202,21 +202,21 @@ end module UCS = struct include E.UCS - (** A list of UCS non-characters values, including: *) - (** a. non-characters within the basic multilingual plane; *) - (** b. non-characters at the end of the basic multilingual plane; *) - (** c. non-characters at the end of the private use area. *) + (** A list of UCS non-characters values, including: + a. non-characters within the basic multilingual plane; + b. non-characters at the end of the basic multilingual plane; + c. non-characters at the end of the private use area. *) let non_characters = [ 0x00fdd0l; 0x00fdefl; (* case a. *) 0x00fffel; 0x00ffffl; (* case b. *) 0x1ffffel; 0x1fffffl; (* case c. *) ] - (** A list of UCS character values located immediately before or *) - (** after UCS non-character values, including: *) - (** a. non-characters within the basic multilingual plane; *) - (** b. non-characters at the end of the basic multilingual plane; *) - (** c. non-characters at the end of the private use area. *) + (** A list of UCS character values located immediately before or + after UCS non-character values, including: + a. non-characters within the basic multilingual plane; + b. non-characters at the end of the basic multilingual plane; + c. non-characters at the end of the private use area. *) let valid_characters_next_to_non_characters = [ 0x00fdcfl; 0x00fdf0l; (* case a. *) 0x00fffdl; 0x010000l; (* case b. *) @@ -322,10 +322,10 @@ end module UTF8_codec = struct include E.UTF8_codec - (** A list of canonical encoding widths of UCS values, *) - (** represented by tuples of the form (v, w), where: *) - (** v = the UCS character value to be encoded; and *) - (** w = the width of the encoded character, in bytes. *) + (** A list of canonical encoding widths of UCS values, + represented by tuples of the form (v, w), where: + v = the UCS character value to be encoded; and + w = the width of the encoded character, in bytes. *) let valid_ucs_value_widths = [ (1l , 1); ((1l <<< 7) --- 1l, 1); @@ -340,11 +340,11 @@ module UTF8_codec = struct include E.UTF8_codec Alcotest.(check int) "same ints" (width_required_for_ucs_value value) width) valid_ucs_value_widths - (** A list of valid header byte decodings, represented by *) - (** tuples of the form (b, (v, w)), where: *) - (** b = a valid header byte; *) - (** v = the (partial) value contained within the byte; and *) - (** w = the total width of the encoded character, in bytes. *) + (** A list of valid header byte decodings, represented by + tuples of the form (b, (v, w)), where: + b = a valid header byte; + v = the (partial) value contained within the byte; and + w = the total width of the encoded character, in bytes. *) let valid_header_byte_decodings = [ (0b00000000, (0b00000000, 1)); @@ -383,10 +383,10 @@ module UTF8_codec = struct include E.UTF8_codec (fun () -> decode_header_byte b |> ignore)) invalid_header_bytes - (** A list of valid continuation byte decodings, represented *) - (** by tuples of the form (b, v), where: *) - (** b = a valid continuation byte; and *) - (** v = the partial value contained within the byte. *) + (** A list of valid continuation byte decodings, represented + by tuples of the form (b, v), where: + b = a valid continuation byte; and + v = the partial value contained within the byte. *) let valid_continuation_byte_decodings = [ (0b10000000, 0b00000000); @@ -420,20 +420,19 @@ module UTF8_codec = struct include E.UTF8_codec (fun () -> decode_continuation_byte byte |> ignore)) invalid_continuation_bytes - (** A list of valid character decodings represented by *) - (** tuples of the form (s, (v, w)), where: *) - (** *) - (** s = a validly-encoded UTF-8 string; *) - (** v = the UCS value represented by the string; *) - (** (which may or may not be valid in its own right) *) - (** w = the width of the encoded string, in bytes. *) - (** *) - (** For each byte length b in [1...4], the list contains *) - (** decodings for: *) - (** *) - (** v_min = the smallest UCS value encodable in b bytes. *) - (** v_max = the greatest UCS value encodable in b bytes. *) - (** *) + (** A list of valid character decodings represented by + tuples of the form (s, (v, w)), where: + + s = a validly-encoded UTF-8 string; + v = the UCS value represented by the string; + (which may or may not be valid in its own right) + w = the width of the encoded string, in bytes. + + For each byte length b in [1...4], the list contains + decodings for: + + v_min = the smallest UCS value encodable in b bytes. + v_max = the greatest UCS value encodable in b bytes. *) let valid_character_decodings = [ (* 7654321 *) (* 0b0xxxxxxx *) (* 00000000000000xxxxxxx *) @@ -461,10 +460,10 @@ module UTF8_codec = struct include E.UTF8_codec (value, width)) valid_character_decodings - (** A list of strings containing overlong character encodings. *) - (** For each byte length b in [2...4], this list contains the *) - (** overlong encoding e (v), where v is the UCS value one less *) - (** than the smallest UCS value validly-encodable in b bytes. *) + (** A list of strings containing overlong character encodings. + For each byte length b in [2...4], this list contains the + overlong encoding e (v), where v is the UCS value one less + than the smallest UCS value validly-encodable in b bytes. *) let overlong_character_encodings = [ "\xc1\xbf" (* 0b11000001 0b10111111 *); @@ -479,9 +478,9 @@ module UTF8_codec = struct include E.UTF8_codec (fun () -> Lenient_UTF8_codec.decode_character string 0 |> ignore)) overlong_character_encodings - (** Encodes a valid UCS value and then decodes it again, testing: *) - (** a. that the encoded width is canonical for the given value. *) - (** b. that the decoded value is identical to the original value. *) + (** Encodes a valid UCS value and then decodes it again, testing: + a. that the encoded width is canonical for the given value. + b. that the decoded value is identical to the original value. *) let test_encode_decode_cycle_for_value value = let string = Lenient_UTF8_codec.encode_character value in let decoded_value, decoded_width = From 4fa7ced76aef6f25b3e2f3c27fb3d2b7b86560f8 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 22 May 2020 17:10:43 +0100 Subject: [PATCH 125/199] maintenance: update travis config Signed-off-by: Pau Ruiz Safont --- .travis.yml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 87cbb784a04..db5c06e6af9 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,7 @@ language: c -sudo: required -service: docker +os: linux +dist: xenial +services: docker install: - wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh - wget https://raw.githubusercontent.com/xapi-project/xs-opam/master/tools/xs-opam-ci.env From 10edcbabedeadf68d531b15d8ef11309d379351f Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 20 Jul 2020 17:56:36 +0100 Subject: [PATCH 126/199] CP-33121: run encodings tests as part of the encodings package It's the only library that currently has tests xapi-stdext is ignored in travis now, nothing else is using it and it can ber dropped from now on. Signed-off-by: Pau Ruiz Safont --- .travis.yml | 6 ++++-- lib_test/dune | 13 ++++--------- lib_test/suite.ml | 5 ----- lib_test/test_encodings.ml | 4 ++++ stdext.opam | 2 -- xapi-stdext-encodings.opam | 7 ++++++- 6 files changed, 18 insertions(+), 19 deletions(-) delete mode 100644 lib_test/suite.ml diff --git a/.travis.yml b/.travis.yml index db5c06e6af9..f6206dc59d2 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,5 +9,7 @@ install: script: bash -ex .travis-docker.sh env: global: - - PACKAGE="xapi-stdext" - - PINS="stdext:. xapi-stdext:. xapi-stdext-date:. xapi-stdext-encodings:. xapi-stdext-pervasives:. xapi-stdext-std:. xapi-stdext-threads:. xapi-stdext-unix:. xapi-stdext-zerocheck:." + - PINS="stdext:. xapi-stdext-date:. xapi-stdext-encodings:. xapi-stdext-pervasives:. xapi-stdext-std:. xapi-stdext-threads:. xapi-stdext-unix:. xapi-stdext-zerocheck:." + jobs: + - PACKAGE="stdext" + - PACKAGE="xapi-stdext-encodings" diff --git a/lib_test/dune b/lib_test/dune index 00fb223d04c..f6fa185e498 100644 --- a/lib_test/dune +++ b/lib_test/dune @@ -1,13 +1,8 @@ -(executable - (name suite) +(test + (name test_encodings) + (package xapi-stdext-encodings) (libraries alcotest xapi_stdext_encodings - xapi_stdext_date) -) - -(alias - (name runtest) - (deps (:x suite.exe)) - (action (run %{x})) + xapi-stdext-date) ) diff --git a/lib_test/suite.ml b/lib_test/suite.ml deleted file mode 100644 index 13932e2b498..00000000000 --- a/lib_test/suite.ml +++ /dev/null @@ -1,5 +0,0 @@ - -let () = - Alcotest.run - "suite" - [ "Test_encodings", Test_encodings.tests ] diff --git a/lib_test/test_encodings.ml b/lib_test/test_encodings.ml index 44ea86eca26..a92a280725b 100644 --- a/lib_test/test_encodings.ml +++ b/lib_test/test_encodings.ml @@ -575,3 +575,7 @@ let tests = XML_UTF8_UCS_validator.tests @ UTF8_codec .tests @ Date .tests +let () = + Alcotest.run + "suite" + [ "Test_encodings", tests ] diff --git a/stdext.opam b/stdext.opam index b0f182aaaa9..4840e57ff6c 100644 --- a/stdext.opam +++ b/stdext.opam @@ -12,10 +12,8 @@ depends: [ "ocaml" "dune" {build} "xapi-stdext-date" - "xapi-stdext-deprecated" "xapi-stdext-encodings" "xapi-stdext-pervasives" - "xapi-stdext-range" "xapi-stdext-std" "xapi-stdext-threads" "xapi-stdext-unix" diff --git a/xapi-stdext-encodings.opam b/xapi-stdext-encodings.opam index a42b701827d..bf0925dd619 100644 --- a/xapi-stdext-encodings.opam +++ b/xapi-stdext-encodings.opam @@ -6,11 +6,16 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [[ "dune" "build" "-p" name "-j" jobs ]] +build: [ + [ "dune" "build" "-p" name "-j" jobs ] + [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} +] depends: [ "ocaml" "dune" {build} + "alcotest" {with-test} + "xapi-stdext-date" {with-test} ] synopsis: "A deprecated collection of utility functions - Encodings module" description: """ From b0c8df0fa7baf33cd11ad35d888c6e2ef1416744 Mon Sep 17 00:00:00 2001 From: lippirk Date: Thu, 30 Jul 2020 15:07:54 +0100 Subject: [PATCH 127/199] CA-342171 allow clients to create an iso8601 from localtime Allow client to call `Date.localtime ()` and create a datetime based on the localtime. Signed-off-by: lippirk --- lib/xapi-stdext-date/date.ml | 83 ++++++++++++++++++++--------------- lib/xapi-stdext-date/date.mli | 7 ++- lib/xapi-stdext-date/dune | 1 + lib_test/test_encodings.ml | 36 ++++++++++++--- 4 files changed, 84 insertions(+), 43 deletions(-) diff --git a/lib/xapi-stdext-date/date.ml b/lib/xapi-stdext-date/date.ml index fca7b9d0efd..7565e1f3114 100644 --- a/lib/xapi-stdext-date/date.ml +++ b/lib/xapi-stdext-date/date.ml @@ -30,9 +30,14 @@ let rfc822_to_string x = x (* ==== ISO8601/RFC3339 ==== *) -type iso8601 = Ptime.t +type print_type = PrintLocal | PrintUTC +(* we must store the print_type with iso8601 to handle the case where the local time zone is UTC *) +type iso8601 = Ptime.date * Ptime.time * print_type - let of_string x = +let of_dt print_type dt = let (date, time) = dt in (date, time, print_type) +let to_dt (date, time, _) = (date, time) + +let of_string x = let x = try (* if x doesn't contain dashes, insert them, so that ptime can parse x *) @@ -44,50 +49,56 @@ type iso8601 = Ptime.t match x |> Ptime.of_rfc3339 |> Ptime.rfc3339_error_to_msg with | Error (`Msg e) -> invalid_arg (Printf.sprintf "date.ml:of_string: %s" e) | Ok (t, tz, _) -> match tz with - | None | Some 0 -> t + | None | Some 0 -> Ptime.to_date_time t |> of_dt PrintUTC | Some _ -> invalid_arg (Printf.sprintf "date.ml:of_string: %s" x) -let to_string t = - Ptime.to_rfc3339 ~tz_offset_s:0 (* to ensure Z printed, rather than +00:00 *) t |> - Astring.String.filter (fun char -> char <> '-') (* remove dashes for backwards compatibility *) +let to_string ((y,mon,d), ((h,min,s), _), print_type) = + match print_type with + | PrintUTC -> Printf.sprintf "%04i%02i%02iT%02i:%02i:%02iZ" y mon d h min s + | PrintLocal -> Printf.sprintf "%04i%02i%02iT%02i:%02i:%02i" y mon d h min s -let of_float x = - let time = Unix.gmtime x in - Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ" - (time.Unix.tm_year+1900) - (time.Unix.tm_mon+1) - time.Unix.tm_mday - time.Unix.tm_hour - time.Unix.tm_min - time.Unix.tm_sec |> of_string - -(* Convert tm in localtime to calendar time, x *) -let to_float_localtime x = - let datetime_to_float y mon d h min s = - fst Unix.(mktime { tm_year = y - 1900; - tm_mon = mon - 1; - tm_mday = d; - tm_hour = h; - tm_min = min; - tm_sec = s; - (* These are ignored: *) - tm_wday = 0; tm_yday = 0; tm_isdst = true; - }) - in - let ((y, mon, d), ((h, min, s), _)) = Ptime.to_date_time x in - datetime_to_float y mon d h min s +let to_ptime_t t = + match to_dt t |> Ptime.of_date_time with + | Some t -> t + | None -> + let (_, (_, offset), _) = t in + invalid_arg (Printf.sprintf "date.ml:to_t: dt='%s', offset='%i' is invalid" (to_string t) offset) + +let of_float s = + match Ptime.of_float_s s with + | None -> invalid_arg (Printf.sprintf "date.ml:of_float: %f" s) + | Some t -> Ptime.to_date_time t |> of_dt PrintUTC (* Convert tm in UTC back into calendar time x (using offset between above UTC and localtime fns to determine offset between UTC and localtime, then correcting for this) *) -let to_float x = - let t = Unix.time () in - let offset = (t |> of_float |> to_float_localtime) -. t in - to_float_localtime x -. offset +let to_float t = + let (_, _, print_type) = t in + match print_type with + | PrintLocal -> invalid_arg "date.ml:to_float: expected utc" + | PrintUTC -> to_ptime_t t |> Ptime.to_float_s + +let _localtime current_tz_offset t = + let tz_offset_s = current_tz_offset |> Option.value ~default:0 in + let localtime = t |> Ptime.to_date_time ~tz_offset_s |> of_dt PrintLocal in + let (_, (_, localtime_offset), _) = localtime in + if localtime_offset <> tz_offset_s then + invalid_arg ( + Printf.sprintf "date.ml:_localtime: offsets don't match. offset='%i', t='%s'" + tz_offset_s + (Ptime.to_rfc3339 t) + ); + localtime + +let _localtime_string current_tz_offset t = + _localtime current_tz_offset t |> to_string + +let localtime () = + _localtime (Ptime_clock.current_tz_offset_s ()) (Ptime_clock.now ()) let assert_utc _ = () let never = of_float 0.0 -let eq = Ptime.equal +let eq x y = x = y diff --git a/lib/xapi-stdext-date/date.mli b/lib/xapi-stdext-date/date.mli index 9cf3d2f7190..3b5881d147b 100644 --- a/lib/xapi-stdext-date/date.mli +++ b/lib/xapi-stdext-date/date.mli @@ -28,7 +28,7 @@ val to_float : iso8601 -> float val to_string : iso8601 -> string (** Convert ISO 8601 formatted string to a date/time value. - * Does not accept a timezone annotated datetime *) + * Does not accept a timezone annotated datetime - i.e. string must be UTC, and end with a Z *) val of_string : string -> iso8601 (** Raises an Invalid_argument exception if the given date is not a UTC date. @@ -39,6 +39,11 @@ val assert_utc : iso8601 -> unit (** Representation of the concept "never" (actually 00:00:00 UTC, 1 Jan 1970). *) val never: iso8601 +(** exposed for testing *) +val _localtime_string : Ptime.tz_offset_s option -> Ptime.t -> string + +val localtime : unit -> iso8601 + (** {2 RFC 822 Dates} *) (** An RFC 822 date/time type. *) diff --git a/lib/xapi-stdext-date/dune b/lib/xapi-stdext-date/dune index bf043d6865e..324e48e2143 100644 --- a/lib/xapi-stdext-date/dune +++ b/lib/xapi-stdext-date/dune @@ -3,5 +3,6 @@ (public_name xapi-stdext-date) (libraries astring ptime + ptime.clock.os unix) ) diff --git a/lib_test/test_encodings.ml b/lib_test/test_encodings.ml index a92a280725b..6e1b2bd9338 100644 --- a/lib_test/test_encodings.ml +++ b/lib_test/test_encodings.ml @@ -522,7 +522,7 @@ module Date = struct let check_string = Alcotest.(check string) let check_true str = Alcotest.(check bool) str true let dash_time_str = "2020-04-07T08:28:32Z" - let no_dash_time_str = "20200407T08:28:32Z" + let no_dash_utc_time_str = "20200407T08:28:32Z" let iso8601_tests = let test_of_float_invertible () = @@ -530,7 +530,6 @@ module Date = struct let time = non_int_time |> Float.floor in check_float "to_float inverts of_float" time (time |> of_float |> to_float); check_true "of_float inverts to_float" @@ eq (time |> of_float) (time |> of_float |> to_float |> of_float); - check_float_neq "non-integers don't work" non_int_time (non_int_time |> of_float |> to_float) in let test_only_utc () = @@ -544,17 +543,40 @@ module Date = struct let test_ca333908 () = check_float "dash time and no dash time have same float repr" (dash_time_str |> of_string |> to_float) - (no_dash_time_str |> of_string |> to_float) + (no_dash_utc_time_str |> of_string |> to_float) in let test_of_string_invertible_when_no_dashes () = - check_string "to_string inverts of_string" no_dash_time_str (no_dash_time_str |> of_string |> to_string); - check_true "of_string inverts to_string" (eq (no_dash_time_str |> of_string) (no_dash_time_str |> of_string |> to_string |> of_string)); + check_string "to_string inverts of_string" no_dash_utc_time_str (no_dash_utc_time_str |> of_string |> to_string); + check_true "of_string inverts to_string" (eq (no_dash_utc_time_str |> of_string) (no_dash_utc_time_str |> of_string |> to_string |> of_string)); in (* CA-338243 - breaking backwards compatibility will break XC and XRT *) let test_to_string_backwards_compatibility () = - check_string "to_string is backwards compatible" no_dash_time_str (dash_time_str |> of_string |> to_string); + check_string "to_string is backwards compatible" no_dash_utc_time_str + (dash_time_str |> of_string |> to_string) + in + + let test_localtime_string () = + let[@warning "-8"] (Ok (t, _, _)) = + Ptime.of_rfc3339 "2020-04-07T09:01:28Z" + in + let minus_2_hrs = -7200 in + let plus_3_hrs = 10800 in + let zero_hrs = 0 in + check_string "can subtract 2 hours" (_localtime_string (Some minus_2_hrs) t) "20200407T07:01:28"; + check_string "can add 3 hours" (_localtime_string (Some plus_3_hrs) t) "20200407T12:01:28"; + check_string "can add None" (_localtime_string None t) "20200407T09:01:28"; + check_string "can add zero" (_localtime_string (Some zero_hrs) t) "20200407T09:01:28" + in + + (* sanity check (on top of test_localtime_string) that localtime produces valid looking output *) + let test_ca342171 () = + (* no exception is thrown + backward compatible formatting *) + let localtime_string = localtime () |> to_string in + Alcotest.(check int) "localtime string has correct number of chars" + (String.length localtime_string) (String.length no_dash_utc_time_str - 1); + Alcotest.(check bool) "localtime string does not contain a Z" false (String.contains localtime_string 'Z') in [ "test_of_float_invertible", `Quick, test_of_float_invertible @@ -562,6 +584,8 @@ module Date = struct ; "test_ca333908", `Quick, test_ca333908 ; "test_of_string_invertible_when_no_dashes", `Quick, test_of_string_invertible_when_no_dashes ; "test_to_string_backwards_compatibility", `Quick, test_to_string_backwards_compatibility + ; "test_localtime_string", `Quick, test_localtime_string + ; "test_ca342171", `Quick, test_ca342171 ] let tests = iso8601_tests From 79fc7075200c10aa80ed93c5462c344cbc47547c Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 11 Aug 2020 11:29:03 +0100 Subject: [PATCH 128/199] CP-33121: remove dependency of date in encodings tests Enables testing of the date package Signed-off-by: Pau Ruiz Safont --- .travis.yml | 1 + lib/xapi-stdext-date/dune | 8 ++++ lib/xapi-stdext-date/test.ml | 74 +++++++++++++++++++++++++++++++++ lib_test/test_encodings.ml | 80 +----------------------------------- xapi-stdext-date.opam | 6 ++- xapi-stdext-encodings.opam | 1 - 6 files changed, 90 insertions(+), 80 deletions(-) create mode 100644 lib/xapi-stdext-date/test.ml diff --git a/.travis.yml b/.travis.yml index f6206dc59d2..a5c9b4732a1 100644 --- a/.travis.yml +++ b/.travis.yml @@ -13,3 +13,4 @@ env: jobs: - PACKAGE="stdext" - PACKAGE="xapi-stdext-encodings" + - PACKAGE="xapi-stdext-date" diff --git a/lib/xapi-stdext-date/dune b/lib/xapi-stdext-date/dune index 324e48e2143..75de1b43647 100644 --- a/lib/xapi-stdext-date/dune +++ b/lib/xapi-stdext-date/dune @@ -1,8 +1,16 @@ (library (name xapi_stdext_date) (public_name xapi-stdext-date) + (modules :standard \ test) (libraries astring ptime ptime.clock.os unix) ) + +(test + (name test) + (package xapi-stdext-date) + (modules test) + (libraries alcotest xapi-stdext-date) +) diff --git a/lib/xapi-stdext-date/test.ml b/lib/xapi-stdext-date/test.ml new file mode 100644 index 00000000000..7691c572129 --- /dev/null +++ b/lib/xapi-stdext-date/test.ml @@ -0,0 +1,74 @@ +open Xapi_stdext_date.Date + +let check_float = Alcotest.(check @@ float 1e-2 ) +let check_float_neq = Alcotest.(check @@ neg @@ float 1e-2) +let check_string = Alcotest.(check string) +let check_true str = Alcotest.(check bool) str true +let dash_time_str = "2020-04-07T08:28:32Z" +let no_dash_utc_time_str = "20200407T08:28:32Z" + +let iso8601_tests = + let test_of_float_invertible () = + let non_int_time = 1586245987.70200706 in + let time = non_int_time |> Float.floor in + check_float "to_float inverts of_float" time (time |> of_float |> to_float); + check_true "of_float inverts to_float" @@ eq (time |> of_float) (time |> of_float |> to_float |> of_float); + in + + let test_only_utc () = + let utc = "2020-12-20T18:10:19Z" in + let _ = of_string utc in (* UTC is valid *) + let non_utc = "2020-12-20T18:10:19+02:00" in + let exn = Invalid_argument "date.ml:of_string: 2020-12-20T18:10:19+02:00" in + Alcotest.check_raises "only UTC is accepted" exn (fun () -> of_string non_utc |> ignore) + in + + let test_ca333908 () = + check_float "dash time and no dash time have same float repr" + (dash_time_str |> of_string |> to_float) + (no_dash_utc_time_str |> of_string |> to_float) + in + + let test_of_string_invertible_when_no_dashes () = + check_string "to_string inverts of_string" no_dash_utc_time_str (no_dash_utc_time_str |> of_string |> to_string); + check_true "of_string inverts to_string" (eq (no_dash_utc_time_str |> of_string) (no_dash_utc_time_str |> of_string |> to_string |> of_string)); + in + + (* CA-338243 - breaking backwards compatibility will break XC and XRT *) + let test_to_string_backwards_compatibility () = + check_string "to_string is backwards compatible" no_dash_utc_time_str + (dash_time_str |> of_string |> to_string) + in + + let test_localtime_string () = + let[@warning "-8"] (Ok (t, _, _)) = + Ptime.of_rfc3339 "2020-04-07T09:01:28Z" + in + let minus_2_hrs = -7200 in + let plus_3_hrs = 10800 in + let zero_hrs = 0 in + check_string "can subtract 2 hours" (_localtime_string (Some minus_2_hrs) t) "20200407T07:01:28"; + check_string "can add 3 hours" (_localtime_string (Some plus_3_hrs) t) "20200407T12:01:28"; + check_string "can add None" (_localtime_string None t) "20200407T09:01:28"; + check_string "can add zero" (_localtime_string (Some zero_hrs) t) "20200407T09:01:28" + in + + (* sanity check (on top of test_localtime_string) that localtime produces valid looking output *) + let test_ca342171 () = + (* no exception is thrown + backward compatible formatting *) + let localtime_string = localtime () |> to_string in + Alcotest.(check int) "localtime string has correct number of chars" + (String.length localtime_string) (String.length no_dash_utc_time_str - 1); + Alcotest.(check bool) "localtime string does not contain a Z" false (String.contains localtime_string 'Z') + in + + [ "test_of_float_invertible", `Quick, test_of_float_invertible + ; "test_only_utc", `Quick, test_only_utc + ; "test_ca333908", `Quick, test_ca333908 + ; "test_of_string_invertible_when_no_dashes", `Quick, test_of_string_invertible_when_no_dashes + ; "test_to_string_backwards_compatibility", `Quick, test_to_string_backwards_compatibility + ; "test_localtime_string", `Quick, test_localtime_string + ; "test_ca342171", `Quick, test_ca342171 + ] + +let () = Alcotest.run "Date" [ "ISO 8601", iso8601_tests ] diff --git a/lib_test/test_encodings.ml b/lib_test/test_encodings.ml index 6e1b2bd9338..dc7a3b0a012 100644 --- a/lib_test/test_encodings.ml +++ b/lib_test/test_encodings.ml @@ -515,90 +515,14 @@ module UTF8_codec = struct include E.UTF8_codec end -module Date = struct - open Xapi_stdext_date.Date - let check_float = Alcotest.(check @@ float 1e-2 ) - let check_float_neq = Alcotest.(check @@ neg @@ float 1e-2) - let check_string = Alcotest.(check string) - let check_true str = Alcotest.(check bool) str true - let dash_time_str = "2020-04-07T08:28:32Z" - let no_dash_utc_time_str = "20200407T08:28:32Z" - - let iso8601_tests = - let test_of_float_invertible () = - let non_int_time = 1586245987.70200706 in - let time = non_int_time |> Float.floor in - check_float "to_float inverts of_float" time (time |> of_float |> to_float); - check_true "of_float inverts to_float" @@ eq (time |> of_float) (time |> of_float |> to_float |> of_float); - in - - let test_only_utc () = - let utc = "2020-12-20T18:10:19Z" in - let _ = of_string utc in (* UTC is valid *) - let non_utc = "2020-12-20T18:10:19+02:00" in - let exn = Invalid_argument "date.ml:of_string: 2020-12-20T18:10:19+02:00" in - Alcotest.check_raises "only UTC is accepted" exn (fun () -> of_string non_utc |> ignore) - in - - let test_ca333908 () = - check_float "dash time and no dash time have same float repr" - (dash_time_str |> of_string |> to_float) - (no_dash_utc_time_str |> of_string |> to_float) - in - - let test_of_string_invertible_when_no_dashes () = - check_string "to_string inverts of_string" no_dash_utc_time_str (no_dash_utc_time_str |> of_string |> to_string); - check_true "of_string inverts to_string" (eq (no_dash_utc_time_str |> of_string) (no_dash_utc_time_str |> of_string |> to_string |> of_string)); - in - - (* CA-338243 - breaking backwards compatibility will break XC and XRT *) - let test_to_string_backwards_compatibility () = - check_string "to_string is backwards compatible" no_dash_utc_time_str - (dash_time_str |> of_string |> to_string) - in - - let test_localtime_string () = - let[@warning "-8"] (Ok (t, _, _)) = - Ptime.of_rfc3339 "2020-04-07T09:01:28Z" - in - let minus_2_hrs = -7200 in - let plus_3_hrs = 10800 in - let zero_hrs = 0 in - check_string "can subtract 2 hours" (_localtime_string (Some minus_2_hrs) t) "20200407T07:01:28"; - check_string "can add 3 hours" (_localtime_string (Some plus_3_hrs) t) "20200407T12:01:28"; - check_string "can add None" (_localtime_string None t) "20200407T09:01:28"; - check_string "can add zero" (_localtime_string (Some zero_hrs) t) "20200407T09:01:28" - in - - (* sanity check (on top of test_localtime_string) that localtime produces valid looking output *) - let test_ca342171 () = - (* no exception is thrown + backward compatible formatting *) - let localtime_string = localtime () |> to_string in - Alcotest.(check int) "localtime string has correct number of chars" - (String.length localtime_string) (String.length no_dash_utc_time_str - 1); - Alcotest.(check bool) "localtime string does not contain a Z" false (String.contains localtime_string 'Z') - in - - [ "test_of_float_invertible", `Quick, test_of_float_invertible - ; "test_only_utc", `Quick, test_only_utc - ; "test_ca333908", `Quick, test_ca333908 - ; "test_of_string_invertible_when_no_dashes", `Quick, test_of_string_invertible_when_no_dashes - ; "test_to_string_backwards_compatibility", `Quick, test_to_string_backwards_compatibility - ; "test_localtime_string", `Quick, test_localtime_string - ; "test_ca342171", `Quick, test_ca342171 - ] - - let tests = iso8601_tests -end - let tests = UCS .tests @ XML .tests @ String_validator .tests @ UTF8_UCS_validator .tests @ XML_UTF8_UCS_validator.tests @ - UTF8_codec .tests @ - Date .tests + UTF8_codec .tests + let () = Alcotest.run "suite" diff --git a/xapi-stdext-date.opam b/xapi-stdext-date.opam index ddee5fbb49e..bba4068980a 100644 --- a/xapi-stdext-date.opam +++ b/xapi-stdext-date.opam @@ -6,11 +6,15 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [[ "dune" "build" "-p" name "-j" jobs ]] +build: [ + [ "dune" "build" "-p" name "-j" jobs ] + [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} +] depends: [ "ocaml" "dune" {build} + "alcotest" {with-test} "astring" "base-unix" "ptime" diff --git a/xapi-stdext-encodings.opam b/xapi-stdext-encodings.opam index bf0925dd619..ba09c43056b 100644 --- a/xapi-stdext-encodings.opam +++ b/xapi-stdext-encodings.opam @@ -15,7 +15,6 @@ depends: [ "ocaml" "dune" {build} "alcotest" {with-test} - "xapi-stdext-date" {with-test} ] synopsis: "A deprecated collection of utility functions - Encodings module" description: """ From cc343183301e728cb78581a42ff239f401ec34dc Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 11 Aug 2020 12:12:49 +0100 Subject: [PATCH 129/199] CP-33121: Move encodings test to the package directory This minimizes the chance to mix tests for different packages in the same file. Also changed how tests are presented in the logs to be more informative. Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-encodings/dune | 18 ++++++++---------- .../xapi-stdext-encodings/test.ml | 19 +++++++++---------- lib_test/dune | 8 -------- 3 files changed, 17 insertions(+), 28 deletions(-) rename lib_test/test_encodings.ml => lib/xapi-stdext-encodings/test.ml (98%) delete mode 100644 lib_test/dune diff --git a/lib/xapi-stdext-encodings/dune b/lib/xapi-stdext-encodings/dune index 18baebe4081..742dd212f1e 100644 --- a/lib/xapi-stdext-encodings/dune +++ b/lib/xapi-stdext-encodings/dune @@ -1,14 +1,12 @@ -(* -*- tuareg -*- *) -let coverage_rewriter = - match Sys.getenv "BISECT_ENABLE" with - | "YES" -> "(preprocess (pps bisect_ppx -conditional))" - | _ -> "" -| exception Not_found -> "" - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| (library (name xapi_stdext_encodings) (public_name xapi-stdext-encodings) - %s + (modules :standard \ test) +) + +(test + (name test) + (package xapi-stdext-encodings) + (modules test) + (libraries alcotest xapi-stdext-encodings) ) -|} coverage_rewriter diff --git a/lib_test/test_encodings.ml b/lib/xapi-stdext-encodings/test.ml similarity index 98% rename from lib_test/test_encodings.ml rename to lib/xapi-stdext-encodings/test.ml index dc7a3b0a012..183e3e9692e 100644 --- a/lib_test/test_encodings.ml +++ b/lib/xapi-stdext-encodings/test.ml @@ -515,15 +515,14 @@ module UTF8_codec = struct include E.UTF8_codec end -let tests = - UCS .tests @ - XML .tests @ - String_validator .tests @ - UTF8_UCS_validator .tests @ - XML_UTF8_UCS_validator.tests @ - UTF8_codec .tests - let () = Alcotest.run - "suite" - [ "Test_encodings", tests ] + "Encodings" + [ + "UCS", UCS.tests + ; "XML", XML.tests + ; "String_validator", String_validator.tests + ; "UTF8_UCS_validator", UTF8_UCS_validator.tests + ; "XML_UTF8_UCS_validator", XML_UTF8_UCS_validator.tests + ; "UTF8_codec", UTF8_codec.tests + ] diff --git a/lib_test/dune b/lib_test/dune deleted file mode 100644 index f6fa185e498..00000000000 --- a/lib_test/dune +++ /dev/null @@ -1,8 +0,0 @@ -(test - (name test_encodings) - (package xapi-stdext-encodings) - (libraries - alcotest - xapi_stdext_encodings - xapi-stdext-date) -) From ca21fce193b75465d2c1af11ec4e04ae24ff8f3f Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Tue, 18 Aug 2020 16:45:24 +0100 Subject: [PATCH 130/199] unixext: remove Fdset module and stubs The functionality is not used in the Toolstack and uses the select() system call which we would like to phase out in favour of epoll(). Signed-off-by: Christian Lindig --- lib/xapi-stdext-unix/unixext.ml | 16 --- lib/xapi-stdext-unix/unixext.mli | 14 -- lib/xapi-stdext-unix/unixext_stubs.c | 189 --------------------------- 3 files changed, 219 deletions(-) diff --git a/lib/xapi-stdext-unix/unixext.ml b/lib/xapi-stdext-unix/unixext.ml index 8a522e9c9c2..ef415b82bad 100644 --- a/lib/xapi-stdext-unix/unixext.ml +++ b/lib/xapi-stdext-unix/unixext.ml @@ -642,22 +642,6 @@ let current_cursor_pos fd = (* 'seek' to the current position, exploiting the return value from Unix.lseek as the new cursor position *) Unix.lseek fd 0 Unix.SEEK_CUR -module Fdset = struct - type t - external of_list : Unix.file_descr list -> t = "stub_fdset_of_list" - external is_set : t -> Unix.file_descr -> bool = "stub_fdset_is_set" - external is_set_and_clear : t -> Unix.file_descr -> bool = "stub_fdset_is_set_and_clear" - external is_empty : t -> bool = "stub_fdset_is_empty" - external set : t -> Unix.file_descr -> unit = "stub_fdset_set" - external clear : t -> Unix.file_descr -> unit = "stub_fdset_clear" - external _select : t -> t -> t -> float -> t * t * t = "stub_fdset_select" - external _select_ro : t -> float -> t = "stub_fdset_select_ro" - external _select_wo : t -> float -> t = "stub_fdset_select_wo" - let select r w e t = _select r w e t - let select_ro r t = _select_ro r t - let select_wo w t = _select_wo w t -end - let wait_for_path path delay timeout = let rec inner ttl = if ttl=0 then failwith "No path!"; diff --git a/lib/xapi-stdext-unix/unixext.mli b/lib/xapi-stdext-unix/unixext.mli index 4c167f6fafb..16439a2f678 100644 --- a/lib/xapi-stdext-unix/unixext.mli +++ b/lib/xapi-stdext-unix/unixext.mli @@ -141,20 +141,6 @@ val seek_to : Unix.file_descr -> int -> int val seek_rel : Unix.file_descr -> int -> int val current_cursor_pos : Unix.file_descr -> int -module Fdset : sig - type t - external of_list : Unix.file_descr list -> t = "stub_fdset_of_list" - external is_set : t -> Unix.file_descr -> bool = "stub_fdset_is_set" - external is_set_and_clear : t -> Unix.file_descr -> bool = "stub_fdset_is_set_and_clear" - external is_empty : t -> bool = "stub_fdset_is_empty" - external set : t -> Unix.file_descr -> unit = "stub_fdset_set" - external clear : t -> Unix.file_descr -> unit = "stub_fdset_clear" - - val select : t -> t -> t -> float -> t * t * t - val select_ro : t -> float -> t - val select_wo : t -> float -> t -end - val wait_for_path : string -> (float -> unit) -> int -> unit val send_fd : Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> Unix.file_descr -> int diff --git a/lib/xapi-stdext-unix/unixext_stubs.c b/lib/xapi-stdext-unix/unixext_stubs.c index 3afbdd31b1b..e27142b2848 100644 --- a/lib/xapi-stdext-unix/unixext_stubs.c +++ b/lib/xapi-stdext-unix/unixext_stubs.c @@ -123,63 +123,6 @@ CAMLprim value stub_unixext_set_sock_keepalives(value fd, value count, value idl CAMLreturn(Val_unit); } -#define FDSET_OF_VALUE(v) (&(((struct fdset_t *) v)->fds)) -#define MAXFD_OF_VALUE(v) (((struct fdset_t *) v)->max) -struct fdset_t { fd_set fds; int max; }; - -CAMLprim value stub_fdset_of_list(value l) -{ - CAMLparam1(l); - CAMLlocal1(set); - - set = caml_alloc(sizeof(struct fdset_t), Abstract_tag); - FD_ZERO(FDSET_OF_VALUE(set)); - MAXFD_OF_VALUE(set) = -1; - while (l != Val_int(0)) { - int fd; - fd = Int_val(Field(l, 0)); - FD_SET(fd, FDSET_OF_VALUE(set)); - if (fd > MAXFD_OF_VALUE(set)) - MAXFD_OF_VALUE(set) = fd; - l = Field(l, 1); - } - CAMLreturn(set); -} - -CAMLprim value stub_fdset_is_set(value set, value fd) -{ - CAMLparam2(set, fd); - CAMLreturn(Val_bool(FD_ISSET(Int_val(fd), FDSET_OF_VALUE(set)))); -} - -CAMLprim value stub_fdset_set(value set, value fd) -{ - CAMLparam2(set, fd); - FD_SET(Int_val(fd), FDSET_OF_VALUE(set)); - CAMLreturn(Val_unit); -} - -CAMLprim value stub_fdset_clear(value set, value fd) -{ - CAMLparam2(set, fd); - FD_CLR(Int_val(fd), FDSET_OF_VALUE(set)); - CAMLreturn(Val_unit); -} - -CAMLprim value stub_fdset_is_set_and_clear(value set, value fd) -{ - CAMLparam2(set, fd); - int r, c_fd; - fd_set *c_set; - - c_fd = Int_val(fd); - c_set = FDSET_OF_VALUE(set); - r = FD_ISSET(c_fd, c_set); - if (r) - FD_CLR(c_fd, c_set); - CAMLreturn(Val_bool(r)); -} - void unixext_error(int code) { static value *exn = NULL; @@ -192,138 +135,6 @@ void unixext_error(int code) caml_raise_with_arg(*exn, Val_int(code)); } -CAMLprim value stub_fdset_select(value rset, value wset, value eset, value t) -{ - CAMLparam4(rset, wset, eset, t); - CAMLlocal4(ret, nrset, nwset, neset); - fd_set r, w, e; - int maxfd; - double tm; - struct timeval tv; - struct timeval *tvp; - int v; - - memcpy(&r, FDSET_OF_VALUE(rset), sizeof(fd_set)); - memcpy(&w, FDSET_OF_VALUE(wset), sizeof(fd_set)); - memcpy(&e, FDSET_OF_VALUE(eset), sizeof(fd_set)); - - maxfd = (MAXFD_OF_VALUE(rset) > MAXFD_OF_VALUE(wset)) - ? MAXFD_OF_VALUE(rset) - : MAXFD_OF_VALUE(wset); - maxfd = (maxfd > MAXFD_OF_VALUE(eset)) ? maxfd : MAXFD_OF_VALUE(eset); - - tm = Double_val(t); - if (tm < 0.0) - tvp = NULL; - else { - tv.tv_sec = (int) tm; - tv.tv_usec = (int) (1e6 * (tm - tv.tv_sec)); - tvp = &tv; - } - - caml_enter_blocking_section(); - v = select(maxfd + 1, &r, &w, &e, tvp); - caml_leave_blocking_section(); - if (v == -1) - unixext_error(errno); - - nrset = caml_alloc(sizeof(struct fdset_t), Abstract_tag); - nwset = caml_alloc(sizeof(struct fdset_t), Abstract_tag); - neset = caml_alloc(sizeof(struct fdset_t), Abstract_tag); - - memcpy(FDSET_OF_VALUE(nrset), &r, sizeof(fd_set)); - memcpy(FDSET_OF_VALUE(nwset), &w, sizeof(fd_set)); - memcpy(FDSET_OF_VALUE(neset), &e, sizeof(fd_set)); - - ret = caml_alloc_small(3, 0); - Field(ret, 0) = nrset; - Field(ret, 1) = nwset; - Field(ret, 2) = neset; - - CAMLreturn(ret); -} - -CAMLprim value stub_fdset_select_ro(value rset, value t) -{ - CAMLparam2(rset, t); - CAMLlocal1(ret); - fd_set r; - int maxfd; - double tm; - struct timeval tv; - struct timeval *tvp; - int v; - - memcpy(&r, FDSET_OF_VALUE(rset), sizeof(fd_set)); - maxfd = MAXFD_OF_VALUE(rset); - - tm = Double_val(t); - if (tm < 0.0) - tvp = NULL; - else { - tv.tv_sec = (int) tm; - tv.tv_usec = (int) (1e6 * (tm - tv.tv_sec)); - tvp = &tv; - } - - caml_enter_blocking_section(); - v = select(maxfd + 1, &r, NULL, NULL, tvp); - caml_leave_blocking_section(); - if (v == -1) - unixext_error(errno); - - ret = caml_alloc(sizeof(struct fdset_t), Abstract_tag); - memcpy(FDSET_OF_VALUE(ret), &r, sizeof(fd_set)); - - CAMLreturn(ret); -} - -CAMLprim value stub_fdset_select_wo(value wset, value t) -{ - CAMLparam2(wset, t); - CAMLlocal1(ret); - fd_set w; - int maxfd; - double tm; - struct timeval tv; - struct timeval *tvp; - int v; - - memcpy(&w, FDSET_OF_VALUE(wset), sizeof(fd_set)); - maxfd = MAXFD_OF_VALUE(wset); - - tm = Double_val(t); - if (tm < 0.0) - tvp = NULL; - else { - tv.tv_sec = (int) tm; - tv.tv_usec = (int) (1e6 * (tm - tv.tv_sec)); - tvp = &tv; - } - - caml_enter_blocking_section(); - v = select(maxfd + 1, NULL, &w, NULL, tvp); - caml_leave_blocking_section(); - if (v == -1) - unixext_error(errno); - - ret = caml_alloc(sizeof(struct fdset_t), Abstract_tag); - memcpy(FDSET_OF_VALUE(ret), &w, sizeof(fd_set)); - - CAMLreturn(ret); -} - -CAMLprim value stub_fdset_is_empty(value set) -{ - CAMLparam1(set); - fd_set x; - int ret; - FD_ZERO(&x); - ret = memcmp(&x, FDSET_OF_VALUE(set), sizeof(fd_set)); - - CAMLreturn(Bool_val(ret == 0)); -} - CAMLprim value stub_statvfs(value filename) { CAMLparam1(filename); From 55d8c09aa9d3c0061f23bf5516e896a5a09c3b76 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 12 Aug 2020 15:14:54 +0100 Subject: [PATCH 131/199] CP-34643: Deprecated non-idiomatic pervasivesext functions The functions replaces do not match the current style of programming in ocaml, most being obscure. Many of the mhave been replaced by Stdlib.Option and other are barely used, if at all. Users have clear alternatives to use. Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-pervasives/pervasiveext.ml | 20 +++++++------------- lib/xapi-stdext-pervasives/pervasiveext.mli | 17 +++++++++++++++++ 2 files changed, 24 insertions(+), 13 deletions(-) diff --git a/lib/xapi-stdext-pervasives/pervasiveext.ml b/lib/xapi-stdext-pervasives/pervasiveext.ml index 29277481f97..f55d28c1c77 100644 --- a/lib/xapi-stdext-pervasives/pervasiveext.ml +++ b/lib/xapi-stdext-pervasives/pervasiveext.ml @@ -36,27 +36,21 @@ let finally fct clean_f = clean_f (); result -(* Those should go into the Opt module: *) -let maybe_with_default d f v = - match v with None -> d | Some x -> f x +let maybe_with_default d f v = Option.fold ~none:d ~some:f v -(** if v is not none, apply f on it and return some value else return none. *) -let may f v = maybe_with_default None (fun x -> Some (f x)) v +let may f v = Option.map f v -(** default value to d if v is none. *) -let default d v = maybe_with_default d (fun x -> x) v +let default d v = Option.value ~default:d v -(** apply f on v if not none *) -let maybe f v = maybe_with_default () f v - -(** if bool is false then we intercept and quiten any exception *) -let reraise_if bool fct = - try fct () with exn -> if bool then raise exn else () +let maybe f v = Option.iter f v (** execute fct ignoring exceptions *) let ignore_exn fct = try fct () with _ -> () +(** if not bool ignore exceptions raised by fct () *) +let reraise_if bool fct = if bool then fct () else ignore_exn fct + (* non polymorphic ignore function *) let ignore_int v = let (_: int) = v in () let ignore_int64 v = let (_: int64) = v in () diff --git a/lib/xapi-stdext-pervasives/pervasiveext.mli b/lib/xapi-stdext-pervasives/pervasiveext.mli index a0328b2fa03..46a364c9caa 100644 --- a/lib/xapi-stdext-pervasives/pervasiveext.mli +++ b/lib/xapi-stdext-pervasives/pervasiveext.mli @@ -17,10 +17,25 @@ val finally : (unit -> 'a) -> (unit -> unit) -> 'a [g ()] even if [f ()] throws an exception. *) val maybe_with_default : 'b -> ('a -> 'b) -> 'a option -> 'b + [@@ocaml.deprecated "Replace with Option.fold"] +(** [maybe_with_default d f v] is Some [f c] if [v] is [Some c] and [d] + otherwise. *) + val may : ('a -> 'b) -> 'a option -> 'b option + [@@ocaml.deprecated "Replace with Option.map"] +(** [may f v] is Some [f c] if [v] is [Some c] and None otherwise. *) + val default : 'a -> 'a option -> 'a + [@@ocaml.deprecated "Replace with Option.value"] +(** [default d v] is [c] if [o] is [Some c] and d otherwise. *) + val maybe : ('a -> unit) -> 'a option -> unit + [@@ocaml.deprecated "Replace with Option.iter"] +(** [maybe f v] is [f c] if [v] is [Some c] and [()] otherwise. *) + val reraise_if : bool -> (unit -> unit) -> unit + [@@ocaml.deprecated "Use ignore_exn instead"] +(** [reraise bool fct] runs [fct ()]. If [not bool] ignores raised exceptions *) val ignore_exn : (unit -> unit) -> unit val ignore_int : int -> unit val ignore_int32 : int32 -> unit @@ -30,4 +45,6 @@ val ignore_float : float -> unit val ignore_bool : bool -> unit val (++) : ('b -> 'c) -> ('a -> 'b) -> ('a -> 'c) + [@@ocaml.deprecated "Not a standard idiom. Define it locally if needed."] val ($) : ('a -> 'b) -> 'a -> 'b + [@@ocaml.deprecated "Not right-associative. Replace with @@"] From 722883292b83fab9aa11b4bcb21a40e6a0500728 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 12 Aug 2020 15:32:39 +0100 Subject: [PATCH 132/199] maintenance: reformat pervasivesext with ocamlformat Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-pervasives/pervasiveext.ml | 67 +++++++++++++-------- lib/xapi-stdext-pervasives/pervasiveext.mli | 10 ++- 2 files changed, 51 insertions(+), 26 deletions(-) diff --git a/lib/xapi-stdext-pervasives/pervasiveext.ml b/lib/xapi-stdext-pervasives/pervasiveext.ml index f55d28c1c77..4840c11b06b 100644 --- a/lib/xapi-stdext-pervasives/pervasiveext.ml +++ b/lib/xapi-stdext-pervasives/pervasiveext.ml @@ -15,27 +15,29 @@ * Even if fct raises an exception, clean_f is applied *) -let src = Logs.Src.create "pervasiveext" ~doc:"logs from Xapi_stdext_pervasives.Pervasiveext" - +let src = + Logs.Src.create "pervasiveext" + ~doc:"logs from Xapi_stdext_pervasives.Pervasiveext" let finally fct clean_f = let result = - try - fct (); + try fct () with exn -> - Backtrace.is_important exn; - begin - (* We catch and log exceptions raised by clean_f to avoid shadowing - the original exception raised by fct *) - try - clean_f (); + Backtrace.is_important exn ; + ( try + (* We catch and log exceptions raised by clean_f to avoid shadowing + the original exception raised by fct *) + clean_f () with cleanup_exn -> - Logs.warn ~src (fun m -> m "finally: Error while running cleanup after failure of main function: %s" (Printexc.to_string cleanup_exn)); - end; - raise exn in - clean_f (); - result - + Logs.warn ~src (fun m -> + m + "finally: Error while running cleanup after failure of main \ + function: %s" + (Printexc.to_string cleanup_exn)) + ) ; + raise exn + in + clean_f () ; result let maybe_with_default d f v = Option.fold ~none:d ~some:f v @@ -52,16 +54,33 @@ let ignore_exn fct = try fct () with _ -> () let reraise_if bool fct = if bool then fct () else ignore_exn fct (* non polymorphic ignore function *) -let ignore_int v = let (_: int) = v in () -let ignore_int64 v = let (_: int64) = v in () -let ignore_int32 v = let (_: int32) = v in () -let ignore_string v = let (_: string) = v in () -let ignore_float v = let (_: float) = v in () -let ignore_bool v = let (_: bool) = v in () +let ignore_int v = + let (_ : int) = v in + () + +let ignore_int64 v = + let (_ : int64) = v in + () + +let ignore_int32 v = + let (_ : int32) = v in + () + +let ignore_string v = + let (_ : string) = v in + () + +let ignore_float v = + let (_ : float) = v in + () + +let ignore_bool v = + let (_ : bool) = v in + () (* To avoid some parens: *) (* composition of functions: *) -let (++) f g x = f (g x) +let ( ++ ) f g x = f (g x) (* and application *) -let ($) f a = f a +let ( $ ) f a = f a diff --git a/lib/xapi-stdext-pervasives/pervasiveext.mli b/lib/xapi-stdext-pervasives/pervasiveext.mli index 46a364c9caa..7be199ef6bb 100644 --- a/lib/xapi-stdext-pervasives/pervasiveext.mli +++ b/lib/xapi-stdext-pervasives/pervasiveext.mli @@ -37,14 +37,20 @@ val reraise_if : bool -> (unit -> unit) -> unit [@@ocaml.deprecated "Use ignore_exn instead"] (** [reraise bool fct] runs [fct ()]. If [not bool] ignores raised exceptions *) val ignore_exn : (unit -> unit) -> unit + val ignore_int : int -> unit + val ignore_int32 : int32 -> unit + val ignore_int64 : int64 -> unit + val ignore_string : string -> unit + val ignore_float : float -> unit + val ignore_bool : bool -> unit -val (++) : ('b -> 'c) -> ('a -> 'b) -> ('a -> 'c) +val ( ++ ) : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c [@@ocaml.deprecated "Not a standard idiom. Define it locally if needed."] -val ($) : ('a -> 'b) -> 'a -> 'b +val ( $ ) : ('a -> 'b) -> 'a -> 'b [@@ocaml.deprecated "Not right-associative. Replace with @@"] From 4c07259cbd578de295c64daac3589202d90dc916 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 18 Aug 2020 16:27:24 +0100 Subject: [PATCH 133/199] CP-34643: add tests for xstringext These document how the module works and will be useful when changing the implementation. Signed-off-by: Pau Ruiz Safont --- .travis.yml | 1 + lib/xapi-stdext-std/dune | 7 + lib/xapi-stdext-std/xstringext_test.ml | 196 +++++++++++++++++++++++++ xapi-stdext-std.opam | 6 +- 4 files changed, 209 insertions(+), 1 deletion(-) create mode 100644 lib/xapi-stdext-std/xstringext_test.ml diff --git a/.travis.yml b/.travis.yml index a5c9b4732a1..3bd824a3c9a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -14,3 +14,4 @@ env: - PACKAGE="stdext" - PACKAGE="xapi-stdext-encodings" - PACKAGE="xapi-stdext-date" + - PACKAGE="xapi-stdext-std" diff --git a/lib/xapi-stdext-std/dune b/lib/xapi-stdext-std/dune index 5b0dcf8704a..ae15668e723 100644 --- a/lib/xapi-stdext-std/dune +++ b/lib/xapi-stdext-std/dune @@ -1,5 +1,12 @@ (library (public_name xapi-stdext-std) (name xapi_stdext_std) + (modules :standard \ xstringext_test) (libraries uuidm) ) +(tests + (names xstringext_test) + (package xapi-stdext-std) + (modules xstringext_test) + (libraries xapi_stdext_std alcotest) +) diff --git a/lib/xapi-stdext-std/xstringext_test.ml b/lib/xapi-stdext-std/xstringext_test.ml new file mode 100644 index 00000000000..096ed58abd5 --- /dev/null +++ b/lib/xapi-stdext-std/xstringext_test.ml @@ -0,0 +1,196 @@ +(* Copyright (C) Citrix Systems Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation; version 2.1 only. with the special + exception on linking described in file LICENSE. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + *) + +module XString = Xapi_stdext_std.Xstringext.String + +let test_boolean tested_f (name, case, expected) = + let check () = Alcotest.(check bool) name expected (tested_f case) in + (name, `Quick, check) + +let test_string tested_f (name, case, expected) = + let check () = Alcotest.(check string) name expected (tested_f case) in + (name, `Quick, check) + +let test_list tested_f (name, case, expected) = + let check () = + Alcotest.(check @@ list string) name expected (tested_f case) + in + (name, `Quick, check) + +let test_rev_map = + let spec_rev = [("", ""); ("foo bar", "rab oof")] in + let spec_func = [("id", Fun.id); ("uppercase_ascii", Char.uppercase_ascii)] in + let test (f_name, f) (case, expected) = + let expected = String.map f expected in + let name = + Printf.sprintf {|"%s" produces "%s" (%s)|} case expected f_name + in + test_string (XString.rev_map f) (name, case, expected) + in + let tests = + (* Generate the product of the two lists to generate the tests *) + List.concat (List.map (fun func -> List.map (test func) spec_rev) spec_func) + in + ("rev_map", tests) + +let test_split = + let test ?limit (splitter, splitted, expected) = + let split, name = + match limit with + | None -> + let name = Printf.sprintf {|'%c' splits "%s"|} splitter splitted in + (* limit being set to -1 is the same as not using the parameter *) + let split = XString.split ~limit:(-1) in + (split, name) + | Some limit -> + let name = + Printf.sprintf {|'%c' splits "%s" with limit %i|} splitter splitted + limit + in + let split = XString.split ~limit in + (split, name) + in + test_list (split splitter) (name, splitted, expected) + in + let specs_no_limit = + [ + ('.', "...", [""; ""; ""; ""]); ('.', "foo.bar.baz", ["foo"; "bar"; "baz"]) + ] + in + let tests_no_limit = List.map test specs_no_limit in + let specs_limit = + [ + (0, [('.', "...", ["..."]); ('.', "foo.bar.baz", ["foo.bar.baz"])]) + ; (1, [('.', "...", ["..."]); ('.', "foo.bar.baz", ["foo.bar.baz"])]) + ; (2, [('.', "...", [""; ".."]); ('.', "foo.bar.baz", ["foo"; "bar.baz"])]) + ; ( 3 + , [ + ('.', "...", [""; ""; "."]) + ; ('.', "foo.bar.baz", ["foo"; "bar"; "baz"]) + ] ) + ; (4, [('.', "...", [""; ""; ""; ""])]) + ] + in + let tests_limit = + List.map (fun (limit, spec) -> List.map (test ~limit) spec) specs_limit + |> List.concat + in + ("split", List.concat [tests_no_limit; tests_limit]) + +let test_split_f = + let specs = + [ + (XString.isspace, "foo bar", ["foo"; "bar"]) + ; (XString.isspace, "foo bar", ["foo"; "bar"]) + ; (XString.isspace, "foo \n\t\r bar", ["foo"; "bar"]) + ; (XString.isspace, " foo bar ", ["foo"; "bar"]) + ; (XString.isspace, "", []) + ; (XString.isspace, " ", []) + ] + in + let test (splitter, splitted, expected) = + let name = Printf.sprintf {|"%s"|} (String.escaped splitted) in + test_list (XString.split_f splitter) (name, splitted, expected) + in + let tests = List.map test specs in + ("split_f", tests) + +let test_has_substr = + let spec = + [ + ("", "", true) + ; ("", "foo bar", true) + ; ("f", "foof", true) + ; ("foofo", "foof", false) + ; ("foof", "foof", true) + ; ("f", "foof", true) + ; ("fo", "foof", true) + ; ("of", "foof", true) + ; ("ff", "foof", false) + ] + in + let test (contained, container, expected) = + let name = Printf.sprintf {|"%s" in "%s"|} contained container in + test_boolean (XString.has_substr container) (name, contained, expected) + in + ("has_substr", List.map test spec) + +let test_startswith = + let spec = + [ + ("", "", true) + ; ("", "foo bar", true) + ; ("foofo", "foof", false) + ; ("foof", "foof", true) + ; ("f", "foof", true) + ; ("fo", "foof", true) + ; ("of", "foof", false) + ; ("ff", "foof", false) + ] + in + let test (contained, container, expected) = + let name = Printf.sprintf {|"%s" starts with "%s"|} container contained in + test_boolean (XString.startswith contained) (name, container, expected) + in + ("startswith", List.map test spec) + +let test_endswith = + let spec = + [ + ("", "", true) + ; ("", "foo bar", true) + ; ("ofoof", "foof", false) + ; ("foof", "foof", true) + ; ("f", "foof", true) + ; ("fo", "foof", false) + ; ("of", "foof", true) + ; ("ff", "foof", false) + ] + in + let test (contained, container, expected) = + let name = Printf.sprintf {|"%s" ends with "%s"|} container contained in + test_boolean (XString.endswith contained) (name, container, expected) + in + ("endswith", List.map test spec) + +let test_rtrim = + let spec = + [ + ("", "") + ; ("\n", "") + ; ("\n\n", "\n") + ; ("\n ", "\n ") + ; ("foo\n", "foo") + ; ("fo\no", "fo\no") + ] + in + let test (case, expected) = + let name = + Printf.sprintf {|"%s" gets trimmed to "%s"|} (String.escaped case) + (String.escaped expected) + in + test_string XString.rtrim (name, case, expected) + in + ("rtrim", List.map test spec) + +let () = + Alcotest.run "Xstringext" + [ + test_rev_map + ; test_split + ; test_split_f + ; test_has_substr + ; test_startswith + ; test_endswith + ; test_rtrim + ] diff --git a/xapi-stdext-std.opam b/xapi-stdext-std.opam index e16c9b7ff51..80b3a02a861 100644 --- a/xapi-stdext-std.opam +++ b/xapi-stdext-std.opam @@ -6,12 +6,16 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [[ "dune" "build" "-p" name "-j" jobs ]] +build: [ + [ "dune" "build" "-p" name "-j" jobs ] + [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} +] depends: [ "ocaml" "dune" {build} "uuidm" + "alcotest" {with-test} ] synopsis: "A deprecated collection of utility functions - Standard library extensions" From cc8f1c351b38c175ad5044cffe9bbc29fb26e2c1 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 18 Aug 2020 16:32:41 +0100 Subject: [PATCH 134/199] xapi-stdext-std: Do not duplicate functions from Stdlib This fixes String.init, the previous implementation failed when creating empty strings. Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-std/xstringext.ml | 17 +---------------- lib/xapi-stdext-std/xstringext.mli | 10 ---------- 2 files changed, 1 insertion(+), 26 deletions(-) diff --git a/lib/xapi-stdext-std/xstringext.ml b/lib/xapi-stdext-std/xstringext.ml index e1f34297810..7699a989c0b 100644 --- a/lib/xapi-stdext-std/xstringext.ml +++ b/lib/xapi-stdext-std/xstringext.ml @@ -15,19 +15,9 @@ module String = struct include String let of_char c = String.make 1 c - let init n f = - let b = Bytes.make n (f 0) in - for i=1 to n-1 do - Bytes.set b i (f i); - done; - Bytes.unsafe_to_string b - - let map f string = - init (length string) (fun i -> f string.[i]) - let rev_map f string = let n = length string in - init n (fun i -> f string.[n - i - 1]) + String.init n (fun i -> f string.[n - i - 1]) let rev_iter f string = for i = length string - 1 downto 0 do @@ -41,11 +31,6 @@ module String = struct include String done; !accu - let iteri f string = - for i = 0 to length string - 1 do - f i string.[i] - done - let fold_right f string accu = let accu = ref accu in for i = length string - 1 downto 0 do diff --git a/lib/xapi-stdext-std/xstringext.mli b/lib/xapi-stdext-std/xstringext.mli index 4f419b4e4ac..780804784fc 100644 --- a/lib/xapi-stdext-std/xstringext.mli +++ b/lib/xapi-stdext-std/xstringext.mli @@ -17,13 +17,6 @@ sig val of_char : char -> string - (** Make a string of the given length with characters generated by the - given function. *) - val init : int -> (int -> char) -> string - - (** Map a string to a string. *) - val map : (char -> char) -> string -> string - (** Map a string to a string, applying the given function in reverse order. *) val rev_map : (char -> char) -> string -> string @@ -34,9 +27,6 @@ sig (** Fold over the characters in a string. *) val fold_left : ('a -> char -> 'a) -> 'a -> string -> 'a - (** Iterate over the characters with the character index in argument *) - val iteri : (int -> char -> unit) -> string -> unit - (** Iterate over the characters in a string in reverse order. *) val fold_right : (char -> 'a -> 'a) -> string -> 'a -> 'a From 4d54016129eac0e3d219804dbf6d33c9bbca263b Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 18 Aug 2020 17:42:28 +0100 Subject: [PATCH 135/199] maintenance: format xstringext files with ocamlformat Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-std/xstringext.ml | 175 +++++++++++++++-------------- lib/xapi-stdext-std/xstringext.mli | 47 ++++---- 2 files changed, 112 insertions(+), 110 deletions(-) diff --git a/lib/xapi-stdext-std/xstringext.ml b/lib/xapi-stdext-std/xstringext.ml index 7699a989c0b..4f85ba949cc 100644 --- a/lib/xapi-stdext-std/xstringext.ml +++ b/lib/xapi-stdext-std/xstringext.ml @@ -11,7 +11,8 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -module String = struct include String +module String = struct + include String let of_char c = String.make 1 c @@ -21,28 +22,26 @@ module String = struct include String let rev_iter f string = for i = length string - 1 downto 0 do - f (string.[i]) + f string.[i] done let fold_left f accu string = let accu = ref accu in for i = 0 to length string - 1 do accu := f !accu string.[i] - done; + done ; !accu let fold_right f string accu = let accu = ref accu in for i = length string - 1 downto 0 do accu := f string.[i] !accu - done; + done ; !accu - let explode string = - fold_right (fun h t -> h :: t) string [] + let explode string = fold_right (fun h t -> h :: t) string [] - let implode list = - concat "" (List.map of_char list) + let implode list = concat "" (List.map of_char list) (** True if string 'x' ends with suffix 'suffix' *) let endswith suffix x = @@ -52,101 +51,109 @@ module String = struct include String (** True if string 'x' starts with prefix 'prefix' *) let startswith prefix x = let x_l = String.length x and prefix_l = String.length prefix in - prefix_l <= x_l && String.sub x 0 prefix_l = prefix + prefix_l <= x_l && String.sub x 0 prefix_l = prefix (** Returns true for whitespace characters, false otherwise *) - let isspace = function - | ' ' | '\n' | '\r' | '\t' -> true - | _ -> false + let isspace = function ' ' | '\n' | '\r' | '\t' -> true | _ -> false (** Removes all the characters from the ends of a string for which the predicate is true *) let strip predicate string = let rec remove = function - | [] -> [] - | c :: cs -> if predicate c then remove cs else c :: cs in + | [] -> + [] + | c :: cs -> + if predicate c then remove cs else c :: cs + in implode (List.rev (remove (List.rev (remove (explode string))))) - let escaped ?rules string = match rules with - | None -> String.escaped string + let escaped ?rules string = + match rules with + | None -> + String.escaped string | Some rules -> - let aux h t = (if List.mem_assoc h rules - then List.assoc h rules - else of_char h) :: t in - concat "" (fold_right aux string []) + let aux h t = + ( if List.mem_assoc h rules then + List.assoc h rules + else + of_char h + ) + :: t + in + concat "" (fold_right aux string []) (** Take a predicate and a string, return a list of strings separated by runs of characters where the predicate was true (excluding those characters from the result) *) let split_f p str = - let not_p = fun x -> not (p x) in + let not_p x = not (p x) in let rec split_one p acc = function - | [] -> List.rev acc, [] - | c :: cs -> if p c then split_one p (c :: acc) cs else List.rev acc, c :: cs in - + | [] -> + (List.rev acc, []) + | c :: cs -> + if p c then split_one p (c :: acc) cs else (List.rev acc, c :: cs) + in let rec alternate acc drop chars = - if chars = [] then acc else - begin - let a, b = split_one (if drop then p else not_p) [] chars in - alternate (if drop then acc else a :: acc) (not drop) b - end in + if chars = [] then + acc + else + let a, b = split_one (if drop then p else not_p) [] chars in + alternate (if drop then acc else a :: acc) (not drop) b + in List.rev (List.map implode (alternate [] true (explode str))) let index_opt s c = let rec loop i = - if String.length s = i - then None + if String.length s = i then + None + else if s.[i] = c then + Some i else - if s.[i] = c - then Some i - else loop (i + 1) in + loop (i + 1) + in loop 0 - let rec split ?limit:(limit=(-1)) c s = - let i = match index_opt s c with | Some x -> x | None -> -1 in + let rec split ?(limit = -1) c s = + let i = match index_opt s c with Some x -> x | None -> -1 in let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in if i = -1 || nlimit = 0 then - [ s ] + [s] else let a = String.sub s 0 i and b = String.sub s (i + 1) (String.length s - i - 1) in - a :: (split ~limit: nlimit c b) + a :: split ~limit:nlimit c b let rtrim s = let n = String.length s in - if n > 0 && String.get s (n - 1) = '\n' then + if n > 0 && s.[n - 1] = '\n' then String.sub s 0 (n - 1) else s (** has_substr str sub returns true if sub is a substring of str. Simple, naive, slow. *) let has_substr str sub = - if String.length sub > String.length str then false else - begin - let result=ref false in - for start = 0 to (String.length str) - (String.length sub) do - if String.sub str start (String.length sub) = sub then result := true - done; - !result - end + if String.length sub > String.length str then + false + else + let result = ref false in + for start = 0 to String.length str - String.length sub do + if String.sub str start (String.length sub) = sub then result := true + done ; + !result (** find all occurences of needle in haystack and return all their respective index *) let find_all needle haystack = let m = String.length needle and n = String.length haystack in - if m > n then [] - else ( + else let i = ref 0 and found = ref [] in - while !i < (n - m + 1) - do - if (String.sub haystack !i m) = needle then ( - found := !i :: !found; + while !i < n - m + 1 do + if String.sub haystack !i m = needle then ( + found := !i :: !found ; i := !i + m - ) else ( + ) else incr i - ) - done; + done ; List.rev !found - ) (* replace all @f substring in @s by @t *) let replace f t s = @@ -157,14 +164,16 @@ module String = struct include String let new_len = String.length s + (n * len_t) - (n * len_f) in let new_b = Bytes.make new_len '\000' in let orig_offset = ref 0 and dest_offset = ref 0 in - List.iter (fun h -> + List.iter + (fun h -> let len = h - !orig_offset in - Bytes.blit_string s !orig_offset new_b !dest_offset len; - Bytes.blit_string t 0 new_b (!dest_offset + len) len_t; - orig_offset := !orig_offset + len + len_f; - dest_offset := !dest_offset + len + len_t; - ) indexes; - Bytes.blit_string s !orig_offset new_b !dest_offset (String.length s - !orig_offset); + Bytes.blit_string s !orig_offset new_b !dest_offset len ; + Bytes.blit_string t 0 new_b (!dest_offset + len) len_t ; + orig_offset := !orig_offset + len + len_f ; + dest_offset := !dest_offset + len + len_t) + indexes ; + Bytes.blit_string s !orig_offset new_b !dest_offset + (String.length s - !orig_offset) ; Bytes.unsafe_to_string new_b ) else s @@ -172,36 +181,33 @@ module String = struct include String let filter_chars s valid = let badchars = ref false in let buf = Buffer.create 0 in - for i = 0 to String.length s - 1 - do + for i = 0 to String.length s - 1 do if !badchars then ( if valid s.[i] then Buffer.add_char buf s.[i] - ) else ( - if not (valid s.[i]) then ( - Buffer.add_substring buf s 0 i; - badchars := true - ) + ) else if not (valid s.[i]) then ( + Buffer.add_substring buf s 0 i ; + badchars := true ) - done; + done ; if !badchars then Buffer.contents buf else s let map_unlikely s f = let changed = ref false in let m = ref 0 in let buf = Buffer.create 0 in - for i = 0 to String.length s - 1 - do + for i = 0 to String.length s - 1 do match f s.[i] with - | None -> () + | None -> + () | Some n -> - changed := true; - Buffer.add_substring buf s !m (i - !m); - Buffer.add_string buf n; - m := i + 1 - done; + changed := true ; + Buffer.add_substring buf s !m (i - !m) ; + Buffer.add_string buf n ; + m := i + 1 + done ; if !changed then ( - Buffer.add_substring buf s !m (String.length s - !m); + Buffer.add_substring buf s !m (String.length s - !m) ; Buffer.contents buf ) else s @@ -210,10 +216,7 @@ module String = struct include String let length = String.length s in String.sub s start (length - start) - let sub_before c s = - String.sub s 0 (String.index s c) - - let sub_after c s = - sub_to_end s (String.index s c + 1) + let sub_before c s = String.sub s 0 (String.index s c) + let sub_after c s = sub_to_end s (String.index s c + 1) end diff --git a/lib/xapi-stdext-std/xstringext.mli b/lib/xapi-stdext-std/xstringext.mli index 780804784fc..4c4c489dec5 100644 --- a/lib/xapi-stdext-std/xstringext.mli +++ b/lib/xapi-stdext-std/xstringext.mli @@ -11,79 +11,78 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -module String : -sig +module String : sig include module type of String val of_char : char -> string (** Map a string to a string, applying the given function in reverse - order. *) + order. *) val rev_map : (char -> char) -> string -> string - (** Iterate over the characters in a string in reverse order. *) val rev_iter : (char -> unit) -> string -> unit + (** Iterate over the characters in a string in reverse order. *) - (** Fold over the characters in a string. *) val fold_left : ('a -> char -> 'a) -> 'a -> string -> 'a + (** Fold over the characters in a string. *) - (** Iterate over the characters in a string in reverse order. *) val fold_right : (char -> 'a -> 'a) -> string -> 'a -> 'a + (** Iterate over the characters in a string in reverse order. *) - (** Split a string into a list of characters. *) val explode : string -> char list + (** Split a string into a list of characters. *) - (** Concatenate a list of characters into a string. *) val implode : char list -> string + (** Concatenate a list of characters into a string. *) - (** True if string 'x' ends with suffix 'suffix' *) val endswith : string -> string -> bool + (** True if string 'x' ends with suffix 'suffix' *) - (** True if string 'x' starts with prefix 'prefix' *) val startswith : string -> string -> bool + (** True if string 'x' starts with prefix 'prefix' *) - (** True if the character is whitespace *) val isspace : char -> bool + (** True if the character is whitespace *) - (** Removes all the characters from the ends of a string for which the predicate is true *) val strip : (char -> bool) -> string -> string + (** Removes all the characters from the ends of a string for which the predicate is true *) + val escaped : ?rules:(char * string) list -> string -> string (** Backward-compatible string escaping, defaulting to the built-in OCaml string escaping but allowing an arbitrary mapping from characters to strings. *) - val escaped : ?rules:(char * string) list -> string -> string + val split_f : (char -> bool) -> string -> string list (** Take a predicate and a string, return a list of strings separated by runs of characters where the predicate was true *) - val split_f : (char -> bool) -> string -> string list - (** split a string on a single char *) val split : ?limit:int -> char -> string -> string list + (** split a string on a single char *) - (** FIXME document me|remove me if similar to strip *) val rtrim : string -> string + (** FIXME document me|remove me if similar to strip *) - (** True if sub is a substr of str *) val has_substr : string -> string -> bool + (** True if sub is a substr of str *) - (** find all occurences of needle in haystack and return all their respective index *) val find_all : string -> string -> int list + (** find all occurences of needle in haystack and return all their respective index *) - (** replace all [f] substring in [s] by [t] *) val replace : string -> string -> string -> string + (** replace all [f] substring in [s] by [t] *) - (** filter chars from a string *) val filter_chars : string -> (char -> bool) -> string + (** filter chars from a string *) - (** map a string trying to fill the buffer by chunk *) val map_unlikely : string -> (char -> string option) -> string + (** map a string trying to fill the buffer by chunk *) - (** a substring from the specified position to the end of the string *) val sub_to_end : string -> int -> string + (** a substring from the specified position to the end of the string *) - (** a substring from the start of the string to the first occurrence of a given character, excluding the character *) val sub_before : char -> string -> string + (** a substring from the start of the string to the first occurrence of a given character, excluding the character *) - (** a substring from the first occurrence of a given character to the end of the string, excluding the character *) val sub_after : char -> string -> string + (** a substring from the first occurrence of a given character to the end of the string, excluding the character *) end From 13b17a753ba113eca4d4f783f50e06548b33e764 Mon Sep 17 00:00:00 2001 From: Ben Anson Date: Thu, 10 Dec 2020 16:40:09 +0000 Subject: [PATCH 136/199] XSI-894 handle iso8601's with no timezone The SDK exposes our iso8601 type as an actual iso8601 value, and takes advantage of iso8601 libraries in other languages. Therefore in order for the SDK to work as expected, we need to align more closely with the iso8601 specification. Internally we try our best to coerce the iso8601 parameters into rfc3339, since rfc3339 is what ptime expects. One particular error we have seen so far is that our date library rejects datetime strings without a timezone qualifier (which is fixed by this change). Signed-off-by: Ben Anson --- lib/xapi-stdext-date/date.ml | 36 +++++++++++++++++++++++++++--------- lib/xapi-stdext-date/test.ml | 11 +++++++++++ 2 files changed, 38 insertions(+), 9 deletions(-) diff --git a/lib/xapi-stdext-date/date.ml b/lib/xapi-stdext-date/date.ml index 7565e1f3114..006627c5a59 100644 --- a/lib/xapi-stdext-date/date.ml +++ b/lib/xapi-stdext-date/date.ml @@ -37,19 +37,37 @@ type iso8601 = Ptime.date * Ptime.time * print_type let of_dt print_type dt = let (date, time) = dt in (date, time, print_type) let to_dt (date, time, _) = (date, time) -let of_string x = +let best_effort_iso8601_to_rfc3339 x = + (* (a) add dashes + * (b) add UTC tz if no tz provided *) let x = try - (* if x doesn't contain dashes, insert them, so that ptime can parse x *) - Scanf.sscanf x "%04d%02d%02dT%s" (fun y mon d rest -> - Printf.sprintf "%04d-%02d-%02dT%s" y mon d rest - ) - with _ -> x + Scanf.sscanf x "%04d%02d%02dT%s" + (fun y mon d rest -> + Printf.sprintf "%04d-%02d-%02dT%s" y mon d rest) + with _ -> + x + in + let tz = + try + Scanf.sscanf x "%04d-%02d-%02dT%02d:%02d:%02d%s" + (fun _ _ _ _ _ _ tz -> Some tz) + with _ -> None in - match x |> Ptime.of_rfc3339 |> Ptime.rfc3339_error_to_msg with - | Error (`Msg e) -> invalid_arg (Printf.sprintf "date.ml:of_string: %s" e) + match tz with + | None | Some "" -> + (* the caller didn't specify a tz. we must try to add one so that ptime can at least attempt to parse *) + (Printf.sprintf "%sZ" x, PrintLocal) + | Some _ -> + (* the caller specified a tz. we assume it's UTC because we don't accept anything else *) + (x, PrintUTC) + +let of_string x = + let (rfc3339, print_type) = best_effort_iso8601_to_rfc3339 x in + match Ptime.of_rfc3339 rfc3339 |> Ptime.rfc3339_error_to_msg with + | Error (`Msg e) -> invalid_arg (Printf.sprintf "date.ml:of_string: %s" x) | Ok (t, tz, _) -> match tz with - | None | Some 0 -> Ptime.to_date_time t |> of_dt PrintUTC + | None | Some 0 -> Ptime.to_date_time t |> of_dt print_type | Some _ -> invalid_arg (Printf.sprintf "date.ml:of_string: %s" x) let to_string ((y,mon,d), ((h,min,s), _), print_type) = diff --git a/lib/xapi-stdext-date/test.ml b/lib/xapi-stdext-date/test.ml index 7691c572129..976903a789a 100644 --- a/lib/xapi-stdext-date/test.ml +++ b/lib/xapi-stdext-date/test.ml @@ -62,6 +62,16 @@ let iso8601_tests = Alcotest.(check bool) "localtime string does not contain a Z" false (String.contains localtime_string 'Z') in + let test_xsi894 () = + let missing_tz_no_dash = "20201210T17:19:20" in + let missing_tz_dash = "2020-12-10T17:19:20" in + check_string "can process missing tz no dash" missing_tz_no_dash (missing_tz_no_dash |> of_string |> to_string) ; + check_string "can process missing tz with dashes, but return without dashes" missing_tz_no_dash (missing_tz_dash |> of_string |> to_string) ; + + let localtime' = localtime () in + check_string "to_string inverts of_string for localtime" (localtime' |> to_string) (localtime' |> to_string |> of_string |> to_string) ; + in + [ "test_of_float_invertible", `Quick, test_of_float_invertible ; "test_only_utc", `Quick, test_only_utc ; "test_ca333908", `Quick, test_ca333908 @@ -69,6 +79,7 @@ let iso8601_tests = ; "test_to_string_backwards_compatibility", `Quick, test_to_string_backwards_compatibility ; "test_localtime_string", `Quick, test_localtime_string ; "test_ca342171", `Quick, test_ca342171 + ; "test_xsi894", `Quick, test_xsi894 ] let () = Alcotest.run "Date" [ "ISO 8601", iso8601_tests ] From 87929362c3c3425a64a6e424fa117832fd3a2c45 Mon Sep 17 00:00:00 2001 From: Ben Anson Date: Wed, 16 Dec 2020 15:19:23 +0000 Subject: [PATCH 137/199] XSI-894 date.iso8601.to_float should assume UTC We must be able to convert all iso8601's to float, in order to avoid a Java SDK regression Signed-off-by: Ben Anson --- lib/xapi-stdext-date/date.ml | 10 +--------- lib/xapi-stdext-date/date.mli | 3 ++- lib/xapi-stdext-date/test.ml | 2 ++ 3 files changed, 5 insertions(+), 10 deletions(-) diff --git a/lib/xapi-stdext-date/date.ml b/lib/xapi-stdext-date/date.ml index 006627c5a59..fb25d7e54bb 100644 --- a/lib/xapi-stdext-date/date.ml +++ b/lib/xapi-stdext-date/date.ml @@ -87,15 +87,7 @@ let of_float s = | None -> invalid_arg (Printf.sprintf "date.ml:of_float: %f" s) | Some t -> Ptime.to_date_time t |> of_dt PrintUTC -(* Convert tm in UTC back into calendar time x (using offset between above - UTC and localtime fns to determine offset between UTC and localtime, then - correcting for this) -*) -let to_float t = - let (_, _, print_type) = t in - match print_type with - | PrintLocal -> invalid_arg "date.ml:to_float: expected utc" - | PrintUTC -> to_ptime_t t |> Ptime.to_float_s +let to_float t = to_ptime_t t |> Ptime.to_float_s let _localtime current_tz_offset t = let tz_offset_s = current_tz_offset |> Option.value ~default:0 in diff --git a/lib/xapi-stdext-date/date.mli b/lib/xapi-stdext-date/date.mli index 3b5881d147b..d09a93eafba 100644 --- a/lib/xapi-stdext-date/date.mli +++ b/lib/xapi-stdext-date/date.mli @@ -21,7 +21,8 @@ type iso8601 (** Convert calendar time [x] (as returned by e.g. Unix.time), to time in UTC. *) val of_float : float -> iso8601 -(** Convert date/time to a float value: the number of seconds since 00:00:00 UTC, 1 Jan 1970. *) +(** Convert date/time to a float value: the number of seconds since 00:00:00 UTC, 1 Jan 1970. + * Assumes the underlying iso8601 is in UTC *) val to_float : iso8601 -> float (** Convert date/time to an ISO 8601 formatted string. *) diff --git a/lib/xapi-stdext-date/test.ml b/lib/xapi-stdext-date/test.ml index 976903a789a..87f3a54963e 100644 --- a/lib/xapi-stdext-date/test.ml +++ b/lib/xapi-stdext-date/test.ml @@ -68,6 +68,8 @@ let iso8601_tests = check_string "can process missing tz no dash" missing_tz_no_dash (missing_tz_no_dash |> of_string |> to_string) ; check_string "can process missing tz with dashes, but return without dashes" missing_tz_no_dash (missing_tz_dash |> of_string |> to_string) ; + check_float "to_float assumes UTC" 1607620760. (missing_tz_no_dash |> of_string |> to_float) ; + let localtime' = localtime () in check_string "to_string inverts of_string for localtime" (localtime' |> to_string) (localtime' |> to_string |> of_string |> to_string) ; in From 9d7c9291eb63991769052474f78cda8d76e282ce Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 17 Dec 2020 15:32:19 +0000 Subject: [PATCH 138/199] date: allow timezones other than UTC for printing The timezone print also does not try to dictate the formats that are allowed as ptime already does this. Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-date/date.ml | 27 ++++++++++++++------------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/lib/xapi-stdext-date/date.ml b/lib/xapi-stdext-date/date.ml index fb25d7e54bb..72504bc84f5 100644 --- a/lib/xapi-stdext-date/date.ml +++ b/lib/xapi-stdext-date/date.ml @@ -15,7 +15,7 @@ (* ==== RFC822 ==== *) type rfc822 = string -let months = [| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun"; +let months = [| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun"; "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec" |] let days = [| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |] @@ -30,9 +30,11 @@ let rfc822_to_string x = x (* ==== ISO8601/RFC3339 ==== *) -type print_type = PrintLocal | PrintUTC +type print_timezone = Empty | TZ of string (* we must store the print_type with iso8601 to handle the case where the local time zone is UTC *) -type iso8601 = Ptime.date * Ptime.time * print_type +type iso8601 = Ptime.date * Ptime.time * print_timezone + +let utc = TZ "Z" let of_dt print_type dt = let (date, time) = dt in (date, time, print_type) let to_dt (date, time, _) = (date, time) @@ -57,23 +59,22 @@ let best_effort_iso8601_to_rfc3339 x = match tz with | None | Some "" -> (* the caller didn't specify a tz. we must try to add one so that ptime can at least attempt to parse *) - (Printf.sprintf "%sZ" x, PrintLocal) - | Some _ -> - (* the caller specified a tz. we assume it's UTC because we don't accept anything else *) - (x, PrintUTC) + (Printf.sprintf "%sZ" x, Empty) + | Some tz -> + (x, TZ tz) let of_string x = - let (rfc3339, print_type) = best_effort_iso8601_to_rfc3339 x in + let (rfc3339, print_timezone) = best_effort_iso8601_to_rfc3339 x in match Ptime.of_rfc3339 rfc3339 |> Ptime.rfc3339_error_to_msg with | Error (`Msg e) -> invalid_arg (Printf.sprintf "date.ml:of_string: %s" x) | Ok (t, tz, _) -> match tz with - | None | Some 0 -> Ptime.to_date_time t |> of_dt print_type + | None | Some 0 -> Ptime.to_date_time t |> of_dt print_timezone | Some _ -> invalid_arg (Printf.sprintf "date.ml:of_string: %s" x) let to_string ((y,mon,d), ((h,min,s), _), print_type) = match print_type with - | PrintUTC -> Printf.sprintf "%04i%02i%02iT%02i:%02i:%02iZ" y mon d h min s - | PrintLocal -> Printf.sprintf "%04i%02i%02iT%02i:%02i:%02i" y mon d h min s + | TZ tz -> Printf.sprintf "%04i%02i%02iT%02i:%02i:%02i%s" y mon d h min s tz + | Empty -> Printf.sprintf "%04i%02i%02iT%02i:%02i:%02i" y mon d h min s let to_ptime_t t = match to_dt t |> Ptime.of_date_time with @@ -85,13 +86,13 @@ let to_ptime_t t = let of_float s = match Ptime.of_float_s s with | None -> invalid_arg (Printf.sprintf "date.ml:of_float: %f" s) - | Some t -> Ptime.to_date_time t |> of_dt PrintUTC + | Some t -> Ptime.to_date_time t |> of_dt utc let to_float t = to_ptime_t t |> Ptime.to_float_s let _localtime current_tz_offset t = let tz_offset_s = current_tz_offset |> Option.value ~default:0 in - let localtime = t |> Ptime.to_date_time ~tz_offset_s |> of_dt PrintLocal in + let localtime = t |> Ptime.to_date_time ~tz_offset_s |> of_dt Empty in let (_, (_, localtime_offset), _) = localtime in if localtime_offset <> tz_offset_s then invalid_arg ( From d0002d95d7980255056308682e04c110038225ec Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 17 Dec 2020 16:02:27 +0000 Subject: [PATCH 139/199] Create ocaml-ci.yml Signed-off-by: Pau Ruiz Safont --- .github/workflows/ocaml-ci.yml | 44 ++++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) create mode 100644 .github/workflows/ocaml-ci.yml diff --git a/.github/workflows/ocaml-ci.yml b/.github/workflows/ocaml-ci.yml new file mode 100644 index 00000000000..9ab3694b956 --- /dev/null +++ b/.github/workflows/ocaml-ci.yml @@ -0,0 +1,44 @@ +name: Build and test + +on: + push: + pull_request: + +jobs: + ocaml-test: + name: Ocaml tests + runs-on: ubuntu-20.04 + env: + package: "xapi-stdext-date xapi-stdext-encodings xapi-stdext-pervasives xapi-stdext-std xapi-stdext-threads xapi-stdext-unix xapi-stdext-zerocheck" + + steps: + - name: Checkout code + uses: actions/checkout@v2 + + - name: Pull configuration from xs-opam + run: | + curl --fail --silent https://raw.githubusercontent.com/xapi-project/xs-opam/master/tools/xs-opam-ci.env | cut -f2 -d " " > .env + + - name: Load environment file + id: dotenv + uses: falti/dotenv-action@v0.2.4 + + - name: Use ocaml + uses: avsm/setup-ocaml@v1 + with: + ocaml-version: ${{ steps.dotenv.outputs.ocaml_version_full }} + opam-repository: ${{ steps.dotenv.outputs.repository }} + + - name: Install dependencies + run: | + opam pin add . --no-action + opam depext -u ${{ env.package }} + opam install ${{ env.package }} --deps-only --with-test -v + + - name: Build + run: | + opam exec -- make build + + - name: Run tests + run: opam exec -- make test + From 0e654b2e84315621ed1fcdc00b5bad93fc0895a2 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 17 Dec 2020 16:03:34 +0000 Subject: [PATCH 140/199] ci: remove travis workflow Also removes unused stdext metapackage Signed-off-by: Pau Ruiz Safont --- .travis.yml | 17 ----------------- lib/xapi-stdext/dune | 14 -------------- lib/xapi-stdext/stdext.ml | 14 -------------- stdext.opam | 29 ----------------------------- xapi-stdext.opam | 14 -------------- 5 files changed, 88 deletions(-) delete mode 100644 .travis.yml delete mode 100644 lib/xapi-stdext/dune delete mode 100644 lib/xapi-stdext/stdext.ml delete mode 100644 stdext.opam delete mode 100644 xapi-stdext.opam diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 3bd824a3c9a..00000000000 --- a/.travis.yml +++ /dev/null @@ -1,17 +0,0 @@ -language: c -os: linux -dist: xenial -services: docker -install: - - wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh - - wget https://raw.githubusercontent.com/xapi-project/xs-opam/master/tools/xs-opam-ci.env - - source xs-opam-ci.env -script: bash -ex .travis-docker.sh -env: - global: - - PINS="stdext:. xapi-stdext-date:. xapi-stdext-encodings:. xapi-stdext-pervasives:. xapi-stdext-std:. xapi-stdext-threads:. xapi-stdext-unix:. xapi-stdext-zerocheck:." - jobs: - - PACKAGE="stdext" - - PACKAGE="xapi-stdext-encodings" - - PACKAGE="xapi-stdext-date" - - PACKAGE="xapi-stdext-std" diff --git a/lib/xapi-stdext/dune b/lib/xapi-stdext/dune deleted file mode 100644 index 11bb5ed7538..00000000000 --- a/lib/xapi-stdext/dune +++ /dev/null @@ -1,14 +0,0 @@ -(library - (public_name stdext) - (name stdext) - (modules stdext) - (wrapped false) - (libraries - xapi-stdext-date - xapi-stdext-encodings - xapi-stdext-pervasives - xapi-stdext-std - xapi-stdext-threads - xapi-stdext-unix - xapi-stdext-zerocheck) -) diff --git a/lib/xapi-stdext/stdext.ml b/lib/xapi-stdext/stdext.ml deleted file mode 100644 index 23c64cc0aa2..00000000000 --- a/lib/xapi-stdext/stdext.ml +++ /dev/null @@ -1,14 +0,0 @@ -(* New modules *) -module Date = Xapi_stdext_date.Date -module Encodings = Xapi_stdext_encodings.Encodings - -(* Standard library extensions and additions*) -module Pervasiveext = Xapi_stdext_pervasives.Pervasiveext -module Listext = Xapi_stdext_std.Listext -module Xstringext = Xapi_stdext_std.Xstringext - -module Threadext = Xapi_stdext_threads.Threadext -module Semaphore = Xapi_stdext_threads.Semaphore - -module Unixext = Xapi_stdext_unix.Unixext -module Zerocheck = Xapi_stdext_zerocheck.Zerocheck diff --git a/stdext.opam b/stdext.opam deleted file mode 100644 index 4840e57ff6c..00000000000 --- a/stdext.opam +++ /dev/null @@ -1,29 +0,0 @@ -opam-version: "2.0" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" -tags: [ "org:xapi-project" ] - -build: [[ "dune" "build" "-p" name "-j" jobs ]] - -depends: [ - "ocaml" - "dune" {build} - "xapi-stdext-date" - "xapi-stdext-encodings" - "xapi-stdext-pervasives" - "xapi-stdext-std" - "xapi-stdext-threads" - "xapi-stdext-unix" - "xapi-stdext-zerocheck" -] -synopsis: "A deprecated collection of utility functions" -description: """ -Backward compatibility wrapper, this is introduced along with -xapi-stdext-3.0.0 and will be removed once the oasis files of the -necessary packages have been updated. - -This library is provided for a transitionary period only. -No new code should use this library.""" diff --git a/xapi-stdext.opam b/xapi-stdext.opam deleted file mode 100644 index aba8746e7fb..00000000000 --- a/xapi-stdext.opam +++ /dev/null @@ -1,14 +0,0 @@ -opam-version: "2.0" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" -tags: [ "org:xapi-project" ] - -depends: ["ocaml" "stdext"] -synopsis: "Deprecated xapi standard library extension" -description: """ -This is a dummy package to facilitate the migration to xapi-stdext 3.0.0 -of oasis-built packages, where several package were split out of the main -stdext package and the findlib name changed from stdext to xapi-stdext.""" From 32242b81d482f185d992b9ac5c13543994439f51 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 26 Jan 2021 14:20:29 +0000 Subject: [PATCH 141/199] CP-34643: listext: remove implementations for functions in Stdlib.List Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-std/listext.ml | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/lib/xapi-stdext-std/listext.ml b/lib/xapi-stdext-std/listext.ml index 49da8a68c88..18f6e77f1df 100644 --- a/lib/xapi-stdext-std/listext.ml +++ b/lib/xapi-stdext-std/listext.ml @@ -22,7 +22,6 @@ module List = struct include List let subset s1 s2 = List.fold_left (&&) true (List.map (fun s->List.mem s s2) s1) let set_equiv s1 s2 = (subset s1 s2) && (subset s2 s1) - let iteri f list = ignore (fold_left (fun i x -> f i x; i+1) 0 list) let iteri_right f list = ignore (fold_right (fun x i -> f i x; i+1) list 0) let rec inv_assoc k = function @@ -40,12 +39,6 @@ module List = struct include List let aux (i, is) e = i + 1, if pred e then i :: is else is in snd (fold_left aux (0, []) l) - let mapi f l = - let rec aux n = function - | h :: t -> let h = f n h in h :: aux (n + 1) t - | [] -> [] in - aux 0 l - let rev_mapi f l = let rec aux n accu = function | h :: t -> aux (n + 1) (f n h :: accu) t @@ -166,9 +159,6 @@ module List = struct include List let map_assoc_with_key op al = List.map (fun (k, v1) -> (k, op k v1)) al - (* Like the Lisp cons *) - let cons a b = a :: b - (* Could use fold_left to get the same value, but that would necessarily go through the whole list everytime, instead of the first n items, only. *) (* ToDo: This is complicated enough to warrant a test. *) (* Is it wise to fail silently on negative values? (They are treated as zero, here.) @@ -201,9 +191,6 @@ module List = struct include List let unbox_list l = List.filter_map Fun.id l - let filter_map f list = - unbox_list (map f list) - let restrict_with_default default keys al = make_assoc (fun k -> assoc_default k al default) keys From af99b87a31285dedc5ff7b960dfaae0cd88e38b7 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 26 Jan 2021 14:20:31 +0000 Subject: [PATCH 142/199] CP-34643: Listext: deprecate functions in Stdlib.List Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-std/listext.mli | 90 ++++++++++++++++----------------- 1 file changed, 45 insertions(+), 45 deletions(-) diff --git a/lib/xapi-stdext-std/listext.mli b/lib/xapi-stdext-std/listext.mli index 0e7143efdf8..9857b523212 100644 --- a/lib/xapi-stdext-std/listext.mli +++ b/lib/xapi-stdext-std/listext.mli @@ -16,48 +16,48 @@ sig val setify : 'a list -> 'a list val subset : 'a list -> 'a list -> bool val set_equiv : 'a list -> 'a list -> bool - val length : 'a list -> int - val hd : 'a list -> 'a - val tl : 'a list -> 'a list - val nth : 'a list -> int -> 'a - val rev : 'a list -> 'a list - val append : 'a list -> 'a list -> 'a list - val rev_append : 'a list -> 'a list -> 'a list - val concat : 'a list list -> 'a list - val flatten : 'a list list -> 'a list - val iter : ('a -> unit) -> 'a list -> unit - val map : ('a -> 'b) -> 'a list -> 'b list - val rev_map : ('a -> 'b) -> 'a list -> 'b list - val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a - val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b - val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit - val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list - val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list - val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a + val length : 'a list -> int [@@deprecated "Use Stdlib.List instead"] + val hd : 'a list -> 'a [@@deprecated "Use Stdlib.List instead"] + val tl : 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] + val nth : 'a list -> int -> 'a [@@deprecated "Use Stdlib.List instead"] + val rev : 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] + val append : 'a list -> 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] + val rev_append : 'a list -> 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] + val concat : 'a list list -> 'a list [@@deprecated "Use Stdlib.List instead"] + val flatten : 'a list list -> 'a list [@@deprecated "Use Stdlib.List instead"] + val iter : ('a -> unit) -> 'a list -> unit [@@deprecated "Use Stdlib.List instead"] + val map : ('a -> 'b) -> 'a list -> 'b list [@@deprecated "Use Stdlib.List instead"] + val rev_map : ('a -> 'b) -> 'a list -> 'b list [@@deprecated "Use Stdlib.List instead"] + val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a [@@deprecated "Use Stdlib.List instead"] + val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b [@@deprecated "Use Stdlib.List instead"] + val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit [@@deprecated "Use Stdlib.List instead"] + val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list [@@deprecated "Use Stdlib.List instead"] + val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list [@@deprecated "Use Stdlib.List instead"] + val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a [@@deprecated "Use Stdlib.List instead"] val fold_right2 : - ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c - val for_all : ('a -> bool) -> 'a list -> bool - val exists : ('a -> bool) -> 'a list -> bool - val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool - val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool - val mem : 'a -> 'a list -> bool - val memq : 'a -> 'a list -> bool - val find : ('a -> bool) -> 'a list -> 'a - val filter : ('a -> bool) -> 'a list -> 'a list - val find_all : ('a -> bool) -> 'a list -> 'a list - val partition : ('a -> bool) -> 'a list -> 'a list * 'a list - val assoc : 'a -> ('a * 'b) list -> 'b - val assq : 'a -> ('a * 'b) list -> 'b - val mem_assoc : 'a -> ('a * 'b) list -> bool - val mem_assq : 'a -> ('a * 'b) list -> bool - val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list - val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list - val split : ('a * 'b) list -> 'a list * 'b list - val combine : 'a list -> 'b list -> ('a * 'b) list - val sort : ('a -> 'a -> int) -> 'a list -> 'a list - val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list - val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list - val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list + ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c [@@deprecated "Use Stdlib.List instead"] + val for_all : ('a -> bool) -> 'a list -> bool [@@deprecated "Use Stdlib.List instead"] + val exists : ('a -> bool) -> 'a list -> bool [@@deprecated "Use Stdlib.List instead"] + val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool [@@deprecated "Use Stdlib.List instead"] + val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool [@@deprecated "Use Stdlib.List instead"] + val mem : 'a -> 'a list -> bool [@@deprecated "Use Stdlib.List instead"] + val memq : 'a -> 'a list -> bool [@@deprecated "Use Stdlib.List instead"] + val find : ('a -> bool) -> 'a list -> 'a [@@deprecated "Use Stdlib.List instead"] + val filter : ('a -> bool) -> 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] + val find_all : ('a -> bool) -> 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] + val partition : ('a -> bool) -> 'a list -> 'a list * 'a list [@@deprecated "Use Stdlib.List instead"] + val assoc : 'a -> ('a * 'b) list -> 'b [@@deprecated "Use Stdlib.List instead"] + val assq : 'a -> ('a * 'b) list -> 'b [@@deprecated "Use Stdlib.List instead"] + val mem_assoc : 'a -> ('a * 'b) list -> bool [@@deprecated "Use Stdlib.List instead"] + val mem_assq : 'a -> ('a * 'b) list -> bool [@@deprecated "Use Stdlib.List instead"] + val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list [@@deprecated "Use Stdlib.List instead"] + val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list [@@deprecated "Use Stdlib.List instead"] + val split : ('a * 'b) list -> 'a list * 'b list [@@deprecated "Use Stdlib.List instead"] + val combine : 'a list -> 'b list -> ('a * 'b) list [@@deprecated "Use Stdlib.List instead"] + val sort : ('a -> 'a -> int) -> 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] + val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] + val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] + val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] (** Perform a lookup on an association list of (value, key) pairs. *) val inv_assoc : 'a -> ('b * 'a) list -> 'b @@ -73,9 +73,9 @@ sig (** Map the given function over a list, supplying the integer index as well as the element value. *) - val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list + val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list [@@deprecated "Use Stdlib.List instead"] - val iteri : (int -> 'a -> unit) -> 'a list -> unit + val iteri : (int -> 'a -> unit) -> 'a list -> unit [@@deprecated "Use Stdlib.List instead"] val iteri_right : (int -> 'a -> unit) -> 'a list -> unit @@ -153,7 +153,7 @@ sig non-optional values B [b1; ...; bn], with m >= n. For each value a in list A, list B contains a corresponding value b if and only if the application of (f a) results in Some b. *) - val filter_map : ('a -> 'b option) -> 'a list -> 'b list + val filter_map : ('a -> 'b option) -> 'a list -> 'b list [@@deprecated "Use Stdlib.List instead"] (** Returns true if and only if the given list is in sorted order according to the given comparison function. *) @@ -174,7 +174,7 @@ sig val map_assoc_with_key : ('k -> 'v1 -> 'v2) -> ('k * 'v1) list -> ('k * 'v2) list (* Like Lisp cons*) - val cons : 'a -> 'a list -> 'a list + val cons : 'a -> 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] (** [take n list] returns the first [n] elements of [list] (or less if list is shorter).*) From 1581ece07aab3caf8ead31e47a61172a35c3626a Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 26 Jan 2021 14:20:35 +0000 Subject: [PATCH 143/199] CP-34643: add unit tests for listext Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-std/dune | 6 +- lib/xapi-stdext-std/listext_test.ml | 181 ++++++++++++++++++++++++++++ 2 files changed, 184 insertions(+), 3 deletions(-) create mode 100644 lib/xapi-stdext-std/listext_test.ml diff --git a/lib/xapi-stdext-std/dune b/lib/xapi-stdext-std/dune index ae15668e723..b2c853da162 100644 --- a/lib/xapi-stdext-std/dune +++ b/lib/xapi-stdext-std/dune @@ -1,12 +1,12 @@ (library (public_name xapi-stdext-std) (name xapi_stdext_std) - (modules :standard \ xstringext_test) + (modules :standard \ xstringext_test listext_test) (libraries uuidm) ) (tests - (names xstringext_test) + (names xstringext_test listext_test) (package xapi-stdext-std) - (modules xstringext_test) + (modules xstringext_test listext_test) (libraries xapi_stdext_std alcotest) ) diff --git a/lib/xapi-stdext-std/listext_test.ml b/lib/xapi-stdext-std/listext_test.ml new file mode 100644 index 00000000000..3f48a85a93a --- /dev/null +++ b/lib/xapi-stdext-std/listext_test.ml @@ -0,0 +1,181 @@ +(* Copyright (C) Citrix Systems Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation; version 2.1 only. with the special + exception on linking described in file LICENSE. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + *) + +module Listext = Xapi_stdext_std.Listext.List + +let test_list tested_f (name, case, expected) = + let check () = Alcotest.(check @@ list int) name expected (tested_f case) in + (name, `Quick, check) + +let test_option tested_f (name, case, expected) = + let check () = Alcotest.(check @@ option int) name expected (tested_f case) in + (name, `Quick, check) + +let test_chopped_list tested_f (name, case, expected) = + let check () = + Alcotest.(check @@ pair (list int) (list int)) name expected (tested_f case) + in + (name, `Quick, check) + +let test_error tested_f (name, case, expected) = + let check () = Alcotest.check_raises name expected (tested_f case) in + (name, `Quick, check) + +let test_iteri_right = + let specs = + [ + ([], []) + ; ([0], [(0, 0)]) + ; ([2; 4], [(0, 4); (1, 2)]) + ; ([2; 4; 8], [(0, 8); (1, 4); (2, 2)]) + ] + in + let test (list, expected) = + let name = + Printf.sprintf "iteri over from [%s]" + (String.concat "; " (List.map string_of_int list)) + in + let accum = ref [] in + let tested_f = Listext.iteri_right (fun i x -> accum := (i, x) :: !accum) in + let check () = + tested_f list ; + (* reverse the list so the lists in the specs reflect the order of + processing *) + let result = List.rev !accum in + Alcotest.(check @@ list @@ pair int int) name expected result + in + (name, `Quick, check) + in + let tests = List.map test specs in + ("iteri_right", tests) + +let test_take = + let specs = + [ + ([], -1, []) + ; ([], 0, []) + ; ([], 1, []) + ; ([1; 2; 3], -1, []) + ; ([1; 2; 3], 0, []) + ; ([1; 2; 3], 1, [1]) + ; ([1; 2; 3], 2, [1; 2]) + ; ([1; 2; 3], 3, [1; 2; 3]) + ; ([1; 2; 3], 4, [1; 2; 3]) + ; ([1; 2; 3], 5, [1; 2; 3]) + ] + in + let test (whole, number, expected) = + let name = + Printf.sprintf "take %i from [%s]" number + (String.concat "; " (List.map string_of_int whole)) + in + test_list (Listext.take number) (name, whole, expected) + in + let tests = List.map test specs in + ("take", tests) + +let test_chop = + let specs = + [ + ([], 0, ([], [])) + ; ([0], 0, ([], [0])) + ; ([0], 1, ([0], [])) + ; ([0; 1], 0, ([], [0; 1])) + ; ([0; 1], 1, ([0], [1])) + ; ([0; 1], 2, ([0; 1], [])) + ] + in + let error_specs = + [([0], -1, Invalid_argument "chop"); ([0], 2, Invalid_argument "chop")] + in + let test (whole, number, expected) = + let name = + Printf.sprintf "chop [%s] with %i" + (String.concat "; " (List.map string_of_int whole)) + number + in + test_chopped_list (Listext.chop number) (name, whole, expected) + in + let tests = List.map test specs in + let error_test (whole, number, error) = + let name = + Printf.sprintf "chop [%s] with %i fails" + (String.concat "; " (List.map string_of_int whole)) + number + in + test_error + (fun ls () -> ignore (Listext.chop number ls)) + (name, whole, error) + in + let error_tests = List.map error_test error_specs in + ("chop", tests @ error_tests) + +let test_sub = + let specs = + [ + ([], 0, 0, []) + ; ([0], 0, 0, []) + ; ([0], 0, 1, [0]) + ; ([0], 1, 1, []) + ; ([0; 1], 0, 0, []) + ; ([0; 1], 0, 1, [0]) + ; ([0; 1], 0, 2, [0; 1]) + ; ([0; 1], 1, 1, []) + ; ([0; 1], 1, 2, [1]) + ; ([0; 1], 2, 2, []) + ] + in + let error_specs = + [ + ([0], -1, 0, Invalid_argument "rev_chop") + ; ([0], 0, -1, Invalid_argument "rev_chop") + ; ([0; 1], 1, 0, Invalid_argument "rev_chop") + ] + in + let test (whole, from, until, expected) = + let name = + Printf.sprintf "sub [%s] from %i to %i" + (String.concat "; " (List.map string_of_int whole)) + from until + in + test_list (Listext.sub from until) (name, whole, expected) + in + let tests = List.map test specs in + let error_test (whole, from, until, error) = + let name = + Printf.sprintf "sub [%s] from %i to %i fails" + (String.concat "; " (List.map string_of_int whole)) + from until + in + test_error + (fun ls () -> ignore (Listext.sub from until ls)) + (name, whole, error) + in + let error_tests = List.map error_test error_specs in + ("sub", tests @ error_tests) + +let test_safe_hd = + let specs = [([], None); ([0], Some 0); ([0; 1], Some 0)] in + let[@warning "-3"] test (list, expected) = + let name = + Printf.sprintf "safe_hd of [%s]" + (String.concat "; " (List.map string_of_int list)) + in + test_option Listext.safe_hd (name, list, expected) + in + let tests = List.map test specs in + ("safe_hd", tests) + +let () = + Alcotest.run "Listext" + [test_iteri_right; test_take; test_chop; test_sub; test_safe_hd] From 65c9d917201fd6bf65f3583058250687519fa589 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 26 Jan 2021 14:20:36 +0000 Subject: [PATCH 144/199] CP-34643: listext: add drop function, rework some functions The implementations had some deficiencies, like being hard to analyze, having poor error or potentially taking a long time until the error was shown. Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-std/listext.ml | 50 ++++++++++++++----------- lib/xapi-stdext-std/listext.mli | 21 ++++++++--- lib/xapi-stdext-std/listext_test.ml | 58 ++++++++++++++++++----------- 3 files changed, 81 insertions(+), 48 deletions(-) diff --git a/lib/xapi-stdext-std/listext.ml b/lib/xapi-stdext-std/listext.ml index 18f6e77f1df..628844d0d0b 100644 --- a/lib/xapi-stdext-std/listext.ml +++ b/lib/xapi-stdext-std/listext.ml @@ -22,7 +22,7 @@ module List = struct include List let subset s1 s2 = List.fold_left (&&) true (List.map (fun s->List.mem s s2) s1) let set_equiv s1 s2 = (subset s1 s2) && (subset s2 s1) - let iteri_right f list = ignore (fold_right (fun x i -> f i x; i+1) list 0) + let iteri_right f list = iteri f (rev list) let rec inv_assoc k = function | [] -> raise Not_found @@ -47,13 +47,37 @@ module List = struct include List let mapi_tr f l = rev (rev_mapi f l) + let take n list = + let rec loop i acc = function + | x :: xs when i < n -> + loop (i + 1) (x :: acc) xs + | _ -> + List.rev acc + in + loop 0 [] list + + let drop n list = + let rec loop i = function + | x :: xs when i < n -> + loop (i + 1) xs + | l -> + l + in + loop 0 list + + let sub i j l = drop i l |> take (j - (max i 0)) + let rec chop i l = match i, l with + | j, _ when j < 0 -> + invalid_arg "chop: index cannot be negative" | 0, l -> [], l - | i, h :: t -> (fun (fr, ba) -> h :: fr, ba) (chop (i - 1) t) - | _ -> invalid_arg "chop" + | _, h :: t -> (fun (fr, ba) -> h :: fr, ba) (chop (i - 1) t) + | _, [] -> invalid_arg "chop: index not in list" let rev_chop i l = let rec aux i fr ba = match i, fr, ba with + | i, _, _ when i < 0 -> + invalid_arg "rev_chop: index cannot be negative" | 0, fr, ba -> (fr, ba) | i, fr, h :: t -> aux (i - 1) (h :: fr) t | _ -> invalid_arg "rev_chop" in @@ -66,9 +90,6 @@ module List = struct include List | l, [] -> [l] | l1, l2 -> l1 :: dice m l2 - let sub i j l = - fst (chop_tr (j - i) (snd (rev_chop i l))) - let remove i l = match rev_chop i l with | rfr, _ :: t -> rev_append rfr t | _ -> invalid_arg "remove" @@ -159,27 +180,12 @@ module List = struct include List let map_assoc_with_key op al = List.map (fun (k, v1) -> (k, op k v1)) al - (* Could use fold_left to get the same value, but that would necessarily go through the whole list everytime, instead of the first n items, only. *) - (* ToDo: This is complicated enough to warrant a test. *) - (* Is it wise to fail silently on negative values? (They are treated as zero, here.) - Pro: Would mask fewer bugs. - Con: Less robust. - *) - let take n list = - let rec helper i acc list = - if i <= 0 || list = [] - then acc - else helper (i-1) (List.hd list :: acc) (List.tl list) - in List.rev (helper n [] list) - (* Thanks to sharing we only use linear space. (Roughly double the space needed for the spine of the original list) *) let rec tails = function | [] -> [[]] | (_::xs) as l -> l :: tails xs - let safe_hd = function - | a::_ -> Some a - | [] -> None + let safe_hd l = List.nth_opt l 0 let replace_assoc key new_value existing = (key, new_value) :: (List.filter (fun (k, _) -> k <> key) existing) diff --git a/lib/xapi-stdext-std/listext.mli b/lib/xapi-stdext-std/listext.mli index 9857b523212..e438cf80db7 100644 --- a/lib/xapi-stdext-std/listext.mli +++ b/lib/xapi-stdext-std/listext.mli @@ -85,20 +85,26 @@ sig (** Tail-recursive [mapi]. *) val mapi_tr : (int -> 'a -> 'b) -> 'a list -> 'b list - (** Split a list at the given index to give a pair of lists. *) + (** [chop k l] splits [l] at index [k] to return a pair of lists. Raises + invalid_arg when [i] is negative or greater than the length of [l]. *) val chop : int -> 'a list -> 'a list * 'a list - (** Split a list at the given index to give a pair of lists, the first in - reverse order. *) + (** [rev_chop k l] splits [l] at index [k] to return a pair of lists, the + first in reverse order. Raises invalid_arg when [i] is negative or + greater than the length of [l]. *) val rev_chop : int -> 'a list -> 'a list * 'a list (** Tail-recursive [chop]. *) val chop_tr : int -> 'a list -> 'a list * 'a list - (** Split a list into lists with the given number of elements. *) + (** [dice k l] splits [l] into lists with [k] elements each. Raises + invalid_arg if [List.length l] is not divisible by [k]. *) val dice : int -> 'a list -> 'a list list - (** Extract the sub-list between the given indices. *) + (** [sub from to l] returns the sub-list of [l] that starts at index [from] + and ends at [to] or an empty list if [to] is equal or less than [from]. + Negative indices are treated as 0 and indeces higher than [List.length l + - 1] are treated as [List.length l - 1]. *) val sub : int -> int -> 'a list -> 'a list (** Remove the element at the given index. *) @@ -180,8 +186,13 @@ sig is shorter).*) val take : int -> 'a list -> 'a list + (** [drop n list] returns the list without the first [n] elements of [list] + (or [] if list is shorter). *) + val drop : int -> 'a list -> 'a list + val tails : 'a list -> ('a list) list val safe_hd : 'a list -> 'a option + [@@deprecated "Use List.nth_opt list 0 instead"] (** Replace the value belonging to a key in an association list. Adds the key/value pair * if it does not yet exist in the list. If the same key occurs multiple time in the original diff --git a/lib/xapi-stdext-std/listext_test.ml b/lib/xapi-stdext-std/listext_test.ml index 3f48a85a93a..a96a9736483 100644 --- a/lib/xapi-stdext-std/listext_test.ml +++ b/lib/xapi-stdext-std/listext_test.ml @@ -84,6 +84,31 @@ let test_take = let tests = List.map test specs in ("take", tests) +let test_drop = + let specs = + [ + ([], -1, []) + ; ([], 0, []) + ; ([], 1, []) + ; ([1; 2; 3], -1, [1; 2; 3]) + ; ([1; 2; 3], 0, [1; 2; 3]) + ; ([1; 2; 3], 1, [2; 3]) + ; ([1; 2; 3], 2, [3]) + ; ([1; 2; 3], 3, []) + ; ([1; 2; 3], 4, []) + ; ([1; 2; 3], 5, []) + ] + in + let test (whole, number, expected) = + let name = + Printf.sprintf "drop %i from [%s]" number + (String.concat "; " (List.map string_of_int whole)) + in + test_list (Listext.drop number) (name, whole, expected) + in + let tests = List.map test specs in + ("drop", tests) + let test_chop = let specs = [ @@ -96,7 +121,10 @@ let test_chop = ] in let error_specs = - [([0], -1, Invalid_argument "chop"); ([0], 2, Invalid_argument "chop")] + [ + ([0], -1, Invalid_argument "chop: index cannot be negative") + ; ([0], 2, Invalid_argument "chop: index not in list") + ] in let test (whole, number, expected) = let name = @@ -124,22 +152,21 @@ let test_sub = let specs = [ ([], 0, 0, []) + ; ([], 0, 1, []) ; ([0], 0, 0, []) ; ([0], 0, 1, [0]) ; ([0], 1, 1, []) + ; ([0], 0, 2, [0]) ; ([0; 1], 0, 0, []) ; ([0; 1], 0, 1, [0]) ; ([0; 1], 0, 2, [0; 1]) ; ([0; 1], 1, 1, []) ; ([0; 1], 1, 2, [1]) ; ([0; 1], 2, 2, []) - ] - in - let error_specs = - [ - ([0], -1, 0, Invalid_argument "rev_chop") - ; ([0], 0, -1, Invalid_argument "rev_chop") - ; ([0; 1], 1, 0, Invalid_argument "rev_chop") + (* test_cases below used to fail *) [@ocamlformat "disable"] + ; ([0], -1, 0, []) + ; ([0], 0, -1, []) + ; ([0; 1], 1, 0, []) ] in let test (whole, from, until, expected) = @@ -151,18 +178,7 @@ let test_sub = test_list (Listext.sub from until) (name, whole, expected) in let tests = List.map test specs in - let error_test (whole, from, until, error) = - let name = - Printf.sprintf "sub [%s] from %i to %i fails" - (String.concat "; " (List.map string_of_int whole)) - from until - in - test_error - (fun ls () -> ignore (Listext.sub from until ls)) - (name, whole, error) - in - let error_tests = List.map error_test error_specs in - ("sub", tests @ error_tests) + ("sub", tests) let test_safe_hd = let specs = [([], None); ([0], Some 0); ([0; 1], Some 0)] in @@ -178,4 +194,4 @@ let test_safe_hd = let () = Alcotest.run "Listext" - [test_iteri_right; test_take; test_chop; test_sub; test_safe_hd] + [test_iteri_right; test_take; test_drop; test_chop; test_sub; test_safe_hd] From f2729fdbbdba1aedf697991fa96a8f7dd14a03bd Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 26 Jan 2021 14:20:32 +0000 Subject: [PATCH 145/199] maintenance: prepare for ocamlformat Signed-off-by: Pau Ruiz Safont --- .ocamlformat | 1 - lib/xapi-stdext-pervasives/pervasiveext.mli | 3 ++- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index b4d356a7786..ea8e56a85a7 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,5 +1,4 @@ profile=ocamlformat -version=0.14.1 indicate-multiline-delimiters=closing-on-separate-line if-then-else=fit-or-vertical dock-collection-brackets=true diff --git a/lib/xapi-stdext-pervasives/pervasiveext.mli b/lib/xapi-stdext-pervasives/pervasiveext.mli index 7be199ef6bb..d0e7fdc5f7a 100644 --- a/lib/xapi-stdext-pervasives/pervasiveext.mli +++ b/lib/xapi-stdext-pervasives/pervasiveext.mli @@ -35,7 +35,8 @@ val maybe : ('a -> unit) -> 'a option -> unit val reraise_if : bool -> (unit -> unit) -> unit [@@ocaml.deprecated "Use ignore_exn instead"] -(** [reraise bool fct] runs [fct ()]. If [not bool] ignores raised exceptions *) +(** [reraise_if bool fct] runs [fct ()]. If [not bool] ignores raised exceptions *) + val ignore_exn : (unit -> unit) -> unit val ignore_int : int -> unit From b2b564eacba28d36f362f6ec6261ba02e8d266f1 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 10 Feb 2021 09:31:14 +0000 Subject: [PATCH 146/199] maintenance: format with ocamlformat Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-std/listext.ml | 216 ++++++++++++++++++----------- lib/xapi-stdext-std/listext.mli | 235 +++++++++++++++++++++----------- 2 files changed, 291 insertions(+), 160 deletions(-) diff --git a/lib/xapi-stdext-std/listext.ml b/lib/xapi-stdext-std/listext.ml index 628844d0d0b..25656b1a8c5 100644 --- a/lib/xapi-stdext-std/listext.ml +++ b/lib/xapi-stdext-std/listext.ml @@ -12,22 +12,30 @@ * GNU Lesser General Public License for more details. *) -module List = struct include List +module List = struct + include List (** Turn a list into a set *) let rec setify = function - | [] -> [] - | (x::xs) -> if mem x xs then setify xs else x::(setify xs) + | [] -> + [] + | x :: xs -> + if mem x xs then setify xs else x :: setify xs - let subset s1 s2 = List.fold_left (&&) true (List.map (fun s->List.mem s s2) s1) - let set_equiv s1 s2 = (subset s1 s2) && (subset s2 s1) + let subset s1 s2 = + List.fold_left ( && ) true (List.map (fun s -> List.mem s s2) s1) + + let set_equiv s1 s2 = subset s1 s2 && subset s2 s1 let iteri_right f list = iteri f (rev list) let rec inv_assoc k = function - | [] -> raise Not_found - | (v, k') :: _ when k = k' -> v - | _ :: t -> inv_assoc k t + | [] -> + raise Not_found + | (v, k') :: _ when k = k' -> + v + | _ :: t -> + inv_assoc k t (* Tail-recursive map. *) let map_tr f l = rev (rev_map f l) @@ -36,13 +44,16 @@ module List = struct include List fold_left (fun count e -> count + if pred e then 1 else 0) 0 l let position pred l = - let aux (i, is) e = i + 1, if pred e then i :: is else is in + let aux (i, is) e = (i + 1, if pred e then i :: is else is) in snd (fold_left aux (0, []) l) let rev_mapi f l = let rec aux n accu = function - | h :: t -> aux (n + 1) (f n h :: accu) t - | [] -> accu in + | h :: t -> + aux (n + 1) (f n h :: accu) t + | [] -> + accu + in aux 0 [] l let mapi_tr f l = rev (rev_mapi f l) @@ -65,97 +76,138 @@ module List = struct include List in loop 0 list - let sub i j l = drop i l |> take (j - (max i 0)) + let sub i j l = drop i l |> take (j - max i 0) - let rec chop i l = match i, l with + let rec chop i l = + match (i, l) with | j, _ when j < 0 -> invalid_arg "chop: index cannot be negative" - | 0, l -> [], l - | _, h :: t -> (fun (fr, ba) -> h :: fr, ba) (chop (i - 1) t) - | _, [] -> invalid_arg "chop: index not in list" + | 0, l -> + ([], l) + | _, h :: t -> + (fun (fr, ba) -> (h :: fr, ba)) (chop (i - 1) t) + | _, [] -> + invalid_arg "chop: index not in list" let rev_chop i l = - let rec aux i fr ba = match i, fr, ba with + let rec aux i fr ba = + match (i, fr, ba) with | i, _, _ when i < 0 -> invalid_arg "rev_chop: index cannot be negative" - | 0, fr, ba -> (fr, ba) - | i, fr, h :: t -> aux (i - 1) (h :: fr) t - | _ -> invalid_arg "rev_chop" in + | 0, fr, ba -> + (fr, ba) + | i, fr, h :: t -> + aux (i - 1) (h :: fr) t + | _ -> + invalid_arg "rev_chop" + in aux i [] l - let chop_tr i l = - (fun (fr, ba) -> rev fr, ba) (rev_chop i l) + let chop_tr i l = (fun (fr, ba) -> (rev fr, ba)) (rev_chop i l) - let rec dice m l = match chop m l with - | l, [] -> [l] - | l1, l2 -> l1 :: dice m l2 + let rec dice m l = + match chop m l with l, [] -> [l] | l1, l2 -> l1 :: dice m l2 - let remove i l = match rev_chop i l with - | rfr, _ :: t -> rev_append rfr t - | _ -> invalid_arg "remove" + let remove i l = + match rev_chop i l with + | rfr, _ :: t -> + rev_append rfr t + | _ -> + invalid_arg "remove" - let extract i l = match rev_chop i l with - | rfr, h :: t -> h, rev_append rfr t - | _ -> invalid_arg "extract" + let extract i l = + match rev_chop i l with + | rfr, h :: t -> + (h, rev_append rfr t) + | _ -> + invalid_arg "extract" - let insert i e l = match rev_chop i l with - rfr, ba -> rev_append rfr (e :: ba) + let insert i e l = + match rev_chop i l with rfr, ba -> rev_append rfr (e :: ba) - let replace i e l = match rev_chop i l with - | rfr, _ :: t -> rev_append rfr (e :: t) - | _ -> invalid_arg "replace" + let replace i e l = + match rev_chop i l with + | rfr, _ :: t -> + rev_append rfr (e :: t) + | _ -> + invalid_arg "replace" - let morph i f l = match rev_chop i l with - | rfr, h :: t -> rev_append rfr (f h :: t) - | _ -> invalid_arg "morph" + let morph i f l = + match rev_chop i l with + | rfr, h :: t -> + rev_append rfr (f h :: t) + | _ -> + invalid_arg "morph" let rec between e = function - | [] -> [] - | [h] -> [h] - | h :: t -> h :: e :: between e t - + | [] -> + [] + | [h] -> + [h] + | h :: t -> + h :: e :: between e t let between_tr e l = let rec aux accu e = function - | [] -> rev accu - | [h] -> rev (h :: accu) - | h :: t -> aux (e :: h :: accu) e t in + | [] -> + rev accu + | [h] -> + rev (h :: accu) + | h :: t -> + aux (e :: h :: accu) e t + in aux [] e l let randomize l = let extract_rand l = extract (Random.int (length l)) l in let rec aux accu = function - | [] -> accu - | l -> (fun (h, t) -> aux (h :: accu) t) (extract_rand l) in + | [] -> + accu + | l -> + (fun (h, t) -> aux (h :: accu) t) (extract_rand l) + in aux [] l let rec distribute e = function - | (h :: t) as l -> - (e :: l) :: (map (fun x -> h :: x) (distribute e t)) - | [] -> [ [ e ] ] + | h :: t as l -> + (e :: l) :: map (fun x -> h :: x) (distribute e t) + | [] -> + [[e]] let rec permute = function - | e :: rest -> flatten (map (distribute e) (permute rest)) - | [] -> [ [] ] + | e :: rest -> + flatten (map (distribute e) (permute rest)) + | [] -> + [[]] let rec aux_rle_eq eq l2 x n = function - | [] -> rev ((x, n) :: l2) - | h :: t when eq x h -> aux_rle_eq eq l2 x (n + 1) t - | h :: t -> aux_rle_eq eq ((x, n) :: l2) h 1 t + | [] -> + rev ((x, n) :: l2) + | h :: t when eq x h -> + aux_rle_eq eq l2 x (n + 1) t + | h :: t -> + aux_rle_eq eq ((x, n) :: l2) h 1 t - let rle_eq eq l = - match l with [] -> [] | h :: t -> aux_rle_eq eq [] h 1 t + let rle_eq eq l = match l with [] -> [] | h :: t -> aux_rle_eq eq [] h 1 t let rle l = rle_eq ( = ) l let unrle l = - let rec aux2 accu i c = match i with - | 0 -> accu - | i when i>0 -> aux2 (c :: accu) (i - 1) c - | _ -> invalid_arg "unrle" in + let rec aux2 accu i c = + match i with + | 0 -> + accu + | i when i > 0 -> + aux2 (c :: accu) (i - 1) c + | _ -> + invalid_arg "unrle" + in let rec aux accu = function - | [] -> rev accu - | (i, c) :: t -> aux (aux2 accu i c) t in + | [] -> + rev accu + | (i, c) :: t -> + aux (aux2 accu i c) t + in aux [] l let inner fold_left2 base f l1 l2 g = @@ -164,36 +216,33 @@ module List = struct include List let rec is_sorted compare list = match list with | x :: y :: list -> - if compare x y <= 0 - then is_sorted compare (y :: list) - else false + if compare x y <= 0 then + is_sorted compare (y :: list) + else + false | _ -> - true + true let intersect xs ys = List.filter (fun x -> List.mem x ys) xs - let set_difference a b = List.filter (fun x -> not(List.mem x b)) a + let set_difference a b = List.filter (fun x -> not (List.mem x b)) a - let assoc_default k l d = - if List.mem_assoc k l then List.assoc k l else d + let assoc_default k l d = if List.mem_assoc k l then List.assoc k l else d - let map_assoc_with_key op al = - List.map (fun (k, v1) -> (k, op k v1)) al + let map_assoc_with_key op al = List.map (fun (k, v1) -> (k, op k v1)) al (* Thanks to sharing we only use linear space. (Roughly double the space needed for the spine of the original list) *) - let rec tails = function - | [] -> [[]] - | (_::xs) as l -> l :: tails xs + let rec tails = function [] -> [[]] | _ :: xs as l -> l :: tails xs let safe_hd l = List.nth_opt l 0 let replace_assoc key new_value existing = - (key, new_value) :: (List.filter (fun (k, _) -> k <> key) existing) + (key, new_value) :: List.filter (fun (k, _) -> k <> key) existing let update_assoc update existing = - update @ (List.filter (fun (k, _) -> not (List.mem_assoc k update)) existing) + update @ List.filter (fun (k, _) -> not (List.mem_assoc k update)) existing - let make_assoc op l = map (fun key -> key, op key) l + let make_assoc op l = map (fun key -> (key, op key)) l let unbox_list l = List.filter_map Fun.id l @@ -202,9 +251,10 @@ module List = struct include List let range lower = let rec aux accu upper = - if lower >= upper - then accu - else aux (upper-1::accu) (upper-1) in + if lower >= upper then + accu + else + aux ((upper - 1) :: accu) (upper - 1) + in aux [] - end diff --git a/lib/xapi-stdext-std/listext.mli b/lib/xapi-stdext-std/listext.mli index e438cf80db7..2d4a1961b14 100644 --- a/lib/xapi-stdext-std/listext.mli +++ b/lib/xapi-stdext-std/listext.mli @@ -11,211 +11,292 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -module List : -sig +module List : sig val setify : 'a list -> 'a list + val subset : 'a list -> 'a list -> bool + val set_equiv : 'a list -> 'a list -> bool + val length : 'a list -> int [@@deprecated "Use Stdlib.List instead"] + val hd : 'a list -> 'a [@@deprecated "Use Stdlib.List instead"] + val tl : 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] + val nth : 'a list -> int -> 'a [@@deprecated "Use Stdlib.List instead"] + val rev : 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] - val append : 'a list -> 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] - val rev_append : 'a list -> 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] + + val append : 'a list -> 'a list -> 'a list + [@@deprecated "Use Stdlib.List instead"] + + val rev_append : 'a list -> 'a list -> 'a list + [@@deprecated "Use Stdlib.List instead"] + val concat : 'a list list -> 'a list [@@deprecated "Use Stdlib.List instead"] + val flatten : 'a list list -> 'a list [@@deprecated "Use Stdlib.List instead"] - val iter : ('a -> unit) -> 'a list -> unit [@@deprecated "Use Stdlib.List instead"] - val map : ('a -> 'b) -> 'a list -> 'b list [@@deprecated "Use Stdlib.List instead"] - val rev_map : ('a -> 'b) -> 'a list -> 'b list [@@deprecated "Use Stdlib.List instead"] - val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a [@@deprecated "Use Stdlib.List instead"] - val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b [@@deprecated "Use Stdlib.List instead"] - val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit [@@deprecated "Use Stdlib.List instead"] - val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list [@@deprecated "Use Stdlib.List instead"] - val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list [@@deprecated "Use Stdlib.List instead"] - val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a [@@deprecated "Use Stdlib.List instead"] - val fold_right2 : - ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c [@@deprecated "Use Stdlib.List instead"] - val for_all : ('a -> bool) -> 'a list -> bool [@@deprecated "Use Stdlib.List instead"] - val exists : ('a -> bool) -> 'a list -> bool [@@deprecated "Use Stdlib.List instead"] - val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool [@@deprecated "Use Stdlib.List instead"] - val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool [@@deprecated "Use Stdlib.List instead"] + + val iter : ('a -> unit) -> 'a list -> unit + [@@deprecated "Use Stdlib.List instead"] + + val map : ('a -> 'b) -> 'a list -> 'b list + [@@deprecated "Use Stdlib.List instead"] + + val rev_map : ('a -> 'b) -> 'a list -> 'b list + [@@deprecated "Use Stdlib.List instead"] + + val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a + [@@deprecated "Use Stdlib.List instead"] + + val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b + [@@deprecated "Use Stdlib.List instead"] + + val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit + [@@deprecated "Use Stdlib.List instead"] + + val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + [@@deprecated "Use Stdlib.List instead"] + + val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + [@@deprecated "Use Stdlib.List instead"] + + val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a + [@@deprecated "Use Stdlib.List instead"] + + val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c + [@@deprecated "Use Stdlib.List instead"] + + val for_all : ('a -> bool) -> 'a list -> bool + [@@deprecated "Use Stdlib.List instead"] + + val exists : ('a -> bool) -> 'a list -> bool + [@@deprecated "Use Stdlib.List instead"] + + val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + [@@deprecated "Use Stdlib.List instead"] + + val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + [@@deprecated "Use Stdlib.List instead"] + val mem : 'a -> 'a list -> bool [@@deprecated "Use Stdlib.List instead"] + val memq : 'a -> 'a list -> bool [@@deprecated "Use Stdlib.List instead"] - val find : ('a -> bool) -> 'a list -> 'a [@@deprecated "Use Stdlib.List instead"] - val filter : ('a -> bool) -> 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] - val find_all : ('a -> bool) -> 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] - val partition : ('a -> bool) -> 'a list -> 'a list * 'a list [@@deprecated "Use Stdlib.List instead"] - val assoc : 'a -> ('a * 'b) list -> 'b [@@deprecated "Use Stdlib.List instead"] + + val find : ('a -> bool) -> 'a list -> 'a + [@@deprecated "Use Stdlib.List instead"] + + val filter : ('a -> bool) -> 'a list -> 'a list + [@@deprecated "Use Stdlib.List instead"] + + val find_all : ('a -> bool) -> 'a list -> 'a list + [@@deprecated "Use Stdlib.List instead"] + + val partition : ('a -> bool) -> 'a list -> 'a list * 'a list + [@@deprecated "Use Stdlib.List instead"] + + val assoc : 'a -> ('a * 'b) list -> 'b + [@@deprecated "Use Stdlib.List instead"] + val assq : 'a -> ('a * 'b) list -> 'b [@@deprecated "Use Stdlib.List instead"] - val mem_assoc : 'a -> ('a * 'b) list -> bool [@@deprecated "Use Stdlib.List instead"] - val mem_assq : 'a -> ('a * 'b) list -> bool [@@deprecated "Use Stdlib.List instead"] - val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list [@@deprecated "Use Stdlib.List instead"] - val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list [@@deprecated "Use Stdlib.List instead"] - val split : ('a * 'b) list -> 'a list * 'b list [@@deprecated "Use Stdlib.List instead"] - val combine : 'a list -> 'b list -> ('a * 'b) list [@@deprecated "Use Stdlib.List instead"] - val sort : ('a -> 'a -> int) -> 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] - val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] - val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] - val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] - (** Perform a lookup on an association list of (value, key) pairs. *) + val mem_assoc : 'a -> ('a * 'b) list -> bool + [@@deprecated "Use Stdlib.List instead"] + + val mem_assq : 'a -> ('a * 'b) list -> bool + [@@deprecated "Use Stdlib.List instead"] + + val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list + [@@deprecated "Use Stdlib.List instead"] + + val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list + [@@deprecated "Use Stdlib.List instead"] + + val split : ('a * 'b) list -> 'a list * 'b list + [@@deprecated "Use Stdlib.List instead"] + + val combine : 'a list -> 'b list -> ('a * 'b) list + [@@deprecated "Use Stdlib.List instead"] + + val sort : ('a -> 'a -> int) -> 'a list -> 'a list + [@@deprecated "Use Stdlib.List instead"] + + val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list + [@@deprecated "Use Stdlib.List instead"] + + val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list + [@@deprecated "Use Stdlib.List instead"] + + val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list + [@@deprecated "Use Stdlib.List instead"] + val inv_assoc : 'a -> ('b * 'a) list -> 'b + (** Perform a lookup on an association list of (value, key) pairs. *) - (** A tail-recursive map. *) val map_tr : ('a -> 'b) -> 'a list -> 'b list + (** A tail-recursive map. *) - (** Count the number of list elements matching the given predicate. *) val count : ('a -> bool) -> 'a list -> int + (** Count the number of list elements matching the given predicate. *) - (** Find the indices of all elements matching the given predicate. *) val position : ('a -> bool) -> 'a list -> int list + (** Find the indices of all elements matching the given predicate. *) + val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list + [@@deprecated "Use Stdlib.List instead"] (** Map the given function over a list, supplying the integer index as well as the element value. *) - val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list [@@deprecated "Use Stdlib.List instead"] - val iteri : (int -> 'a -> unit) -> 'a list -> unit [@@deprecated "Use Stdlib.List instead"] + val iteri : (int -> 'a -> unit) -> 'a list -> unit + [@@deprecated "Use Stdlib.List instead"] val iteri_right : (int -> 'a -> unit) -> 'a list -> unit - (** Map the given function over a list in reverse order. *) val rev_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list + (** Map the given function over a list in reverse order. *) - (** Tail-recursive [mapi]. *) val mapi_tr : (int -> 'a -> 'b) -> 'a list -> 'b list + (** Tail-recursive [mapi]. *) + val chop : int -> 'a list -> 'a list * 'a list (** [chop k l] splits [l] at index [k] to return a pair of lists. Raises invalid_arg when [i] is negative or greater than the length of [l]. *) - val chop : int -> 'a list -> 'a list * 'a list + val rev_chop : int -> 'a list -> 'a list * 'a list (** [rev_chop k l] splits [l] at index [k] to return a pair of lists, the first in reverse order. Raises invalid_arg when [i] is negative or greater than the length of [l]. *) - val rev_chop : int -> 'a list -> 'a list * 'a list - (** Tail-recursive [chop]. *) val chop_tr : int -> 'a list -> 'a list * 'a list + (** Tail-recursive [chop]. *) + val dice : int -> 'a list -> 'a list list (** [dice k l] splits [l] into lists with [k] elements each. Raises invalid_arg if [List.length l] is not divisible by [k]. *) - val dice : int -> 'a list -> 'a list list + val sub : int -> int -> 'a list -> 'a list (** [sub from to l] returns the sub-list of [l] that starts at index [from] and ends at [to] or an empty list if [to] is equal or less than [from]. Negative indices are treated as 0 and indeces higher than [List.length l - 1] are treated as [List.length l - 1]. *) - val sub : int -> int -> 'a list -> 'a list - (** Remove the element at the given index. *) val remove : int -> 'a list -> 'a list + (** Remove the element at the given index. *) (** Extract the element at the given index, returning the element and the list without that element. *) - val extract : int -> 'a list -> 'a * 'a list - (** Insert the given element at the given index. *) val insert : int -> 'a -> 'a list -> 'a list + (** Insert the given element at the given index. *) - (** Replace the element at the given index with the given value. *) val replace : int -> 'a -> 'a list -> 'a list + (** Replace the element at the given index with the given value. *) - (** Apply the given function to the element at the given index. *) val morph : int -> ('a -> 'a) -> 'a list -> 'a list + (** Apply the given function to the element at the given index. *) + val between : 'a -> 'a list -> 'a list (** Insert the element [e] between every pair of adjacent elements in the given list. *) - val between : 'a -> 'a list -> 'a list - (** Tail-recursive [between]. *) val between_tr : 'a -> 'a list -> 'a list + (** Tail-recursive [between]. *) - (** Generate a random permutation of the given list. *) val randomize : 'a list -> 'a list + (** Generate a random permutation of the given list. *) + val distribute : 'a -> 'a list -> 'a list list (** Distribute the given element over the given list, returning a list of lists with the new element in each position. *) - val distribute : 'a -> 'a list -> 'a list list - (** Generate all permutations of the given list. *) val permute : 'a list -> 'a list list + (** Generate all permutations of the given list. *) - (** Run-length encode the given list using the given equality function. *) val rle_eq : ('a -> 'a -> bool) -> 'a list -> ('a * int) list + (** Run-length encode the given list using the given equality function. *) - (** Run-length encode the given list using built-in equality. *) val rle : 'a list -> ('a * int) list + (** Run-length encode the given list using built-in equality. *) - (** Decode a run-length encoded list. *) val unrle : (int * 'a) list -> 'a list + (** Decode a run-length encoded list. *) - (** Compute the inner product of two lists. *) val inner : - (('a -> 'b -> 'c -> 'd) -> 'e -> 'f -> 'g -> 'h) -> - 'e -> ('b -> 'c -> 'i) -> 'f -> 'g -> ('a -> 'i -> 'd) -> 'h + (('a -> 'b -> 'c -> 'd) -> 'e -> 'f -> 'g -> 'h) + -> 'e + -> ('b -> 'c -> 'i) + -> 'f + -> 'g + -> ('a -> 'i -> 'd) + -> 'h + (** Compute the inner product of two lists. *) + val filter_map : ('a -> 'b option) -> 'a list -> 'b list + [@@deprecated "Use Stdlib.List instead"] (** Applies a function f that generates optional values, to each of the items in a list A [a1; ...; am], generating a new list of non-optional values B [b1; ...; bn], with m >= n. For each value a in list A, list B contains a corresponding value b if and only if the application of (f a) results in Some b. *) - val filter_map : ('a -> 'b option) -> 'a list -> 'b list [@@deprecated "Use Stdlib.List instead"] + val is_sorted : ('a -> 'a -> int) -> 'a list -> bool (** Returns true if and only if the given list is in sorted order according to the given comparison function. *) - val is_sorted : ('a -> 'a -> int) -> 'a list -> bool - (** Returns the intersection of two lists. *) val intersect : 'a list -> 'a list -> 'a list + (** Returns the intersection of two lists. *) - (** Returns the set difference of two lists *) val set_difference : 'a list -> 'a list -> 'a list + (** Returns the set difference of two lists *) + val assoc_default : 'a -> ('a * 'b) list -> 'b -> 'b (** Act as List.assoc, but return the given default value if the key is not in the list. *) - val assoc_default : 'a -> ('a * 'b) list -> 'b -> 'b + val map_assoc_with_key : + ('k -> 'v1 -> 'v2) -> ('k * 'v1) list -> ('k * 'v2) list (** [map_assoc_with_key op al] transforms every value in [al] based on the key and the value using [op]. *) - val map_assoc_with_key : ('k -> 'v1 -> 'v2) -> ('k * 'v1) list -> ('k * 'v2) list (* Like Lisp cons*) val cons : 'a -> 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] + val take : int -> 'a list -> 'a list (** [take n list] returns the first [n] elements of [list] (or less if list is shorter).*) - val take : int -> 'a list -> 'a list + val drop : int -> 'a list -> 'a list (** [drop n list] returns the list without the first [n] elements of [list] (or [] if list is shorter). *) - val drop : int -> 'a list -> 'a list - val tails : 'a list -> ('a list) list + val tails : 'a list -> 'a list list + val safe_hd : 'a list -> 'a option [@@deprecated "Use List.nth_opt list 0 instead"] + val replace_assoc : 'a -> 'b -> ('a * 'b) list -> ('a * 'b) list (** Replace the value belonging to a key in an association list. Adds the key/value pair * if it does not yet exist in the list. If the same key occurs multiple time in the original * list, all occurances are removed and replaced by a single new key/value pair. * This function is useful is the assoc list is used as a lightweight map/hashtable/dictonary. *) - val replace_assoc : 'a -> 'b -> ('a * 'b) list -> ('a * 'b) list + val update_assoc : ('a * 'b) list -> ('a * 'b) list -> ('a * 'b) list (** Includes everything from [update] and all key/value pairs from [existing] for * which the key does not exist in [update]. In other words, it is like [replace_assoc] * but then given a whole assoc list of updates rather than a single key/value pair. *) - val update_assoc : ('a * 'b) list -> ('a * 'b) list -> ('a * 'b) list val make_assoc : ('a -> 'b) -> 'a list -> ('a * 'b) list - (** Unbox all values from the option list. *) val unbox_list : 'a option list -> 'a list + (** Unbox all values from the option list. *) + val restrict_with_default : 'v -> 'k list -> ('k * 'v) list -> ('k * 'v) list (** [restrict_with_default default keys al] makes a new association map from [keys] to previous values for [keys] in [al]. If a key is not found in [al], the [default] is used. *) - val restrict_with_default : 'v -> 'k list -> ('k * 'v) list -> ('k * 'v) list + val range : int -> int -> int list (** range lower upper = [lower; lower + 1; ...; upper - 1] Returns the empty list if lower >= upper. *) - val range : int -> int -> int list end From d085fe370672fd9fadfccb51fbfff0d48c9a0846 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 10 Feb 2021 11:39:36 +0000 Subject: [PATCH 147/199] listext: avoid traversing list twice on assoc_default Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-std/listext.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/xapi-stdext-std/listext.ml b/lib/xapi-stdext-std/listext.ml index 25656b1a8c5..9a1095823d7 100644 --- a/lib/xapi-stdext-std/listext.ml +++ b/lib/xapi-stdext-std/listext.ml @@ -227,7 +227,7 @@ module List = struct let set_difference a b = List.filter (fun x -> not (List.mem x b)) a - let assoc_default k l d = if List.mem_assoc k l then List.assoc k l else d + let assoc_default k l d = Option.value ~default:d (List.assoc_opt k l) let map_assoc_with_key op al = List.map (fun (k, v1) -> (k, op k v1)) al From 32eac485ee1d29f5f97023831468a088cc35714c Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 22 Apr 2021 15:05:13 +0100 Subject: [PATCH 148/199] unix: remove unused stdext-std dependency Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-unix/dune | 3 +-- xapi-stdext-unix.opam | 1 - 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/lib/xapi-stdext-unix/dune b/lib/xapi-stdext-unix/dune index 6e3a9f9385f..6478ad3ae78 100644 --- a/lib/xapi-stdext-unix/dune +++ b/lib/xapi-stdext-unix/dune @@ -9,6 +9,5 @@ (libraries fd-send-recv unix - xapi-stdext-pervasives - xapi-stdext-std) + xapi-stdext-pervasives) ) diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam index f8985bfd130..cd78519036b 100644 --- a/xapi-stdext-unix.opam +++ b/xapi-stdext-unix.opam @@ -14,7 +14,6 @@ depends: [ "base-unix" "fd-send-recv" {>= "2.0.0"} "xapi-stdext-pervasives" - "xapi-stdext-std" ] synopsis: "A deprecated collection of utility functions - Unix module extensions" From a332e697f4b6a238026910e25628352cb7f68f88 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 21 May 2021 14:44:13 +0100 Subject: [PATCH 149/199] CP-34643: drop deprecated methods from listext Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-std/listext.ml | 2 +- lib/xapi-stdext-std/listext.mli | 166 +++------------------------- lib/xapi-stdext-std/listext_test.ml | 14 +-- 3 files changed, 16 insertions(+), 166 deletions(-) diff --git a/lib/xapi-stdext-std/listext.ml b/lib/xapi-stdext-std/listext.ml index 9a1095823d7..683568e303c 100644 --- a/lib/xapi-stdext-std/listext.ml +++ b/lib/xapi-stdext-std/listext.ml @@ -13,7 +13,7 @@ *) module List = struct - include List + open! List (** Turn a list into a set *) let rec setify = function diff --git a/lib/xapi-stdext-std/listext.mli b/lib/xapi-stdext-std/listext.mli index 2d4a1961b14..51874e6cf65 100644 --- a/lib/xapi-stdext-std/listext.mli +++ b/lib/xapi-stdext-std/listext.mli @@ -18,119 +18,6 @@ module List : sig val set_equiv : 'a list -> 'a list -> bool - val length : 'a list -> int [@@deprecated "Use Stdlib.List instead"] - - val hd : 'a list -> 'a [@@deprecated "Use Stdlib.List instead"] - - val tl : 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] - - val nth : 'a list -> int -> 'a [@@deprecated "Use Stdlib.List instead"] - - val rev : 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] - - val append : 'a list -> 'a list -> 'a list - [@@deprecated "Use Stdlib.List instead"] - - val rev_append : 'a list -> 'a list -> 'a list - [@@deprecated "Use Stdlib.List instead"] - - val concat : 'a list list -> 'a list [@@deprecated "Use Stdlib.List instead"] - - val flatten : 'a list list -> 'a list [@@deprecated "Use Stdlib.List instead"] - - val iter : ('a -> unit) -> 'a list -> unit - [@@deprecated "Use Stdlib.List instead"] - - val map : ('a -> 'b) -> 'a list -> 'b list - [@@deprecated "Use Stdlib.List instead"] - - val rev_map : ('a -> 'b) -> 'a list -> 'b list - [@@deprecated "Use Stdlib.List instead"] - - val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a - [@@deprecated "Use Stdlib.List instead"] - - val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b - [@@deprecated "Use Stdlib.List instead"] - - val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit - [@@deprecated "Use Stdlib.List instead"] - - val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list - [@@deprecated "Use Stdlib.List instead"] - - val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list - [@@deprecated "Use Stdlib.List instead"] - - val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a - [@@deprecated "Use Stdlib.List instead"] - - val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c - [@@deprecated "Use Stdlib.List instead"] - - val for_all : ('a -> bool) -> 'a list -> bool - [@@deprecated "Use Stdlib.List instead"] - - val exists : ('a -> bool) -> 'a list -> bool - [@@deprecated "Use Stdlib.List instead"] - - val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool - [@@deprecated "Use Stdlib.List instead"] - - val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool - [@@deprecated "Use Stdlib.List instead"] - - val mem : 'a -> 'a list -> bool [@@deprecated "Use Stdlib.List instead"] - - val memq : 'a -> 'a list -> bool [@@deprecated "Use Stdlib.List instead"] - - val find : ('a -> bool) -> 'a list -> 'a - [@@deprecated "Use Stdlib.List instead"] - - val filter : ('a -> bool) -> 'a list -> 'a list - [@@deprecated "Use Stdlib.List instead"] - - val find_all : ('a -> bool) -> 'a list -> 'a list - [@@deprecated "Use Stdlib.List instead"] - - val partition : ('a -> bool) -> 'a list -> 'a list * 'a list - [@@deprecated "Use Stdlib.List instead"] - - val assoc : 'a -> ('a * 'b) list -> 'b - [@@deprecated "Use Stdlib.List instead"] - - val assq : 'a -> ('a * 'b) list -> 'b [@@deprecated "Use Stdlib.List instead"] - - val mem_assoc : 'a -> ('a * 'b) list -> bool - [@@deprecated "Use Stdlib.List instead"] - - val mem_assq : 'a -> ('a * 'b) list -> bool - [@@deprecated "Use Stdlib.List instead"] - - val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list - [@@deprecated "Use Stdlib.List instead"] - - val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list - [@@deprecated "Use Stdlib.List instead"] - - val split : ('a * 'b) list -> 'a list * 'b list - [@@deprecated "Use Stdlib.List instead"] - - val combine : 'a list -> 'b list -> ('a * 'b) list - [@@deprecated "Use Stdlib.List instead"] - - val sort : ('a -> 'a -> int) -> 'a list -> 'a list - [@@deprecated "Use Stdlib.List instead"] - - val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list - [@@deprecated "Use Stdlib.List instead"] - - val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list - [@@deprecated "Use Stdlib.List instead"] - - val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list - [@@deprecated "Use Stdlib.List instead"] - val inv_assoc : 'a -> ('b * 'a) list -> 'b (** Perform a lookup on an association list of (value, key) pairs. *) @@ -143,14 +30,6 @@ module List : sig val position : ('a -> bool) -> 'a list -> int list (** Find the indices of all elements matching the given predicate. *) - val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list - [@@deprecated "Use Stdlib.List instead"] - (** Map the given function over a list, supplying the integer - index as well as the element value. *) - - val iteri : (int -> 'a -> unit) -> 'a list -> unit - [@@deprecated "Use Stdlib.List instead"] - val iteri_right : (int -> 'a -> unit) -> 'a list -> unit val rev_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list @@ -184,9 +63,6 @@ module List : sig val remove : int -> 'a list -> 'a list (** Remove the element at the given index. *) - (** Extract the element at the given index, returning the element and the - list without that element. *) - val insert : int -> 'a -> 'a list -> 'a list (** Insert the given element at the given index. *) @@ -198,7 +74,7 @@ module List : sig val between : 'a -> 'a list -> 'a list (** Insert the element [e] between every pair of adjacent elements in the - given list. *) + given list. *) val between_tr : 'a -> 'a list -> 'a list (** Tail-recursive [between]. *) @@ -208,7 +84,7 @@ module List : sig val distribute : 'a -> 'a list -> 'a list list (** Distribute the given element over the given list, returning a list of - lists with the new element in each position. *) + lists with the new element in each position. *) val permute : 'a list -> 'a list list (** Generate all permutations of the given list. *) @@ -232,17 +108,9 @@ module List : sig -> 'h (** Compute the inner product of two lists. *) - val filter_map : ('a -> 'b option) -> 'a list -> 'b list - [@@deprecated "Use Stdlib.List instead"] - (** Applies a function f that generates optional values, to each - of the items in a list A [a1; ...; am], generating a new list of - non-optional values B [b1; ...; bn], with m >= n. For each value - a in list A, list B contains a corresponding value b if and only - if the application of (f a) results in Some b. *) - val is_sorted : ('a -> 'a -> int) -> 'a list -> bool (** Returns true if and only if the given list is in sorted order - according to the given comparison function. *) + according to the given comparison function. *) val intersect : 'a list -> 'a list -> 'a list (** Returns the intersection of two lists. *) @@ -252,19 +120,16 @@ module List : sig val assoc_default : 'a -> ('a * 'b) list -> 'b -> 'b (** Act as List.assoc, but return the given default value if the - key is not in the list. *) + key is not in the list. *) val map_assoc_with_key : ('k -> 'v1 -> 'v2) -> ('k * 'v1) list -> ('k * 'v2) list (** [map_assoc_with_key op al] transforms every value in [al] based on the - key and the value using [op]. *) - - (* Like Lisp cons*) - val cons : 'a -> 'a list -> 'a list [@@deprecated "Use Stdlib.List instead"] + key and the value using [op]. *) val take : int -> 'a list -> 'a list (** [take n list] returns the first [n] elements of [list] (or less if list - is shorter).*) + is shorter).*) val drop : int -> 'a list -> 'a list (** [drop n list] returns the list without the first [n] elements of [list] @@ -272,19 +137,16 @@ module List : sig val tails : 'a list -> 'a list list - val safe_hd : 'a list -> 'a option - [@@deprecated "Use List.nth_opt list 0 instead"] - val replace_assoc : 'a -> 'b -> ('a * 'b) list -> ('a * 'b) list (** Replace the value belonging to a key in an association list. Adds the key/value pair - * if it does not yet exist in the list. If the same key occurs multiple time in the original - * list, all occurances are removed and replaced by a single new key/value pair. - * This function is useful is the assoc list is used as a lightweight map/hashtable/dictonary. *) + if it does not yet exist in the list. If the same key occurs multiple time in the original + list, all occurances are removed and replaced by a single new key/value pair. + This function is useful is the assoc list is used as a lightweight map/hashtable/dictonary. *) val update_assoc : ('a * 'b) list -> ('a * 'b) list -> ('a * 'b) list (** Includes everything from [update] and all key/value pairs from [existing] for - * which the key does not exist in [update]. In other words, it is like [replace_assoc] - * but then given a whole assoc list of updates rather than a single key/value pair. *) + which the key does not exist in [update]. In other words, it is like [replace_assoc] + but then given a whole assoc list of updates rather than a single key/value pair. *) val make_assoc : ('a -> 'b) -> 'a list -> ('a * 'b) list @@ -293,10 +155,10 @@ module List : sig val restrict_with_default : 'v -> 'k list -> ('k * 'v) list -> ('k * 'v) list (** [restrict_with_default default keys al] makes a new association map - from [keys] to previous values for [keys] in [al]. If a key is not found - in [al], the [default] is used. *) + from [keys] to previous values for [keys] in [al]. If a key is not found + in [al], the [default] is used. *) val range : int -> int -> int list (** range lower upper = [lower; lower + 1; ...; upper - 1] - Returns the empty list if lower >= upper. *) + Returns the empty list if lower >= upper. *) end diff --git a/lib/xapi-stdext-std/listext_test.ml b/lib/xapi-stdext-std/listext_test.ml index a96a9736483..8fcedeb9ee7 100644 --- a/lib/xapi-stdext-std/listext_test.ml +++ b/lib/xapi-stdext-std/listext_test.ml @@ -180,18 +180,6 @@ let test_sub = let tests = List.map test specs in ("sub", tests) -let test_safe_hd = - let specs = [([], None); ([0], Some 0); ([0; 1], Some 0)] in - let[@warning "-3"] test (list, expected) = - let name = - Printf.sprintf "safe_hd of [%s]" - (String.concat "; " (List.map string_of_int list)) - in - test_option Listext.safe_hd (name, list, expected) - in - let tests = List.map test specs in - ("safe_hd", tests) - let () = Alcotest.run "Listext" - [test_iteri_right; test_take; test_drop; test_chop; test_sub; test_safe_hd] + [test_iteri_right; test_take; test_drop; test_chop; test_sub] From a769bc19f447b4c2bd1eb85c40ea1deec80e835c Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 21 May 2021 17:08:24 +0100 Subject: [PATCH 150/199] CP-34643: Reorder functions in listext interface This allows to direct users away from certain functions which should be avoided and offer alternatives in the documentation. Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-std/listext.mli | 175 ++++++++++++++++++-------------- 1 file changed, 101 insertions(+), 74 deletions(-) diff --git a/lib/xapi-stdext-std/listext.mli b/lib/xapi-stdext-std/listext.mli index 51874e6cf65..e7b6092abe2 100644 --- a/lib/xapi-stdext-std/listext.mli +++ b/lib/xapi-stdext-std/listext.mli @@ -12,17 +12,33 @@ * GNU Lesser General Public License for more details. *) module List : sig - val setify : 'a list -> 'a list + (** {1 Comparison} *) - val subset : 'a list -> 'a list -> bool + val is_sorted : ('a -> 'a -> int) -> 'a list -> bool + (** [is_sorted cmp l] returns whether [l] is sorted according to [cmp]. *) - val set_equiv : 'a list -> 'a list -> bool + (** {1 Iterators} *) - val inv_assoc : 'a -> ('b * 'a) list -> 'b - (** Perform a lookup on an association list of (value, key) pairs. *) + val take : int -> 'a list -> 'a list + (** [take n list] returns the first [n] elements of [list] (or less if list + is shorter).*) + + val drop : int -> 'a list -> 'a list + (** [drop n list] returns the list without the first [n] elements of [list] + (or [] if list is shorter). *) + + val rev_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list + (** [rev_map f l] gives the same result as {!Stdlib.List.rev}[ (] + {!Stdlib.List.mapi}[ f l)], but is tail-recursive and more efficient. *) val map_tr : ('a -> 'b) -> 'a list -> 'b list - (** A tail-recursive map. *) + (** [map_tr f l] is {!Stdlib.List.rev}[ (]{!Stdlib.List.rev_map}[ f l)]. *) + + val mapi_tr : (int -> 'a -> 'b) -> 'a list -> 'b list + (** [mapi_tr f l] is {!Stdlib.List.rev}[ (]{!rev_mapi}[ f l)]. *) + + val unbox_list : 'a option list -> 'a list + (** Unbox all values from the option list. *) val count : ('a -> bool) -> 'a list -> int (** Count the number of list elements matching the given predicate. *) @@ -31,12 +47,9 @@ module List : sig (** Find the indices of all elements matching the given predicate. *) val iteri_right : (int -> 'a -> unit) -> 'a list -> unit + (** [iteri_right f l] is {!Stdlib.List.iteri}[ f (]{!Stdlib.List.rev}[ l)] *) - val rev_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list - (** Map the given function over a list in reverse order. *) - - val mapi_tr : (int -> 'a -> 'b) -> 'a list -> 'b list - (** Tail-recursive [mapi]. *) + (** {1 Using indices to manipulate lists} *) val chop : int -> 'a list -> 'a list * 'a list (** [chop k l] splits [l] at index [k] to return a pair of lists. Raises @@ -48,11 +61,11 @@ module List : sig greater than the length of [l]. *) val chop_tr : int -> 'a list -> 'a list * 'a list - (** Tail-recursive [chop]. *) + (** Tail-recursive {!chop}. *) val dice : int -> 'a list -> 'a list list (** [dice k l] splits [l] into lists with [k] elements each. Raises - invalid_arg if [List.length l] is not divisible by [k]. *) + {!Invalid_arg} if [List.length l] is not divisible by [k]. *) val sub : int -> int -> 'a list -> 'a list (** [sub from to l] returns the sub-list of [l] that starts at index [from] @@ -72,32 +85,79 @@ module List : sig val morph : int -> ('a -> 'a) -> 'a list -> 'a list (** Apply the given function to the element at the given index. *) - val between : 'a -> 'a list -> 'a list - (** Insert the element [e] between every pair of adjacent elements in the - given list. *) + (** {1 Association Lists} *) - val between_tr : 'a -> 'a list -> 'a list - (** Tail-recursive [between]. *) + val make_assoc : ('a -> 'b) -> 'a list -> ('a * 'b) list - val randomize : 'a list -> 'a list - (** Generate a random permutation of the given list. *) + val assoc_default : 'a -> ('a * 'b) list -> 'b -> 'b + (** Act as List.assoc, but return the given default value if the + key is not in the list. *) - val distribute : 'a -> 'a list -> 'a list list - (** Distribute the given element over the given list, returning a list of - lists with the new element in each position. *) + val replace_assoc : 'a -> 'b -> ('a * 'b) list -> ('a * 'b) list + (** Replace the value belonging to a key in an association list. Adds the key/value pair + if it does not yet exist in the list. If the same key occurs multiple time in the original + list, all occurances are removed and replaced by a single new key/value pair. + This function is useful is the assoc list is used as a lightweight map/hashtable/dictonary. *) - val permute : 'a list -> 'a list list - (** Generate all permutations of the given list. *) + val update_assoc : ('a * 'b) list -> ('a * 'b) list -> ('a * 'b) list + (** Includes everything from [update] and all key/value pairs from [existing] for + which the key does not exist in [update]. In other words, it is like [replace_assoc] + but then given a whole assoc list of updates rather than a single key/value pair. *) - val rle_eq : ('a -> 'a -> bool) -> 'a list -> ('a * int) list - (** Run-length encode the given list using the given equality function. *) + val map_assoc_with_key : + ('k -> 'v1 -> 'v2) -> ('k * 'v1) list -> ('k * 'v2) list + (** [map_assoc_with_key op al] transforms every value in [al] based on the + key and the value using [op]. *) + + val inv_assoc : 'a -> ('b * 'a) list -> 'b + (** Perform a lookup on an association list of (value, key) pairs. *) + + val restrict_with_default : 'v -> 'k list -> ('k * 'v) list -> ('k * 'v) list + (** [restrict_with_default default keys al] makes a new association map + from [keys] to previous values for [keys] in [al]. If a key is not found + in [al], the [default] is used. *) + + (** {1 Run-length encoded lists} + There are no known users of these functions. *) val rle : 'a list -> ('a * int) list - (** Run-length encode the given list using built-in equality. *) + [@@deprecated + "No known users, consider creating a proper datatype, this kind of list \ + might be confused with association lists"] + (** Run-length encodes the given list using polimorphic equality *) val unrle : (int * 'a) list -> 'a list + [@@deprecated "No known users"] (** Decode a run-length encoded list. *) + val rle_eq : ('a -> 'a -> bool) -> 'a list -> ('a * int) list + [@@deprecated "No known users"] + (** [rle_eq eq l] run-length encodes [l] using [eq] *) + + (** {1 Generative functions} + These are usually useful for coding challenges like Advent of Code.*) + + val range : int -> int -> int list + (** range lower upper = [lower; lower + 1; ...; upper - 1] + Returns the empty list if lower >= upper. + Consider building an {!Stdlib.Seq}, it's more flexible *) + + val between : 'a -> 'a list -> 'a list + (** [between e l] Intersperses [e] between elements of [l]. *) + + val between_tr : 'a -> 'a list -> 'a list + (** Tail-recursive {!between}. *) + + val randomize : 'a list -> 'a list [@@deprecated "Not used"] + (** Generate a random permutation of the given list. *) + + val distribute : 'a -> 'a list -> 'a list list [@@deprecated "Not used"] + (** Distribute the given element over the given list, returning a list of + lists with the new element in each position. *) + + val permute : 'a list -> 'a list list [@@deprecated "Not used"] + (** Generate all permutations of the given list. *) + val inner : (('a -> 'b -> 'c -> 'd) -> 'e -> 'f -> 'g -> 'h) -> 'e @@ -108,57 +168,24 @@ module List : sig -> 'h (** Compute the inner product of two lists. *) - val is_sorted : ('a -> 'a -> int) -> 'a list -> bool - (** Returns true if and only if the given list is in sorted order - according to the given comparison function. *) - - val intersect : 'a list -> 'a list -> 'a list - (** Returns the intersection of two lists. *) - - val set_difference : 'a list -> 'a list -> 'a list - (** Returns the set difference of two lists *) - - val assoc_default : 'a -> ('a * 'b) list -> 'b -> 'b - (** Act as List.assoc, but return the given default value if the - key is not in the list. *) - - val map_assoc_with_key : - ('k -> 'v1 -> 'v2) -> ('k * 'v1) list -> ('k * 'v2) list - (** [map_assoc_with_key op al] transforms every value in [al] based on the - key and the value using [op]. *) - - val take : int -> 'a list -> 'a list - (** [take n list] returns the first [n] elements of [list] (or less if list - is shorter).*) - - val drop : int -> 'a list -> 'a list - (** [drop n list] returns the list without the first [n] elements of [list] - (or [] if list is shorter). *) - val tails : 'a list -> 'a list list - val replace_assoc : 'a -> 'b -> ('a * 'b) list -> ('a * 'b) list - (** Replace the value belonging to a key in an association list. Adds the key/value pair - if it does not yet exist in the list. If the same key occurs multiple time in the original - list, all occurances are removed and replaced by a single new key/value pair. - This function is useful is the assoc list is used as a lightweight map/hashtable/dictonary. *) + (** {1 Lists as sets, avoid} + Please use Set.Make instead, these functions have quadratic costs! *) - val update_assoc : ('a * 'b) list -> ('a * 'b) list -> ('a * 'b) list - (** Includes everything from [update] and all key/value pairs from [existing] for - which the key does not exist in [update]. In other words, it is like [replace_assoc] - but then given a whole assoc list of updates rather than a single key/value pair. *) + val setify : 'a list -> 'a list + (** [setify a] removes all duplicates from [a] while maintaining order. + Please use [List.sort_uniq] instead to deduplicate lists if possible *) - val make_assoc : ('a -> 'b) -> 'a list -> ('a * 'b) list + val subset : 'a list -> 'a list -> bool + (** [subset a b] returns whether all elements in [b] can be found in [a]*) - val unbox_list : 'a option list -> 'a list - (** Unbox all values from the option list. *) + val set_equiv : 'a list -> 'a list -> bool - val restrict_with_default : 'v -> 'k list -> ('k * 'v) list -> ('k * 'v) list - (** [restrict_with_default default keys al] makes a new association map - from [keys] to previous values for [keys] in [al]. If a key is not found - in [al], the [default] is used. *) + val set_difference : 'a list -> 'a list -> 'a list + (** Returns the set difference of two lists *) + + val intersect : 'a list -> 'a list -> 'a list + (** Returns the intersection of two lists. *) - val range : int -> int -> int list - (** range lower upper = [lower; lower + 1; ...; upper - 1] - Returns the empty list if lower >= upper. *) end From d71bcceb23e296247f394f007ca3627d771ddda9 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 21 May 2021 17:11:10 +0100 Subject: [PATCH 151/199] CP-34643: Prepare doc comments for odoc Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-threads/semaphore.mli | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/lib/xapi-stdext-threads/semaphore.mli b/lib/xapi-stdext-threads/semaphore.mli index 8cea7755e0c..0db704ce9c8 100644 --- a/lib/xapi-stdext-threads/semaphore.mli +++ b/lib/xapi-stdext-threads/semaphore.mli @@ -17,21 +17,21 @@ type t exception Inconsistent_state of string (** [create n] create a semaphore with initial value [n] (a positive integer). - Raise {Invalid_argument} if [n] <= 0 *) + Raise {!Invalid_argument} if [n] <= 0 *) val create : int -> t (** [acquire k s] block until the semaphore value is >= [k] (a positive integer), then atomically decrement the semaphore value by [k]. - Raise {Invalid_argument} if [k] <= 0 *) + Raise {!Invalid_argument} if [k] <= 0 *) val acquire : t -> int -> unit (** [release k s] atomically increment the semaphore value by [k] (a positive integer). - Raise {Invalid_argument} if [k] <= 0 *) + Raise {!Invalid_argument} if [k] <= 0 *) val release : t -> int -> unit -(** [execute_with_weight s k f] {acquire} the semaphore with [k], - then run [f ()], and finally {release} the semaphore with the same value [k] +(** [execute_with_weight s k f] {!acquire} the semaphore with [k], + then run [f ()], and finally {!release} the semaphore with the same value [k] (even in case of failure in the execution of [f]). Return the value of [f ()] or re-raise the exception if any. *) val execute_with_weight : t -> int -> (unit -> 'a) -> 'a From 70923afb98123be290df19cd4127ba760f16ec42 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 21 May 2021 17:32:49 +0100 Subject: [PATCH 152/199] CP-31119: Prepare to generate documentation Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-std/dune | 1 - xapi-stdext-date.opam | 6 ++++-- xapi-stdext-encodings.opam | 6 ++++-- xapi-stdext-pervasives.opam | 8 ++++++-- xapi-stdext-std.opam | 5 +++-- xapi-stdext-threads.opam | 8 ++++++-- xapi-stdext-unix.opam | 7 +++++-- xapi-stdext-zerocheck.opam | 9 ++++++--- 8 files changed, 34 insertions(+), 16 deletions(-) diff --git a/lib/xapi-stdext-std/dune b/lib/xapi-stdext-std/dune index b2c853da162..dd8393a4427 100644 --- a/lib/xapi-stdext-std/dune +++ b/lib/xapi-stdext-std/dune @@ -2,7 +2,6 @@ (public_name xapi-stdext-std) (name xapi_stdext_std) (modules :standard \ xstringext_test listext_test) - (libraries uuidm) ) (tests (names xstringext_test listext_test) diff --git a/xapi-stdext-date.opam b/xapi-stdext-date.opam index bba4068980a..cc1f1ecdfd9 100644 --- a/xapi-stdext-date.opam +++ b/xapi-stdext-date.opam @@ -8,16 +8,18 @@ tags: [ "org:xapi-project" ] build: [ [ "dune" "build" "-p" name "-j" jobs ] - [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} + ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} + ["dune" "build" "-p" name "-j" jobs "@runtest"] {with-test} ] depends: [ "ocaml" - "dune" {build} + "dune" {>= "1.11"} "alcotest" {with-test} "astring" "base-unix" "ptime" + "odoc" {with-doc} ] synopsis: "A deprecated collection of utility functions - Date module" description: """ diff --git a/xapi-stdext-encodings.opam b/xapi-stdext-encodings.opam index ba09c43056b..95f2a55e76b 100644 --- a/xapi-stdext-encodings.opam +++ b/xapi-stdext-encodings.opam @@ -8,13 +8,15 @@ tags: [ "org:xapi-project" ] build: [ [ "dune" "build" "-p" name "-j" jobs ] - [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} + ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} + ["dune" "build" "-p" name "-j" jobs "@runtest"] {with-test} ] depends: [ "ocaml" - "dune" {build} + "dune" {>= "1.11"} "alcotest" {with-test} + "odoc" {with-doc} ] synopsis: "A deprecated collection of utility functions - Encodings module" description: """ diff --git a/xapi-stdext-pervasives.opam b/xapi-stdext-pervasives.opam index 2d61db939b9..fae8b4af557 100644 --- a/xapi-stdext-pervasives.opam +++ b/xapi-stdext-pervasives.opam @@ -6,12 +6,16 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [[ "dune" "build" "-p" name "-j" jobs ]] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} +] depends: [ "ocaml" - "dune" {build} + "dune" {>= "1.11"} "logs" + "odoc" {with-doc} "xapi-backtrace" ] synopsis: diff --git a/xapi-stdext-std.opam b/xapi-stdext-std.opam index 80b3a02a861..9330473b535 100644 --- a/xapi-stdext-std.opam +++ b/xapi-stdext-std.opam @@ -8,14 +8,15 @@ tags: [ "org:xapi-project" ] build: [ [ "dune" "build" "-p" name "-j" jobs ] + ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} ] depends: [ "ocaml" - "dune" {build} - "uuidm" + "dune" {>= "1.11"} "alcotest" {with-test} + "odoc" {with-doc} ] synopsis: "A deprecated collection of utility functions - Standard library extensions" diff --git a/xapi-stdext-threads.opam b/xapi-stdext-threads.opam index c4496192ae9..5b9ae91ff2a 100644 --- a/xapi-stdext-threads.opam +++ b/xapi-stdext-threads.opam @@ -6,13 +6,17 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [[ "dune" "build" "-p" name "-j" jobs ]] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} +] depends: [ "ocaml" - "dune" {build} + "dune" {>= "1.11"} "base-threads" "base-unix" + "odoc" {with-doc} "xapi-stdext-pervasives" ] synopsis: diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam index cd78519036b..09c0f47aa4a 100644 --- a/xapi-stdext-unix.opam +++ b/xapi-stdext-unix.opam @@ -6,11 +6,14 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [[ "dune" "build" "-p" name "-j" jobs ]] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} +] depends: [ "ocaml" - "dune" {build} + "dune" {>= "1.11"} "base-unix" "fd-send-recv" {>= "2.0.0"} "xapi-stdext-pervasives" diff --git a/xapi-stdext-zerocheck.opam b/xapi-stdext-zerocheck.opam index 49339481cdc..1f438429d72 100644 --- a/xapi-stdext-zerocheck.opam +++ b/xapi-stdext-zerocheck.opam @@ -6,11 +6,14 @@ dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" tags: [ "org:xapi-project" ] -build: [[ "dune" "build" "-p" name "-j" jobs ]] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} +] depends: [ - "ocaml" - "dune" {build} + "dune" {>= "1.11"} + "odoc" {with-doc} ] synopsis: "A deprecated collection of utility functions - Zerocheck module" description: """ From 473f90e03ea04fdd0d310ce7d81b3b35ff444d6b Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 21 May 2021 17:40:19 +0100 Subject: [PATCH 153/199] CP-31119: Enable documentation upload Signed-off-by: Pau Ruiz Safont --- .github/workflows/gh-pages.yml | 47 ++++++++++++++++++++++++++++++++++ README.md | 7 ++--- 2 files changed, 51 insertions(+), 3 deletions(-) create mode 100644 .github/workflows/gh-pages.yml diff --git a/.github/workflows/gh-pages.yml b/.github/workflows/gh-pages.yml new file mode 100644 index 00000000000..82a59cca91b --- /dev/null +++ b/.github/workflows/gh-pages.yml @@ -0,0 +1,47 @@ +name: Generate and upload docs + +on: + push: + branches: master + +jobs: + ocaml: + name: Ocaml docs + runs-on: ubuntu-20.04 + env: + package: "xapi-stdext-date xapi-stdext-encodings xapi-stdext-pervasives xapi-stdext-std xapi-stdext-threads xapi-stdext-unix xapi-stdext-zerocheck" + + steps: + - name: Checkout code + uses: actions/checkout@v2 + + - name: Pull configuration from xs-opam + run: | + curl --fail --silent https://raw.githubusercontent.com/xapi-project/xs-opam/master/tools/xs-opam-ci.env | cut -f2 -d " " > .env + + - name: Load environment file + id: dotenv + uses: falti/dotenv-action@v0.2.5 + + - name: Use ocaml + uses: ocaml/setup-ocaml@v1 + with: + ocaml-version: ${{ steps.dotenv.outputs.ocaml_version_full }} + opam-repository: ${{ steps.dotenv.outputs.repository }} + + - name: Install dependencies + run: | + opam pin add . --no-action + opam depext -u ${{ env.package }} + opam install ${{ env.package }} --deps-only --with-doc -v + + - name: Docs + run: opam exec -- make doc + + - name: Deploy + uses: peaceiris/actions-gh-pages@v3 + with: + github_token: ${{ secrets.GITHUB_TOKEN }} + publish_dir: _build/default/_doc/_html/ + publish_branch: gh-pages + diff --git a/README.md b/README.md index 50a7fe27276..258f7cb3732 100644 --- a/README.md +++ b/README.md @@ -3,8 +3,9 @@ Deprecated misc utility functions These utility functions are used by several other services. Much of this should be replaced with other libraries such as - * cohttp - * uri - * re + * Stdlib + * Bos Eventually this library should disappear. + +In the meantime documentation can be found at http://xapi-project.github.io/stdext/index.html From 59f8dc512f1233afbab5ca10832d0ff46764dbbf Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 17 Feb 2022 17:48:03 +0000 Subject: [PATCH 154/199] Add license to opam metadata, remove unused opam files Signed-off-by: Pau Ruiz Safont --- stdext.opam | 33 --------------------------------- xapi-stdext-base64.opam | 19 ------------------- xapi-stdext-bigbuffer.opam | 18 ------------------ xapi-stdext-date.opam | 1 + xapi-stdext-deprecated.opam | 18 ------------------ xapi-stdext-encodings.opam | 1 + xapi-stdext-monadic.opam | 19 ------------------- xapi-stdext-pervasives.opam | 1 + xapi-stdext-range.opam | 18 ------------------ xapi-stdext-std.opam | 1 + xapi-stdext-threads.opam | 1 + xapi-stdext-unix.opam | 1 + xapi-stdext-zerocheck.opam | 1 + xapi-stdext.opam | 14 -------------- 14 files changed, 7 insertions(+), 139 deletions(-) delete mode 100644 stdext.opam delete mode 100644 xapi-stdext-base64.opam delete mode 100644 xapi-stdext-bigbuffer.opam delete mode 100644 xapi-stdext-deprecated.opam delete mode 100644 xapi-stdext-monadic.opam delete mode 100644 xapi-stdext-range.opam delete mode 100644 xapi-stdext.opam diff --git a/stdext.opam b/stdext.opam deleted file mode 100644 index bc43416e2f4..00000000000 --- a/stdext.opam +++ /dev/null @@ -1,33 +0,0 @@ -opam-version: "2.0" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" -tags: [ "org:xapi-project" ] - -build: [[ "dune" "build" "-p" name "-j" jobs ]] - -depends: [ - "ocaml" - "dune" {build} - "xapi-stdext-base64" - "xapi-stdext-date" - "xapi-stdext-deprecated" - "xapi-stdext-encodings" - "xapi-stdext-monadic" - "xapi-stdext-pervasives" - "xapi-stdext-range" - "xapi-stdext-std" - "xapi-stdext-threads" - "xapi-stdext-unix" - "xapi-stdext-zerocheck" -] -synopsis: "A deprecated collection of utility functions" -description: """ -Backward compatibility wrapper, this is introduced along with -xapi-stdext-3.0.0 and will be removed once the oasis files of the -necessary packages have been updated. - -This library is provided for a transitionary period only. -No new code should use this library.""" diff --git a/xapi-stdext-base64.opam b/xapi-stdext-base64.opam deleted file mode 100644 index be96a5795e2..00000000000 --- a/xapi-stdext-base64.opam +++ /dev/null @@ -1,19 +0,0 @@ -opam-version: "2.0" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" -tags: [ "org:xapi-project" ] - -build: [[ "dune" "build" "-p" name "-j" jobs ]] - -depends: [ - "ocaml" - "dune" {build} - "base64" -] -synopsis: "A deprecated collection of utility functions - Base64 module" -description: """ -This library is provided for a transitionary period only. -No new code should use this library.""" diff --git a/xapi-stdext-bigbuffer.opam b/xapi-stdext-bigbuffer.opam deleted file mode 100644 index aac6e717f1b..00000000000 --- a/xapi-stdext-bigbuffer.opam +++ /dev/null @@ -1,18 +0,0 @@ -opam-version: "2.0" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" -tags: [ "org:xapi-project" ] - -build: [[ "dune" "build" "-p" name "-j" jobs ]] - -depends: [ - "ocaml" - "dune" {build} -] -synopsis: "A deprecated collection of utility functions - bigbuffer module" -description: """ -This library is provided for a transitionary period only. -No new code should use this library.""" diff --git a/xapi-stdext-date.opam b/xapi-stdext-date.opam index e4c64986eff..17892c7f9b6 100644 --- a/xapi-stdext-date.opam +++ b/xapi-stdext-date.opam @@ -4,6 +4,7 @@ authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" tags: [ "org:xapi-project" ] build: [[ "dune" "build" "-p" name "-j" jobs ]] diff --git a/xapi-stdext-deprecated.opam b/xapi-stdext-deprecated.opam deleted file mode 100644 index 1ff7b82a6a2..00000000000 --- a/xapi-stdext-deprecated.opam +++ /dev/null @@ -1,18 +0,0 @@ -opam-version: "2.0" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" -tags: [ "org:xapi-project" ] - -build: [[ "dune" "build" "-p" name "-j" jobs ]] - -depends: [ - "ocaml" - "dune" {build} -] -synopsis: "A deprecated collection of utility functions - Deprecated modules" -description: """ -This library is provided for a transitionary period only. -No new code should use this library.""" diff --git a/xapi-stdext-encodings.opam b/xapi-stdext-encodings.opam index a42b701827d..168f1a6f770 100644 --- a/xapi-stdext-encodings.opam +++ b/xapi-stdext-encodings.opam @@ -4,6 +4,7 @@ authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" tags: [ "org:xapi-project" ] build: [[ "dune" "build" "-p" name "-j" jobs ]] diff --git a/xapi-stdext-monadic.opam b/xapi-stdext-monadic.opam deleted file mode 100644 index ac1d465b221..00000000000 --- a/xapi-stdext-monadic.opam +++ /dev/null @@ -1,19 +0,0 @@ -opam-version: "2.0" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" -tags: [ "org:xapi-project" ] - -build: [[ "dune" "build" "-p" name "-j" jobs ]] - -depends: [ - "ocaml" - "dune" {build} -] -synopsis: - "A deprecated collection of utility functions - Monadic modules (Monad, Listext, Either)" -description: """ -This library is provided for a transitionary period only. -No new code should use this library.""" diff --git a/xapi-stdext-pervasives.opam b/xapi-stdext-pervasives.opam index 2d61db939b9..a66f2a14586 100644 --- a/xapi-stdext-pervasives.opam +++ b/xapi-stdext-pervasives.opam @@ -4,6 +4,7 @@ authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" tags: [ "org:xapi-project" ] build: [[ "dune" "build" "-p" name "-j" jobs ]] diff --git a/xapi-stdext-range.opam b/xapi-stdext-range.opam deleted file mode 100644 index e9eff09c027..00000000000 --- a/xapi-stdext-range.opam +++ /dev/null @@ -1,18 +0,0 @@ -opam-version: "2.0" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" -tags: [ "org:xapi-project" ] - -build: [[ "dune" "build" "-p" name "-j" jobs ]] - -depends: [ - "ocaml" - "dune" {build} -] -synopsis: "A deprecated collection of utility functions - Range module" -description: """ -This library is provided for a transitionary period only. -No new code should use this library.""" diff --git a/xapi-stdext-std.opam b/xapi-stdext-std.opam index b5ae1dceb91..e38fe11ddbe 100644 --- a/xapi-stdext-std.opam +++ b/xapi-stdext-std.opam @@ -4,6 +4,7 @@ authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" tags: [ "org:xapi-project" ] build: [[ "dune" "build" "-p" name "-j" jobs ]] diff --git a/xapi-stdext-threads.opam b/xapi-stdext-threads.opam index c4496192ae9..aa1225838e0 100644 --- a/xapi-stdext-threads.opam +++ b/xapi-stdext-threads.opam @@ -4,6 +4,7 @@ authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" tags: [ "org:xapi-project" ] build: [[ "dune" "build" "-p" name "-j" jobs ]] diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam index f8985bfd130..85e650a2ad6 100644 --- a/xapi-stdext-unix.opam +++ b/xapi-stdext-unix.opam @@ -4,6 +4,7 @@ authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" tags: [ "org:xapi-project" ] build: [[ "dune" "build" "-p" name "-j" jobs ]] diff --git a/xapi-stdext-zerocheck.opam b/xapi-stdext-zerocheck.opam index 49339481cdc..3498f6cea0d 100644 --- a/xapi-stdext-zerocheck.opam +++ b/xapi-stdext-zerocheck.opam @@ -4,6 +4,7 @@ authors: "xen-api@list.xen.org" bug-reports: "https://github.com/xapi-project/stdext/issues" dev-repo: "git://github.com/xapi-project/stdext.git" homepage: "https://xapi-project.github.io/" +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" tags: [ "org:xapi-project" ] build: [[ "dune" "build" "-p" name "-j" jobs ]] diff --git a/xapi-stdext.opam b/xapi-stdext.opam deleted file mode 100644 index aba8746e7fb..00000000000 --- a/xapi-stdext.opam +++ /dev/null @@ -1,14 +0,0 @@ -opam-version: "2.0" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" -tags: [ "org:xapi-project" ] - -depends: ["ocaml" "stdext"] -synopsis: "Deprecated xapi standard library extension" -description: """ -This is a dummy package to facilitate the migration to xapi-stdext 3.0.0 -of oasis-built packages, where several package were split out of the main -stdext package and the findlib name changed from stdext to xapi-stdext.""" From ef59ce7eb1042eb44f86235172db8672cb2e9f5c Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 30 Mar 2022 13:51:19 +0100 Subject: [PATCH 155/199] threads: Remove all the modules except Mutex These modules are barely used and are problematic because they need much testing with the coming ocaml 5.0 Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-threads/threadext.ml | 338 ++------------------------ lib/xapi-stdext-threads/threadext.mli | 68 +----- 2 files changed, 23 insertions(+), 383 deletions(-) diff --git a/lib/xapi-stdext-threads/threadext.ml b/lib/xapi-stdext-threads/threadext.ml index 1249810f02d..a58b34c73df 100644 --- a/lib/xapi-stdext-threads/threadext.ml +++ b/lib/xapi-stdext-threads/threadext.ml @@ -12,321 +12,26 @@ * GNU Lesser General Public License for more details. *) -module Mutex = struct - include Mutex +module M = Mutex +module Mutex = struct (** execute the function f with the mutex hold *) let execute lock f = Mutex.lock lock; Xapi_stdext_pervasives.Pervasiveext.finally f (fun () -> Mutex.unlock lock) end - -module Alarm = struct - - type t = - { token: Mutex.t ; - mutable queue: (float * (unit -> unit)) list ; - mutable notifier: (Unix.file_descr * Unix.file_descr) option ; - } - - let create () = - { token = Mutex.create () ; - queue = [] ; - notifier = None ; - } - - let global_alarm = create () - - let rec watch alarm = - match alarm.notifier with - | None -> assert false - | Some (pipe_in, pipe_out) -> - while Thread.wait_timed_read pipe_in 0. do - ignore (Unix.read pipe_in (Bytes.create 1) 0 1) - done; - let next = Mutex.execute alarm.token - (fun () -> - let now = Unix.time () in - let nqueue = List.filter - (fun (clock, callback) -> - (* Create helper thread in case callback could block us *) - clock > now || (let _ = Thread.create callback () in false)) - alarm.queue in - alarm.queue <- nqueue; - match nqueue with - | [] -> - Unix.close pipe_out; - Unix.close pipe_in; - alarm.notifier <- None; - None - | (c, _) :: _ -> - Some c) in - match next with - | None -> Thread.exit () - | Some c -> - let now = Unix.time () in - if c > now then ignore (Thread.wait_timed_read pipe_in (c -. now)); - watch alarm - - let register ?(alarm = global_alarm) time callback = - Mutex.execute alarm.token - (fun () -> - let nqueue = (time, callback) :: alarm.queue in - alarm.queue <- List.sort (fun x1 x2 -> compare (fst x1) (fst x2)) nqueue; - match alarm.notifier with - | Some (_, pipe_out) -> - ignore (Unix.write pipe_out (Bytes.of_string "X") 0 1) - | None -> - let pipe_in, pipe_out = Unix.pipe () in - alarm.notifier <- Some (pipe_in, pipe_out); - ignore (Thread.create watch alarm)) -end - -module Thread = struct - - type t = - | Running of Thread.t - | Pending of pthread - and pthread = float * int * Thread.t lazy_t - - type schedule = Now | Timeout of float | Indefinite - - type policy = - | AlwaysRun - | MaxCapacity of int * float option - | WaitCondition of (unit -> schedule) - - let count = ref 0 - - module PQueue = Set.Make(struct type t = pthread let compare = compare end) - - let running = ref 0 - - let pqueue = ref PQueue.empty - - (* This info can be deduced from pqueue, but having a specific int val allow - us to inspect it with lower cost and be lock free *) - let pending = ref 0 - - let running_threads () = !running - - let pending_threads () = !pending - - let scheduler_token = Mutex.create () - - let policy = ref AlwaysRun - - (* Should be protected by scheduler_token *) - let run_thread ((_, _, pt) as t) = - (* Might have run by other scheduling policy *) - if PQueue.mem t !pqueue then - (pqueue := PQueue.remove t !pqueue; decr pending); - if not (Lazy.is_val pt) then - let _ = Lazy.force pt in - incr running - - let fake_pivot = max_float, 0, lazy (Thread.create ignore ()) - let pivot = ref fake_pivot - let pre_pivot = ref max_int - - (* Should be protected by scheduler_token, this could be triggered either - because a thread finishes running and hence possibly provide an running - slot, or the scheduling policy has been updated hence more oppotunities - appear. *) - let rec run_pendings () = - if not (PQueue.is_empty !pqueue) then - let now = Unix.time() in - let (c, _, _) as t = PQueue.min_elt !pqueue in - (* Just in case policy has been changed *) - let to_run = match !policy with - | AlwaysRun -> true - | MaxCapacity (max_threads, _) -> c <= now || !running < max_threads - | WaitCondition f -> f () = Now in - if to_run then (run_thread t; run_pendings ()) - else (* extra logic to avoid starvation or wrongly programmed deadlock *) - let timeouts, exist, indefs = PQueue.split !pivot !pqueue in - if not exist || (PQueue.cardinal timeouts >= !pre_pivot - && (run_thread !pivot; true)) then - pivot := - if PQueue.is_empty indefs then fake_pivot - else PQueue.min_elt indefs; - pre_pivot := PQueue.cardinal timeouts - - let exit () = - Mutex.execute scheduler_token - (fun () -> decr running; run_pendings ()); - Thread.exit () - - let set_policy p = - Mutex.execute scheduler_token - (fun () -> - policy := p; - run_pendings ()) - - let create ?(schedule=Indefinite) f x = - let finally = Xapi_stdext_pervasives.Pervasiveext.finally in - let f' x = - finally - (fun () -> f x) - exit in - Mutex.execute scheduler_token - (fun () -> - run_pendings (); - let timeout = match schedule with - | Now -> 0. - | Timeout t -> t - | Indefinite -> max_float in - let timeout = - if timeout = 0. then 0. else - match !policy with - | AlwaysRun -> 0. - | MaxCapacity (max_threads, max_wait_opt) -> - if !running < max_threads && PQueue.is_empty !pqueue then 0. - else begin match max_wait_opt with - | None -> timeout - | Some t -> min timeout t end - | WaitCondition f -> match f () with - | Now -> 0. - | Timeout t -> min t timeout - | Indefinite -> timeout in - if timeout <= 0. then - let t = Thread.create f' x in - incr running; - Running t - else - let deadline = - if timeout < max_float then timeout +. Unix.time() - else max_float in - let pt = lazy (Thread.create f' x) in - incr count; - if !count = max_int then count := 0; - let t = (deadline, !count, pt) in - pqueue := PQueue.add t !pqueue; - incr pending; - if deadline < max_float then - Alarm.register deadline - (fun () -> Mutex.execute scheduler_token - (fun () -> run_thread t)); - (* It's fine that a pended thread might get scheduled later on so - that the information held in 't' becomes meaningless. This is - comparable to the case that a Thread.t finishes running and its - thread id still exits. - *) - Pending t) - - let self () = - (* When we get here, the thread must be running *) - Running (Thread.self ()) - - let id = function - | Running t -> Thread.id t - | Pending (_, id, _) -> - (* Pending thread have a negative id to avoid overlapping with running - thread id *) - -id - - let join = function - | Running t -> Thread.join t - | Pending ((_, _, pt) as t) -> - if not (Lazy.is_val pt) then begin - (* Give priority to those to be joined *) - Mutex.execute scheduler_token (fun () -> run_thread t); - assert (Lazy.is_val pt); - end; - Thread.join (Lazy.force pt) - - let kill = function - | Running t -> - (* Not implemented in stdlib *) - Thread.kill t - | Pending ((_, _, pt) as t) -> - if Lazy.is_val pt then - Thread.kill (Lazy.force pt) - else - Mutex.execute scheduler_token - (fun () -> - (* Just in case something happens before we grab the lock *) - if Lazy.is_val pt then Thread.kill (Lazy.force pt) - else (pqueue := PQueue.remove t !pqueue; decr pending)) - - let delay = Thread.delay - let exit = Thread.exit - let wait_read = Thread.wait_read - let wait_write = Thread.wait_write - let wait_timed_read = Thread.wait_timed_read - let wait_timed_write = Thread.wait_timed_write - let wait_pid = Thread.wait_pid - let select = Thread.select - let yield = Thread.yield - let sigmask = Thread.sigmask - let wait_signal = Thread.wait_signal -end - - -(** create thread loops which periodically applies a function *) -module Thread_loop - : functor (Tr : sig type t val delay : unit -> float end) -> - sig - val start : Tr.t -> (unit -> unit) -> unit - val stop : Tr.t -> unit - val update : Tr.t -> (unit -> unit) -> unit - end - = functor (Tr: sig type t val delay : unit -> float end) -> struct - - exception Done_loop - let ref_table : ((Tr.t,(Mutex.t * Thread.t * bool ref)) Hashtbl.t) = - Hashtbl.create 1 - - (** Create a thread which periodically applies a function to the - reference specified, and exits cleanly when removed *) - let start xref fn = - let mut = Mutex.create () in - let exit_var = ref false in - (* create thread which periodically applies the function *) - let tid = Thread.create (fun () -> - try while true do - Thread.delay (Tr.delay ()); - Mutex.execute mut (fun () -> - if !exit_var then - raise Done_loop; - let () = fn () in () - ); - done; with Done_loop -> (); - ) () in - (* create thread to manage the reference table and clean it up - safely once the delay thread is removed *) - let _ = Thread.create (fun () -> - Hashtbl.add ref_table xref (mut,tid,exit_var); - Thread.join tid; - List.iter (fun (_,t,_) -> - if tid = t then Hashtbl.remove ref_table xref - ) (Hashtbl.find_all ref_table xref) - ) () in () - - (** Remove a reference from the thread table *) - let stop xref = - try let mut,_,exit_ref = Hashtbl.find ref_table xref in - Mutex.execute mut (fun () -> exit_ref := true) - with Not_found -> () - - (** Replace a thread with another one *) - let update xref fn = - stop xref; - start xref fn - end - (** Parallel List.iter. Remembers all exceptions and returns an association list mapping input x to an exception. Applications of x which succeed will be missing from the returned list. *) -let thread_iter_all_exns f xs = +let thread_iter_all_exns f xs = let exns = ref [] in - let m = Mutex.create () in - List.iter - Thread.join - (List.map - (fun x -> - Thread.create - (fun () -> + let m = M.create () in + List.iter + Thread.join + (List.map + (fun x -> + Thread.create + (fun () -> try f x with e -> Mutex.execute m (fun () -> exns := (x, e) :: !exns) @@ -335,7 +40,7 @@ let thread_iter_all_exns f xs = ) xs); !exns -(** Parallel List.iter. Remembers one exception (at random) and throws it in the +(** Parallel List.iter. Remembers one exception (at random) and throws it in the error case. *) let thread_iter f xs = match thread_iter_all_exns f xs with | [] -> () @@ -343,27 +48,27 @@ let thread_iter f xs = match thread_iter_all_exns f xs with module Delay = struct (* Concrete type is the ends of a pipe *) - type t = { + type t = { (* A pipe is used to wake up a thread blocked in wait: *) mutable pipe_out: Unix.file_descr option; mutable pipe_in: Unix.file_descr option; (* Indicates that a signal arrived before a wait: *) mutable signalled: bool; - m: Mutex.t + m: M.t } - let make () = + let make () = { pipe_out = None; pipe_in = None; signalled = false; - m = Mutex.create () } + m = M.create () } exception Pre_signalled let wait (x: t) (seconds: float) = let finally = Xapi_stdext_pervasives.Pervasiveext.finally in let to_close = ref [ ] in - let close' fd = + let close' fd = if List.mem fd !to_close then Unix.close fd; to_close := List.filter (fun x -> fd <> x) !to_close in finally @@ -389,7 +94,7 @@ module Delay = struct r = [] with Pre_signalled -> false ) - (fun () -> + (fun () -> Mutex.execute x.m (fun () -> x.pipe_out <- None; @@ -397,16 +102,11 @@ module Delay = struct List.iter close' !to_close) ) - let signal (x: t) = + let signal (x: t) = Mutex.execute x.m (fun () -> match x.pipe_in with | Some fd -> ignore(Unix.write fd (Bytes.of_string "X") 0 1) - | None -> x.signalled <- true (* If the wait hasn't happened yet then store up the signal *) + | None -> x.signalled <- true (* If the wait hasn't happened yet then store up the signal *) ) end - -let keep_alive () = - while true do - Thread.delay 20000. - done diff --git a/lib/xapi-stdext-threads/threadext.mli b/lib/xapi-stdext-threads/threadext.mli index 0c1393a3872..7c154688011 100644 --- a/lib/xapi-stdext-threads/threadext.mli +++ b/lib/xapi-stdext-threads/threadext.mli @@ -13,66 +13,9 @@ *) module Mutex : sig - type t = Mutex.t - val create : unit -> t - val lock : t -> unit - val try_lock : t -> bool - val unlock : t -> unit val execute : Mutex.t -> (unit -> 'a) -> 'a end -module Alarm : -sig - type t - val create: unit -> t - val register: ?alarm:t -> float -> (unit -> unit) -> unit -end - -module Thread : -sig - type t - - (* Global policy on deciding whether threads should start immediately, can - be refined by specific thread creation function with the schedule - parameter. *) - type policy = - | AlwaysRun (* always start the threads immediately *) - | MaxCapacity of int * float option - (* Static configuration on the largest number of active threads, and - optionally max wait time for queued threads *) - | WaitCondition of (unit -> schedule) - (* Dynamic configuration to be tested whnever creating a new thread, - None means do not wait, Some t means wait at most t seconds. *) - - (* Schedule policy on each particular thread. This will get considered together - with the global policy, taking whichever earlier among the two. *) - and schedule = - | Now (* Run the threads right now *) - | Timeout of float (* Run the threads at latest x seconds *) - | Indefinite (* Don't care, i.e. timeout = forever *) - - val scheduler_token: Mutex.t - - val running_threads: unit -> int - - val pending_threads: unit -> int - - (* Default policy is AlwaysRun, the same as standard thread semantics *) - val set_policy: policy -> unit - - include module type of Thread with type t := t - - (* The default schedule is Indefinite, i.e. to let the global policy in control *) - val create: ?schedule:schedule -> ('a -> 'b) -> 'a -> t -end - -module Thread_loop : - functor (Tr : sig type t val delay : unit -> float end) -> - sig - val start : Tr.t -> (unit -> unit) -> unit - val stop : Tr.t -> unit - val update : Tr.t -> (unit -> unit) -> unit - end val thread_iter_all_exns: ('a -> unit) -> 'a list -> ('a * exn) list val thread_iter: ('a -> unit) -> 'a list -> unit @@ -80,16 +23,13 @@ module Delay : sig type t val make : unit -> t - (** Blocks the calling thread for a given period of time with the option of - returning early if someone calls 'signal'. Returns true if the full time - period elapsed and false if signalled. Note that multple 'signals' are - coalesced; 'signals' sent before 'wait' is called are not lost. *) + (** Blocks the calling thread for a given period of time with the option of + returning early if someone calls 'signal'. Returns true if the full time + period elapsed and false if signalled. Note that multple 'signals' are + coalesced; 'signals' sent before 'wait' is called are not lost. *) val wait : t -> float -> bool (** Sends a signal to a waiting thread. See 'wait' *) val signal : t -> unit end - -(** Keeps a thread alive without doing anything. Used e.g. in XML/RPC daemons. *) -val keep_alive: unit -> unit From 09ef6c971ea3ac8e8cd23d25a658067a9e79f426 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 16 Jun 2022 15:15:36 +0100 Subject: [PATCH 156/199] maintenance: prepare for release Tidy up Changelog Generate .opam files using dune, these will be regenerated every time make is run Add metapackage xapi-stdext (needed to publish) Signed-off-by: Pau Ruiz Safont --- CHANGES.md | 126 ++++++++++++++++++++++++++++++++++++ ChangeLog | 48 -------------- dune-project | 107 ++++++++++++++++++++++++++++++ xapi-stdext-date.opam | 38 ++++++----- xapi-stdext-encodings.opam | 38 ++++++----- xapi-stdext-pervasives.opam | 38 ++++++----- xapi-stdext-std.opam | 39 +++++------ xapi-stdext-threads.opam | 40 ++++++------ xapi-stdext-unix.opam | 41 ++++++------ xapi-stdext-zerocheck.opam | 38 ++++++----- xapi-stdext.opam | 34 ++++++++++ 11 files changed, 418 insertions(+), 169 deletions(-) create mode 100644 CHANGES.md delete mode 100644 ChangeLog create mode 100644 xapi-stdext.opam diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 index 00000000000..6f68bf2f928 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,126 @@ +## v4.19.0 (17-Jun-2022) + - maintenance: give a name to the project + - threads: Remove all the modules except Mutex + - Add license to opam metadata, remove unused opam files + +## v4.18.0 (15-Jun-2021) + - CP-31119: Enable documentation upload + - CP-31119: Prepare to generate documentation + - CP-34643: Prepare doc comments for odoc + - CP-34643: Reorder functions in listext interface + - CP-34643: drop deprecated methods from listext + - unix: remove unused stdext-std dependency + +## v4.17.0 (01-Mar-2021) + - listext: avoid traversing list twice on assoc_default + - maintenance: format with ocamlformat + - maintenance: prepare for ocamlformat + - CP-34643: listext: add drop function, rework some functions + - CP-34643: add unit tests for listext + - CP-34643: Listext: deprecate functions in Stdlib.List + - CP-34643: listext: remove implementations for functions in Stdlib.List + +## v4.16.0 (29-Dec-2020) + - ci: remove travis workflow + - Create ocaml-ci.yml + - date: allow timezones other than UTC for printing + - XSI-894 date.iso8601.to_float should assume UTC + +## v4.15.0 (14-Dec-2020) + - XSI-894 handle iso8601's with no timezone + - maintenance: format xstringext files with ocamlformat + - xapi-stdext-std: Do not duplicate functions from Stdlib + - CP-34643: add tests for xstringext + - maintenance: reformat pervasivesext with ocamlformat + - CP-34643: Deprecated non-idiomatic pervasivesext functions + - unixext: remove Fdset module and stubs + +## v4.14.0 (11-Aug-2020) + - CP-33121: Move encodings test to the package directory + - CP-33121: remove dependency of date in encodings tests + +## v4.13.0 (11-Aug-2020) + - CA-342171 allow clients to create an iso8601 from localtime + +## v4.12.0 (24-Jul-2020) + - CP-33121: run encodings tests as part of the encodings package + - maintenance: update travis config + - maintenance: prepare for ocamlformat + - CP-33121: remove obsoleted modules and packages + +## v4.11.0 (24-Apr-2020) + - CA-338243 remove legacy variant in iso8601 + +## v4.09.0 (23-Apr-2020) + - CA-338243 iso8601.to_string backwards compatibility + +## v4.8.0 (15-Apr-2020) + - CA-333908 accept YYYY-MM-DD date format + - unixext: better description for write___to_file + - fixup! CP-32686: Ensure durability with atomic_write_to_file + - fixup! CP-32686: Ensure durability with atomic_write_to_file + - maintenance: whitespace + - CP-32686: Ensure durability with atomic_write_to_file + - ci: use environment vars from xs-opam + - ci: do do not pin base64, it doesn't exist + +## v4.7.0 (04-Jun-2019) + - CP-30756: Remove Base64 + +## v4.6.0 (02-Apr-2019) +- CA-314001: release runtime lock around long running system calls + +## v4.5.0 (13-Mar-2019) + - Update .travis.yml + - CA-310525 fix C binding for statvfs + +## 4.4.1 (21-Jan-2019) + - Replaced jbuild files with dune. + +## 4.4.0 (05-Jul-2018): -- xapi-stdext-pervasives only +* CA-292641: Use Logs to log cleanup exn instead of shadowing the original one with it + +## 4.3.0 (30-May-2018): +* CP-28365: improve backtraces by using finally + +## 4.2.0 (25-May-2018): -- xapi-stdext-unix only +* unixext: update interface to mimick the ocaml Unix one + +## 4.1.0 (25-Apr-2018): -- xapi-stdext-unix only +* really_write: + - use single_write_substring and avoid an unsafe coercion + - remove deprecation and make robust against EINTR +* unixext_open_stubs: fix use of uninitialised variable + +## 4.0.0 (15-Mar-2018): +* Make safe-string safe (xap-stdext-{bigbuffer, encodings, std, threads, unix} 1.1.0) +* Remove bigbuffer from the default stdext set of packages +* Use backward compatible naming for stdext xapi-stdext + +## 3.0.0 (02-Aug-2017): +* Remove unused packages +* Refactor in a backward compatible wrapper and 12 new separate libraries (see https://github.com/xapi-project/stdext/pull/21) +* Port to jbuilder + +## 2.1.0 (20-Oct-2016): +* New Semaphore module + +## 2.0.0 (22-Jun-2016): +* Namespace everything under Stdext. This is a backwards incompatible change. + +## 0.13.0 (20-Nov-2014): +* Depend on Backtrace from xapi-backtrace +* Add an opam file + +## 0.12.0 (26-Sep-2014): +* Fix build errors on OS X + +## 0.11.0 (30-May-2013): +* Change Stringext module to Xstringext to avoid conflict with other packages + +## 0.9.1 (10-Sep-2013): +* Add Unixext.domain_of_addr +* Add String.sub_{before,after} + +## 0.9.0 (3-Jun-2013): +* first public release diff --git a/ChangeLog b/ChangeLog deleted file mode 100644 index b6ff032c6a2..00000000000 --- a/ChangeLog +++ /dev/null @@ -1,48 +0,0 @@ -4.4.0 (05-Jul-2018): -- xapi-stdext-pervasives only -* CA-292641: Use Logs to log cleanup exn instead of shadowing the original one with it - -4.3.0 (30-May-2018): -* CP-28365: improve backtraces by using finally - -4.2.0 (25-May-2018): -- xapi-stdext-unix only -* unixext: update interface to mimick the ocaml Unix one - -4.1.0 (25-Apr-2018): -- xapi-stdext-unix only -* really_write: - - use single_write_substring and avoid an unsafe coercion - - remove deprecation and make robust against EINTR -* unixext_open_stubs: fix use of uninitialised variable - -4.0.0 (15-Mar-2018): -* Make safe-string safe (xap-stdext-{bigbuffer, encodings, std, threads, unix} 1.1.0) -* Remove bigbuffer from the default stdext set of packages -* Use backward compatible naming for stdext xapi-stdext - -3.0.0 (02-Aug-2017): -* Remove unused packages -* Refactor in a backward compatible wrapper and 12 new separate libraries (see https://github.com/xapi-project/stdext/pull/21) -* Port to jbuilder - -2.1.0 (20-Oct-2016): -* New Semaphore module - -2.0.0 (22-Jun-2016): -* Namespace everything under Stdext. This is a backwards incompatible change. - -0.13.0 (20-Nov-2014): -* Depend on Backtrace from xapi-backtrace -* Add an opam file - -0.12.0 (26-Sep-2014): -* Fix build errors on OS X - -0.11.0 (30-May-2013): -* Change Stringext module to Xstringext to avoid conflict with other packages - -0.9.1 (10-Sep-2013): -* Add Unixext.domain_of_addr -* Add String.sub_{before,after} - -0.9.0 (3-Jun-2013): -* first public release - diff --git a/dune-project b/dune-project index cd5e890aea7..781499839ab 100644 --- a/dune-project +++ b/dune-project @@ -1,2 +1,109 @@ (lang dune 1.11) (using fmt 1.2 (enabled_for ocaml)) +(name xapi-stdext) + +(generate_opam_files true) + +(source (github xapi-project/stdext)) +(license "LGPL-2.1-only WITH OCaml-LGPL-linking-exception") +(authors "Jonathan Ludlam") +(maintainers "Xapi project maintainers") + +(package + (name xapi-stdext) + (synopsis "Xapi's standard library extension") + (description "Dummy package that enables the usage of dune-release") + (depends + (xapi-stdext-date (= :version)) + (xapi-stdext-encodings (= :version)) + (xapi-stdext-pervasives (= :version)) + (xapi-stdext-std (= :version)) + (xapi-stdext-threads (= :version)) + (xapi-stdext-unix (= :version)) + (xapi-stdext-zerocheck (= :version)) + ) +) + +(package + (name xapi-stdext-date) + (synopsis "Xapi's standard library extension, Dates") + (depends + ocaml + (dune (>= 1.11)) + (alcotest :with-test) + astring + base-unix + ptime + (odoc :with-doc) + ) +) + +(package + (name xapi-stdext-encodings) + (synopsis "Xapi's standard library extension, Encodings") + (depends + ocaml + (dune (>= 1.11)) + (alcotest :with-test) + (odoc :with-doc) + ) +) + +(package + (name xapi-stdext-pervasives) + (synopsis "Xapi's standard library extension, Pervasives") + (depends + ocaml + (dune (>= 1.11)) + logs + (odoc :with-doc) + xapi-backtrace + ) +) + +(package + (name xapi-stdext-std) + (synopsis "Xapi's standard library extension, Stdlib") + (depends + ocaml + (dune (>= 1.11)) + (alcotest :with-test) + (odoc :with-doc) + ) +) + +(package + (name xapi-stdext-threads) + (synopsis "Xapi's standard library extension, Threads") + (depends + ocaml + (dune (>= 1.11)) + base-threads + base-unix + (odoc :with-doc) + (xapi-stdext-pervasives (= :version)) + ) +) + +(package + (name xapi-stdext-unix) + (synopsis "Xapi's standard library extension, Unix") + (depends + ocaml + (dune (>= 1.11)) + base-unix + (fd-send-recv (>= 2.0.0)) + (odoc :with-doc) + (xapi-stdext-pervasives (= :version)) + ) +) + +(package + (name xapi-stdext-zerocheck) + (synopsis "Xapi's standard library extension, Zerocheck") + (depends + ocaml + (dune (>= 1.11)) + (odoc :with-doc) + ) +) diff --git a/xapi-stdext-date.opam b/xapi-stdext-date.opam index 0f7de727179..083f92e7c7b 100644 --- a/xapi-stdext-date.opam +++ b/xapi-stdext-date.opam @@ -1,18 +1,11 @@ +# This file is generated by dune, edit dune-project instead opam-version: "2.0" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" +synopsis: "Xapi's standard library extension, Dates" +maintainer: ["Xapi project maintainers"] +authors: ["Jonathan Ludlam"] license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" -tags: [ "org:xapi-project" ] - -build: [ - [ "dune" "build" "-p" name "-j" jobs ] - ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} - ["dune" "build" "-p" name "-j" jobs "@runtest"] {with-test} -] - +homepage: "https://github.com/xapi-project/stdext" +bug-reports: "https://github.com/xapi-project/stdext/issues" depends: [ "ocaml" "dune" {>= "1.11"} @@ -22,7 +15,18 @@ depends: [ "ptime" "odoc" {with-doc} ] -synopsis: "A deprecated collection of utility functions - Date module" -description: """ -This library is provided for a transitionary period only. -No new code should use this library.""" +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/stdext.git" diff --git a/xapi-stdext-encodings.opam b/xapi-stdext-encodings.opam index 9db4ee0e32a..c8f419acd5e 100644 --- a/xapi-stdext-encodings.opam +++ b/xapi-stdext-encodings.opam @@ -1,25 +1,29 @@ +# This file is generated by dune, edit dune-project instead opam-version: "2.0" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" +synopsis: "Xapi's standard library extension, Encodings" +maintainer: ["Xapi project maintainers"] +authors: ["Jonathan Ludlam"] license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" -tags: [ "org:xapi-project" ] - -build: [ - [ "dune" "build" "-p" name "-j" jobs ] - ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} - ["dune" "build" "-p" name "-j" jobs "@runtest"] {with-test} -] - +homepage: "https://github.com/xapi-project/stdext" +bug-reports: "https://github.com/xapi-project/stdext/issues" depends: [ "ocaml" "dune" {>= "1.11"} "alcotest" {with-test} "odoc" {with-doc} ] -synopsis: "A deprecated collection of utility functions - Encodings module" -description: """ -This library is provided for a transitionary period only. -No new code should use this library.""" +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/stdext.git" diff --git a/xapi-stdext-pervasives.opam b/xapi-stdext-pervasives.opam index fb32df536dc..6bffd2e7fc2 100644 --- a/xapi-stdext-pervasives.opam +++ b/xapi-stdext-pervasives.opam @@ -1,17 +1,11 @@ +# This file is generated by dune, edit dune-project instead opam-version: "2.0" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" +synopsis: "Xapi's standard library extension, Pervasives" +maintainer: ["Xapi project maintainers"] +authors: ["Jonathan Ludlam"] license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" -tags: [ "org:xapi-project" ] - -build: [ - ["dune" "build" "-p" name "-j" jobs] - ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} -] - +homepage: "https://github.com/xapi-project/stdext" +bug-reports: "https://github.com/xapi-project/stdext/issues" depends: [ "ocaml" "dune" {>= "1.11"} @@ -19,8 +13,18 @@ depends: [ "odoc" {with-doc} "xapi-backtrace" ] -synopsis: - "A deprecated collection of utility functions - Pervasives extension" -description: """ -This library is provided for a transitionary period only. -No new code should use this library.""" +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/stdext.git" diff --git a/xapi-stdext-std.opam b/xapi-stdext-std.opam index 8b616fb7a3d..019d03c087b 100644 --- a/xapi-stdext-std.opam +++ b/xapi-stdext-std.opam @@ -1,26 +1,29 @@ +# This file is generated by dune, edit dune-project instead opam-version: "2.0" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" +synopsis: "Xapi's standard library extension, Stdlib" +maintainer: ["Xapi project maintainers"] +authors: ["Jonathan Ludlam"] license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" -tags: [ "org:xapi-project" ] - -build: [ - [ "dune" "build" "-p" name "-j" jobs ] - ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} - [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} -] - +homepage: "https://github.com/xapi-project/stdext" +bug-reports: "https://github.com/xapi-project/stdext/issues" depends: [ "ocaml" "dune" {>= "1.11"} "alcotest" {with-test} "odoc" {with-doc} ] -synopsis: - "A deprecated collection of utility functions - Standard library extensions" -description: """ -This library is provided for a transitionary period only. -No new code should use this library.""" +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/stdext.git" diff --git a/xapi-stdext-threads.opam b/xapi-stdext-threads.opam index c10202a8630..d35226e3647 100644 --- a/xapi-stdext-threads.opam +++ b/xapi-stdext-threads.opam @@ -1,27 +1,31 @@ +# This file is generated by dune, edit dune-project instead opam-version: "2.0" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" +synopsis: "Xapi's standard library extension, Threads" +maintainer: ["Xapi project maintainers"] +authors: ["Jonathan Ludlam"] license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" -tags: [ "org:xapi-project" ] - -build: [ - ["dune" "build" "-p" name "-j" jobs] - ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} -] - +homepage: "https://github.com/xapi-project/stdext" +bug-reports: "https://github.com/xapi-project/stdext/issues" depends: [ "ocaml" "dune" {>= "1.11"} "base-threads" "base-unix" "odoc" {with-doc} - "xapi-stdext-pervasives" + "xapi-stdext-pervasives" {= version} +] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] ] -synopsis: - "A deprecated collection of utility functions - Threads extensions and Semaphore" -description: """ -This library is provided for a transitionary period only. -No new code should use this library.""" +dev-repo: "git+https://github.com/xapi-project/stdext.git" diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam index ab8bc4f3c24..9de7d71a238 100644 --- a/xapi-stdext-unix.opam +++ b/xapi-stdext-unix.opam @@ -1,26 +1,31 @@ +# This file is generated by dune, edit dune-project instead opam-version: "2.0" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" +synopsis: "Xapi's standard library extension, Unix" +maintainer: ["Xapi project maintainers"] +authors: ["Jonathan Ludlam"] license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" -tags: [ "org:xapi-project" ] - -build: [ - ["dune" "build" "-p" name "-j" jobs] - ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} -] - +homepage: "https://github.com/xapi-project/stdext" +bug-reports: "https://github.com/xapi-project/stdext/issues" depends: [ "ocaml" "dune" {>= "1.11"} "base-unix" "fd-send-recv" {>= "2.0.0"} - "xapi-stdext-pervasives" + "odoc" {with-doc} + "xapi-stdext-pervasives" {= version} +] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] ] -synopsis: - "A deprecated collection of utility functions - Unix module extensions" -description: """ -This library is provided for a transitionary period only. -No new code should use this library.""" +dev-repo: "git+https://github.com/xapi-project/stdext.git" diff --git a/xapi-stdext-zerocheck.opam b/xapi-stdext-zerocheck.opam index 78119053680..f1dc3de23f5 100644 --- a/xapi-stdext-zerocheck.opam +++ b/xapi-stdext-zerocheck.opam @@ -1,22 +1,28 @@ +# This file is generated by dune, edit dune-project instead opam-version: "2.0" -maintainer: "jonathan.ludlam@citrix.com" -authors: "xen-api@list.xen.org" -bug-reports: "https://github.com/xapi-project/stdext/issues" -dev-repo: "git://github.com/xapi-project/stdext.git" -homepage: "https://xapi-project.github.io/" +synopsis: "Xapi's standard library extension, Zerocheck" +maintainer: ["Xapi project maintainers"] +authors: ["Jonathan Ludlam"] license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" -tags: [ "org:xapi-project" ] - -build: [ - ["dune" "build" "-p" name "-j" jobs] - ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} -] - +homepage: "https://github.com/xapi-project/stdext" +bug-reports: "https://github.com/xapi-project/stdext/issues" depends: [ + "ocaml" "dune" {>= "1.11"} "odoc" {with-doc} ] -synopsis: "A deprecated collection of utility functions - Zerocheck module" -description: """ -This library is provided for a transitionary period only. -No new code should use this library.""" +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/stdext.git" diff --git a/xapi-stdext.opam b/xapi-stdext.opam new file mode 100644 index 00000000000..1f172724d88 --- /dev/null +++ b/xapi-stdext.opam @@ -0,0 +1,34 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Xapi's standard library extension" +description: "Dummy package that enables the usage of dune-release" +maintainer: ["Xapi project maintainers"] +authors: ["Jonathan Ludlam"] +license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" +homepage: "https://github.com/xapi-project/stdext" +bug-reports: "https://github.com/xapi-project/stdext/issues" +depends: [ + "dune" {>= "1.11"} + "xapi-stdext-date" {= version} + "xapi-stdext-encodings" {= version} + "xapi-stdext-pervasives" {= version} + "xapi-stdext-std" {= version} + "xapi-stdext-threads" {= version} + "xapi-stdext-unix" {= version} + "xapi-stdext-zerocheck" {= version} +] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/stdext.git" From 933d96774803134a8c0d29c0855a5f9b6163bb38 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 31 Oct 2022 09:36:10 +0000 Subject: [PATCH 157/199] Date: use conversions to/from Ptime.t, unix_time and formatted strings Currently the only way to create dates is from floats and strings, since these do not have a semantic meaning, new names are now used for the conversions, making it obvious floats represent Unix timestamps and strings with representation do dates using RFC 3339 and ISO 8601. Additionally allow conversions from and to Ptime.t, which is actually the main type that implements datetimes. There's a new helper function to get the current time in date as a convenience method. The origin of Unix time has been renamed to `epoch` from `never`: using never as a synonym to the beginning of Unix time is not quite accurate semantically even if the value itself will be exceedingly rare in practice. In the future the `{to,of}_float`, `{to,of}_string` and `never` will be deprecated. Not doing so immediately allows for a smooth transition path. Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-date/date.ml | 37 +++++++++++++++++++++++++---------- lib/xapi-stdext-date/date.mli | 33 ++++++++++++++++++++++++++++--- lib/xapi-stdext-date/test.ml | 16 +++++++-------- 3 files changed, 65 insertions(+), 21 deletions(-) diff --git a/lib/xapi-stdext-date/date.ml b/lib/xapi-stdext-date/date.ml index 72504bc84f5..e0bb6af1401 100644 --- a/lib/xapi-stdext-date/date.ml +++ b/lib/xapi-stdext-date/date.ml @@ -63,7 +63,7 @@ let best_effort_iso8601_to_rfc3339 x = | Some tz -> (x, TZ tz) -let of_string x = +let of_iso8601 x = let (rfc3339, print_timezone) = best_effort_iso8601_to_rfc3339 x in match Ptime.of_rfc3339 rfc3339 |> Ptime.rfc3339_error_to_msg with | Error (`Msg e) -> invalid_arg (Printf.sprintf "date.ml:of_string: %s" x) @@ -71,7 +71,7 @@ let of_string x = | None | Some 0 -> Ptime.to_date_time t |> of_dt print_timezone | Some _ -> invalid_arg (Printf.sprintf "date.ml:of_string: %s" x) -let to_string ((y,mon,d), ((h,min,s), _), print_type) = +let to_rfc3339 ((y,mon,d), ((h,min,s), _), print_type) = match print_type with | TZ tz -> Printf.sprintf "%04i%02i%02iT%02i:%02i:%02i%s" y mon d h min s tz | Empty -> Printf.sprintf "%04i%02i%02iT%02i:%02i:%02i" y mon d h min s @@ -81,14 +81,18 @@ let to_ptime_t t = | Some t -> t | None -> let (_, (_, offset), _) = t in - invalid_arg (Printf.sprintf "date.ml:to_t: dt='%s', offset='%i' is invalid" (to_string t) offset) + invalid_arg (Printf.sprintf "date.ml:to_t: dt='%s', offset='%i' is invalid" (to_rfc3339 t) offset) -let of_float s = +let to_ptime = to_ptime_t + +let of_ptime t = Ptime.to_date_time t |> of_dt utc + +let of_unix_time s = match Ptime.of_float_s s with - | None -> invalid_arg (Printf.sprintf "date.ml:of_float: %f" s) - | Some t -> Ptime.to_date_time t |> of_dt utc + | None -> invalid_arg (Printf.sprintf "%s: %f" __FUNCTION__ s) + | Some t -> of_ptime t -let to_float t = to_ptime_t t |> Ptime.to_float_s +let to_unix_time t = to_ptime_t t |> Ptime.to_float_s let _localtime current_tz_offset t = let tz_offset_s = current_tz_offset |> Option.value ~default:0 in @@ -103,13 +107,26 @@ let _localtime current_tz_offset t = localtime let _localtime_string current_tz_offset t = - _localtime current_tz_offset t |> to_string + _localtime current_tz_offset t |> to_rfc3339 let localtime () = _localtime (Ptime_clock.current_tz_offset_s ()) (Ptime_clock.now ()) -let assert_utc _ = () +let now () = of_ptime (Ptime_clock.now ()) -let never = of_float 0.0 +let epoch = of_ptime Ptime.epoch let eq x y = x = y + +let assert_utc _ = () + +let never = epoch + +let of_string = of_iso8601 + +let to_string = to_rfc3339 + +let of_float = of_unix_time + +let to_float = to_unix_time + diff --git a/lib/xapi-stdext-date/date.mli b/lib/xapi-stdext-date/date.mli index d09a93eafba..2069cf937be 100644 --- a/lib/xapi-stdext-date/date.mli +++ b/lib/xapi-stdext-date/date.mli @@ -18,11 +18,32 @@ (** An ISO-8601 date/time type. *) type iso8601 +(** Convert ptime to time in UTC *) +val of_ptime : Ptime.t -> iso8601 + +(** Convert date/time to a ptime value: the number of seconds since 00:00:00 + UTC, 1 Jan 1970. Assumes the underlying iso8601 is in UTC *) +val to_ptime : iso8601 -> Ptime.t + (** Convert calendar time [x] (as returned by e.g. Unix.time), to time in UTC. *) +val of_unix_time : float -> iso8601 + +(** Convert date/time to a unix timestamp: the number of seconds since + 00:00:00 UTC, 1 Jan 1970. Assumes the underlying iso8601 is in UTC *) +val to_unix_time : iso8601 -> float + +val to_rfc3339 : iso8601 -> string +(** Convert date/time to an RFC-3339-formatted string. It also complies with + the ISO 8601 format.*) + +val of_iso8601 : string -> iso8601 +(** Convert ISO 8601 formatted string to a date/time value. Does not accept a + timezone annotated datetime - i.e. string must be UTC, and end with a Z *) + +(** Same as [of_unix_time] *) val of_float : float -> iso8601 -(** Convert date/time to a float value: the number of seconds since 00:00:00 UTC, 1 Jan 1970. - * Assumes the underlying iso8601 is in UTC *) +(** Same as [to_unix_time] *) val to_float : iso8601 -> float (** Convert date/time to an ISO 8601 formatted string. *) @@ -37,9 +58,15 @@ val of_string : string -> iso8601 val assert_utc : iso8601 -> unit [@@deprecated "assertions performed inside constructors, so this fn does nothing"] -(** Representation of the concept "never" (actually 00:00:00 UTC, 1 Jan 1970). *) +(** 00:00:00 UTC, 1 Jan 1970, in UTC *) +val epoch: iso8601 + +(** Same as [epoch] *) val never: iso8601 +(** Count the number of seconds passed since 00:00:00 UTC, 1 Jan 1970, in UTC *) +val now : unit -> iso8601 + (** exposed for testing *) val _localtime_string : Ptime.tz_offset_s option -> Ptime.t -> string diff --git a/lib/xapi-stdext-date/test.ml b/lib/xapi-stdext-date/test.ml index 87f3a54963e..8b7ddf81360 100644 --- a/lib/xapi-stdext-date/test.ml +++ b/lib/xapi-stdext-date/test.ml @@ -8,11 +8,11 @@ let dash_time_str = "2020-04-07T08:28:32Z" let no_dash_utc_time_str = "20200407T08:28:32Z" let iso8601_tests = - let test_of_float_invertible () = + let test_of_unix_time_invertible () = let non_int_time = 1586245987.70200706 in let time = non_int_time |> Float.floor in - check_float "to_float inverts of_float" time (time |> of_float |> to_float); - check_true "of_float inverts to_float" @@ eq (time |> of_float) (time |> of_float |> to_float |> of_float); + check_float "to_unix_time inverts of_unix_time" time (time |> of_unix_time |> to_unix_time); + check_true "of_unix_time inverts to_unix_time" @@ eq (time |> of_unix_time) (time |> of_unix_time |> to_unix_time |> of_unix_time); in let test_only_utc () = @@ -24,9 +24,9 @@ let iso8601_tests = in let test_ca333908 () = - check_float "dash time and no dash time have same float repr" - (dash_time_str |> of_string |> to_float) - (no_dash_utc_time_str |> of_string |> to_float) + check_float "dash time and no dash time represent the same unix timestamp" + (dash_time_str |> of_string |> to_unix_time) + (no_dash_utc_time_str |> of_string |> to_unix_time) in let test_of_string_invertible_when_no_dashes () = @@ -68,13 +68,13 @@ let iso8601_tests = check_string "can process missing tz no dash" missing_tz_no_dash (missing_tz_no_dash |> of_string |> to_string) ; check_string "can process missing tz with dashes, but return without dashes" missing_tz_no_dash (missing_tz_dash |> of_string |> to_string) ; - check_float "to_float assumes UTC" 1607620760. (missing_tz_no_dash |> of_string |> to_float) ; + check_float "to_unix_time assumes UTC" 1607620760. (missing_tz_no_dash |> of_string |> to_unix_time) ; let localtime' = localtime () in check_string "to_string inverts of_string for localtime" (localtime' |> to_string) (localtime' |> to_string |> of_string |> to_string) ; in - [ "test_of_float_invertible", `Quick, test_of_float_invertible + [ "test_of_unix_time_invertible", `Quick, test_of_unix_time_invertible ; "test_only_utc", `Quick, test_only_utc ; "test_ca333908", `Quick, test_ca333908 ; "test_of_string_invertible_when_no_dashes", `Quick, test_of_string_invertible_when_no_dashes From a9cda200fb530a536f614ad363a0a8a38e648e91 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 9 Nov 2022 10:00:40 +0000 Subject: [PATCH 158/199] ocamlformat: format date library Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-date/date.ml | 107 +++++++++++++++++++++------------- lib/xapi-stdext-date/date.mli | 33 ++++++----- lib/xapi-stdext-date/test.ml | 107 +++++++++++++++++++++------------- 3 files changed, 153 insertions(+), 94 deletions(-) diff --git a/lib/xapi-stdext-date/date.ml b/lib/xapi-stdext-date/date.ml index e0bb6af1401..a447b710344 100644 --- a/lib/xapi-stdext-date/date.ml +++ b/lib/xapi-stdext-date/date.ml @@ -15,15 +15,28 @@ (* ==== RFC822 ==== *) type rfc822 = string -let months = [| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun"; - "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec" |] -let days = [| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |] +let months = + [| + "Jan" + ; "Feb" + ; "Mar" + ; "Apr" + ; "May" + ; "Jun" + ; "Jul" + ; "Aug" + ; "Sep" + ; "Oct" + ; "Nov" + ; "Dec" + |] + +let days = [|"Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat"|] let rfc822_of_float x = let time = Unix.gmtime x in - Printf.sprintf "%s, %d %s %d %02d:%02d:%02d GMT" - days.(time.Unix.tm_wday) time.Unix.tm_mday - months.(time.Unix.tm_mon) (time.Unix.tm_year+1900) + Printf.sprintf "%s, %d %s %d %02d:%02d:%02d GMT" days.(time.Unix.tm_wday) + time.Unix.tm_mday months.(time.Unix.tm_mon) (time.Unix.tm_year + 1900) time.Unix.tm_hour time.Unix.tm_min time.Unix.tm_sec let rfc822_to_string x = x @@ -31,12 +44,16 @@ let rfc822_to_string x = x (* ==== ISO8601/RFC3339 ==== *) type print_timezone = Empty | TZ of string + (* we must store the print_type with iso8601 to handle the case where the local time zone is UTC *) type iso8601 = Ptime.date * Ptime.time * print_timezone let utc = TZ "Z" -let of_dt print_type dt = let (date, time) = dt in (date, time, print_type) +let of_dt print_type dt = + let date, time = dt in + (date, time, print_type) + let to_dt (date, time, _) = (date, time) let best_effort_iso8601_to_rfc3339 x = @@ -44,44 +61,55 @@ let best_effort_iso8601_to_rfc3339 x = * (b) add UTC tz if no tz provided *) let x = try - Scanf.sscanf x "%04d%02d%02dT%s" - (fun y mon d rest -> - Printf.sprintf "%04d-%02d-%02dT%s" y mon d rest) - with _ -> - x + Scanf.sscanf x "%04d%02d%02dT%s" (fun y mon d rest -> + Printf.sprintf "%04d-%02d-%02dT%s" y mon d rest + ) + with _ -> x in let tz = try - Scanf.sscanf x "%04d-%02d-%02dT%02d:%02d:%02d%s" - (fun _ _ _ _ _ _ tz -> Some tz) + Scanf.sscanf x "%04d-%02d-%02dT%02d:%02d:%02d%s" (fun _ _ _ _ _ _ tz -> + Some tz + ) with _ -> None in match tz with | None | Some "" -> - (* the caller didn't specify a tz. we must try to add one so that ptime can at least attempt to parse *) - (Printf.sprintf "%sZ" x, Empty) - | Some tz -> - (x, TZ tz) + (* the caller didn't specify a tz. we must try to add one so that ptime can at least attempt to parse *) + (Printf.sprintf "%sZ" x, Empty) + | Some tz -> + (x, TZ tz) let of_iso8601 x = - let (rfc3339, print_timezone) = best_effort_iso8601_to_rfc3339 x in + let rfc3339, print_timezone = best_effort_iso8601_to_rfc3339 x in match Ptime.of_rfc3339 rfc3339 |> Ptime.rfc3339_error_to_msg with - | Error (`Msg e) -> invalid_arg (Printf.sprintf "date.ml:of_string: %s" x) - | Ok (t, tz, _) -> match tz with - | None | Some 0 -> Ptime.to_date_time t |> of_dt print_timezone - | Some _ -> invalid_arg (Printf.sprintf "date.ml:of_string: %s" x) - -let to_rfc3339 ((y,mon,d), ((h,min,s), _), print_type) = + | Error _ -> + invalid_arg (Printf.sprintf "date.ml:of_string: %s" x) + | Ok (t, tz, _) -> ( + match tz with + | None | Some 0 -> + Ptime.to_date_time t |> of_dt print_timezone + | Some _ -> + invalid_arg (Printf.sprintf "date.ml:of_string: %s" x) + ) + +let to_rfc3339 ((y, mon, d), ((h, min, s), _), print_type) = match print_type with - | TZ tz -> Printf.sprintf "%04i%02i%02iT%02i:%02i:%02i%s" y mon d h min s tz - | Empty -> Printf.sprintf "%04i%02i%02iT%02i:%02i:%02i" y mon d h min s + | TZ tz -> + Printf.sprintf "%04i%02i%02iT%02i:%02i:%02i%s" y mon d h min s tz + | Empty -> + Printf.sprintf "%04i%02i%02iT%02i:%02i:%02i" y mon d h min s let to_ptime_t t = match to_dt t |> Ptime.of_date_time with - | Some t -> t + | Some t -> + t | None -> - let (_, (_, offset), _) = t in - invalid_arg (Printf.sprintf "date.ml:to_t: dt='%s', offset='%i' is invalid" (to_rfc3339 t) offset) + let _, (_, offset), _ = t in + invalid_arg + (Printf.sprintf "date.ml:to_t: dt='%s', offset='%i' is invalid" + (to_rfc3339 t) offset + ) let to_ptime = to_ptime_t @@ -89,21 +117,23 @@ let of_ptime t = Ptime.to_date_time t |> of_dt utc let of_unix_time s = match Ptime.of_float_s s with - | None -> invalid_arg (Printf.sprintf "%s: %f" __FUNCTION__ s) - | Some t -> of_ptime t + | None -> + invalid_arg (Printf.sprintf "%s: %f" __FUNCTION__ s) + | Some t -> + of_ptime t let to_unix_time t = to_ptime_t t |> Ptime.to_float_s let _localtime current_tz_offset t = let tz_offset_s = current_tz_offset |> Option.value ~default:0 in let localtime = t |> Ptime.to_date_time ~tz_offset_s |> of_dt Empty in - let (_, (_, localtime_offset), _) = localtime in + let _, (_, localtime_offset), _ = localtime in if localtime_offset <> tz_offset_s then - invalid_arg ( - Printf.sprintf "date.ml:_localtime: offsets don't match. offset='%i', t='%s'" - tz_offset_s - (Ptime.to_rfc3339 t) - ); + invalid_arg + (Printf.sprintf + "date.ml:_localtime: offsets don't match. offset='%i', t='%s'" + tz_offset_s (Ptime.to_rfc3339 t) + ) ; localtime let _localtime_string current_tz_offset t = @@ -129,4 +159,3 @@ let to_string = to_rfc3339 let of_float = of_unix_time let to_float = to_unix_time - diff --git a/lib/xapi-stdext-date/date.mli b/lib/xapi-stdext-date/date.mli index 2069cf937be..e4f4d73a1cd 100644 --- a/lib/xapi-stdext-date/date.mli +++ b/lib/xapi-stdext-date/date.mli @@ -18,19 +18,19 @@ (** An ISO-8601 date/time type. *) type iso8601 -(** Convert ptime to time in UTC *) val of_ptime : Ptime.t -> iso8601 +(** Convert ptime to time in UTC *) +val to_ptime : iso8601 -> Ptime.t (** Convert date/time to a ptime value: the number of seconds since 00:00:00 UTC, 1 Jan 1970. Assumes the underlying iso8601 is in UTC *) -val to_ptime : iso8601 -> Ptime.t -(** Convert calendar time [x] (as returned by e.g. Unix.time), to time in UTC. *) val of_unix_time : float -> iso8601 +(** Convert calendar time [x] (as returned by e.g. Unix.time), to time in UTC. *) +val to_unix_time : iso8601 -> float (** Convert date/time to a unix timestamp: the number of seconds since 00:00:00 UTC, 1 Jan 1970. Assumes the underlying iso8601 is in UTC *) -val to_unix_time : iso8601 -> float val to_rfc3339 : iso8601 -> string (** Convert date/time to an RFC-3339-formatted string. It also complies with @@ -40,35 +40,36 @@ val of_iso8601 : string -> iso8601 (** Convert ISO 8601 formatted string to a date/time value. Does not accept a timezone annotated datetime - i.e. string must be UTC, and end with a Z *) -(** Same as [of_unix_time] *) val of_float : float -> iso8601 +(** Same as [of_unix_time] *) -(** Same as [to_unix_time] *) val to_float : iso8601 -> float +(** Same as [to_unix_time] *) -(** Convert date/time to an ISO 8601 formatted string. *) val to_string : iso8601 -> string +(** Convert date/time to an ISO 8601 formatted string. *) +val of_string : string -> iso8601 (** Convert ISO 8601 formatted string to a date/time value. * Does not accept a timezone annotated datetime - i.e. string must be UTC, and end with a Z *) -val of_string : string -> iso8601 +val assert_utc : iso8601 -> unit + [@@deprecated + "assertions performed inside constructors, so this fn does nothing"] (** Raises an Invalid_argument exception if the given date is not a UTC date. * A UTC date is an ISO 8601 strings that ends with the character 'Z'. *) -val assert_utc : iso8601 -> unit -[@@deprecated "assertions performed inside constructors, so this fn does nothing"] +val epoch : iso8601 (** 00:00:00 UTC, 1 Jan 1970, in UTC *) -val epoch: iso8601 +val never : iso8601 (** Same as [epoch] *) -val never: iso8601 -(** Count the number of seconds passed since 00:00:00 UTC, 1 Jan 1970, in UTC *) val now : unit -> iso8601 +(** Count the number of seconds passed since 00:00:00 UTC, 1 Jan 1970, in UTC *) -(** exposed for testing *) val _localtime_string : Ptime.tz_offset_s option -> Ptime.t -> string +(** exposed for testing *) val localtime : unit -> iso8601 @@ -77,10 +78,10 @@ val localtime : unit -> iso8601 (** An RFC 822 date/time type. *) type rfc822 -(** Convert calendar time [x] (as returned by e.g. Unix.time), to RFC 822. *) val rfc822_of_float : float -> rfc822 +(** Convert calendar time [x] (as returned by e.g. Unix.time), to RFC 822. *) -(** Convert RFC 822 date/time to a formatted string. *) val rfc822_to_string : rfc822 -> string +(** Convert RFC 822 date/time to a formatted string. *) val eq : iso8601 -> iso8601 -> bool diff --git a/lib/xapi-stdext-date/test.ml b/lib/xapi-stdext-date/test.ml index 8b7ddf81360..e0bd83640b7 100644 --- a/lib/xapi-stdext-date/test.ml +++ b/lib/xapi-stdext-date/test.ml @@ -1,45 +1,56 @@ open Xapi_stdext_date.Date -let check_float = Alcotest.(check @@ float 1e-2 ) +let check_float = Alcotest.(check @@ float 1e-2) + let check_float_neq = Alcotest.(check @@ neg @@ float 1e-2) + let check_string = Alcotest.(check string) + let check_true str = Alcotest.(check bool) str true + let dash_time_str = "2020-04-07T08:28:32Z" + let no_dash_utc_time_str = "20200407T08:28:32Z" let iso8601_tests = let test_of_unix_time_invertible () = let non_int_time = 1586245987.70200706 in let time = non_int_time |> Float.floor in - check_float "to_unix_time inverts of_unix_time" time (time |> of_unix_time |> to_unix_time); - check_true "of_unix_time inverts to_unix_time" @@ eq (time |> of_unix_time) (time |> of_unix_time |> to_unix_time |> of_unix_time); + check_float "to_unix_time inverts of_unix_time" time + (time |> of_unix_time |> to_unix_time) ; + check_true "of_unix_time inverts to_unix_time" + @@ eq (time |> of_unix_time) + (time |> of_unix_time |> to_unix_time |> of_unix_time) in - let test_only_utc () = let utc = "2020-12-20T18:10:19Z" in - let _ = of_string utc in (* UTC is valid *) + let _ = of_string utc in + (* UTC is valid *) let non_utc = "2020-12-20T18:10:19+02:00" in let exn = Invalid_argument "date.ml:of_string: 2020-12-20T18:10:19+02:00" in - Alcotest.check_raises "only UTC is accepted" exn (fun () -> of_string non_utc |> ignore) + Alcotest.check_raises "only UTC is accepted" exn (fun () -> + of_string non_utc |> ignore + ) in - let test_ca333908 () = check_float "dash time and no dash time represent the same unix timestamp" - (dash_time_str |> of_string |> to_unix_time) - (no_dash_utc_time_str |> of_string |> to_unix_time) + (dash_time_str |> of_string |> to_unix_time) + (no_dash_utc_time_str |> of_string |> to_unix_time) in - let test_of_string_invertible_when_no_dashes () = - check_string "to_string inverts of_string" no_dash_utc_time_str (no_dash_utc_time_str |> of_string |> to_string); - check_true "of_string inverts to_string" (eq (no_dash_utc_time_str |> of_string) (no_dash_utc_time_str |> of_string |> to_string |> of_string)); + check_string "to_string inverts of_string" no_dash_utc_time_str + (no_dash_utc_time_str |> of_string |> to_string) ; + check_true "of_string inverts to_string" + (eq + (no_dash_utc_time_str |> of_string) + (no_dash_utc_time_str |> of_string |> to_string |> of_string) + ) in - (* CA-338243 - breaking backwards compatibility will break XC and XRT *) let test_to_string_backwards_compatibility () = check_string "to_string is backwards compatible" no_dash_utc_time_str (dash_time_str |> of_string |> to_string) in - let test_localtime_string () = let[@warning "-8"] (Ok (t, _, _)) = Ptime.of_rfc3339 "2020-04-07T09:01:28Z" @@ -47,41 +58,59 @@ let iso8601_tests = let minus_2_hrs = -7200 in let plus_3_hrs = 10800 in let zero_hrs = 0 in - check_string "can subtract 2 hours" (_localtime_string (Some minus_2_hrs) t) "20200407T07:01:28"; - check_string "can add 3 hours" (_localtime_string (Some plus_3_hrs) t) "20200407T12:01:28"; - check_string "can add None" (_localtime_string None t) "20200407T09:01:28"; - check_string "can add zero" (_localtime_string (Some zero_hrs) t) "20200407T09:01:28" + check_string "can subtract 2 hours" + (_localtime_string (Some minus_2_hrs) t) + "20200407T07:01:28" ; + check_string "can add 3 hours" + (_localtime_string (Some plus_3_hrs) t) + "20200407T12:01:28" ; + check_string "can add None" (_localtime_string None t) "20200407T09:01:28" ; + check_string "can add zero" + (_localtime_string (Some zero_hrs) t) + "20200407T09:01:28" in - (* sanity check (on top of test_localtime_string) that localtime produces valid looking output *) let test_ca342171 () = (* no exception is thrown + backward compatible formatting *) let localtime_string = localtime () |> to_string in - Alcotest.(check int) "localtime string has correct number of chars" - (String.length localtime_string) (String.length no_dash_utc_time_str - 1); - Alcotest.(check bool) "localtime string does not contain a Z" false (String.contains localtime_string 'Z') + Alcotest.(check int) + "localtime string has correct number of chars" + (String.length localtime_string) + (String.length no_dash_utc_time_str - 1) ; + Alcotest.(check bool) + "localtime string does not contain a Z" false + (String.contains localtime_string 'Z') in - let test_xsi894 () = let missing_tz_no_dash = "20201210T17:19:20" in let missing_tz_dash = "2020-12-10T17:19:20" in - check_string "can process missing tz no dash" missing_tz_no_dash (missing_tz_no_dash |> of_string |> to_string) ; - check_string "can process missing tz with dashes, but return without dashes" missing_tz_no_dash (missing_tz_dash |> of_string |> to_string) ; - - check_float "to_unix_time assumes UTC" 1607620760. (missing_tz_no_dash |> of_string |> to_unix_time) ; - + check_string "can process missing tz no dash" missing_tz_no_dash + (missing_tz_no_dash |> of_string |> to_string) ; + check_string "can process missing tz with dashes, but return without dashes" + missing_tz_no_dash + (missing_tz_dash |> of_string |> to_string) ; + check_float "to_unix_time assumes UTC" 1607620760. + (missing_tz_no_dash |> of_string |> to_unix_time) ; let localtime' = localtime () in - check_string "to_string inverts of_string for localtime" (localtime' |> to_string) (localtime' |> to_string |> of_string |> to_string) ; + check_string "to_string inverts of_string for localtime" + (localtime' |> to_string) + (localtime' |> to_string |> of_string |> to_string) in - - [ "test_of_unix_time_invertible", `Quick, test_of_unix_time_invertible - ; "test_only_utc", `Quick, test_only_utc - ; "test_ca333908", `Quick, test_ca333908 - ; "test_of_string_invertible_when_no_dashes", `Quick, test_of_string_invertible_when_no_dashes - ; "test_to_string_backwards_compatibility", `Quick, test_to_string_backwards_compatibility - ; "test_localtime_string", `Quick, test_localtime_string - ; "test_ca342171", `Quick, test_ca342171 - ; "test_xsi894", `Quick, test_xsi894 + [ + ("test_of_unix_time_invertible", `Quick, test_of_unix_time_invertible) + ; ("test_only_utc", `Quick, test_only_utc) + ; ("test_ca333908", `Quick, test_ca333908) + ; ( "test_of_string_invertible_when_no_dashes" + , `Quick + , test_of_string_invertible_when_no_dashes + ) + ; ( "test_to_string_backwards_compatibility" + , `Quick + , test_to_string_backwards_compatibility + ) + ; ("test_localtime_string", `Quick, test_localtime_string) + ; ("test_ca342171", `Quick, test_ca342171) + ; ("test_xsi894", `Quick, test_xsi894) ] -let () = Alcotest.run "Date" [ "ISO 8601", iso8601_tests ] +let () = Alcotest.run "Date" [("ISO 8601", iso8601_tests)] From bbcf1ee215429c2bc7126401c3d49293638c32fa Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 17 Nov 2022 11:16:23 +0000 Subject: [PATCH 159/199] Date: test RFC 822 formatting Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-date/test.ml | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/lib/xapi-stdext-date/test.ml b/lib/xapi-stdext-date/test.ml index e0bd83640b7..e5e2490ba22 100644 --- a/lib/xapi-stdext-date/test.ml +++ b/lib/xapi-stdext-date/test.ml @@ -113,4 +113,21 @@ let iso8601_tests = ; ("test_xsi894", `Quick, test_xsi894) ] -let () = Alcotest.run "Date" [("ISO 8601", iso8601_tests)] +let rfc822_tests = + let dates = + [ + (-1221847200., "Tue, 14 Apr 1931 06:00:00 GMT") + ; (0., "Thu, 1 Jan 1970 00:00:00 GMT") + ; (626637180., "Thu, 9 Nov 1989 17:53:00 GMT") + ; (2889734400., "Thu, 28 Jul 2061 00:00:00 GMT") + ] + in + let test_email_date (unix_timestamp, expected) = + let formatted = rfc822_of_float unix_timestamp |> rfc822_to_string in + check_string "String is properly RFC-822-formatted" expected formatted + in + let test_email_dates () = List.iter test_email_date dates in + [("RFC 822 formatting", `Quick, test_email_dates)] + +let () = + Alcotest.run "Date" [("ISO 8601", iso8601_tests); ("RFC 822", rfc822_tests)] From 4b354c2f2bac2f6be53ef70af6756d5a1389f9af Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 16 Nov 2022 16:33:58 +0000 Subject: [PATCH 160/199] Date: create RFC-822-formatted strings from Date.iso8601 Add a function to print datetimes in email format, this allows to alias both types into one encompassing all the functionality of the module Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-date/date.ml | 32 +++++++++++++++++++++----------- lib/xapi-stdext-date/date.mli | 3 +++ 2 files changed, 24 insertions(+), 11 deletions(-) diff --git a/lib/xapi-stdext-date/date.ml b/lib/xapi-stdext-date/date.ml index a447b710344..db9f2b1809a 100644 --- a/lib/xapi-stdext-date/date.ml +++ b/lib/xapi-stdext-date/date.ml @@ -12,9 +12,6 @@ * GNU Lesser General Public License for more details. *) -(* ==== RFC822 ==== *) -type rfc822 = string - let months = [| "Jan" @@ -33,14 +30,6 @@ let months = let days = [|"Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat"|] -let rfc822_of_float x = - let time = Unix.gmtime x in - Printf.sprintf "%s, %d %s %d %02d:%02d:%02d GMT" days.(time.Unix.tm_wday) - time.Unix.tm_mday months.(time.Unix.tm_mon) (time.Unix.tm_year + 1900) - time.Unix.tm_hour time.Unix.tm_min time.Unix.tm_sec - -let rfc822_to_string x = x - (* ==== ISO8601/RFC3339 ==== *) type print_timezone = Empty | TZ of string @@ -100,6 +89,21 @@ let to_rfc3339 ((y, mon, d), ((h, min, s), _), print_type) = | Empty -> Printf.sprintf "%04i%02i%02iT%02i:%02i:%02i" y mon d h min s +let weekday ~year ~mon ~day = + let a = (14 - mon) / 12 in + let y = year - a in + let m = mon + (12 * a) - 2 in + (day + y + (y / 4) - (y / 100) + (y / 400) + (31 * m / 12)) mod 7 + +let to_rfc822 ((year, mon, day), ((h, min, s), _), print_type) = + let timezone = + match print_type with Empty | TZ "Z" -> "GMT" | TZ tz -> tz + in + let weekday = weekday ~year ~mon ~day in + Printf.sprintf "%s, %d %s %d %02d:%02d:%02d %s" days.(weekday) day + months.(mon - 1) + year h min s timezone + let to_ptime_t t = match to_dt t |> Ptime.of_date_time with | Some t -> @@ -159,3 +163,9 @@ let to_string = to_rfc3339 let of_float = of_unix_time let to_float = to_unix_time + +let rfc822_of_float = of_unix_time + +let rfc822_to_string = to_rfc822 + +type rfc822 = iso8601 diff --git a/lib/xapi-stdext-date/date.mli b/lib/xapi-stdext-date/date.mli index e4f4d73a1cd..829ab9f9b24 100644 --- a/lib/xapi-stdext-date/date.mli +++ b/lib/xapi-stdext-date/date.mli @@ -32,6 +32,9 @@ val to_unix_time : iso8601 -> float (** Convert date/time to a unix timestamp: the number of seconds since 00:00:00 UTC, 1 Jan 1970. Assumes the underlying iso8601 is in UTC *) +val to_rfc822 : iso8601 -> string +(** Convert date/time to email-formatted (RFC 822) string. *) + val to_rfc3339 : iso8601 -> string (** Convert date/time to an RFC-3339-formatted string. It also complies with the ISO 8601 format.*) From 29872b1f374836e9d201999c28c7220f6f8a5bd4 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 16 Nov 2022 17:30:50 +0000 Subject: [PATCH 161/199] Date: Use type t as main type, prepare for deprecations Both iso8601 and rfc822 types and related functions have been moved at the bottom to make them less visible and deprecate them on the next version, providing a smooth transition path Tests have been changed to use the new functions Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-date/date.ml | 19 ++++--- lib/xapi-stdext-date/date.mli | 96 ++++++++++++++++++----------------- lib/xapi-stdext-date/test.ml | 90 ++++++++++++++++---------------- 3 files changed, 104 insertions(+), 101 deletions(-) diff --git a/lib/xapi-stdext-date/date.ml b/lib/xapi-stdext-date/date.ml index db9f2b1809a..c9520011dae 100644 --- a/lib/xapi-stdext-date/date.ml +++ b/lib/xapi-stdext-date/date.ml @@ -30,12 +30,10 @@ let months = let days = [|"Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat"|] -(* ==== ISO8601/RFC3339 ==== *) - type print_timezone = Empty | TZ of string (* we must store the print_type with iso8601 to handle the case where the local time zone is UTC *) -type iso8601 = Ptime.date * Ptime.time * print_timezone +type t = Ptime.date * Ptime.time * print_timezone let utc = TZ "Z" @@ -73,13 +71,13 @@ let of_iso8601 x = let rfc3339, print_timezone = best_effort_iso8601_to_rfc3339 x in match Ptime.of_rfc3339 rfc3339 |> Ptime.rfc3339_error_to_msg with | Error _ -> - invalid_arg (Printf.sprintf "date.ml:of_string: %s" x) + invalid_arg (Printf.sprintf "%s: %s" __FUNCTION__ x) | Ok (t, tz, _) -> ( match tz with | None | Some 0 -> Ptime.to_date_time t |> of_dt print_timezone | Some _ -> - invalid_arg (Printf.sprintf "date.ml:of_string: %s" x) + invalid_arg (Printf.sprintf "%s: %s" __FUNCTION__ x) ) let to_rfc3339 ((y, mon, d), ((h, min, s), _), print_type) = @@ -111,7 +109,7 @@ let to_ptime_t t = | None -> let _, (_, offset), _ = t in invalid_arg - (Printf.sprintf "date.ml:to_t: dt='%s', offset='%i' is invalid" + (Printf.sprintf "%s: dt='%s', offset='%i' is invalid" __FUNCTION__ (to_rfc3339 t) offset ) @@ -134,9 +132,8 @@ let _localtime current_tz_offset t = let _, (_, localtime_offset), _ = localtime in if localtime_offset <> tz_offset_s then invalid_arg - (Printf.sprintf - "date.ml:_localtime: offsets don't match. offset='%i', t='%s'" - tz_offset_s (Ptime.to_rfc3339 t) + (Printf.sprintf "%s: offsets don't match. offset='%i', t='%s'" + __FUNCTION__ tz_offset_s (Ptime.to_rfc3339 t) ) ; localtime @@ -168,4 +165,6 @@ let rfc822_of_float = of_unix_time let rfc822_to_string = to_rfc822 -type rfc822 = iso8601 +type iso8601 = t + +type rfc822 = t diff --git a/lib/xapi-stdext-date/date.mli b/lib/xapi-stdext-date/date.mli index 829ab9f9b24..637a529ca7e 100644 --- a/lib/xapi-stdext-date/date.mli +++ b/lib/xapi-stdext-date/date.mli @@ -11,80 +11,82 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -(** Additional types and functions for dates *) -(** {2 ISO 8601 Dates} *) +(** date-time with support for keeping timezone for ISO 8601 conversion *) +type t -(** An ISO-8601 date/time type. *) -type iso8601 - -val of_ptime : Ptime.t -> iso8601 +val of_ptime : Ptime.t -> t (** Convert ptime to time in UTC *) -val to_ptime : iso8601 -> Ptime.t +val to_ptime : t -> Ptime.t (** Convert date/time to a ptime value: the number of seconds since 00:00:00 - UTC, 1 Jan 1970. Assumes the underlying iso8601 is in UTC *) + UTC, 1 Jan 1970. Assumes the underlying {!t} is in UTC *) -val of_unix_time : float -> iso8601 -(** Convert calendar time [x] (as returned by e.g. Unix.time), to time in UTC. *) +val of_unix_time : float -> t +(** Convert calendar time [x] (as returned by e.g. Unix.time), to time in UTC *) -val to_unix_time : iso8601 -> float +val to_unix_time : t -> float (** Convert date/time to a unix timestamp: the number of seconds since - 00:00:00 UTC, 1 Jan 1970. Assumes the underlying iso8601 is in UTC *) + 00:00:00 UTC, 1 Jan 1970. Assumes the underlying {!t} is in UTC *) -val to_rfc822 : iso8601 -> string +val to_rfc822 : t -> string (** Convert date/time to email-formatted (RFC 822) string. *) -val to_rfc3339 : iso8601 -> string +val to_rfc3339 : t -> string (** Convert date/time to an RFC-3339-formatted string. It also complies with - the ISO 8601 format.*) + the ISO 8601 format *) -val of_iso8601 : string -> iso8601 +val of_iso8601 : string -> t (** Convert ISO 8601 formatted string to a date/time value. Does not accept a timezone annotated datetime - i.e. string must be UTC, and end with a Z *) -val of_float : float -> iso8601 -(** Same as [of_unix_time] *) +val epoch : t +(** 00:00:00 UTC, 1 Jan 1970, in UTC *) -val to_float : iso8601 -> float -(** Same as [to_unix_time] *) +val now : unit -> t +(** Count the number of seconds passed since 00:00:00 UTC, 1 Jan 1970, in UTC *) -val to_string : iso8601 -> string -(** Convert date/time to an ISO 8601 formatted string. *) +val _localtime_string : Ptime.tz_offset_s option -> Ptime.t -> string +(** exposed for testing *) -val of_string : string -> iso8601 -(** Convert ISO 8601 formatted string to a date/time value. - * Does not accept a timezone annotated datetime - i.e. string must be UTC, and end with a Z *) +val localtime : unit -> t +(** Count the number of seconds passed since 00:00:00 UTC, 1 Jan 1970, in local + time *) -val assert_utc : iso8601 -> unit - [@@deprecated - "assertions performed inside constructors, so this fn does nothing"] -(** Raises an Invalid_argument exception if the given date is not a UTC date. - * A UTC date is an ISO 8601 strings that ends with the character 'Z'. *) +val eq : t -> t -> bool +(** [eq a b] returns whether [a] and [b] are equal *) -val epoch : iso8601 -(** 00:00:00 UTC, 1 Jan 1970, in UTC *) +(** Deprecated bindings, these will be removed in a future release: *) -val never : iso8601 -(** Same as [epoch] *) +val rfc822_to_string : t -> string +(** Same as {!to_rfc822} *) -val now : unit -> iso8601 -(** Count the number of seconds passed since 00:00:00 UTC, 1 Jan 1970, in UTC *) +val rfc822_of_float : float -> t +(** Same as {!of_unix_time} *) -val _localtime_string : Ptime.tz_offset_s option -> Ptime.t -> string -(** exposed for testing *) +val of_float : float -> t +(** Same as {!of_unix_time} *) -val localtime : unit -> iso8601 +val to_float : t -> float +(** Same as {!to_unix_time} *) -(** {2 RFC 822 Dates} *) +val to_string : t -> string +(** Same as {!to_rfc3339} *) -(** An RFC 822 date/time type. *) -type rfc822 +val of_string : string -> t +(** Same as {!of_iso8601} *) -val rfc822_of_float : float -> rfc822 -(** Convert calendar time [x] (as returned by e.g. Unix.time), to RFC 822. *) +val never : t +(** Same as {!epoch} *) + +val assert_utc : t -> unit + [@@deprecated + "assertions performed inside constructors, so this fn does nothing"] +(** Raises an Invalid_argument exception if the given date is not a UTC date. + A UTC date is an ISO 8601 strings that ends with the character 'Z' *) -val rfc822_to_string : rfc822 -> string -(** Convert RFC 822 date/time to a formatted string. *) +(** Deprecated alias for {!t} *) +type iso8601 = t -val eq : iso8601 -> iso8601 -> bool +(** Deprecated alias for {!t} *) +type rfc822 = t diff --git a/lib/xapi-stdext-date/test.ml b/lib/xapi-stdext-date/test.ml index e5e2490ba22..66ec59696da 100644 --- a/lib/xapi-stdext-date/test.ml +++ b/lib/xapi-stdext-date/test.ml @@ -12,7 +12,7 @@ let dash_time_str = "2020-04-07T08:28:32Z" let no_dash_utc_time_str = "20200407T08:28:32Z" -let iso8601_tests = +let tests = let test_of_unix_time_invertible () = let non_int_time = 1586245987.70200706 in let time = non_int_time |> Float.floor in @@ -24,32 +24,35 @@ let iso8601_tests = in let test_only_utc () = let utc = "2020-12-20T18:10:19Z" in - let _ = of_string utc in + let _ = of_iso8601 utc in (* UTC is valid *) let non_utc = "2020-12-20T18:10:19+02:00" in - let exn = Invalid_argument "date.ml:of_string: 2020-12-20T18:10:19+02:00" in + let exn = + Invalid_argument + "Xapi_stdext_date__Date.of_iso8601: 2020-12-20T18:10:19+02:00" + in Alcotest.check_raises "only UTC is accepted" exn (fun () -> - of_string non_utc |> ignore + of_iso8601 non_utc |> ignore ) in let test_ca333908 () = check_float "dash time and no dash time represent the same unix timestamp" - (dash_time_str |> of_string |> to_unix_time) - (no_dash_utc_time_str |> of_string |> to_unix_time) + (dash_time_str |> of_iso8601 |> to_unix_time) + (no_dash_utc_time_str |> of_iso8601 |> to_unix_time) in - let test_of_string_invertible_when_no_dashes () = - check_string "to_string inverts of_string" no_dash_utc_time_str - (no_dash_utc_time_str |> of_string |> to_string) ; - check_true "of_string inverts to_string" + let test_of_iso8601_invertible_when_no_dashes () = + check_string "to_rfc3339 inverts of_iso8601" no_dash_utc_time_str + (no_dash_utc_time_str |> of_iso8601 |> to_rfc3339) ; + check_true "of_iso8601 inverts to_rfc3339" (eq - (no_dash_utc_time_str |> of_string) - (no_dash_utc_time_str |> of_string |> to_string |> of_string) + (no_dash_utc_time_str |> of_iso8601) + (no_dash_utc_time_str |> of_iso8601 |> to_rfc3339 |> of_iso8601) ) in (* CA-338243 - breaking backwards compatibility will break XC and XRT *) - let test_to_string_backwards_compatibility () = - check_string "to_string is backwards compatible" no_dash_utc_time_str - (dash_time_str |> of_string |> to_string) + let test_to_rfc3339_backwards_compatibility () = + check_string "to_rfc3339 is backwards compatible" no_dash_utc_time_str + (dash_time_str |> of_iso8601 |> to_rfc3339) in let test_localtime_string () = let[@warning "-8"] (Ok (t, _, _)) = @@ -72,7 +75,7 @@ let iso8601_tests = (* sanity check (on top of test_localtime_string) that localtime produces valid looking output *) let test_ca342171 () = (* no exception is thrown + backward compatible formatting *) - let localtime_string = localtime () |> to_string in + let localtime_string = localtime () |> to_rfc3339 in Alcotest.(check int) "localtime string has correct number of chars" (String.length localtime_string) @@ -85,49 +88,48 @@ let iso8601_tests = let missing_tz_no_dash = "20201210T17:19:20" in let missing_tz_dash = "2020-12-10T17:19:20" in check_string "can process missing tz no dash" missing_tz_no_dash - (missing_tz_no_dash |> of_string |> to_string) ; + (missing_tz_no_dash |> of_iso8601 |> to_rfc3339) ; check_string "can process missing tz with dashes, but return without dashes" missing_tz_no_dash - (missing_tz_dash |> of_string |> to_string) ; + (missing_tz_dash |> of_iso8601 |> to_rfc3339) ; check_float "to_unix_time assumes UTC" 1607620760. - (missing_tz_no_dash |> of_string |> to_unix_time) ; + (missing_tz_no_dash |> of_iso8601 |> to_unix_time) ; let localtime' = localtime () in - check_string "to_string inverts of_string for localtime" - (localtime' |> to_string) - (localtime' |> to_string |> of_string |> to_string) + check_string "to_rfc3339 inverts of_iso8601 for localtime" + (localtime' |> to_rfc3339) + (localtime' |> to_rfc3339 |> of_iso8601 |> to_rfc3339) + in + let test_email_date (unix_timestamp, expected) = + let formatted = of_unix_time unix_timestamp |> to_rfc822 in + check_string "String is properly RFC-822-formatted" expected formatted + in + let test_email_dates () = + let dates = + [ + (-1221847200., "Tue, 14 Apr 1931 06:00:00 GMT") + ; (0., "Thu, 1 Jan 1970 00:00:00 GMT") + ; (626637180., "Thu, 9 Nov 1989 17:53:00 GMT") + ; (2889734400., "Thu, 28 Jul 2061 00:00:00 GMT") + ] + in + List.iter test_email_date dates in [ ("test_of_unix_time_invertible", `Quick, test_of_unix_time_invertible) ; ("test_only_utc", `Quick, test_only_utc) ; ("test_ca333908", `Quick, test_ca333908) - ; ( "test_of_string_invertible_when_no_dashes" + ; ( "test_of_iso8601_invertible_when_no_dashes" , `Quick - , test_of_string_invertible_when_no_dashes + , test_of_iso8601_invertible_when_no_dashes ) - ; ( "test_to_string_backwards_compatibility" + ; ( "test_to_rfc3339_backwards_compatibility" , `Quick - , test_to_string_backwards_compatibility + , test_to_rfc3339_backwards_compatibility ) ; ("test_localtime_string", `Quick, test_localtime_string) ; ("test_ca342171", `Quick, test_ca342171) ; ("test_xsi894", `Quick, test_xsi894) + ; ("RFC 822 formatting", `Quick, test_email_dates) ] -let rfc822_tests = - let dates = - [ - (-1221847200., "Tue, 14 Apr 1931 06:00:00 GMT") - ; (0., "Thu, 1 Jan 1970 00:00:00 GMT") - ; (626637180., "Thu, 9 Nov 1989 17:53:00 GMT") - ; (2889734400., "Thu, 28 Jul 2061 00:00:00 GMT") - ] - in - let test_email_date (unix_timestamp, expected) = - let formatted = rfc822_of_float unix_timestamp |> rfc822_to_string in - check_string "String is properly RFC-822-formatted" expected formatted - in - let test_email_dates () = List.iter test_email_date dates in - [("RFC 822 formatting", `Quick, test_email_dates)] - -let () = - Alcotest.run "Date" [("ISO 8601", iso8601_tests); ("RFC 822", rfc822_tests)] +let () = Alcotest.run "Date" [("Conversions", tests)] From 3c9f5e271c9266a08b2a6fc638c9b40fbe47ea86 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 17 Nov 2022 11:53:42 +0000 Subject: [PATCH 162/199] Prepare for release v4.20 Signed-off-by: Pau Ruiz Safont --- CHANGES.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 6f68bf2f928..6db1ab55e28 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,7 @@ +## 4.20.0 (17-Nov-2022) + - date: consolidate the types into a single t + - date: add conversion functions that have semantic meaning, the previous functions containing 'float' and 'string' will be deprecated in a future release. + ## v4.19.0 (17-Jun-2022) - maintenance: give a name to the project - threads: Remove all the modules except Mutex From 50d6e80024e3b8840828c863b574cdb4941f8280 Mon Sep 17 00:00:00 2001 From: Steven Woods Date: Thu, 24 Nov 2022 14:09:23 +0000 Subject: [PATCH 163/199] Allow optional perms parameter when writing string or bytes to file Signed-off-by: Steven Woods --- lib/xapi-stdext-unix/unixext.ml | 8 ++++---- lib/xapi-stdext-unix/unixext.mli | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/lib/xapi-stdext-unix/unixext.ml b/lib/xapi-stdext-unix/unixext.ml index ef415b82bad..04e99487838 100644 --- a/lib/xapi-stdext-unix/unixext.ml +++ b/lib/xapi-stdext-unix/unixext.ml @@ -180,14 +180,14 @@ let atomic_write_to_file fname perms f = (** Atomically write a string to a file *) -let write_bytes_to_file fname b = - atomic_write_to_file fname 0o644 (fun fd -> +let write_bytes_to_file ?(perms=0o644) fname b = + atomic_write_to_file fname perms (fun fd -> let len = Bytes.length b in let written = Unix.write fd b 0 len in if written <> len then (failwith "Short write occured!")) -let write_string_to_file fname s = - write_bytes_to_file fname (Bytes.unsafe_of_string s) +let write_string_to_file ?(perms=0o644) fname s = + write_bytes_to_file fname ~perms (Bytes.unsafe_of_string s) let execv_get_output cmd args = let (pipe_exit, pipe_entrance) = Unix.pipe () in diff --git a/lib/xapi-stdext-unix/unixext.mli b/lib/xapi-stdext-unix/unixext.mli index 16439a2f678..77ce223e9ba 100644 --- a/lib/xapi-stdext-unix/unixext.mli +++ b/lib/xapi-stdext-unix/unixext.mli @@ -69,11 +69,11 @@ val atomic_write_to_file : string -> Unix.file_perm -> (Unix.file_descr -> 'a) - (** [write_string_to_file fname contents] creates a file with path [fname] with the string [contents] as its contents, atomically *) -val write_string_to_file : string -> string -> unit +val write_string_to_file : ?perms:Unix.file_perm -> string -> string -> unit (** [write_string_to_file fname contents] creates a file with path [fname] with the buffer [contents] as its contents, atomically *) -val write_bytes_to_file : string -> bytes -> unit +val write_bytes_to_file : ?perms:Unix.file_perm -> string -> bytes -> unit val execv_get_output : string -> string array -> int * Unix.file_descr val copy_file : ?limit:int64 -> Unix.file_descr -> Unix.file_descr -> int64 From e41338bd4e99a0ee1d4c01d5927f653c0edbc99a Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 17 Nov 2022 13:35:10 +0000 Subject: [PATCH 164/199] dune: require 2.7 This generates correctly the opam definitions, and required updating the syntax for the c foreign stubs Signed-off-by: Pau Ruiz Safont --- CHANGES.md | 6 +++++- dune-project | 17 +++++------------ lib/xapi-stdext-unix/dune | 13 ++++++++----- lib/xapi-stdext-zerocheck/dune | 2 +- xapi-stdext-date.opam | 6 +++--- xapi-stdext-encodings.opam | 6 +++--- xapi-stdext-pervasives.opam | 6 +++--- xapi-stdext-std.opam | 4 ++-- xapi-stdext-threads.opam | 4 ++-- xapi-stdext-unix.opam | 4 ++-- xapi-stdext-zerocheck.opam | 4 ++-- xapi-stdext.opam | 5 +++-- 12 files changed, 39 insertions(+), 38 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 6db1ab55e28..4f0260c03a3 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,4 +1,8 @@ -## 4.20.0 (17-Nov-2022) +## v4.21.0 (unreleased) + - unix: add permissions to write_{bytes,string}_to_file + - Use a dune version with fixed metadata generation + +## v4.20.0 (17-Nov-2022) - date: consolidate the types into a single t - date: add conversion functions that have semantic meaning, the previous functions containing 'float' and 'string' will be deprecated in a future release. diff --git a/dune-project b/dune-project index 781499839ab..1bc01308d59 100644 --- a/dune-project +++ b/dune-project @@ -1,5 +1,5 @@ -(lang dune 1.11) -(using fmt 1.2 (enabled_for ocaml)) +(lang dune 2.7) +(formatting (enabled_for ocaml)) (name xapi-stdext) (generate_opam_files true) @@ -28,8 +28,7 @@ (name xapi-stdext-date) (synopsis "Xapi's standard library extension, Dates") (depends - ocaml - (dune (>= 1.11)) + (ocaml (>= 4.12)) (alcotest :with-test) astring base-unix @@ -43,8 +42,7 @@ (synopsis "Xapi's standard library extension, Encodings") (depends ocaml - (dune (>= 1.11)) - (alcotest :with-test) + (alcotest (and (>= 0.6.0) :with-test)) (odoc :with-doc) ) ) @@ -53,8 +51,7 @@ (name xapi-stdext-pervasives) (synopsis "Xapi's standard library extension, Pervasives") (depends - ocaml - (dune (>= 1.11)) + (ocaml (>= 4.08)) logs (odoc :with-doc) xapi-backtrace @@ -66,7 +63,6 @@ (synopsis "Xapi's standard library extension, Stdlib") (depends ocaml - (dune (>= 1.11)) (alcotest :with-test) (odoc :with-doc) ) @@ -77,7 +73,6 @@ (synopsis "Xapi's standard library extension, Threads") (depends ocaml - (dune (>= 1.11)) base-threads base-unix (odoc :with-doc) @@ -90,7 +85,6 @@ (synopsis "Xapi's standard library extension, Unix") (depends ocaml - (dune (>= 1.11)) base-unix (fd-send-recv (>= 2.0.0)) (odoc :with-doc) @@ -103,7 +97,6 @@ (synopsis "Xapi's standard library extension, Zerocheck") (depends ocaml - (dune (>= 1.11)) (odoc :with-doc) ) ) diff --git a/lib/xapi-stdext-unix/dune b/lib/xapi-stdext-unix/dune index 6478ad3ae78..2e74dac45ba 100644 --- a/lib/xapi-stdext-unix/dune +++ b/lib/xapi-stdext-unix/dune @@ -1,13 +1,16 @@ (library (name xapi_stdext_unix) (public_name xapi-stdext-unix) - (c_names - blkgetsize_stubs - unixext_open_stubs - unixext_stubs - unixext_write_stubs) (libraries fd-send-recv unix xapi-stdext-pervasives) + (foreign_stubs + (language c) + (names + blkgetsize_stubs + unixext_open_stubs + unixext_stubs + unixext_write_stubs + )) ) diff --git a/lib/xapi-stdext-zerocheck/dune b/lib/xapi-stdext-zerocheck/dune index ef68c063d5c..ec7532c6a9a 100644 --- a/lib/xapi-stdext-zerocheck/dune +++ b/lib/xapi-stdext-zerocheck/dune @@ -1,5 +1,5 @@ (library (public_name xapi-stdext-zerocheck) (name xapi_stdext_zerocheck) - (c_names zerocheck_stub) + (foreign_stubs (language c) (names zerocheck_stub)) ) diff --git a/xapi-stdext-date.opam b/xapi-stdext-date.opam index 083f92e7c7b..136772a39f8 100644 --- a/xapi-stdext-date.opam +++ b/xapi-stdext-date.opam @@ -7,8 +7,8 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://github.com/xapi-project/stdext" bug-reports: "https://github.com/xapi-project/stdext/issues" depends: [ - "ocaml" - "dune" {>= "1.11"} + "dune" {>= "2.7"} + "ocaml" {>= "4.12"} "alcotest" {with-test} "astring" "base-unix" @@ -16,7 +16,7 @@ depends: [ "odoc" {with-doc} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext-encodings.opam b/xapi-stdext-encodings.opam index c8f419acd5e..8d7eeb152fa 100644 --- a/xapi-stdext-encodings.opam +++ b/xapi-stdext-encodings.opam @@ -7,13 +7,13 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://github.com/xapi-project/stdext" bug-reports: "https://github.com/xapi-project/stdext/issues" depends: [ + "dune" {>= "2.7"} "ocaml" - "dune" {>= "1.11"} - "alcotest" {with-test} + "alcotest" {>= "0.6.0" & with-test} "odoc" {with-doc} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext-pervasives.opam b/xapi-stdext-pervasives.opam index 6bffd2e7fc2..fe8325d9ecc 100644 --- a/xapi-stdext-pervasives.opam +++ b/xapi-stdext-pervasives.opam @@ -7,14 +7,14 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://github.com/xapi-project/stdext" bug-reports: "https://github.com/xapi-project/stdext/issues" depends: [ - "ocaml" - "dune" {>= "1.11"} + "dune" {>= "2.7"} + "ocaml" {>= "4.08"} "logs" "odoc" {with-doc} "xapi-backtrace" ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext-std.opam b/xapi-stdext-std.opam index 019d03c087b..833fc64b831 100644 --- a/xapi-stdext-std.opam +++ b/xapi-stdext-std.opam @@ -7,13 +7,13 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://github.com/xapi-project/stdext" bug-reports: "https://github.com/xapi-project/stdext/issues" depends: [ + "dune" {>= "2.7"} "ocaml" - "dune" {>= "1.11"} "alcotest" {with-test} "odoc" {with-doc} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext-threads.opam b/xapi-stdext-threads.opam index d35226e3647..04cd8fea4f7 100644 --- a/xapi-stdext-threads.opam +++ b/xapi-stdext-threads.opam @@ -7,15 +7,15 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://github.com/xapi-project/stdext" bug-reports: "https://github.com/xapi-project/stdext/issues" depends: [ + "dune" {>= "2.7"} "ocaml" - "dune" {>= "1.11"} "base-threads" "base-unix" "odoc" {with-doc} "xapi-stdext-pervasives" {= version} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam index 9de7d71a238..e7e2b807a69 100644 --- a/xapi-stdext-unix.opam +++ b/xapi-stdext-unix.opam @@ -7,15 +7,15 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://github.com/xapi-project/stdext" bug-reports: "https://github.com/xapi-project/stdext/issues" depends: [ + "dune" {>= "2.7"} "ocaml" - "dune" {>= "1.11"} "base-unix" "fd-send-recv" {>= "2.0.0"} "odoc" {with-doc} "xapi-stdext-pervasives" {= version} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext-zerocheck.opam b/xapi-stdext-zerocheck.opam index f1dc3de23f5..b5e43408e5f 100644 --- a/xapi-stdext-zerocheck.opam +++ b/xapi-stdext-zerocheck.opam @@ -7,12 +7,12 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://github.com/xapi-project/stdext" bug-reports: "https://github.com/xapi-project/stdext/issues" depends: [ + "dune" {>= "2.7"} "ocaml" - "dune" {>= "1.11"} "odoc" {with-doc} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" diff --git a/xapi-stdext.opam b/xapi-stdext.opam index 1f172724d88..4042980266d 100644 --- a/xapi-stdext.opam +++ b/xapi-stdext.opam @@ -8,7 +8,7 @@ license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" homepage: "https://github.com/xapi-project/stdext" bug-reports: "https://github.com/xapi-project/stdext/issues" depends: [ - "dune" {>= "1.11"} + "dune" {>= "2.7"} "xapi-stdext-date" {= version} "xapi-stdext-encodings" {= version} "xapi-stdext-pervasives" {= version} @@ -16,9 +16,10 @@ depends: [ "xapi-stdext-threads" {= version} "xapi-stdext-unix" {= version} "xapi-stdext-zerocheck" {= version} + "odoc" {with-doc} ] build: [ - ["dune" "subst"] {pinned} + ["dune" "subst"] {dev} [ "dune" "build" From 8cb86f26f4102e70d68034a2f6fd943ef5acd817 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 17 Nov 2022 13:45:15 +0000 Subject: [PATCH 165/199] threads, unix: remove usages of deprecated functions All of them fixed by simple renames Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-threads/semaphore.ml | 2 +- lib/xapi-stdext-unix/dune | 9 ++++----- lib/xapi-stdext-unix/unixext.ml | 2 +- lib/xapi-stdext-unix/unixext.mli | 2 +- lib/xapi-stdext-unix/unixext_open_stubs.c | 10 +++++----- lib/xapi-stdext-unix/unixext_write_stubs.c | 4 ++-- 6 files changed, 14 insertions(+), 15 deletions(-) diff --git a/lib/xapi-stdext-threads/semaphore.ml b/lib/xapi-stdext-threads/semaphore.ml index 2f52a835df4..b1dc6707835 100644 --- a/lib/xapi-stdext-threads/semaphore.ml +++ b/lib/xapi-stdext-threads/semaphore.ml @@ -27,7 +27,7 @@ let create n = { n; m; c; } exception Inconsistent_state of string -let inconsistent_state fmt = Printf.kprintf (fun msg -> +let inconsistent_state fmt = Printf.ksprintf (fun msg -> raise (Inconsistent_state msg)) fmt let acquire s k = diff --git a/lib/xapi-stdext-unix/dune b/lib/xapi-stdext-unix/dune index 2e74dac45ba..9cfcbb96bd7 100644 --- a/lib/xapi-stdext-unix/dune +++ b/lib/xapi-stdext-unix/dune @@ -8,9 +8,8 @@ (foreign_stubs (language c) (names - blkgetsize_stubs - unixext_open_stubs - unixext_stubs - unixext_write_stubs - )) + blkgetsize_stubs + unixext_open_stubs + unixext_stubs + unixext_write_stubs)) ) diff --git a/lib/xapi-stdext-unix/unixext.ml b/lib/xapi-stdext-unix/unixext.ml index 04e99487838..6016082286e 100644 --- a/lib/xapi-stdext-unix/unixext.ml +++ b/lib/xapi-stdext-unix/unixext.ml @@ -15,7 +15,7 @@ open Xapi_stdext_pervasives.Pervasiveext exception Unix_error of int -external _exit : int -> unit = "unix_exit" +let _exit = Unix._exit (** remove a file, but doesn't raise an exception if the file is already removed *) let unlink_safe file = diff --git a/lib/xapi-stdext-unix/unixext.mli b/lib/xapi-stdext-unix/unixext.mli index 77ce223e9ba..ce9c7750e64 100644 --- a/lib/xapi-stdext-unix/unixext.mli +++ b/lib/xapi-stdext-unix/unixext.mli @@ -13,7 +13,7 @@ *) (** A collection of extensions to the [Unix] module. *) -external _exit : int -> unit = "unix_exit" +val _exit : int -> unit val unlink_safe : string -> unit val mkdir_safe : string -> Unix.file_perm -> unit val mkdir_rec : string -> Unix.file_perm -> unit diff --git a/lib/xapi-stdext-unix/unixext_open_stubs.c b/lib/xapi-stdext-unix/unixext_open_stubs.c index af1f967f41d..d15cfeff0b1 100644 --- a/lib/xapi-stdext-unix/unixext_open_stubs.c +++ b/lib/xapi-stdext-unix/unixext_open_stubs.c @@ -50,22 +50,22 @@ CAMLprim value stub_stdext_unix_open_direct(value path, value flags, value perm) #endif char * p; - cv_flags = convert_flag_list(flags, open_flag_table); + cv_flags = caml_convert_flag_list(flags, open_flag_table); #ifdef O_DIRECT cv_flags |= O_DIRECT; #endif - p = stat_alloc(string_length(path) + 1); + p = caml_stat_alloc(caml_string_length(path) + 1); strcpy(p, String_val(path)); /* open on a named FIFO can block (PR#1533) */ - enter_blocking_section(); + caml_enter_blocking_section(); fd = open(p, cv_flags, Int_val(perm)); #ifndef O_DIRECT if (fd != -1) ret = fcntl(fd, F_NOCACHE); #endif - leave_blocking_section(); - stat_free(p); + caml_leave_blocking_section(); + caml_stat_free(p); if (fd == -1) uerror("open", path); #ifndef O_DIRECT if (ret == -1) uerror("fcntl", path); diff --git a/lib/xapi-stdext-unix/unixext_write_stubs.c b/lib/xapi-stdext-unix/unixext_write_stubs.c index db98172db0f..e4be9f68018 100644 --- a/lib/xapi-stdext-unix/unixext_write_stubs.c +++ b/lib/xapi-stdext-unix/unixext_write_stubs.c @@ -46,9 +46,9 @@ CAMLprim value stub_stdext_unix_write(value fd, value buf, value vofs, value vle uerror("write/posix_memalign", Nothing); memmove (iobuf, &Byte(buf, ofs), numbytes); - enter_blocking_section(); + caml_enter_blocking_section(); ret = write(Int_val(fd), iobuf, numbytes); - leave_blocking_section(); + caml_leave_blocking_section(); free(iobuf); if (ret == -1) { From 3687ee1ea99fe55a45c363d5d13d5b5bbb864d4d Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 17 Nov 2022 14:26:29 +0000 Subject: [PATCH 166/199] Avoid warnings and check it at the ci On zerocheck it allows the C code to use OCaml strings directly. Signed-off-by: Pau Ruiz Safont --- .github/workflows/ocaml-ci.yml | 6 ++++-- CHANGES.md | 2 ++ Makefile | 3 +++ lib/xapi-stdext-encodings/test.ml | 6 +++--- lib/xapi-stdext-std/listext.ml | 4 +--- lib/xapi-stdext-zerocheck/zerocheck_stub.c | 6 +++--- 6 files changed, 16 insertions(+), 11 deletions(-) diff --git a/.github/workflows/ocaml-ci.yml b/.github/workflows/ocaml-ci.yml index 9ab3694b956..5f13703fc83 100644 --- a/.github/workflows/ocaml-ci.yml +++ b/.github/workflows/ocaml-ci.yml @@ -36,8 +36,10 @@ jobs: opam install ${{ env.package }} --deps-only --with-test -v - name: Build - run: | - opam exec -- make build + run: opam exec -- make build + + - name: Check + run: opam exec -- make check - name: Run tests run: opam exec -- make test diff --git a/CHANGES.md b/CHANGES.md index 4f0260c03a3..4d5e702ff91 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,8 @@ ## v4.21.0 (unreleased) - unix: add permissions to write_{bytes,string}_to_file - Use a dune version with fixed metadata generation + - threads, unix: avoid using C functions deprecated in OCaml 5 + - Avoid warnings and add the check to detect them to the CI ## v4.20.0 (17-Nov-2022) - date: consolidate the types into a single t diff --git a/Makefile b/Makefile index 1034b3efedf..70ed716fd29 100644 --- a/Makefile +++ b/Makefile @@ -17,6 +17,9 @@ clean: test: dune runtest --profile=$(PROFILE) +check: + dune build @check + # requires odoc doc: dune build @doc --profile=$(PROFILE) diff --git a/lib/xapi-stdext-encodings/test.ml b/lib/xapi-stdext-encodings/test.ml index 183e3e9692e..56bcaaacaae 100644 --- a/lib/xapi-stdext-encodings/test.ml +++ b/lib/xapi-stdext-encodings/test.ml @@ -29,7 +29,7 @@ module type WIDTH_GENERATOR = sig val next : unit -> int end (** A validator that always succeeds. *) module Lenient_UCS_validator : E.UCS_VALIDATOR = struct - let validate value = () + let validate _ = () end (* === Mock character decoders ============================================= *) @@ -63,12 +63,12 @@ module Logged_n_byte_character_decoder = Logged_character_decoder (** A decoder that succeeds for all characters. *) module Universal_character_decoder = struct - let decode_character string index = (0l, 1) + let decode_character _ _ = (0l, 1) end (** A decoder that fails for all characters. *) module Failing_character_decoder = struct - let decode_character string index = raise Decode_error + let decode_character _ _ = raise Decode_error end (** A decoder that succeeds for all characters except the letter 'F'. *) diff --git a/lib/xapi-stdext-std/listext.ml b/lib/xapi-stdext-std/listext.ml index 683568e303c..a1ad76510dd 100644 --- a/lib/xapi-stdext-std/listext.ml +++ b/lib/xapi-stdext-std/listext.ml @@ -69,7 +69,7 @@ module List = struct let drop n list = let rec loop i = function - | x :: xs when i < n -> + | _ :: xs when i < n -> loop (i + 1) xs | l -> l @@ -234,8 +234,6 @@ module List = struct (* Thanks to sharing we only use linear space. (Roughly double the space needed for the spine of the original list) *) let rec tails = function [] -> [[]] | _ :: xs as l -> l :: tails xs - let safe_hd l = List.nth_opt l 0 - let replace_assoc key new_value existing = (key, new_value) :: List.filter (fun (k, _) -> k <> key) existing diff --git a/lib/xapi-stdext-zerocheck/zerocheck_stub.c b/lib/xapi-stdext-zerocheck/zerocheck_stub.c index 76f0e221d0d..51dc885cdbb 100644 --- a/lib/xapi-stdext-zerocheck/zerocheck_stub.c +++ b/lib/xapi-stdext-zerocheck/zerocheck_stub.c @@ -29,7 +29,7 @@ value find_a_nonzero(value string, value offset, value remaining) int c_offset = Int_val(offset); int c_remaining = Int_val(remaining); int c_origremaining = c_remaining; - char *c_string = String_val(string); + const char *c_string = String_val(string); char *s = c_string + c_offset; /* Go character by character until we hit an unsigned int boundary */ @@ -68,7 +68,7 @@ value find_a_zero(value string, value offset, value remaining) int c_offset = Int_val(offset); int c_remaining = Int_val(remaining); int c_origremaining = c_remaining; - char *c_string = String_val(string); + const char *c_string = String_val(string); char *s = c_string + c_offset; /* Go character by character until we hit an unsigned int boundary */ @@ -108,7 +108,7 @@ value find_a_zero(value string, value offset, value remaining) value is_all_zeros(value string, value length) { CAMLparam2(string, length); - char *s = String_val(string); + const char *s = String_val(string); unsigned int *p; int len = Int_val(length); int i; From 5315baaa5d8f9ad81dbdde7a2833d54dc2a26a88 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 25 Nov 2022 15:02:25 +0000 Subject: [PATCH 167/199] zerocheck: remove unused code The function is_all_zeroes has users, drop the rest as the results. I've seen while trying to unit-test are nonsensical in quite a few cases. The code has probably never been correct under 64-bit architectures and it's therefore dangerous to keep it exposed Signed-off-by: Pau Ruiz Safont --- CHANGES.md | 1 + lib/xapi-stdext-zerocheck/zerocheck.ml | 34 --------- lib/xapi-stdext-zerocheck/zerocheck.mli | 25 ------- lib/xapi-stdext-zerocheck/zerocheck_stub.c | 86 ---------------------- 4 files changed, 1 insertion(+), 145 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 4d5e702ff91..c5c84d103bf 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -3,6 +3,7 @@ - Use a dune version with fixed metadata generation - threads, unix: avoid using C functions deprecated in OCaml 5 - Avoid warnings and add the check to detect them to the CI + - zerocheck: remove wrong, unused code. It was dangerous to leave it available ## v4.20.0 (17-Nov-2022) - date: consolidate the types into a single t diff --git a/lib/xapi-stdext-zerocheck/zerocheck.ml b/lib/xapi-stdext-zerocheck/zerocheck.ml index 1affe1c9fbe..e128431c588 100644 --- a/lib/xapi-stdext-zerocheck/zerocheck.ml +++ b/lib/xapi-stdext-zerocheck/zerocheck.ml @@ -12,37 +12,3 @@ * GNU Lesser General Public License for more details. *) external is_all_zeros : string -> int -> bool = "is_all_zeros" - -external _find_a_nonzero : string -> int -> int -> int = "find_a_nonzero" -external _find_a_zero : string -> int -> int -> int = "find_a_zero" - -let wrap f x len offset = - let remaining = len - offset in - if remaining <= 0 then raise (Invalid_argument "offset > length"); - let result = f x offset remaining in - if result = remaining then None else Some (result + offset) - -let find_a_nonzero = wrap _find_a_nonzero -let find_a_zero = wrap _find_a_zero - -type substring = { - buf: string; - offset: int; - len: int -} - -let fold_over_nonzeros x len rounddown roundup f initial = - let rec inner acc offset = - if offset = len then acc - else - match find_a_nonzero x len offset with - | None -> acc (* no more *) - | Some s -> - let e = match find_a_zero x len s with - | None -> len - | Some e -> e in - let e = min len (roundup e) in - let s = max 0 (rounddown s) in - inner (f acc { buf = x; offset = s; len = e - s }) e in - inner initial 0 - diff --git a/lib/xapi-stdext-zerocheck/zerocheck.mli b/lib/xapi-stdext-zerocheck/zerocheck.mli index 222e16c8151..84489e637e8 100644 --- a/lib/xapi-stdext-zerocheck/zerocheck.mli +++ b/lib/xapi-stdext-zerocheck/zerocheck.mli @@ -14,28 +14,3 @@ (** [is_all_zeroes x len] returns true if the substring is all zeroes *) external is_all_zeros : string -> int -> bool = "is_all_zeros" - -(** [find_a_zero x len offset] returns the offset in [x] of a zero - character after [offset], or None if no zero was detected. - Note this function is approximate and is not guaranteed to find - strictly the first zero. *) -val find_a_zero: string -> int -> int -> int option - -(** [find_a_nonzero x len offset] returns the offset in [x] of a - nonzero character after [offset], or None if none could be detected. - Note this function is approximate and is not guaranteed to find - strictly the first nonzero. *) -val find_a_nonzero: string -> int -> int -> int option - -type substring = { - buf: string; - offset: int; - len: int -} - -(** [fold_over_nonzeros buf len rounddown roundup f initial] folds [f] over all - (start, length) pairs of non-zero data in string [buf] up to [len]. - The start of each pair is rounded down with [rounddown] and - the end offset of each pair is rounded up with [roundup] (e.g. to - potential block boudaries. *) -val fold_over_nonzeros: string -> int -> (int -> int) -> (int -> int) -> ('a -> substring -> 'a) -> 'a -> 'a diff --git a/lib/xapi-stdext-zerocheck/zerocheck_stub.c b/lib/xapi-stdext-zerocheck/zerocheck_stub.c index 51dc885cdbb..776ef854849 100644 --- a/lib/xapi-stdext-zerocheck/zerocheck_stub.c +++ b/lib/xapi-stdext-zerocheck/zerocheck_stub.c @@ -12,93 +12,7 @@ * GNU Lesser General Public License for more details. */ -#define CAML_NAME_SPACE -#include #include -#include -#include - -#define OFFSET(s) (((unsigned int)s) & (sizeof(unsigned int) - 1)) - - -/* Return the offset of the next non-zero byte (possibly rounded down a bit). - The value 'remaining' is returned if there is no non-zero byte found. */ -value find_a_nonzero(value string, value offset, value remaining) -{ - CAMLparam3(string, offset, remaining); - int c_offset = Int_val(offset); - int c_remaining = Int_val(remaining); - int c_origremaining = c_remaining; - const char *c_string = String_val(string); - char *s = c_string + c_offset; - - /* Go character by character until we hit an unsigned int boundary */ - while ((OFFSET(s) != 0) && (c_remaining > 0)){ - if (*s != '\000') goto finish; - s++; c_remaining--; - } - /* Go word by word. Note we don't need to determine the exact position - of the nonzero, it suffices to return the index of the word containing - the nonzero. */ - unsigned int *p = (unsigned int *)s; - while (c_remaining > 4){ - if (*p != 0) goto finish; - p++; c_remaining-=4; - } - /* Go character by character until the end of the string */ - s = (char*) p; - while (c_remaining > 0){ - if (*s != '\000') goto finish; - s++; c_remaining--; - } - /* c_remaining == 0 */ - finish: - /* If we didn't find a nonzero then we return c_origremaining. - If we did then we return the number of chars after the starting - offset where the word containing the nonzero was detected. */ - CAMLreturn(Val_int(c_origremaining - c_remaining)); - -} - -/* Return the offset of the next zero byte (possibly rounded up a bit). - The value 'remaining' is returned if there is no zero byte found. */ -value find_a_zero(value string, value offset, value remaining) -{ - CAMLparam3(string, offset, remaining); - int c_offset = Int_val(offset); - int c_remaining = Int_val(remaining); - int c_origremaining = c_remaining; - const char *c_string = String_val(string); - char *s = c_string + c_offset; - - /* Go character by character until we hit an unsigned int boundary */ - while ((OFFSET(s) != 0) && (c_remaining > 0)){ - if (*s == '\000') goto finish; - s++; c_remaining--; - } - /* Go word by word. Note we don't need to determine the exact position - of the zero, it suffices to return the index of the word following - the zero. */ - unsigned int *p = (unsigned int *)s; - while (c_remaining > 4){ - if (*p == 0) goto finish; - p++; c_remaining-=4; - } - /* Go character by character until the end of the string */ - s = (char*) p; - while (c_remaining > 0){ - if (*s == '\000') goto finish; - s++; c_remaining--; - } - /* c_remaining == 0 */ - finish: - /* If we didn't find a zero then we return c_origremaining. - If we did then we return the number of chars after the starting - offset where the word containing the zero was detected. */ - CAMLreturn(Val_int(c_origremaining - c_remaining)); -} - - /* for better performance in all case, we should process the unalign data at * the beginning until we reach a 32 bit align value, however since ocaml From 986d1aeb566773906eb436a2df9aeb677f56d0fa Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 29 Nov 2022 13:52:02 +0000 Subject: [PATCH 168/199] changelog: prepare for 4.21 release Signed-off-by: Pau Ruiz Safont --- CHANGES.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index c5c84d103bf..9ffce4a0c5c 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,4 +1,4 @@ -## v4.21.0 (unreleased) +## v4.21.0 (29-Nov-2022) - unix: add permissions to write_{bytes,string}_to_file - Use a dune version with fixed metadata generation - threads, unix: avoid using C functions deprecated in OCaml 5 From 3c696daac6012fd8bf97da6fab94def214ec2a77 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 16 May 2023 10:29:59 +0100 Subject: [PATCH 169/199] date, pervasive, std: remove deprecated code Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-date/date.ml | 2 - lib/xapi-stdext-date/date.mli | 10 +--- lib/xapi-stdext-pervasives/pervasiveext.ml | 17 ------ lib/xapi-stdext-pervasives/pervasiveext.mli | 26 --------- lib/xapi-stdext-std/listext.ml | 59 --------------------- lib/xapi-stdext-std/listext.mli | 24 --------- 6 files changed, 2 insertions(+), 136 deletions(-) diff --git a/lib/xapi-stdext-date/date.ml b/lib/xapi-stdext-date/date.ml index c9520011dae..5a3b406412f 100644 --- a/lib/xapi-stdext-date/date.ml +++ b/lib/xapi-stdext-date/date.ml @@ -149,8 +149,6 @@ let epoch = of_ptime Ptime.epoch let eq x y = x = y -let assert_utc _ = () - let never = epoch let of_string = of_iso8601 diff --git a/lib/xapi-stdext-date/date.mli b/lib/xapi-stdext-date/date.mli index 637a529ca7e..25eb00ab230 100644 --- a/lib/xapi-stdext-date/date.mli +++ b/lib/xapi-stdext-date/date.mli @@ -79,14 +79,8 @@ val of_string : string -> t val never : t (** Same as {!epoch} *) -val assert_utc : t -> unit - [@@deprecated - "assertions performed inside constructors, so this fn does nothing"] -(** Raises an Invalid_argument exception if the given date is not a UTC date. - A UTC date is an ISO 8601 strings that ends with the character 'Z' *) - -(** Deprecated alias for {!t} *) type iso8601 = t - (** Deprecated alias for {!t} *) + type rfc822 = t +(** Deprecated alias for {!t} *) diff --git a/lib/xapi-stdext-pervasives/pervasiveext.ml b/lib/xapi-stdext-pervasives/pervasiveext.ml index 4840c11b06b..8741b506a20 100644 --- a/lib/xapi-stdext-pervasives/pervasiveext.ml +++ b/lib/xapi-stdext-pervasives/pervasiveext.ml @@ -39,20 +39,10 @@ let finally fct clean_f = in clean_f () ; result -let maybe_with_default d f v = Option.fold ~none:d ~some:f v - -let may f v = Option.map f v - -let default d v = Option.value ~default:d v - -let maybe f v = Option.iter f v (** execute fct ignoring exceptions *) let ignore_exn fct = try fct () with _ -> () -(** if not bool ignore exceptions raised by fct () *) -let reraise_if bool fct = if bool then fct () else ignore_exn fct - (* non polymorphic ignore function *) let ignore_int v = let (_ : int) = v in @@ -77,10 +67,3 @@ let ignore_float v = let ignore_bool v = let (_ : bool) = v in () - -(* To avoid some parens: *) -(* composition of functions: *) -let ( ++ ) f g x = f (g x) - -(* and application *) -let ( $ ) f a = f a diff --git a/lib/xapi-stdext-pervasives/pervasiveext.mli b/lib/xapi-stdext-pervasives/pervasiveext.mli index d0e7fdc5f7a..4190071de07 100644 --- a/lib/xapi-stdext-pervasives/pervasiveext.mli +++ b/lib/xapi-stdext-pervasives/pervasiveext.mli @@ -16,27 +16,6 @@ val finally : (unit -> 'a) -> (unit -> unit) -> 'a (** [finally f g] returns [f ()] guaranteeing to run clean-up actions [g ()] even if [f ()] throws an exception. *) -val maybe_with_default : 'b -> ('a -> 'b) -> 'a option -> 'b - [@@ocaml.deprecated "Replace with Option.fold"] -(** [maybe_with_default d f v] is Some [f c] if [v] is [Some c] and [d] - otherwise. *) - -val may : ('a -> 'b) -> 'a option -> 'b option - [@@ocaml.deprecated "Replace with Option.map"] -(** [may f v] is Some [f c] if [v] is [Some c] and None otherwise. *) - -val default : 'a -> 'a option -> 'a - [@@ocaml.deprecated "Replace with Option.value"] -(** [default d v] is [c] if [o] is [Some c] and d otherwise. *) - -val maybe : ('a -> unit) -> 'a option -> unit - [@@ocaml.deprecated "Replace with Option.iter"] -(** [maybe f v] is [f c] if [v] is [Some c] and [()] otherwise. *) - -val reraise_if : bool -> (unit -> unit) -> unit - [@@ocaml.deprecated "Use ignore_exn instead"] -(** [reraise_if bool fct] runs [fct ()]. If [not bool] ignores raised exceptions *) - val ignore_exn : (unit -> unit) -> unit val ignore_int : int -> unit @@ -50,8 +29,3 @@ val ignore_string : string -> unit val ignore_float : float -> unit val ignore_bool : bool -> unit - -val ( ++ ) : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c - [@@ocaml.deprecated "Not a standard idiom. Define it locally if needed."] -val ( $ ) : ('a -> 'b) -> 'a -> 'b - [@@ocaml.deprecated "Not right-associative. Replace with @@"] diff --git a/lib/xapi-stdext-std/listext.ml b/lib/xapi-stdext-std/listext.ml index a1ad76510dd..c3ffc20e294 100644 --- a/lib/xapi-stdext-std/listext.ml +++ b/lib/xapi-stdext-std/listext.ml @@ -115,13 +115,6 @@ module List = struct | _ -> invalid_arg "remove" - let extract i l = - match rev_chop i l with - | rfr, h :: t -> - (h, rev_append rfr t) - | _ -> - invalid_arg "extract" - let insert i e l = match rev_chop i l with rfr, ba -> rev_append rfr (e :: ba) @@ -158,58 +151,6 @@ module List = struct in aux [] e l - let randomize l = - let extract_rand l = extract (Random.int (length l)) l in - let rec aux accu = function - | [] -> - accu - | l -> - (fun (h, t) -> aux (h :: accu) t) (extract_rand l) - in - aux [] l - - let rec distribute e = function - | h :: t as l -> - (e :: l) :: map (fun x -> h :: x) (distribute e t) - | [] -> - [[e]] - - let rec permute = function - | e :: rest -> - flatten (map (distribute e) (permute rest)) - | [] -> - [[]] - - let rec aux_rle_eq eq l2 x n = function - | [] -> - rev ((x, n) :: l2) - | h :: t when eq x h -> - aux_rle_eq eq l2 x (n + 1) t - | h :: t -> - aux_rle_eq eq ((x, n) :: l2) h 1 t - - let rle_eq eq l = match l with [] -> [] | h :: t -> aux_rle_eq eq [] h 1 t - - let rle l = rle_eq ( = ) l - - let unrle l = - let rec aux2 accu i c = - match i with - | 0 -> - accu - | i when i > 0 -> - aux2 (c :: accu) (i - 1) c - | _ -> - invalid_arg "unrle" - in - let rec aux accu = function - | [] -> - rev accu - | (i, c) :: t -> - aux (aux2 accu i c) t - in - aux [] l - let inner fold_left2 base f l1 l2 g = fold_left2 (fun accu e1 e2 -> g accu (f e1 e2)) base l1 l2 diff --git a/lib/xapi-stdext-std/listext.mli b/lib/xapi-stdext-std/listext.mli index e7b6092abe2..f81b619e03d 100644 --- a/lib/xapi-stdext-std/listext.mli +++ b/lib/xapi-stdext-std/listext.mli @@ -120,20 +120,6 @@ module List : sig (** {1 Run-length encoded lists} There are no known users of these functions. *) - val rle : 'a list -> ('a * int) list - [@@deprecated - "No known users, consider creating a proper datatype, this kind of list \ - might be confused with association lists"] - (** Run-length encodes the given list using polimorphic equality *) - - val unrle : (int * 'a) list -> 'a list - [@@deprecated "No known users"] - (** Decode a run-length encoded list. *) - - val rle_eq : ('a -> 'a -> bool) -> 'a list -> ('a * int) list - [@@deprecated "No known users"] - (** [rle_eq eq l] run-length encodes [l] using [eq] *) - (** {1 Generative functions} These are usually useful for coding challenges like Advent of Code.*) @@ -148,16 +134,6 @@ module List : sig val between_tr : 'a -> 'a list -> 'a list (** Tail-recursive {!between}. *) - val randomize : 'a list -> 'a list [@@deprecated "Not used"] - (** Generate a random permutation of the given list. *) - - val distribute : 'a -> 'a list -> 'a list list [@@deprecated "Not used"] - (** Distribute the given element over the given list, returning a list of - lists with the new element in each position. *) - - val permute : 'a list -> 'a list list [@@deprecated "Not used"] - (** Generate all permutations of the given list. *) - val inner : (('a -> 'b -> 'c -> 'd) -> 'e -> 'f -> 'g -> 'h) -> 'e From fbe9292cb9d88f1e5a896f32403f8fdc95aab487 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 16 May 2023 11:31:01 +0100 Subject: [PATCH 170/199] Replace Int32 with int for unicode characters MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- lib/xapi-stdext-encodings/encodings.ml | 68 +++++++++++--------- lib/xapi-stdext-encodings/encodings.mli | 62 +++++++++--------- lib/xapi-stdext-encodings/test.ml | 85 +++++++++++++------------ 3 files changed, 113 insertions(+), 102 deletions(-) diff --git a/lib/xapi-stdext-encodings/encodings.ml b/lib/xapi-stdext-encodings/encodings.ml index fe4c6526c5f..260a3b37078 100644 --- a/lib/xapi-stdext-encodings/encodings.ml +++ b/lib/xapi-stdext-encodings/encodings.ml @@ -20,40 +20,48 @@ exception UTF8_continuation_byte_invalid exception UTF8_encoding_not_canonical exception String_incomplete +module Int = struct + include Int + let to_int (x:int) = x + let of_int (x:int) = x +end + +type uchar = int + (* === Utility Functions === *) -let ( +++ ) = Int32.add -let ( --- ) = Int32.sub -let ( &&& ) = Int32.logand -let ( ||| ) = Int32.logor -let ( <<< ) = Int32.shift_left -let ( >>> ) = Int32.shift_right_logical +let ( +++ ) = Int.add +let ( --- ) = Int.sub +let ( &&& ) = Int.logand +let ( ||| ) = Int.logor +let ( <<< ) = Int.shift_left +let ( >>> ) = Int.shift_right_logical (* === Unicode Functions === *) module UCS = struct - let min_value = 0x000000l - let max_value = 0x1fffffl + let min_value = 0x000000 + let max_value = 0x1fffff let is_non_character value = false - || (0xfdd0l <= value && value <= 0xfdefl) (* case 1 *) - || (Int32.logand 0xfffel value = 0xfffel) (* case 2 *) + || (0xfdd0 <= value && value <= 0xfdef) (* case 1 *) + || (Int.logand 0xfffe value = 0xfffe) (* case 2 *) let is_out_of_range value = value < min_value || value > max_value let is_surrogate value = - (0xd800l <= value && value <= 0xdfffl) + (0xd800 <= value && value <= 0xdfff) end module XML = struct - let is_forbidden_control_character value = value < 0x20l - && value <> 0x09l - && value <> 0x0al - && value <> 0x0dl + let is_forbidden_control_character value = value < 0x20 + && value <> 0x09 + && value <> 0x0a + && value <> 0x0d end @@ -61,7 +69,7 @@ end module type UCS_VALIDATOR = sig - val validate : int32 -> unit + val validate : uchar -> unit end @@ -86,18 +94,18 @@ end (* ==== Character Codecs ==== *) module type CHARACTER_DECODER = sig - val decode_character : string -> int -> int32 * int + val decode_character : string -> int -> uchar * int end module type CHARACTER_ENCODER = sig - val encode_character : int32 -> string + val encode_character : uchar -> string end module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) = struct let width_required_for_ucs_value value = - if value < 0x000080l (* 1 lsl 7 *) then 1 else - if value < 0x000800l (* 1 lsl 11 *) then 2 else - if value < 0x010000l (* 1 lsl 16 *) then 3 else 4 + if value < 0x000080 (* 1 lsl 7 *) then 1 else + if value < 0x000800 (* 1 lsl 11 *) then 2 else + if value < 0x010000 (* 1 lsl 16 *) then 3 else 4 (* === Decoding === *) @@ -114,12 +122,12 @@ module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) = struct let decode_character string index = let value, width = decode_header_byte (Char.code string.[index]) in - let value = if width = 1 then (Int32.of_int value) + let value = if width = 1 then (Int.of_int value) else begin - let value = ref (Int32.of_int value) in + let value = ref (Int.of_int value) in for index = index + 1 to index + width - 1 do let chunk = decode_continuation_byte (Char.code string.[index]) in - value := (!value <<< 6) ||| (Int32.of_int chunk) + value := (!value <<< 6) ||| (Int.of_int chunk) done; if width > (width_required_for_ucs_value !value) then raise UTF8_encoding_not_canonical; @@ -133,13 +141,13 @@ module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) = struct let encode_header_byte width value = match width with | 1 -> value - | 2 -> value ||| 0b11000000l - | 3 -> value ||| 0b11100000l - | 4 -> value ||| 0b11110000l + | 2 -> value ||| 0b11000000 + | 3 -> value ||| 0b11100000 + | 4 -> value ||| 0b11110000 | _ -> raise UCS_value_out_of_range let encode_continuation_byte value = - ((value &&& 0b00111111l) ||| 0b10000000l, value >>> 6) + ((value &&& 0b00111111) ||| 0b10000000, value >>> 6) let encode_character value = UCS_validator.validate value; @@ -149,12 +157,12 @@ module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) = struct let rec encode_continuation_bytes remainder index = if index = 0 then remainder else let byte, remainder = encode_continuation_byte remainder in - Bytes.set b index @@ Char.chr (Int32.to_int byte); + Bytes.set b index @@ Char.chr (Int.to_int byte); encode_continuation_bytes remainder (index - 1) in let remainder = encode_continuation_bytes value (width - 1) in (* Finish by encoding the header byte. *) let byte = encode_header_byte width remainder in - Bytes.set b 0 @@ Char.chr (Int32.to_int byte); + Bytes.set b 0 @@ Char.chr (Int.to_int byte); Bytes.unsafe_to_string b end diff --git a/lib/xapi-stdext-encodings/encodings.mli b/lib/xapi-stdext-encodings/encodings.mli index bc2bdd065c1..50874c31916 100644 --- a/lib/xapi-stdext-encodings/encodings.mli +++ b/lib/xapi-stdext-encodings/encodings.mli @@ -25,11 +25,13 @@ exception UTF8_continuation_byte_invalid exception UTF8_encoding_not_canonical exception String_incomplete +type uchar = int + (** {2 UCS Validators} *) (** Validates UCS character values. *) module type UCS_VALIDATOR = sig - val validate : int32 -> unit + val validate : uchar -> unit end (** Accepts all values within the UCS character value range @@ -41,8 +43,8 @@ module UTF8_UCS_validator : UCS_VALIDATOR module XML_UTF8_UCS_validator : UCS_VALIDATOR module UCS : sig - val min_value : int32 - val max_value : int32 + val min_value : uchar + val max_value : uchar (** Returns true if and only if the given value corresponds to a UCS * non-character. Such non-characters are forbidden for use in open @@ -50,30 +52,30 @@ module UCS : sig * 1. values from 0xFDD0 to 0xFDEF; and * 2. values 0xnFFFE and 0xnFFFF, where (0x0 <= n <= 0x10). * See the Unicode 5.0 Standard, section 16.7 for further details. *) - val is_non_character : int32 -> bool + val is_non_character : uchar -> bool (** Returns true if and only if the given value lies outside the * entire UCS range. *) - val is_out_of_range : int32 -> bool + val is_out_of_range : uchar -> bool (** Returns true if and only if the given value corresponds to a UCS * surrogate code point, only for use in UTF-16 encoded strings. * See the Unicode 5.0 Standard, section 16.6 for further details. *) - val is_surrogate : int32 -> bool + val is_surrogate : uchar -> bool end -val (+++) : int32 -> int32 -> int32 -val (---) : int32 -> int32 -> int32 -val (&&&) : int32 -> int32 -> int32 -val (|||) : int32 -> int32 -> int32 -val (<<<) : int32 -> int -> int32 -val (>>>) : int32 -> int -> int32 +val (+++) : uchar -> uchar -> uchar +val (---) : uchar -> uchar -> uchar +val (&&&) : uchar -> uchar -> uchar +val (|||) : uchar -> uchar -> uchar +val (<<<) : uchar -> int -> uchar +val (>>>) : uchar -> int -> uchar module XML : sig (** Returns true if and only if the given value corresponds to * a forbidden control character as defined in section 2.2 of * the XML specification, version 1.0. *) - val is_forbidden_control_character : int32 -> bool + val is_forbidden_control_character : uchar -> bool end (** {2 Character Codecs} *) @@ -82,7 +84,7 @@ module type CHARACTER_ENCODER = sig (** Encodes a single character value, returning a string containing * the character. Raises an error if the character value is invalid. *) - val encode_character : int32 -> string + val encode_character : uchar -> string end @@ -92,13 +94,13 @@ module type CHARACTER_DECODER = sig * value = the value of the character at the given index; and * width = the width of the character at the given index, in bytes. * Raises an appropriate error if the character is invalid. *) - val decode_character : string -> int -> int32 * int + val decode_character : string -> int -> uchar * int end module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) : sig (** Given a valid UCS value, returns the canonical * number of bytes required to encode the value. *) - val width_required_for_ucs_value : int32 -> int + val width_required_for_ucs_value : uchar -> int (** {3 Decoding} *) @@ -116,46 +118,46 @@ module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) : sig * value = the value of the character at the given index; and * width = the width of the character at the given index, in bytes. * Raises an appropriate error if the character is invalid. *) - val decode_character : string -> int -> int32 * int + val decode_character : string -> int -> uchar * int (** {3 Encoding} *) (** Encodes a header byte for the given parameters, where: * width = the total width of the encoded character, in bytes; * value = the most significant bits of the original UCS value. *) - val encode_header_byte : int -> int32 -> int32 + val encode_header_byte : int -> uchar -> uchar (** Encodes a continuation byte from the given UCS * remainder value, returning a tuple (b, r), where: * b = the continuation byte; * r = a new UCS remainder value. *) - val encode_continuation_byte : int32 -> int32 * int32 + val encode_continuation_byte : uchar -> uchar * uchar (** Encodes a single character value, returning a string containing * the character. Raises an error if the character value is invalid. *) - val encode_character : int32 -> string + val encode_character : uchar -> string end module UTF8_codec : sig - val width_required_for_ucs_value : int32 -> int + val width_required_for_ucs_value : uchar -> int val decode_header_byte : int -> int * int val decode_continuation_byte : int -> int - val decode_character : string -> int -> int32 * int + val decode_character : string -> int -> uchar * int - val encode_header_byte : int -> int32 -> int32 - val encode_continuation_byte : int32 -> int32 * int32 - val encode_character : int32 -> string + val encode_header_byte : int -> uchar -> uchar + val encode_continuation_byte : uchar -> uchar * uchar + val encode_character : uchar -> string end module XML_UTF8_codec : sig - val width_required_for_ucs_value : int32 -> int + val width_required_for_ucs_value : uchar -> int val decode_header_byte : int -> int * int val decode_continuation_byte : int -> int - val decode_character : string -> int -> int32 * int + val decode_character : string -> int -> uchar * int - val encode_header_byte : int -> int32 -> int32 - val encode_continuation_byte : int32 -> int32 * int32 - val encode_character : int32 -> string + val encode_header_byte : int -> uchar -> uchar + val encode_continuation_byte : uchar -> uchar * uchar + val encode_character : uchar -> string end (** {2 String Validators} *) diff --git a/lib/xapi-stdext-encodings/test.ml b/lib/xapi-stdext-encodings/test.ml index 56bcaaacaae..7e9b79da7c3 100644 --- a/lib/xapi-stdext-encodings/test.ml +++ b/lib/xapi-stdext-encodings/test.ml @@ -50,7 +50,7 @@ module Logged_character_decoder (W : WIDTH_GENERATOR) = struct ignore (string.[index]) done; indices := (index :: !indices); - 0l, width + 0, width end @@ -63,7 +63,7 @@ module Logged_n_byte_character_decoder = Logged_character_decoder (** A decoder that succeeds for all characters. *) module Universal_character_decoder = struct - let decode_character _ _ = (0l, 1) + let decode_character _ _ = (0, 1) end (** A decoder that fails for all characters. *) @@ -74,7 +74,7 @@ end (** A decoder that succeeds for all characters except the letter 'F'. *) module Selective_character_decoder = struct let decode_character string index = - if string.[index] = 'F' then raise Decode_error else (0l, 1) + if string.[index] = 'F' then raise Decode_error else (0, 1) end (* === Mock codecs ========================================================= *) @@ -207,9 +207,9 @@ module UCS = struct include E.UCS b. non-characters at the end of the basic multilingual plane; c. non-characters at the end of the private use area. *) let non_characters = [ - 0x00fdd0l; 0x00fdefl; (* case a. *) - 0x00fffel; 0x00ffffl; (* case b. *) - 0x1ffffel; 0x1fffffl; (* case c. *) + 0x00fdd0; 0x00fdef; (* case a. *) + 0x00fffe; 0x00ffff; (* case b. *) + 0x1ffffe; 0x1fffff; (* case c. *) ] (** A list of UCS character values located immediately before or @@ -218,9 +218,9 @@ module UCS = struct include E.UCS b. non-characters at the end of the basic multilingual plane; c. non-characters at the end of the private use area. *) let valid_characters_next_to_non_characters = [ - 0x00fdcfl; 0x00fdf0l; (* case a. *) - 0x00fffdl; 0x010000l; (* case b. *) - 0x1ffffdl; 0x200000l; (* case c. *) + 0x00fdcf; 0x00fdf0; (* case a. *) + 0x00fffd; 0x010000; (* case b. *) + 0x1ffffd; 0x200000; (* case c. *) ] let test_is_non_character () = @@ -230,16 +230,16 @@ module UCS = struct include E.UCS valid_characters_next_to_non_characters let test_is_out_of_range () = - assert_true (is_out_of_range (min_value --- 1l)); + assert_true (is_out_of_range (min_value --- 1)); assert_false (is_out_of_range (min_value)); assert_false (is_out_of_range (max_value)); - assert_true (is_out_of_range (max_value +++ 1l)) + assert_true (is_out_of_range (max_value +++ 1)) let test_is_surrogate () = - assert_false (is_surrogate (0xd7ffl)); - assert_true (is_surrogate (0xd800l)); - assert_true (is_surrogate (0xdfffl)); - assert_false (is_surrogate (0xe000l)) + assert_false (is_surrogate (0xd7ff)); + assert_true (is_surrogate (0xd800)); + assert_true (is_surrogate (0xdfff)); + assert_false (is_surrogate (0xe000)) let tests = [ "test_is_non_character", `Quick, test_is_non_character @@ -252,12 +252,12 @@ end module XML = struct include E.XML let test_is_forbidden_control_character () = - assert_true (is_forbidden_control_character (0x00l)); - assert_true (is_forbidden_control_character (0x19l)); - assert_false (is_forbidden_control_character (0x09l)); - assert_false (is_forbidden_control_character (0x0al)); - assert_false (is_forbidden_control_character (0x0dl)); - assert_false (is_forbidden_control_character (0x20l)) + assert_true (is_forbidden_control_character (0x00)); + assert_true (is_forbidden_control_character (0x19)); + assert_false (is_forbidden_control_character (0x09)); + assert_false (is_forbidden_control_character (0x0a)); + assert_false (is_forbidden_control_character (0x0d)); + assert_false (is_forbidden_control_character (0x20)) let tests = [ "test_is_forbidden_control_character", `Quick, test_is_forbidden_control_character @@ -268,8 +268,8 @@ end module UTF8_UCS_validator = struct include E.UTF8_UCS_validator let test_validate () = - let value = ref (UCS.min_value --- 1l) in - while !value <= (UCS.max_value +++ 1l) do + let value = ref (UCS.min_value --- 1) in + while !value <= (UCS.max_value +++ 1) do if UCS.is_out_of_range !value then Alcotest.check_raises "should fail" E.UCS_value_out_of_range @@ -282,7 +282,7 @@ module UTF8_UCS_validator = struct include E.UTF8_UCS_validator (fun () -> validate !value) else validate !value; - value := !value +++ 1l + value := !value +++ 1 done let tests = @@ -295,8 +295,8 @@ end module XML_UTF8_UCS_validator = struct include E.XML_UTF8_UCS_validator let test_validate () = - let value = ref (UCS.min_value --- 1l) in - while !value <= (UCS.max_value +++ 1l) do + let value = ref (UCS.min_value --- 1) in + while !value <= (UCS.max_value +++ 1) do if UCS.is_out_of_range !value then Alcotest.check_raises "should fail" E.UCS_value_out_of_range (fun () -> validate !value) @@ -311,7 +311,7 @@ module XML_UTF8_UCS_validator = struct include E.XML_UTF8_UCS_validator (fun () -> validate !value) else validate !value; - value := !value +++ 1l + value := !value +++ 1 done let tests = @@ -328,10 +328,10 @@ module UTF8_codec = struct include E.UTF8_codec w = the width of the encoded character, in bytes. *) let valid_ucs_value_widths = [ - (1l , 1); ((1l <<< 7) --- 1l, 1); - (1l <<< 7, 2); ((1l <<< 11) --- 1l, 2); - (1l <<< 11, 3); ((1l <<< 16) --- 1l, 3); - (1l <<< 16, 4); ((1l <<< 21) --- 1l, 4); + (1 , 1); ((1 <<< 7) --- 1, 1); + (1 <<< 7, 2); ((1 <<< 11) --- 1, 2); + (1 <<< 11, 3); ((1 <<< 16) --- 1, 3); + (1 <<< 16, 4); ((1 <<< 21) --- 1, 4); ] let test_width_required_for_ucs_value () = @@ -436,26 +436,27 @@ module UTF8_codec = struct include E.UTF8_codec let valid_character_decodings = [ (* 7654321 *) (* 0b0xxxxxxx *) (* 00000000000000xxxxxxx *) - "\x00" (* 0b00000000 *), (0b000000000000000000000l, 1); - "\x7f" (* 0b01111111 *), (0b000000000000001111111l, 1); + "\x00" (* 0b00000000 *), (0b000000000000000000000, 1); + "\x7f" (* 0b01111111 *), (0b000000000000001111111, 1); (* 10987654321 *) (* 0b110xxxsx 0b10xxxxxx *) (* 0000000000xxxsxxxxxxx *) - "\xc2\x80" (* 0b11000010 0b10000000 *), (0b000000000000010000000l, 2); - "\xdf\xbf" (* 0b11011111 0b10111111 *), (0b000000000011111111111l, 2); + "\xc2\x80" (* 0b11000010 0b10000000 *), (0b000000000000010000000, 2); + "\xdf\xbf" (* 0b11011111 0b10111111 *), (0b000000000011111111111, 2); (* 6543210987654321 *) (* 0b1110xxxx 0b10sxxxxx 0b10xxxxxx *) (* xxxxsxxxxxxxxxxx *) - "\xe0\xa0\x80" (* 0b11100000 0b10100000 0b10000000 *), (0b000000000100000000000l, 3); - "\xef\xbf\xbf" (* 0b11101111 0b10111111 0b10111111 *), (0b000001111111111111111l, 3); + "\xe0\xa0\x80" (* 0b11100000 0b10100000 0b10000000 *), (0b000000000100000000000, 3); + "\xef\xbf\xbf" (* 0b11101111 0b10111111 0b10111111 *), (0b000001111111111111111, 3); (* 109876543210987654321 *) (* 0b11110xxx 0b10xsxxxx 0b10xxxxxx 0b10xxxxxx *) (* xxxxsxxxxxxxxxxxxxxxx *) - "\xf0\x90\x80\x80" (* 0b11110000 0b10010000 0b10000000 0b10000000 *), (0b000010000000000000000l, 4); - "\xf7\xbf\xbf\xbf" (* 0b11110111 0b10111111 0b10111111 0b10111111 *), (0b111111111111111111111l, 4); + "\xf0\x90\x80\x80" (* 0b11110000 0b10010000 0b10000000 0b10000000 *), (0b000010000000000000000, 4); + "\xf7\xbf\xbf\xbf" (* 0b11110111 0b10111111 0b10111111 0b10111111 *), (0b111111111111111111111, 4); ] + let uchar = Alcotest.int let test_decode_character_when_valid () = List.iter (fun (string, (value, width)) -> - Alcotest.(check (pair int32 int)) "same pair" + Alcotest.(check (pair uchar int)) "same pair" (Lenient_UTF8_codec.decode_character string 0) (value, width)) valid_character_decodings @@ -488,7 +489,7 @@ module UTF8_codec = struct include E.UTF8_codec let width = E.UTF8_codec.width_required_for_ucs_value value in if (value <> decoded_value) then Alcotest.fail (Printf.sprintf - "expected value %06lx but decoded value %06lx\n" + "expected value %06x but decoded value %06x\n" value decoded_value); if (width <> decoded_width) then Alcotest.fail (Printf.sprintf @@ -499,7 +500,7 @@ module UTF8_codec = struct include E.UTF8_codec let value = ref UCS.min_value in while !value <= UCS.max_value do test_encode_decode_cycle_for_value !value; - value := Int32.add !value 1l; + value := Int.add !value 1; done let tests = From e35b6532998b0e2b570bfff205920d326c3b18c3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 16 May 2023 13:37:59 +0100 Subject: [PATCH 171/199] xapi-stdext-encodings: drop encoding and unused functions from API MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit XAPI only uses this module for validating XML UTF8 strings. However all the unit tests here are still useful, so gradually drop functionality from the encodings API until we're left just with the validator, which can be implemented more efficiently without allocation. This moves some code that is still useful for tests into the test module (which can be used to check that the stdlib or Uutf's semantics matches the pre-existing semantics of this module). Signed-off-by: Edwin Török --- lib/xapi-stdext-encodings/encodings.ml | 48 ++--------- lib/xapi-stdext-encodings/encodings.mli | 103 +---------------------- lib/xapi-stdext-encodings/test.ml | 106 +++++------------------- 3 files changed, 27 insertions(+), 230 deletions(-) diff --git a/lib/xapi-stdext-encodings/encodings.ml b/lib/xapi-stdext-encodings/encodings.ml index 260a3b37078..e4e0e7b7252 100644 --- a/lib/xapi-stdext-encodings/encodings.ml +++ b/lib/xapi-stdext-encodings/encodings.ml @@ -22,7 +22,6 @@ exception String_incomplete module Int = struct include Int - let to_int (x:int) = x let of_int (x:int) = x end @@ -30,12 +29,8 @@ type uchar = int (* === Utility Functions === *) -let ( +++ ) = Int.add -let ( --- ) = Int.sub -let ( &&& ) = Int.logand let ( ||| ) = Int.logor let ( <<< ) = Int.shift_left -let ( >>> ) = Int.shift_right_logical (* === Unicode Functions === *) @@ -97,16 +92,7 @@ module type CHARACTER_DECODER = sig val decode_character : string -> int -> uchar * int end -module type CHARACTER_ENCODER = sig - val encode_character : uchar -> string -end - module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) = struct - let width_required_for_ucs_value value = - if value < 0x000080 (* 1 lsl 7 *) then 1 else - if value < 0x000800 (* 1 lsl 11 *) then 2 else - if value < 0x010000 (* 1 lsl 16 *) then 3 else 4 - (* === Decoding === *) let decode_header_byte byte = @@ -120,6 +106,11 @@ module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) = struct if byte land 0b11000000 = 0b10000000 then byte land 0b00111111 else raise UTF8_continuation_byte_invalid + let width_required_for_ucs_value value = + if value < 0x000080 (* 1 lsl 7 *) then 1 else + if value < 0x000800 (* 1 lsl 11 *) then 2 else + if value < 0x010000 (* 1 lsl 16 *) then 3 else 4 + let decode_character string index = let value, width = decode_header_byte (Char.code string.[index]) in let value = if width = 1 then (Int.of_int value) @@ -136,35 +127,6 @@ module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) = struct UCS_validator.validate value; (value, width) - (* === Encoding === *) - - let encode_header_byte width value = - match width with - | 1 -> value - | 2 -> value ||| 0b11000000 - | 3 -> value ||| 0b11100000 - | 4 -> value ||| 0b11110000 - | _ -> raise UCS_value_out_of_range - - let encode_continuation_byte value = - ((value &&& 0b00111111) ||| 0b10000000, value >>> 6) - - let encode_character value = - UCS_validator.validate value; - let width = width_required_for_ucs_value value in - let b = Bytes.make width ' ' in - (* Start by encoding the continuation bytes in reverse order. *) - let rec encode_continuation_bytes remainder index = - if index = 0 then remainder else - let byte, remainder = encode_continuation_byte remainder in - Bytes.set b index @@ Char.chr (Int.to_int byte); - encode_continuation_bytes remainder (index - 1) in - let remainder = encode_continuation_bytes value (width - 1) in - (* Finish by encoding the header byte. *) - let byte = encode_header_byte width remainder in - Bytes.set b 0 @@ Char.chr (Int.to_int byte); - Bytes.unsafe_to_string b - end module UTF8_codec = UTF8_CODEC ( UTF8_UCS_validator) diff --git a/lib/xapi-stdext-encodings/encodings.mli b/lib/xapi-stdext-encodings/encodings.mli index 50874c31916..4216470f8d5 100644 --- a/lib/xapi-stdext-encodings/encodings.mli +++ b/lib/xapi-stdext-encodings/encodings.mli @@ -34,43 +34,10 @@ module type UCS_VALIDATOR = sig val validate : uchar -> unit end -(** Accepts all values within the UCS character value range - * except those which are invalid for all UTF-8 documents. *) -module UTF8_UCS_validator : UCS_VALIDATOR - (** Accepts all values within the UCS character value range except * those which are invalid for all UTF-8-encoded XML documents. *) module XML_UTF8_UCS_validator : UCS_VALIDATOR -module UCS : sig - val min_value : uchar - val max_value : uchar - - (** Returns true if and only if the given value corresponds to a UCS - * non-character. Such non-characters are forbidden for use in open - * interchange of Unicode text data, and include the following: - * 1. values from 0xFDD0 to 0xFDEF; and - * 2. values 0xnFFFE and 0xnFFFF, where (0x0 <= n <= 0x10). - * See the Unicode 5.0 Standard, section 16.7 for further details. *) - val is_non_character : uchar -> bool - - (** Returns true if and only if the given value lies outside the - * entire UCS range. *) - val is_out_of_range : uchar -> bool - - (** Returns true if and only if the given value corresponds to a UCS - * surrogate code point, only for use in UTF-16 encoded strings. - * See the Unicode 5.0 Standard, section 16.6 for further details. *) - val is_surrogate : uchar -> bool -end - -val (+++) : uchar -> uchar -> uchar -val (---) : uchar -> uchar -> uchar -val (&&&) : uchar -> uchar -> uchar -val (|||) : uchar -> uchar -> uchar -val (<<<) : uchar -> int -> uchar -val (>>>) : uchar -> int -> uchar - module XML : sig (** Returns true if and only if the given value corresponds to * a forbidden control character as defined in section 2.2 of @@ -80,14 +47,6 @@ end (** {2 Character Codecs} *) -module type CHARACTER_ENCODER = sig - - (** Encodes a single character value, returning a string containing - * the character. Raises an error if the character value is invalid. *) - val encode_character : uchar -> string - -end - module type CHARACTER_DECODER = sig (** Decodes a single character embedded within a string. Given a string * and an index into that string, returns a tuple (value, width) where: @@ -98,68 +57,8 @@ module type CHARACTER_DECODER = sig end module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) : sig - (** Given a valid UCS value, returns the canonical - * number of bytes required to encode the value. *) - val width_required_for_ucs_value : uchar -> int - - (** {3 Decoding} *) - - (** Decodes a header byte, returning a tuple (v, w) where: - * v = the (partial) value contained within the byte; and - * w = the total width of the encoded character, in bytes. *) - val decode_header_byte : int -> int * int - - (** Decodes a continuation byte, returning the - * 6-bit-wide value contained within the byte. *) - val decode_continuation_byte : int -> int - - (** Decodes a single character embedded within a string. Given a string - * and an index into that string, returns a tuple (value, width) where: - * value = the value of the character at the given index; and - * width = the width of the character at the given index, in bytes. - * Raises an appropriate error if the character is invalid. *) - val decode_character : string -> int -> uchar * int - - (** {3 Encoding} *) - - (** Encodes a header byte for the given parameters, where: - * width = the total width of the encoded character, in bytes; - * value = the most significant bits of the original UCS value. *) - val encode_header_byte : int -> uchar -> uchar - - (** Encodes a continuation byte from the given UCS - * remainder value, returning a tuple (b, r), where: - * b = the continuation byte; - * r = a new UCS remainder value. *) - val encode_continuation_byte : uchar -> uchar * uchar - - (** Encodes a single character value, returning a string containing - * the character. Raises an error if the character value is invalid. *) - val encode_character : uchar -> string + include CHARACTER_DECODER end - -module UTF8_codec : sig - val width_required_for_ucs_value : uchar -> int - val decode_header_byte : int -> int * int - val decode_continuation_byte : int -> int - val decode_character : string -> int -> uchar * int - - val encode_header_byte : int -> uchar -> uchar - val encode_continuation_byte : uchar -> uchar * uchar - val encode_character : uchar -> string -end - -module XML_UTF8_codec : sig - val width_required_for_ucs_value : uchar -> int - val decode_header_byte : int -> int * int - val decode_continuation_byte : int -> int - val decode_character : string -> int -> uchar * int - - val encode_header_byte : int -> uchar -> uchar - val encode_continuation_byte : uchar -> uchar * uchar - val encode_character : uchar -> string -end - (** {2 String Validators} *) (** Provides functionality for validating and processing diff --git a/lib/xapi-stdext-encodings/test.ml b/lib/xapi-stdext-encodings/test.ml index 7e9b79da7c3..8cbba2ae254 100644 --- a/lib/xapi-stdext-encodings/test.ml +++ b/lib/xapi-stdext-encodings/test.ml @@ -13,7 +13,7 @@ *) module E = Xapi_stdext_encodings.Encodings (* Pull in the infix operators from Encodings used in this test *) -let (---), (+++), (<<<) = E.( (---), (+++), (<<<) ) +let (---), (+++), (<<<) = Int.sub, Int.add, Int.shift_left (* === Mock exceptions ==================================================== *) @@ -200,7 +200,20 @@ module String_validator = struct end -module UCS = struct include E.UCS +module UCS = struct + (* === Unicode Functions === *) + let min_value = 0x000000 + let max_value = 0x1fffff + + let is_non_character value = false + || (0xfdd0 <= value && value <= 0xfdef) (* case 1 *) + || (Int.logand 0xfffe value = 0xfffe) (* case 2 *) + + let is_out_of_range value = + value < min_value || value > max_value + + let is_surrogate value = + (0xd800 <= value && value <= 0xdfff) (** A list of UCS non-characters values, including: a. non-characters within the basic multilingual plane; @@ -265,32 +278,6 @@ module XML = struct include E.XML end -module UTF8_UCS_validator = struct include E.UTF8_UCS_validator - - let test_validate () = - let value = ref (UCS.min_value --- 1) in - while !value <= (UCS.max_value +++ 1) do - if UCS.is_out_of_range !value - then Alcotest.check_raises "should fail" - E.UCS_value_out_of_range - (fun () -> validate !value) - else - if UCS.is_non_character !value - || UCS.is_surrogate !value - then Alcotest.check_raises "should fail" - E.UCS_value_prohibited_in_UTF8 - (fun () -> validate !value) - else - validate !value; - value := !value +++ 1 - done - - let tests = - [ "test_vaidate", `Quick, test_validate - ] - -end - (** Tests the XML-specific UTF-8 UCS validation function. *) module XML_UTF8_UCS_validator = struct include E.XML_UTF8_UCS_validator @@ -320,7 +307,7 @@ module XML_UTF8_UCS_validator = struct include E.XML_UTF8_UCS_validator end -module UTF8_codec = struct include E.UTF8_codec +module UTF8_codec = struct (** A list of canonical encoding widths of UCS values, represented by tuples of the form (v, w), where: @@ -333,6 +320,11 @@ module UTF8_codec = struct include E.UTF8_codec (1 <<< 11, 3); ((1 <<< 16) --- 1, 3); (1 <<< 16, 4); ((1 <<< 21) --- 1, 4); ] + + let width_required_for_ucs_value value = + if value < 0x000080 (* 1 lsl 7 *) then 1 else + if value < 0x000800 (* 1 lsl 11 *) then 2 else + if value < 0x010000 (* 1 lsl 16 *) then 3 else 4 let test_width_required_for_ucs_value () = List.iter @@ -370,19 +362,6 @@ module UTF8_codec = struct include E.UTF8_codec 0b11111110; 0b11111111; ] - let test_decode_header_byte_when_valid () = - List.iter - (fun (b, (v, w)) -> - Alcotest.(check (pair int int)) "same ints" (decode_header_byte b) (v, w)) - valid_header_byte_decodings - - let test_decode_header_byte_when_invalid () = - List.iter - (fun b -> - Alcotest.check_raises "should fail" E.UTF8_header_byte_invalid - (fun () -> decode_header_byte b |> ignore)) - invalid_header_bytes - (** A list of valid continuation byte decodings, represented by tuples of the form (b, v), where: b = a valid continuation byte; and @@ -407,19 +386,6 @@ module UTF8_codec = struct include E.UTF8_codec 0b11111111; 0b11111110; ] - let test_decode_continuation_byte_when_valid () = - List.iter - (fun (byte, value) -> - Alcotest.(check int) "same ints" (decode_continuation_byte byte) value) - valid_continuation_byte_decodings - - let test_decode_continuation_byte_when_invalid () = - List.iter - (fun byte -> - Alcotest.check_raises "should fail" E.UTF8_continuation_byte_invalid - (fun () -> decode_continuation_byte byte |> ignore)) - invalid_continuation_bytes - (** A list of valid character decodings represented by tuples of the form (s, (v, w)), where: @@ -479,39 +445,10 @@ module UTF8_codec = struct include E.UTF8_codec (fun () -> Lenient_UTF8_codec.decode_character string 0 |> ignore)) overlong_character_encodings - (** Encodes a valid UCS value and then decodes it again, testing: - a. that the encoded width is canonical for the given value. - b. that the decoded value is identical to the original value. *) - let test_encode_decode_cycle_for_value value = - let string = Lenient_UTF8_codec.encode_character value in - let decoded_value, decoded_width = - Lenient_UTF8_codec.decode_character string 0 in - let width = E.UTF8_codec.width_required_for_ucs_value value in - if (value <> decoded_value) then Alcotest.fail - (Printf.sprintf - "expected value %06x but decoded value %06x\n" - value decoded_value); - if (width <> decoded_width) then Alcotest.fail - (Printf.sprintf - "expected width %i but decoded width %i\n" - width decoded_width) - - let test_encode_decode_cycle () = - let value = ref UCS.min_value in - while !value <= UCS.max_value do - test_encode_decode_cycle_for_value !value; - value := Int.add !value 1; - done - let tests = [ "test_width_required_for_ucs_value", `Quick, test_width_required_for_ucs_value - ; "test_decode_header_byte_when_valid", `Quick, test_decode_header_byte_when_valid - ; "test_decode_header_byte_when_invalid", `Quick, test_decode_header_byte_when_invalid - ; "test_decode_continuation_byte_when_valid", `Quick, test_decode_continuation_byte_when_valid - ; "test_decode_continuation_byte_when_invalid", `Quick, test_decode_continuation_byte_when_invalid ; "test_decode_character_when_valid", `Quick, test_decode_character_when_valid ; "test_decode_character_when_overlong", `Quick, test_decode_character_when_overlong - ; "test_encode_decode_cycle", `Quick, test_encode_decode_cycle ] end @@ -523,7 +460,6 @@ let () = "UCS", UCS.tests ; "XML", XML.tests ; "String_validator", String_validator.tests - ; "UTF8_UCS_validator", UTF8_UCS_validator.tests ; "XML_UTF8_UCS_validator", XML_UTF8_UCS_validator.tests ; "UTF8_codec", UTF8_codec.tests ] From ab203e020748b6d5c3b717e0493faac6892577db Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 16 May 2023 14:02:12 +0100 Subject: [PATCH 172/199] xapi-stdext-encodings: drop all functions that allocate from the interface MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Moved decoding into the test code, and supply only an UCS validator as input to the functor. This will allow replacing the implementation with a more efficient one based on Uchar.t and Uutf (or the stdlib in 4.14) Drops some tests that no longer makes sense, but still keep the majority of the tests. Signed-off-by: Edwin Török --- lib/xapi-stdext-encodings/encodings.ml | 13 +- lib/xapi-stdext-encodings/encodings.mli | 16 +- lib/xapi-stdext-encodings/test.ml | 263 +++++++++++------------- 3 files changed, 127 insertions(+), 165 deletions(-) diff --git a/lib/xapi-stdext-encodings/encodings.ml b/lib/xapi-stdext-encodings/encodings.ml index e4e0e7b7252..431ec36f9f2 100644 --- a/lib/xapi-stdext-encodings/encodings.ml +++ b/lib/xapi-stdext-encodings/encodings.ml @@ -88,10 +88,6 @@ end (* ==== Character Codecs ==== *) -module type CHARACTER_DECODER = sig - val decode_character : string -> int -> uchar * int -end - module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) = struct (* === Decoding === *) @@ -144,13 +140,14 @@ end exception Validation_error of int * exn -module String_validator (Decoder : CHARACTER_DECODER) : STRING_VALIDATOR = struct +module String_validator (Validator : UCS_VALIDATOR) : STRING_VALIDATOR = struct + include UTF8_CODEC(Validator) let validate string = let index = ref 0 and length = String.length string in begin try while !index < length do - let _, width = Decoder.decode_character string !index in + let _, width = decode_character string !index in index := !index + width done; with @@ -167,5 +164,5 @@ module String_validator (Decoder : CHARACTER_DECODER) : STRING_VALIDATOR = struc end -module UTF8 = String_validator ( UTF8_codec) -module UTF8_XML = String_validator (XML_UTF8_codec) +module UTF8 = String_validator (UTF8_UCS_validator) +module UTF8_XML = String_validator (XML_UTF8_UCS_validator) diff --git a/lib/xapi-stdext-encodings/encodings.mli b/lib/xapi-stdext-encodings/encodings.mli index 4216470f8d5..268957f6adc 100644 --- a/lib/xapi-stdext-encodings/encodings.mli +++ b/lib/xapi-stdext-encodings/encodings.mli @@ -45,20 +45,6 @@ module XML : sig val is_forbidden_control_character : uchar -> bool end -(** {2 Character Codecs} *) - -module type CHARACTER_DECODER = sig - (** Decodes a single character embedded within a string. Given a string - * and an index into that string, returns a tuple (value, width) where: - * value = the value of the character at the given index; and - * width = the width of the character at the given index, in bytes. - * Raises an appropriate error if the character is invalid. *) - val decode_character : string -> int -> uchar * int -end - -module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) : sig - include CHARACTER_DECODER -end (** {2 String Validators} *) (** Provides functionality for validating and processing @@ -76,7 +62,7 @@ module type STRING_VALIDATOR = sig end -module String_validator (Decoder : CHARACTER_DECODER) : STRING_VALIDATOR +module String_validator (Decoder : UCS_VALIDATOR) : STRING_VALIDATOR (** Represents a validation error as a tuple [(i,e)], where: * [i] = the index of the first non-compliant character; diff --git a/lib/xapi-stdext-encodings/test.ml b/lib/xapi-stdext-encodings/test.ml index 8cbba2ae254..8479a021643 100644 --- a/lib/xapi-stdext-encodings/test.ml +++ b/lib/xapi-stdext-encodings/test.ml @@ -32,76 +32,25 @@ module Lenient_UCS_validator : E.UCS_VALIDATOR = struct let validate _ = () end -(* === Mock character decoders ============================================= *) +(* === Mock character validators ============================================= *) -(** A character decoder that logs every index it is called with. *) -module Logged_character_decoder (W : WIDTH_GENERATOR) = struct - (** The indices already supplied to the decoder. *) - let indices = ref ([] : int list) - - (** Clears the list of indices. *) - let reset () = indices := [] - - (** Records the given index in the list of indices. *) - let decode_character string index = - let width = W.next () in - for index = index to index + width - 1 do - ignore (string.[index]) - done; - indices := (index :: !indices); - 0, width - -end - -module Logged_1_byte_character_decoder = Logged_character_decoder - (struct let next () = 1 end) -module Logged_2_byte_character_decoder = Logged_character_decoder - (struct let next () = 2 end) -module Logged_n_byte_character_decoder = Logged_character_decoder - (struct let last = ref 0 let next () = incr last; !last end) - -(** A decoder that succeeds for all characters. *) -module Universal_character_decoder = struct - let decode_character _ _ = (0, 1) +(** A validator that succeeds for all characters. *) +module Universal_character_validator = struct + let validate _ = () end -(** A decoder that fails for all characters. *) -module Failing_character_decoder = struct - let decode_character _ _ = raise Decode_error +(** A validator that fails for all characters. *) +module Failing_character_validator = struct + let validate _ = raise Decode_error end (** A decoder that succeeds for all characters except the letter 'F'. *) -module Selective_character_decoder = struct - let decode_character string index = - if string.[index] = 'F' then raise Decode_error else (0, 1) +module Selective_character_validator = struct + let validate uchar = + if uchar = Char.code 'F' then raise Decode_error end -(* === Mock codecs ========================================================= *) - -module Lenient_UTF8_codec = E.UTF8_CODEC (Lenient_UCS_validator) - -(* === Mock string validators ============================================== *) - -module Logged_1_byte_character_string_validator = E.String_validator - (Logged_1_byte_character_decoder) -module Logged_2_byte_character_string_validator = E.String_validator - (Logged_2_byte_character_decoder) -module Logged_n_byte_character_string_validator = E.String_validator - (Logged_n_byte_character_decoder) - -(** A validator that accepts all strings. *) -module Universal_string_validator = E.String_validator - (Universal_character_decoder) - -(** A validator that rejects all strings. *) -module Failing_string_validator = E.String_validator - (Failing_character_decoder) - -(** A validator that rejects strings containing the character 'F'. *) -module Selective_string_validator = E.String_validator - (Selective_character_decoder) - (* === Test helpers ======================================================== *) let assert_true = Alcotest.(check bool) "true" true @@ -117,88 +66,8 @@ let assert_raises_match exception_match fn = then raise failure else () -(* === Tests =============================================================== *) - -module String_validator = struct - - let test_is_valid () = - assert_true (Universal_string_validator.is_valid "" ); - assert_true (Universal_string_validator.is_valid "123456789"); - assert_true (Selective_string_validator.is_valid "" ); - assert_true (Selective_string_validator.is_valid "123456789"); - assert_false (Selective_string_validator.is_valid "F23456789"); - assert_false (Selective_string_validator.is_valid "1234F6789"); - assert_false (Selective_string_validator.is_valid "12345678F"); - assert_false (Selective_string_validator.is_valid "FFFFFFFFF") - - let test_longest_valid_prefix () = - Alcotest.(check string) "prefix" (Universal_string_validator.longest_valid_prefix "" ) "" ; - Alcotest.(check string) "prefix" (Universal_string_validator.longest_valid_prefix "123456789") "123456789"; - Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "" ) "" ; - Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "123456789") "123456789"; - Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "F23456789") "" ; - Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "1234F6789") "1234" ; - Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "12345678F") "12345678" ; - Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "FFFFFFFFF") "" - - let test_validate_with_1_byte_characters () = - Logged_1_byte_character_decoder.reset (); - Logged_1_byte_character_string_validator.validate "0123456789"; - Alcotest.(check (list int)) "indices" !Logged_1_byte_character_decoder.indices [9;8;7;6;5;4;3;2;1;0] - - let test_validate_with_2_byte_characters () = - Logged_2_byte_character_decoder.reset (); - Logged_2_byte_character_string_validator.validate "0123456789"; - Alcotest.(check (list int)) "indices" !Logged_2_byte_character_decoder.indices [8;6;4;2;0] - - let test_validate_with_n_byte_characters () = - Logged_n_byte_character_decoder.reset (); - Logged_n_byte_character_string_validator.validate "0123456789"; - check_indices !Logged_n_byte_character_decoder.indices [6;3;1;0] - - (** Tests that validation does not fail for an empty string. *) - let test_validate_with_empty_string () = - Logged_1_byte_character_decoder.reset (); - Logged_1_byte_character_string_validator.validate ""; - check_indices !Logged_1_byte_character_decoder.indices [] - - let test_validate_with_incomplete_string () = - Logged_2_byte_character_decoder.reset (); - Alcotest.check_raises - "Validation fails correctly for an incomplete string" - E.String_incomplete - (fun () -> Logged_2_byte_character_string_validator.validate "0") - - let test_validate_with_failing_decoders () = - Failing_string_validator.validate ""; - assert_raises_match - (function E.Validation_error (0, Decode_error) -> true | _ -> false) - (fun () -> Selective_string_validator.validate "F"); - assert_raises_match - (function E.Validation_error (0, Decode_error) -> true | _ -> false) - (fun () -> Selective_string_validator.validate "F12345678"); - assert_raises_match - (function E.Validation_error (4, Decode_error) -> true | _ -> false) - (fun () -> Selective_string_validator.validate "0123F5678"); - assert_raises_match - (function E.Validation_error (8, Decode_error) -> true | _ -> false) - (fun () -> Selective_string_validator.validate "01234567F"); - assert_raises_match - (function E.Validation_error (0, Decode_error) -> true | _ -> false) - (fun () -> Selective_string_validator.validate "FFFFFFFFF") - - let tests = - [ "test_is_valid", `Quick, test_is_valid - ; "test_longest_valid_prefix", `Quick, test_longest_valid_prefix - ; "test_validate_with_1_byte_characters", `Quick, test_validate_with_1_byte_characters - ; "test_validate_with_2_byte_characters", `Quick, test_validate_with_2_byte_characters - ; "test_validate_with_n_byte_characters", `Quick, test_validate_with_n_byte_characters - ; "test_validate_with_empty_string", `Quick, test_validate_with_empty_string - ; "test_validate_with_incomplete_string", `Quick, test_validate_with_incomplete_string - ; "test_validate_with_failing_decoders", `Quick, test_validate_with_failing_decoders - ] -end +(* === Mock codecs ========================================================= *) module UCS = struct (* === Unicode Functions === *) @@ -262,6 +131,116 @@ module UCS = struct end +module Lenient_UTF8_codec = struct + let decode_header_byte byte = + if byte land 0b10000000 = 0b00000000 then (byte , 1) else + if byte land 0b11100000 = 0b11000000 then (byte land 0b0011111, 2) else + if byte land 0b11110000 = 0b11100000 then (byte land 0b0001111, 3) else + if byte land 0b11111000 = 0b11110000 then (byte land 0b0000111, 4) else + raise E.UTF8_header_byte_invalid + + let decode_continuation_byte byte = + if byte land 0b11000000 = 0b10000000 then byte land 0b00111111 else + raise E.UTF8_continuation_byte_invalid + + let width_required_for_ucs_value value = + if value < 0x000080 (* 1 lsl 7 *) then 1 else + if value < 0x000800 (* 1 lsl 11 *) then 2 else + if value < 0x010000 (* 1 lsl 16 *) then 3 else 4 + + let decode_character string index = + let value, width = decode_header_byte (Char.code string.[index]) in + let value = if width = 1 then value + else begin + let value = ref value in + for index = index + 1 to index + width - 1 do + let chunk = decode_continuation_byte (Char.code string.[index]) in + value := (!value lsl 6) lor chunk + done; + if width > (width_required_for_ucs_value !value) + then raise E.UTF8_encoding_not_canonical; + !value + end in + (value, width) +end + +(* === Mock string validators ============================================== *) + +(** A validator that accepts all strings. *) +module Universal_string_validator = E.String_validator + (Universal_character_validator) + +(** A validator that rejects all strings. *) +module Failing_string_validator = E.String_validator + (Failing_character_validator) + +(** A validator that rejects strings containing the character 'F'. *) +module Selective_string_validator = E.String_validator + (Selective_character_validator) + +(* === Tests =============================================================== *) + +module String_validator = struct + + let test_is_valid () = + assert_true (Universal_string_validator.is_valid "" ); + assert_true (Universal_string_validator.is_valid "123456789"); + assert_true (Selective_string_validator.is_valid "" ); + assert_true (Selective_string_validator.is_valid "123456789"); + assert_false (Selective_string_validator.is_valid "F23456789"); + assert_false (Selective_string_validator.is_valid "1234F6789"); + assert_false (Selective_string_validator.is_valid "12345678F"); + assert_false (Selective_string_validator.is_valid "FFFFFFFFF") + + let test_longest_valid_prefix () = + Alcotest.(check string) "prefix" (Universal_string_validator.longest_valid_prefix "" ) "" ; + Alcotest.(check string) "prefix" (Universal_string_validator.longest_valid_prefix "123456789") "123456789"; + Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "" ) "" ; + Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "123456789") "123456789"; + Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "F23456789") "" ; + Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "1234F6789") "1234" ; + Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "12345678F") "12345678" ; + Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "FFFFFFFFF") "" + + + (** Tests that validation does not fail for an empty string. *) + let test_validate_with_empty_string () = + E.UTF8_XML.validate "" + + let test_validate_with_incomplete_string () = + Alcotest.check_raises + "Validation fails correctly for an incomplete string" + E.String_incomplete + (fun () -> E.UTF8_XML.validate "\xc2") + + let test_validate_with_failing_decoders () = + Failing_string_validator.validate ""; + assert_raises_match + (function E.Validation_error (0, Decode_error) -> true | _ -> false) + (fun () -> Selective_string_validator.validate "F"); + assert_raises_match + (function E.Validation_error (0, Decode_error) -> true | _ -> false) + (fun () -> Selective_string_validator.validate "F12345678"); + assert_raises_match + (function E.Validation_error (4, Decode_error) -> true | _ -> false) + (fun () -> Selective_string_validator.validate "0123F5678"); + assert_raises_match + (function E.Validation_error (8, Decode_error) -> true | _ -> false) + (fun () -> Selective_string_validator.validate "01234567F"); + assert_raises_match + (function E.Validation_error (0, Decode_error) -> true | _ -> false) + (fun () -> Selective_string_validator.validate "FFFFFFFFF") + + let tests = + [ "test_is_valid", `Quick, test_is_valid + ; "test_longest_valid_prefix", `Quick, test_longest_valid_prefix + ; "test_validate_with_empty_string", `Quick, test_validate_with_empty_string + ; "test_validate_with_incomplete_string", `Quick, test_validate_with_incomplete_string + ; "test_validate_with_failing_decoders", `Quick, test_validate_with_failing_decoders + ] + +end + module XML = struct include E.XML let test_is_forbidden_control_character () = From 932ae78dfe4ade3a81d61cbe66ef5158498e7ed2 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 16 May 2023 15:55:32 +0100 Subject: [PATCH 173/199] date: add useful comparison methods This will help in updating users to use date more thoroughly instead of ad-hoc methods Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-date/date.ml | 23 ++++++++++++++++++++++- lib/xapi-stdext-date/date.mli | 21 ++++++++++++++++++++- 2 files changed, 42 insertions(+), 2 deletions(-) diff --git a/lib/xapi-stdext-date/date.ml b/lib/xapi-stdext-date/date.ml index 5a3b406412f..77f3994fe68 100644 --- a/lib/xapi-stdext-date/date.ml +++ b/lib/xapi-stdext-date/date.ml @@ -147,7 +147,28 @@ let now () = of_ptime (Ptime_clock.now ()) let epoch = of_ptime Ptime.epoch -let eq x y = x = y +let is_earlier ~than t = Ptime.is_earlier ~than:(to_ptime than) (to_ptime t) + +let is_later ~than t = Ptime.is_later ~than:(to_ptime than) (to_ptime t) + +let diff a b = Ptime.diff (to_ptime a) (to_ptime b) + +let compare_print_tz a b = + match (a, b) with + | Empty, Empty -> + 0 + | TZ a_s, TZ b_s -> + String.compare a_s b_s + | Empty, TZ _ -> + -1 + | TZ _, Empty -> + 1 + +let compare ((_, _, a_z) as a) ((_, _, b_z) as b) = + let ( ) a b = if a = 0 then b else a in + Ptime.compare (to_ptime a) (to_ptime b) compare_print_tz a_z b_z + +let eq x y = compare x y = 0 let never = epoch diff --git a/lib/xapi-stdext-date/date.mli b/lib/xapi-stdext-date/date.mli index 25eb00ab230..1255608bfce 100644 --- a/lib/xapi-stdext-date/date.mli +++ b/lib/xapi-stdext-date/date.mli @@ -15,6 +15,8 @@ (** date-time with support for keeping timezone for ISO 8601 conversion *) type t +(** Conversions *) + val of_ptime : Ptime.t -> t (** Convert ptime to time in UTC *) @@ -26,7 +28,7 @@ val of_unix_time : float -> t (** Convert calendar time [x] (as returned by e.g. Unix.time), to time in UTC *) val to_unix_time : t -> float -(** Convert date/time to a unix timestamp: the number of seconds since +(** Convert date/time to a unix timestamp: the number of seconds since 00:00:00 UTC, 1 Jan 1970. Assumes the underlying {!t} is in UTC *) val to_rfc822 : t -> string @@ -53,9 +55,26 @@ val localtime : unit -> t (** Count the number of seconds passed since 00:00:00 UTC, 1 Jan 1970, in local time *) +(** Comparisons *) + val eq : t -> t -> bool (** [eq a b] returns whether [a] and [b] are equal *) +val compare : t -> t -> int +(** [compare a b] returns -1 if [a] is earlier than [b], 1 if [a] is later than + [b] or the ordering of the timezone printer *) + +val is_earlier : than:t -> t -> bool +(** [is_earlier ~than a] returns whether the timestamp [a] happens before + [than] *) + +val is_later : than:t -> t -> bool +(** [is_later ~than a] returns whether the timestamp [a] happens after [than] + *) + +val diff : t -> t -> Ptime.Span.t +(** [diff a b] returns the span of time corresponding to [a - b] *) + (** Deprecated bindings, these will be removed in a future release: *) val rfc822_to_string : t -> string From b3acec277f103b35a185a41eb4b2a2fe3b3f9962 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 16 May 2023 15:00:42 +0100 Subject: [PATCH 174/199] xapi-stdext-encodings: optimize away some allocations MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit We can't use Uutf either: it would allocate on each char. Only the 4.14 stdlib would be better: it doesn't allocate at all, only deals with ints. Signed-off-by: Edwin Török --- lib/xapi-stdext-encodings/encodings.ml | 98 +++++++++---------------- lib/xapi-stdext-encodings/encodings.mli | 5 +- lib/xapi-stdext-encodings/test.ml | 28 ++++--- 3 files changed, 56 insertions(+), 75 deletions(-) diff --git a/lib/xapi-stdext-encodings/encodings.ml b/lib/xapi-stdext-encodings/encodings.ml index 431ec36f9f2..550e6a37dd2 100644 --- a/lib/xapi-stdext-encodings/encodings.ml +++ b/lib/xapi-stdext-encodings/encodings.ml @@ -20,40 +20,20 @@ exception UTF8_continuation_byte_invalid exception UTF8_encoding_not_canonical exception String_incomplete -module Int = struct - include Int - let of_int (x:int) = x -end - -type uchar = int - -(* === Utility Functions === *) - -let ( ||| ) = Int.logor -let ( <<< ) = Int.shift_left - (* === Unicode Functions === *) module UCS = struct - let min_value = 0x000000 - let max_value = 0x1fffff - let is_non_character value = false || (0xfdd0 <= value && value <= 0xfdef) (* case 1 *) || (Int.logand 0xfffe value = 0xfffe) (* case 2 *) - let is_out_of_range value = - value < min_value || value > max_value - - let is_surrogate value = - (0xd800 <= value && value <= 0xdfff) - end module XML = struct - let is_forbidden_control_character value = value < 0x20 + let is_forbidden_control_character value = let value = Uchar.to_int value in + value < 0x20 && value <> 0x09 && value <> 0x0a && value <> 0x0d @@ -64,16 +44,14 @@ end module type UCS_VALIDATOR = sig - val validate : uchar -> unit + val validate : Uchar.t -> unit end module UTF8_UCS_validator : UCS_VALIDATOR = struct let validate value = - if UCS.is_out_of_range value then raise UCS_value_out_of_range; - if UCS.is_non_character value then raise UCS_value_prohibited_in_UTF8; - if UCS.is_surrogate value then raise UCS_value_prohibited_in_UTF8 + if UCS.is_non_character (Uchar.to_int value) then raise UCS_value_prohibited_in_UTF8 end @@ -91,37 +69,31 @@ end module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) = struct (* === Decoding === *) - let decode_header_byte byte = - if byte land 0b10000000 = 0b00000000 then (byte , 1) else - if byte land 0b11100000 = 0b11000000 then (byte land 0b0011111, 2) else - if byte land 0b11110000 = 0b11100000 then (byte land 0b0001111, 3) else - if byte land 0b11111000 = 0b11110000 then (byte land 0b0000111, 4) else - raise UTF8_header_byte_invalid - let decode_continuation_byte byte = if byte land 0b11000000 = 0b10000000 then byte land 0b00111111 else raise UTF8_continuation_byte_invalid - let width_required_for_ucs_value value = - if value < 0x000080 (* 1 lsl 7 *) then 1 else - if value < 0x000800 (* 1 lsl 11 *) then 2 else - if value < 0x010000 (* 1 lsl 16 *) then 3 else 4 - - let decode_character string index = - let value, width = decode_header_byte (Char.code string.[index]) in - let value = if width = 1 then (Int.of_int value) - else begin - let value = ref (Int.of_int value) in - for index = index + 1 to index + width - 1 do - let chunk = decode_continuation_byte (Char.code string.[index]) in - value := (!value <<< 6) ||| (Int.of_int chunk) - done; - if width > (width_required_for_ucs_value !value) - then raise UTF8_encoding_not_canonical; - !value - end in - UCS_validator.validate value; - (value, width) + let rec decode_continuation_bytes string last value index = + if index <= last then + let chunk = decode_continuation_byte (Char.code string.[index]) in + let value = (value lsl 6) lor chunk in + decode_continuation_bytes string last value (index + 1) + else value + + let validate_character string index = + let value, width = + let byte = Char.code string.[index] in + if byte land 0b10000000 = 0b00000000 then (byte , 1) else + if byte land 0b11100000 = 0b11000000 then (byte land 0b0011111, 2) else + if byte land 0b11110000 = 0b11100000 then (byte land 0b0001111, 3) else + if byte land 0b11111000 = 0b11110000 then (byte land 0b0000111, 4) else + raise UTF8_header_byte_invalid + in + let value = if width = 1 then value + else decode_continuation_bytes string (index+width-1) value (index+1) + in + UCS_validator.validate (Uchar.unsafe_of_int value); + width end @@ -143,17 +115,19 @@ exception Validation_error of int * exn module String_validator (Validator : UCS_VALIDATOR) : STRING_VALIDATOR = struct include UTF8_CODEC(Validator) - let validate string = - let index = ref 0 and length = String.length string in - begin try - while !index < length do - let _, width = decode_character string !index in - index := !index + width - done; + let rec validate_aux string length index = + if index = length then () + else + let width = + try validate_character string index with | Invalid_argument _ -> raise String_incomplete - | error -> raise (Validation_error (!index, error)) - end; assert (!index = length) + | error -> raise (Validation_error (index, error)) + in + validate_aux string length (index + width) + + let validate string = + validate_aux string (String.length string) 0 let is_valid string = try validate string; true with _ -> false diff --git a/lib/xapi-stdext-encodings/encodings.mli b/lib/xapi-stdext-encodings/encodings.mli index 268957f6adc..be2aadc01d4 100644 --- a/lib/xapi-stdext-encodings/encodings.mli +++ b/lib/xapi-stdext-encodings/encodings.mli @@ -25,13 +25,12 @@ exception UTF8_continuation_byte_invalid exception UTF8_encoding_not_canonical exception String_incomplete -type uchar = int (** {2 UCS Validators} *) (** Validates UCS character values. *) module type UCS_VALIDATOR = sig - val validate : uchar -> unit + val validate : Uchar.t -> unit end (** Accepts all values within the UCS character value range except @@ -42,7 +41,7 @@ module XML : sig (** Returns true if and only if the given value corresponds to * a forbidden control character as defined in section 2.2 of * the XML specification, version 1.0. *) - val is_forbidden_control_character : uchar -> bool + val is_forbidden_control_character : Uchar.t -> bool end (** {2 String Validators} *) diff --git a/lib/xapi-stdext-encodings/test.ml b/lib/xapi-stdext-encodings/test.ml index 8479a021643..fc449eda028 100644 --- a/lib/xapi-stdext-encodings/test.ml +++ b/lib/xapi-stdext-encodings/test.ml @@ -45,10 +45,10 @@ module Failing_character_validator = struct let validate _ = raise Decode_error end -(** A decoder that succeeds for all characters except the letter 'F'. *) +(** A validator that succeeds for all characters except the letter 'F'. *) module Selective_character_validator = struct let validate uchar = - if uchar = Char.code 'F' then raise Decode_error + if Uchar.equal uchar (Uchar.of_char 'F') then raise Decode_error end (* === Test helpers ======================================================== *) @@ -72,7 +72,7 @@ let assert_raises_match exception_match fn = module UCS = struct (* === Unicode Functions === *) let min_value = 0x000000 - let max_value = 0x1fffff + let max_value = 0x10ffff (* used to be 0x1fffff, but this changed and Unicode won't allocate larger than 0x10ffff *) let is_non_character value = false || (0xfdd0 <= value && value <= 0xfdef) (* case 1 *) @@ -244,12 +244,12 @@ end module XML = struct include E.XML let test_is_forbidden_control_character () = - assert_true (is_forbidden_control_character (0x00)); - assert_true (is_forbidden_control_character (0x19)); - assert_false (is_forbidden_control_character (0x09)); - assert_false (is_forbidden_control_character (0x0a)); - assert_false (is_forbidden_control_character (0x0d)); - assert_false (is_forbidden_control_character (0x20)) + assert_true (is_forbidden_control_character (Uchar.of_int 0x00)); + assert_true (is_forbidden_control_character (Uchar.of_int 0x19)); + assert_false (is_forbidden_control_character (Uchar.of_int 0x09)); + assert_false (is_forbidden_control_character (Uchar.of_int 0x0a)); + assert_false (is_forbidden_control_character (Uchar.of_int 0x0d)); + assert_false (is_forbidden_control_character (Uchar.of_int 0x20)) let tests = [ "test_is_forbidden_control_character", `Quick, test_is_forbidden_control_character @@ -259,6 +259,14 @@ end (** Tests the XML-specific UTF-8 UCS validation function. *) module XML_UTF8_UCS_validator = struct include E.XML_UTF8_UCS_validator + let validate uchar = + if Uchar.is_valid uchar then validate @@ Uchar.of_int uchar + else + if uchar < Uchar.to_int Uchar.min + || uchar > Uchar.to_int Uchar.max then + raise E.UCS_value_out_of_range + else + raise E.UCS_value_prohibited_in_UTF8 let test_validate () = let value = ref (UCS.min_value --- 1) in @@ -272,7 +280,7 @@ module XML_UTF8_UCS_validator = struct include E.XML_UTF8_UCS_validator then Alcotest.check_raises "should fail" E.UCS_value_prohibited_in_UTF8 (fun () -> validate !value) else - if XML.is_forbidden_control_character !value + if Uchar.is_valid !value && XML.is_forbidden_control_character (Uchar.of_int !value) then Alcotest.check_raises "should fail" E.UCS_value_prohibited_in_XML (fun () -> validate !value) else From 9eb1462b471328ed556bb06e8fdcb64d8d496a73 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 16 May 2023 16:20:30 +0100 Subject: [PATCH 175/199] xapi-stdext-encodings: add some inline annotations MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- lib/xapi-stdext-encodings/encodings.ml | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/lib/xapi-stdext-encodings/encodings.ml b/lib/xapi-stdext-encodings/encodings.ml index 550e6a37dd2..860cb703291 100644 --- a/lib/xapi-stdext-encodings/encodings.ml +++ b/lib/xapi-stdext-encodings/encodings.ml @@ -27,6 +27,7 @@ module UCS = struct let is_non_character value = false || (0xfdd0 <= value && value <= 0xfdef) (* case 1 *) || (Int.logand 0xfffe value = 0xfffe) (* case 2 *) + [@@inline] end @@ -37,6 +38,7 @@ module XML = struct && value <> 0x09 && value <> 0x0a && value <> 0x0d + [@@inline] end @@ -44,14 +46,14 @@ end module type UCS_VALIDATOR = sig - val validate : Uchar.t -> unit + val validate : Uchar.t -> unit [@@inline] end module UTF8_UCS_validator : UCS_VALIDATOR = struct let validate value = - if UCS.is_non_character (Uchar.to_int value) then raise UCS_value_prohibited_in_UTF8 + if (UCS.is_non_character[@inlined]) (Uchar.to_int value) then raise UCS_value_prohibited_in_UTF8 end @@ -59,7 +61,7 @@ module XML_UTF8_UCS_validator : UCS_VALIDATOR = struct let validate value = UTF8_UCS_validator.validate value; - if XML.is_forbidden_control_character value + if (XML.is_forbidden_control_character[@inlined]) value then raise UCS_value_prohibited_in_XML end @@ -72,10 +74,11 @@ module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) = struct let decode_continuation_byte byte = if byte land 0b11000000 = 0b10000000 then byte land 0b00111111 else raise UTF8_continuation_byte_invalid + [@@inline] let rec decode_continuation_bytes string last value index = if index <= last then - let chunk = decode_continuation_byte (Char.code string.[index]) in + let chunk = (decode_continuation_byte[@inlined]) (Char.code string.[index]) in let value = (value lsl 6) lor chunk in decode_continuation_bytes string last value (index + 1) else value @@ -94,6 +97,7 @@ module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) = struct in UCS_validator.validate (Uchar.unsafe_of_int value); width + [@@inline] end @@ -119,7 +123,7 @@ module String_validator (Validator : UCS_VALIDATOR) : STRING_VALIDATOR = struct if index = length then () else let width = - try validate_character string index + try (validate_character[@inlined]) string index with | Invalid_argument _ -> raise String_incomplete | error -> raise (Validation_error (index, error)) @@ -139,4 +143,4 @@ module String_validator (Validator : UCS_VALIDATOR) : STRING_VALIDATOR = struct end module UTF8 = String_validator (UTF8_UCS_validator) -module UTF8_XML = String_validator (XML_UTF8_UCS_validator) +module UTF8_XML = String_validator (XML_UTF8_UCS_validator) \ No newline at end of file From be9adef78ee0d40426339c2a07bdebed5c903453 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 16 May 2023 19:46:53 +0100 Subject: [PATCH 176/199] xapi-stdext-encodings: inline UTF8_CODEC MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- lib/xapi-stdext-encodings/encodings.ml | 45 ++++++++++--------------- lib/xapi-stdext-encodings/encodings.mli | 9 ----- 2 files changed, 18 insertions(+), 36 deletions(-) diff --git a/lib/xapi-stdext-encodings/encodings.ml b/lib/xapi-stdext-encodings/encodings.ml index 860cb703291..012a436add6 100644 --- a/lib/xapi-stdext-encodings/encodings.ml +++ b/lib/xapi-stdext-encodings/encodings.ml @@ -50,27 +50,36 @@ module type UCS_VALIDATOR = sig end -module UTF8_UCS_validator : UCS_VALIDATOR = struct +module UTF8_UCS_validator = struct let validate value = if (UCS.is_non_character[@inlined]) (Uchar.to_int value) then raise UCS_value_prohibited_in_UTF8 + [@@inline] end -module XML_UTF8_UCS_validator : UCS_VALIDATOR = struct +module XML_UTF8_UCS_validator = struct let validate value = - UTF8_UCS_validator.validate value; + (UTF8_UCS_validator.validate[@inlined]) value; if (XML.is_forbidden_control_character[@inlined]) value then raise UCS_value_prohibited_in_XML end -(* ==== Character Codecs ==== *) +(* === String Validators === *) + +module type STRING_VALIDATOR = sig -module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) = struct - (* === Decoding === *) + val is_valid : string -> bool + val validate : string -> unit + val longest_valid_prefix : string -> string +end + +exception Validation_error of int * exn + +module String_validator (UCS_validator : UCS_VALIDATOR) : STRING_VALIDATOR = struct let decode_continuation_byte byte = if byte land 0b11000000 = 0b10000000 then byte land 0b00111111 else raise UTF8_continuation_byte_invalid @@ -99,25 +108,8 @@ module UTF8_CODEC (UCS_validator : UCS_VALIDATOR) = struct width [@@inline] -end - -module UTF8_codec = UTF8_CODEC ( UTF8_UCS_validator) -module XML_UTF8_codec = UTF8_CODEC (XML_UTF8_UCS_validator) - -(* === String Validators === *) - -module type STRING_VALIDATOR = sig - - val is_valid : string -> bool - val validate : string -> unit - val longest_valid_prefix : string -> string - -end - -exception Validation_error of int * exn - -module String_validator (Validator : UCS_VALIDATOR) : STRING_VALIDATOR = struct - include UTF8_CODEC(Validator) + let raise_validation_error index error = raise (Validation_error(index, error)) + [@@inline never][@@local never][@@specialise never] let rec validate_aux string length index = if index = length then () @@ -126,7 +118,7 @@ module String_validator (Validator : UCS_VALIDATOR) : STRING_VALIDATOR = struct try (validate_character[@inlined]) string index with | Invalid_argument _ -> raise String_incomplete - | error -> raise (Validation_error (index, error)) + | error -> raise_validation_error index error in validate_aux string length (index + width) @@ -142,5 +134,4 @@ module String_validator (Validator : UCS_VALIDATOR) : STRING_VALIDATOR = struct end -module UTF8 = String_validator (UTF8_UCS_validator) module UTF8_XML = String_validator (XML_UTF8_UCS_validator) \ No newline at end of file diff --git a/lib/xapi-stdext-encodings/encodings.mli b/lib/xapi-stdext-encodings/encodings.mli index be2aadc01d4..26e515b3aac 100644 --- a/lib/xapi-stdext-encodings/encodings.mli +++ b/lib/xapi-stdext-encodings/encodings.mli @@ -68,15 +68,6 @@ module String_validator (Decoder : UCS_VALIDATOR) : STRING_VALIDATOR * [e] = the reason for non-compliance. *) exception Validation_error of int * exn -(** Provides functions for validating and processing - * strings according to the UTF-8 character encoding. - * - * Validly-encoded strings must satisfy RFC 3629. - * - * For further information, see: - * http://www.rfc.net/rfc3629.html *) -module UTF8 : STRING_VALIDATOR - (** Provides functions for validating and processing * strings according to the UTF-8 character encoding, * with certain additional restrictions on UCS values From 2d52866bf5520f2ce9fdf253f8ab029e14463acb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 16 May 2023 19:52:07 +0100 Subject: [PATCH 177/199] xapi-stdext-encodings: add a fastpath for ASCII MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- lib/xapi-stdext-encodings/encodings.ml | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/lib/xapi-stdext-encodings/encodings.ml b/lib/xapi-stdext-encodings/encodings.ml index 012a436add6..88fea18549c 100644 --- a/lib/xapi-stdext-encodings/encodings.ml +++ b/lib/xapi-stdext-encodings/encodings.ml @@ -92,21 +92,26 @@ module String_validator (UCS_validator : UCS_VALIDATOR) : STRING_VALIDATOR = str decode_continuation_bytes string last value (index + 1) else value - let validate_character string index = + let validate_character_utf8 string byte index = let value, width = - let byte = Char.code string.[index] in - if byte land 0b10000000 = 0b00000000 then (byte , 1) else if byte land 0b11100000 = 0b11000000 then (byte land 0b0011111, 2) else if byte land 0b11110000 = 0b11100000 then (byte land 0b0001111, 3) else if byte land 0b11111000 = 0b11110000 then (byte land 0b0000111, 4) else raise UTF8_header_byte_invalid in - let value = if width = 1 then value - else decode_continuation_bytes string (index+width-1) value (index+1) + let value = decode_continuation_bytes string (index+width-1) value (index+1) in UCS_validator.validate (Uchar.unsafe_of_int value); width - [@@inline] + [@@inline never][@@local never][@@specialise never] + + let validate_character string index = + let byte = Char.code string.[index] in + if byte land 0b10000000 = 0b00000000 then begin + UCS_validator.validate (Uchar.unsafe_of_int byte); + 1 + end else validate_character_utf8 string byte index + [@@inline] let raise_validation_error index error = raise (Validation_error(index, error)) [@@inline never][@@local never][@@specialise never] From ed383b684bf0146bf0242d27c9c57d9787962b54 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 16 May 2023 21:02:03 +0100 Subject: [PATCH 178/199] xapi-stdext-encodings: fast-path that decodes 2 ASCII chars at a time MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- lib/xapi-stdext-encodings/encodings.ml | 26 +++++++++++++++++++++----- 1 file changed, 21 insertions(+), 5 deletions(-) diff --git a/lib/xapi-stdext-encodings/encodings.ml b/lib/xapi-stdext-encodings/encodings.ml index 88fea18549c..189ba8387f6 100644 --- a/lib/xapi-stdext-encodings/encodings.ml +++ b/lib/xapi-stdext-encodings/encodings.ml @@ -92,7 +92,7 @@ module String_validator (UCS_validator : UCS_VALIDATOR) : STRING_VALIDATOR = str decode_continuation_bytes string last value (index + 1) else value - let validate_character_utf8 string byte index = + let validate_character_long_utf8 string byte index = let value, width = if byte land 0b11100000 = 0b11000000 then (byte land 0b0011111, 2) else if byte land 0b11110000 = 0b11100000 then (byte land 0b0001111, 3) else @@ -104,13 +104,29 @@ module String_validator (UCS_validator : UCS_VALIDATOR) : STRING_VALIDATOR = str UCS_validator.validate (Uchar.unsafe_of_int value); width [@@inline never][@@local never][@@specialise never] - - let validate_character string index = - let byte = Char.code string.[index] in + + let validate_byte byte = UCS_validator.validate (Uchar.unsafe_of_int byte)[@@inline] + + let validate_character_utf8 string byte index = if byte land 0b10000000 = 0b00000000 then begin UCS_validator.validate (Uchar.unsafe_of_int byte); 1 - end else validate_character_utf8 string byte index + end else validate_character_long_utf8 string byte index + [@@inline] + + let validate_character string index = + if index + 1 < String.length string then + let i16 = String.get_uint16_le string index in + if (i16 land 0x80_80 = 0) then begin + validate_byte (i16 land 0xff); + validate_byte (i16 lsr 8); + 2 + end + else + validate_character_utf8 string (i16 land 0xff) index + else + let byte = Char.code string.[index] in + validate_character_utf8 string byte index [@@inline] let raise_validation_error index error = raise (Validation_error(index, error)) From 612cbaea40dc0d5ff2253264e57e5c67c2dc9264 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 17 May 2023 14:24:57 +0100 Subject: [PATCH 179/199] xapi-stdext-encodings: add a benchmark MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- .../bench/bechamel_simple_cli.ml | 56 +++++++++++++++++++ .../bench/bench_encodings.ml | 18 ++++++ lib/xapi-stdext-encodings/bench/dune | 6 ++ 3 files changed, 80 insertions(+) create mode 100644 lib/xapi-stdext-encodings/bench/bechamel_simple_cli.ml create mode 100644 lib/xapi-stdext-encodings/bench/bench_encodings.ml create mode 100644 lib/xapi-stdext-encodings/bench/dune diff --git a/lib/xapi-stdext-encodings/bench/bechamel_simple_cli.ml b/lib/xapi-stdext-encodings/bench/bechamel_simple_cli.ml new file mode 100644 index 00000000000..d4e58e52c51 --- /dev/null +++ b/lib/xapi-stdext-encodings/bench/bechamel_simple_cli.ml @@ -0,0 +1,56 @@ +(* based on bechamel example code *) +open Bechamel +open Toolkit + +let instances = Instance.[monotonic_clock; minor_allocated; major_allocated] + +let benchmark tests = + let cfg = Benchmark.cfg () in + Benchmark.all cfg instances tests + +let analyze raw_results = + let ols = + Analyze.ols ~r_square:true ~bootstrap:0 ~predictors:[|Measure.run|] + in + let results = + List.map (fun instance -> Analyze.all ols instance raw_results) instances in + (Analyze.merge ols instances results, raw_results) + +let () = + List.iter (fun i -> Bechamel_notty.Unit.add i (Measure.unit i)) instances + +let img (window, results) = + Bechamel_notty.Multiple.image_of_ols_results ~rect:window + ~predictor:Measure.run results + +open Notty_unix + +let cli tests = + Format.printf "@,Running benchmarks@."; + let results, _ = tests |> benchmark |> analyze in + + (* compute speed from duration *) + let () = + Hashtbl.find results (Measure.label Instance.monotonic_clock) + |> Hashtbl.iter @@ fun name result -> + try + (* this relies on extracting input size from test name, + which works if Test.make_indexed* was used *) + Scanf.sscanf name "%_s@:%d" @@ fun length -> + match Analyze.OLS.estimates result with + | Some [duration] -> + (* unit is ns *) + let speed = 1e9 *. float length /. duration /. 1048576.0 in + Fmt.pf Fmt.stdout "@[%s = %.1f MiB/s@]@." name speed + | _ -> () + with Failure _ | Scanf.Scan_failure _ -> () + in + + let window = + match winsize Unix.stdout with + | Some (w, h) -> + {Bechamel_notty.w; h} + | None -> + {Bechamel_notty.w= 80; h= 1} + in + img (window, results) |> eol |> output_image diff --git a/lib/xapi-stdext-encodings/bench/bench_encodings.ml b/lib/xapi-stdext-encodings/bench/bench_encodings.ml new file mode 100644 index 00000000000..4bb2426c1b5 --- /dev/null +++ b/lib/xapi-stdext-encodings/bench/bench_encodings.ml @@ -0,0 +1,18 @@ +open Bechamel +open Xapi_stdext_encodings.Encodings + +let test name f = + Test.make_indexed_with_resource ~name + ~args:[10; 1000; 10000] + Test.multiple (* TODO: Test.uniq segfaults here, bechamel bug *) + ~allocate:(fun i -> String.make i 'x') + ~free:ignore + (fun (_:int) -> Staged.stage f) + +let benchmarks = + Test.make_grouped ~name:"Encodings.validate" + [ test "UTF8_XML" UTF8_XML.validate + ] + +let () = + Bechamel_simple_cli.cli benchmarks diff --git a/lib/xapi-stdext-encodings/bench/dune b/lib/xapi-stdext-encodings/bench/dune new file mode 100644 index 00000000000..11f37666064 --- /dev/null +++ b/lib/xapi-stdext-encodings/bench/dune @@ -0,0 +1,6 @@ +(executable + (name bench_encodings) + (modes exe) + (optional) + (libraries bechamel xapi_stdext_encodings bechamel-notty notty.unix) +) From 7e0d616ac2ae93ae50ef03cd74cbde168ed563b1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 17 May 2023 18:21:10 +0100 Subject: [PATCH 180/199] xapi-stdext-encodings: inline character validator MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This removes the String_validator functor, and enables further performance optimizations of exactly the XML UTF8 validator. (where we can add a fastpath that can take advantage of the specific properties of this validator) Signed-off-by: Edwin Török --- lib/xapi-stdext-encodings/encodings.ml | 12 ++++----- lib/xapi-stdext-encodings/encodings.mli | 2 -- lib/xapi-stdext-encodings/test.ml | 35 ++++++++++++++++++++++--- 3 files changed, 38 insertions(+), 11 deletions(-) diff --git a/lib/xapi-stdext-encodings/encodings.ml b/lib/xapi-stdext-encodings/encodings.ml index 189ba8387f6..51743f14d69 100644 --- a/lib/xapi-stdext-encodings/encodings.ml +++ b/lib/xapi-stdext-encodings/encodings.ml @@ -79,7 +79,9 @@ end exception Validation_error of int * exn -module String_validator (UCS_validator : UCS_VALIDATOR) : STRING_VALIDATOR = struct +module UTF8_XML : STRING_VALIDATOR = struct + let validate = XML_UTF8_UCS_validator.validate + let decode_continuation_byte byte = if byte land 0b11000000 = 0b10000000 then byte land 0b00111111 else raise UTF8_continuation_byte_invalid @@ -101,15 +103,15 @@ module String_validator (UCS_validator : UCS_VALIDATOR) : STRING_VALIDATOR = str in let value = decode_continuation_bytes string (index+width-1) value (index+1) in - UCS_validator.validate (Uchar.unsafe_of_int value); + validate (Uchar.unsafe_of_int value); width [@@inline never][@@local never][@@specialise never] - let validate_byte byte = UCS_validator.validate (Uchar.unsafe_of_int byte)[@@inline] + let validate_byte byte = validate (Uchar.unsafe_of_int byte)[@@inline] let validate_character_utf8 string byte index = if byte land 0b10000000 = 0b00000000 then begin - UCS_validator.validate (Uchar.unsafe_of_int byte); + validate (Uchar.unsafe_of_int byte); 1 end else validate_character_long_utf8 string byte index [@@inline] @@ -154,5 +156,3 @@ module String_validator (UCS_validator : UCS_VALIDATOR) : STRING_VALIDATOR = str with Validation_error (index, _) -> String.sub string 0 index end - -module UTF8_XML = String_validator (XML_UTF8_UCS_validator) \ No newline at end of file diff --git a/lib/xapi-stdext-encodings/encodings.mli b/lib/xapi-stdext-encodings/encodings.mli index 26e515b3aac..fe06b6b2cbc 100644 --- a/lib/xapi-stdext-encodings/encodings.mli +++ b/lib/xapi-stdext-encodings/encodings.mli @@ -61,8 +61,6 @@ module type STRING_VALIDATOR = sig end -module String_validator (Decoder : UCS_VALIDATOR) : STRING_VALIDATOR - (** Represents a validation error as a tuple [(i,e)], where: * [i] = the index of the first non-compliant character; * [e] = the reason for non-compliance. *) diff --git a/lib/xapi-stdext-encodings/test.ml b/lib/xapi-stdext-encodings/test.ml index fc449eda028..db95e00b1ee 100644 --- a/lib/xapi-stdext-encodings/test.ml +++ b/lib/xapi-stdext-encodings/test.ml @@ -165,17 +165,46 @@ module Lenient_UTF8_codec = struct end (* === Mock string validators ============================================== *) +module Mock_String_validator(Validator: E.UCS_VALIDATOR) : E.STRING_VALIDATOR = struct + (* no longer a functor in Encodings for performance reasons, + so modify the original string passed as argument instead replacing + characters that would be invalid with a known invalid XML char: 0x0B. + *) + + let transform str = + let b = Buffer.create (String.length str) in + let rec loop pos = + if pos < String.length str then + let value, width = Lenient_UTF8_codec.decode_character str pos in + let () = try + let u = Uchar.of_int value in + Validator.validate u; + Buffer.add_utf_8_uchar b u + with _ -> Buffer.add_char b '\x0B' + in + loop (pos + width) + in + loop 0; + Buffer.contents b + + let is_valid str = E.UTF8_XML.is_valid (transform str) + let validate str = + try E.UTF8_XML.validate (transform str) + with E.Validation_error(pos, _) -> + raise (E.Validation_error(pos, Decode_error)) + let longest_valid_prefix str = E.UTF8_XML.longest_valid_prefix (transform str) +end (** A validator that accepts all strings. *) -module Universal_string_validator = E.String_validator +module Universal_string_validator = Mock_String_validator (Universal_character_validator) (** A validator that rejects all strings. *) -module Failing_string_validator = E.String_validator +module Failing_string_validator = Mock_String_validator (Failing_character_validator) (** A validator that rejects strings containing the character 'F'. *) -module Selective_string_validator = E.String_validator +module Selective_string_validator = Mock_String_validator (Selective_character_validator) (* === Tests =============================================================== *) From 40bd10c0161ed2f614528be921cac5d08cea9989 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 17 May 2023 18:21:16 +0100 Subject: [PATCH 181/199] xapi-stdext-encodings: read 4 bytes at a time in ASCII fastpath MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Speeds up validation considerably, achieving > 1700 MiB/s. The idea to use subtraction and bit twiddling for checking the range of bytes in a word is from: https://graphics.stanford.edu/~seander/bithacks.html#HasLessInWord However the formula is simplified significantly taking advantage that we also check that the MSB in each byte (0x80) is clear in the first place. Signed-off-by: Edwin Török --- lib/xapi-stdext-encodings/encodings.ml | 72 +++++++++++++------------- 1 file changed, 36 insertions(+), 36 deletions(-) diff --git a/lib/xapi-stdext-encodings/encodings.ml b/lib/xapi-stdext-encodings/encodings.ml index 51743f14d69..eafdff31497 100644 --- a/lib/xapi-stdext-encodings/encodings.ml +++ b/lib/xapi-stdext-encodings/encodings.ml @@ -80,74 +80,74 @@ end exception Validation_error of int * exn module UTF8_XML : STRING_VALIDATOR = struct - let validate = XML_UTF8_UCS_validator.validate let decode_continuation_byte byte = if byte land 0b11000000 = 0b10000000 then byte land 0b00111111 else raise UTF8_continuation_byte_invalid - [@@inline] let rec decode_continuation_bytes string last value index = if index <= last then - let chunk = (decode_continuation_byte[@inlined]) (Char.code string.[index]) in + let chunk = decode_continuation_byte (Char.code string.[index]) in let value = (value lsl 6) lor chunk in decode_continuation_bytes string last value (index + 1) else value - let validate_character_long_utf8 string byte index = + let validate_character_utf8 string byte index = let value, width = + if byte land 0b10000000 = 0b00000000 then (byte, 1) else if byte land 0b11100000 = 0b11000000 then (byte land 0b0011111, 2) else if byte land 0b11110000 = 0b11100000 then (byte land 0b0001111, 3) else if byte land 0b11111000 = 0b11110000 then (byte land 0b0000111, 4) else raise UTF8_header_byte_invalid in - let value = decode_continuation_bytes string (index+width-1) value (index+1) + let value = + if width = 1 then value + else decode_continuation_bytes string (index+width-1) value (index+1) in - validate (Uchar.unsafe_of_int value); + XML_UTF8_UCS_validator.validate (Uchar.unsafe_of_int value); width - [@@inline never][@@local never][@@specialise never] - let validate_byte byte = validate (Uchar.unsafe_of_int byte)[@@inline] - - let validate_character_utf8 string byte index = - if byte land 0b10000000 = 0b00000000 then begin - validate (Uchar.unsafe_of_int byte); - 1 - end else validate_character_long_utf8 string byte index - [@@inline] - - let validate_character string index = - if index + 1 < String.length string then - let i16 = String.get_uint16_le string index in - if (i16 land 0x80_80 = 0) then begin - validate_byte (i16 land 0xff); - validate_byte (i16 lsr 8); - 2 - end - else - validate_character_utf8 string (i16 land 0xff) index - else - let byte = Char.code string.[index] in - validate_character_utf8 string byte index - [@@inline] - - let raise_validation_error index error = raise (Validation_error(index, error)) - [@@inline never][@@local never][@@specialise never] - let rec validate_aux string length index = if index = length then () else let width = - try (validate_character[@inlined]) string index + try + let byte = string.[index] |> Char.code in + validate_character_utf8 string byte index with | Invalid_argument _ -> raise String_incomplete - | error -> raise_validation_error index error + | error -> raise (Validation_error(index, error)) in validate_aux string length (index + width) let validate string = validate_aux string (String.length string) 0 + let rec validate_with_fastpath string stop pos = + if pos < stop then + (* the compiler is smart enough to optimize the 'int32' away here, + and not allocate *) + let i32 = String.get_int32_ne string pos |> Int32.to_int in + (* test that for all bytes 0x20 <= byte < 0x80. + If any is <0x20 it would cause a negative value to appear in that byte, + which we can detect if we use 0x80 as a mask. + Byte >= 0x80 can be similarly detected with a mask of 0x80 on each byte. + We don't want to see a 0x80 from either of these, hence we bitwise or the 2 values together. + *) + if (i32 lor (i32 - 0x20_20_20_20)) land 0x80_80_80_80 = 0 then + validate_with_fastpath string stop (pos + 4) + else (* when the condition doesn't hold fall back to full UTF8 decoder *) + validate_aux string (String.length string) pos + else + validate_aux string (String.length string) pos + + let validate_with_fastpath string = + validate_with_fastpath string (String.length string - 3) 0 + + let validate = + if Sys.word_size = 64 then validate_with_fastpath + else validate + let is_valid string = try validate string; true with _ -> false From 2d7146f4a94df4c9ca269a12a55b1fd72326f77d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 17 May 2023 19:24:34 +0100 Subject: [PATCH 182/199] xapi-stdext-encodings: rename forbidden to illegal MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- lib/xapi-stdext-encodings/encodings.ml | 4 ++-- lib/xapi-stdext-encodings/encodings.mli | 4 ++-- lib/xapi-stdext-encodings/test.ml | 18 +++++++++--------- 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/lib/xapi-stdext-encodings/encodings.ml b/lib/xapi-stdext-encodings/encodings.ml index eafdff31497..2e1000556e9 100644 --- a/lib/xapi-stdext-encodings/encodings.ml +++ b/lib/xapi-stdext-encodings/encodings.ml @@ -33,7 +33,7 @@ end module XML = struct - let is_forbidden_control_character value = let value = Uchar.to_int value in + let is_illegal_control_character value = let value = Uchar.to_int value in value < 0x20 && value <> 0x09 && value <> 0x0a @@ -62,7 +62,7 @@ module XML_UTF8_UCS_validator = struct let validate value = (UTF8_UCS_validator.validate[@inlined]) value; - if (XML.is_forbidden_control_character[@inlined]) value + if (XML.is_illegal_control_character[@inlined]) value then raise UCS_value_prohibited_in_XML end diff --git a/lib/xapi-stdext-encodings/encodings.mli b/lib/xapi-stdext-encodings/encodings.mli index fe06b6b2cbc..f149b5134bb 100644 --- a/lib/xapi-stdext-encodings/encodings.mli +++ b/lib/xapi-stdext-encodings/encodings.mli @@ -39,9 +39,9 @@ module XML_UTF8_UCS_validator : UCS_VALIDATOR module XML : sig (** Returns true if and only if the given value corresponds to - * a forbidden control character as defined in section 2.2 of + * a illegal control character as defined in section 2.2 of * the XML specification, version 1.0. *) - val is_forbidden_control_character : Uchar.t -> bool + val is_illegal_control_character : Uchar.t -> bool end (** {2 String Validators} *) diff --git a/lib/xapi-stdext-encodings/test.ml b/lib/xapi-stdext-encodings/test.ml index db95e00b1ee..ff27a10e191 100644 --- a/lib/xapi-stdext-encodings/test.ml +++ b/lib/xapi-stdext-encodings/test.ml @@ -272,16 +272,16 @@ end module XML = struct include E.XML - let test_is_forbidden_control_character () = - assert_true (is_forbidden_control_character (Uchar.of_int 0x00)); - assert_true (is_forbidden_control_character (Uchar.of_int 0x19)); - assert_false (is_forbidden_control_character (Uchar.of_int 0x09)); - assert_false (is_forbidden_control_character (Uchar.of_int 0x0a)); - assert_false (is_forbidden_control_character (Uchar.of_int 0x0d)); - assert_false (is_forbidden_control_character (Uchar.of_int 0x20)) + let test_is_illegal_control_character () = + assert_true (is_illegal_control_character (Uchar.of_int 0x00)); + assert_true (is_illegal_control_character (Uchar.of_int 0x19)); + assert_false (is_illegal_control_character (Uchar.of_int 0x09)); + assert_false (is_illegal_control_character (Uchar.of_int 0x0a)); + assert_false (is_illegal_control_character (Uchar.of_int 0x0d)); + assert_false (is_illegal_control_character (Uchar.of_int 0x20)) let tests = - [ "test_is_forbidden_control_character", `Quick, test_is_forbidden_control_character + [ "test_is_illegal_control_character", `Quick, test_is_illegal_control_character ] end @@ -309,7 +309,7 @@ module XML_UTF8_UCS_validator = struct include E.XML_UTF8_UCS_validator then Alcotest.check_raises "should fail" E.UCS_value_prohibited_in_UTF8 (fun () -> validate !value) else - if Uchar.is_valid !value && XML.is_forbidden_control_character (Uchar.of_int !value) + if Uchar.is_valid !value && XML.is_illegal_control_character (Uchar.of_int !value) then Alcotest.check_raises "should fail" E.UCS_value_prohibited_in_XML (fun () -> validate !value) else From 1e1559c40eb1efd75cdd46ef294f93b60df22aab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 24 May 2023 14:18:24 +0100 Subject: [PATCH 183/199] add bechamel as test dependencies to fix "dune build @check" test MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- xapi-stdext-encodings.opam | 3 +++ 1 file changed, 3 insertions(+) diff --git a/xapi-stdext-encodings.opam b/xapi-stdext-encodings.opam index 8d7eeb152fa..b1b79c5f645 100644 --- a/xapi-stdext-encodings.opam +++ b/xapi-stdext-encodings.opam @@ -10,6 +10,9 @@ depends: [ "dune" {>= "2.7"} "ocaml" "alcotest" {>= "0.6.0" & with-test} + "bechamel" { with-test} + "bechamel-notty" { with-test} + "notty" { with-test} "odoc" {with-doc} ] build: [ From 89a6ce2174e5694977a7de5ba9d5ac5108ef5105 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 23 Aug 2023 14:41:50 +0100 Subject: [PATCH 184/199] CA-382014: blkgetsize: fix return type mismatch MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Noticed by an LTO enabled build at link time of a binary using xapi-stdext-unix. Fix the type and move the prototype declaration to a header file that is included by both C files. That way a mismatch in the prototype will always result in a compilation error instead of a potential LTO warning. Signed-off-by: Edwin Török --- lib/xapi-stdext-unix/blkgetsize.h | 6 ++++++ lib/xapi-stdext-unix/blkgetsize_stubs.c | 1 + lib/xapi-stdext-unix/unixext_stubs.c | 3 ++- 3 files changed, 9 insertions(+), 1 deletion(-) create mode 100644 lib/xapi-stdext-unix/blkgetsize.h diff --git a/lib/xapi-stdext-unix/blkgetsize.h b/lib/xapi-stdext-unix/blkgetsize.h new file mode 100644 index 00000000000..a9cd75bfedc --- /dev/null +++ b/lib/xapi-stdext-unix/blkgetsize.h @@ -0,0 +1,6 @@ +#ifndef BLKGETSIZE_H +#define BLKGETSIZE_H + +#include +int stdext_blkgetsize(int fd, uint64_t *psize); +#endif diff --git a/lib/xapi-stdext-unix/blkgetsize_stubs.c b/lib/xapi-stdext-unix/blkgetsize_stubs.c index 78fc6e52acf..0324f3dfb3f 100644 --- a/lib/xapi-stdext-unix/blkgetsize_stubs.c +++ b/lib/xapi-stdext-unix/blkgetsize_stubs.c @@ -30,6 +30,7 @@ #include #include +#include "blkgetsize.h" #ifdef __linux__ #include diff --git a/lib/xapi-stdext-unix/unixext_stubs.c b/lib/xapi-stdext-unix/unixext_stubs.c index e27142b2848..091cacae35d 100644 --- a/lib/xapi-stdext-unix/unixext_stubs.c +++ b/lib/xapi-stdext-unix/unixext_stubs.c @@ -36,6 +36,8 @@ #include #include +#include "blkgetsize.h" + /* Set the TCP_NODELAY flag on a Unix.file_descr */ CAMLprim value stub_unixext_set_tcp_nodelay (value fd, value bool) { @@ -61,7 +63,6 @@ CAMLprim value stub_unixext_fsync (value fd) CAMLreturn(Val_unit); } -extern uint64_t stdext_blkgetsize(int fd, uint64_t *psize); CAMLprim value stub_unixext_blkgetsize64(value fd) { From ba88a00f73fe9bdccef0554e88d89822e16c47a5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 23 Aug 2023 14:48:15 +0100 Subject: [PATCH 185/199] CA-382014: unixext_stubs: fix const warning MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit unixext_stubs.c:132:21: warning: assignment discards ‘const’ qualifier from pointer target type [-Wdiscarded-qualifiers] 132 | exn = caml_named_value("unixext.unix_error"); | ^ Signed-off-by: Edwin Török --- lib/xapi-stdext-unix/unixext_stubs.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/xapi-stdext-unix/unixext_stubs.c b/lib/xapi-stdext-unix/unixext_stubs.c index 091cacae35d..28fd7f9af89 100644 --- a/lib/xapi-stdext-unix/unixext_stubs.c +++ b/lib/xapi-stdext-unix/unixext_stubs.c @@ -126,7 +126,7 @@ CAMLprim value stub_unixext_set_sock_keepalives(value fd, value count, value idl void unixext_error(int code) { - static value *exn = NULL; + static const value *exn = NULL; if (!exn) { exn = caml_named_value("unixext.unix_error"); From 3db50c3069fa84941ef1dca7c18779e56ecc56f7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 23 Aug 2023 14:52:50 +0100 Subject: [PATCH 186/199] fixup! add bechamel as test dependencies to fix "dune build @check" test MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- dune-project | 3 +++ xapi-stdext-encodings.opam | 6 +++--- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/dune-project b/dune-project index 1bc01308d59..816c9d11712 100644 --- a/dune-project +++ b/dune-project @@ -44,6 +44,9 @@ ocaml (alcotest (and (>= 0.6.0) :with-test)) (odoc :with-doc) + (bechamel :with-test) + (bechamel-notty :with-test) + (notty :with-test) ) ) diff --git a/xapi-stdext-encodings.opam b/xapi-stdext-encodings.opam index b1b79c5f645..ef3a75cd38a 100644 --- a/xapi-stdext-encodings.opam +++ b/xapi-stdext-encodings.opam @@ -10,10 +10,10 @@ depends: [ "dune" {>= "2.7"} "ocaml" "alcotest" {>= "0.6.0" & with-test} - "bechamel" { with-test} - "bechamel-notty" { with-test} - "notty" { with-test} "odoc" {with-doc} + "bechamel" {with-test} + "bechamel-notty" {with-test} + "notty" {with-test} ] build: [ ["dune" "subst"] {dev} From 1456ab746467e13460f0ce65f82a958ee1d0b45c Mon Sep 17 00:00:00 2001 From: Steven Woods Date: Tue, 24 Oct 2023 15:07:12 +0100 Subject: [PATCH 187/199] Create a function to recursively remove files Signed-off-by: Steven Woods --- lib/xapi-stdext-unix/unixext.ml | 22 ++++++++++++++++++++++ lib/xapi-stdext-unix/unixext.mli | 6 ++++++ 2 files changed, 28 insertions(+) diff --git a/lib/xapi-stdext-unix/unixext.ml b/lib/xapi-stdext-unix/unixext.ml index 6016082286e..ba8f418aef0 100644 --- a/lib/xapi-stdext-unix/unixext.ml +++ b/lib/xapi-stdext-unix/unixext.ml @@ -34,6 +34,28 @@ let mkdir_rec dir perm = mkdir_safe dir perm in p_mkdir dir +(** removes a file or recursively removes files/directories below a directory without following + symbolic links. If path is a directory, it is only itself removed if rm_top is true. If path + is non-existent nothing happens, it does not lead to an error. *) +let rm_rec ?(rm_top = true) path = + let ( // ) = Filename.concat in + let rec rm rm_top path = + match Unix.lstat path with + | exception Unix.Unix_error (Unix.ENOENT, _, _) -> + () (*noop*) + | exception e -> + raise e + | st -> ( + match st.Unix.st_kind with + | Unix.S_DIR -> + Sys.readdir path |> Array.iter (fun file -> rm true (path // file)) ; + if rm_top then Unix.rmdir path + | _ -> + Unix.unlink path + ) + in + rm rm_top path + (** write a pidfile file *) let pidfile_write filename = let fd = Unix.openfile filename diff --git a/lib/xapi-stdext-unix/unixext.mli b/lib/xapi-stdext-unix/unixext.mli index ce9c7750e64..032270d45fe 100644 --- a/lib/xapi-stdext-unix/unixext.mli +++ b/lib/xapi-stdext-unix/unixext.mli @@ -17,6 +17,12 @@ val _exit : int -> unit val unlink_safe : string -> unit val mkdir_safe : string -> Unix.file_perm -> unit val mkdir_rec : string -> Unix.file_perm -> unit + +(** removes a file or recursively removes files/directories below a directory without following + symbolic links. If path is a directory, it is only itself removed if rm_top is true. If path + is non-existent nothing happens, it does not lead to an error. *) +val rm_rec : ?rm_top:bool -> string -> unit + val pidfile_write : string -> unit val pidfile_read : string -> int option val daemonize : unit -> unit From 42f237c8454e88487edb3bff2383c5e3f4bf36f0 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 30 Oct 2023 10:54:34 +0000 Subject: [PATCH 188/199] opam: update metadata Signed-off-by: Pau Ruiz Safont --- dune-project | 6 +++--- xapi-stdext-encodings.opam | 3 ++- xapi-stdext-std.opam | 2 +- xapi-stdext-unix.opam | 4 +++- 4 files changed, 9 insertions(+), 6 deletions(-) diff --git a/dune-project b/dune-project index 816c9d11712..2f53c2c814a 100644 --- a/dune-project +++ b/dune-project @@ -41,7 +41,7 @@ (name xapi-stdext-encodings) (synopsis "Xapi's standard library extension, Encodings") (depends - ocaml + (ocaml (>= 4.13)) (alcotest (and (>= 0.6.0) :with-test)) (odoc :with-doc) (bechamel :with-test) @@ -65,7 +65,7 @@ (name xapi-stdext-std) (synopsis "Xapi's standard library extension, Stdlib") (depends - ocaml + (ocaml (>= 4.08)) (alcotest :with-test) (odoc :with-doc) ) @@ -87,7 +87,7 @@ (name xapi-stdext-unix) (synopsis "Xapi's standard library extension, Unix") (depends - ocaml + (ocaml (>= 4.12)) base-unix (fd-send-recv (>= 2.0.0)) (odoc :with-doc) diff --git a/xapi-stdext-encodings.opam b/xapi-stdext-encodings.opam index ef3a75cd38a..fc0eff53640 100644 --- a/xapi-stdext-encodings.opam +++ b/xapi-stdext-encodings.opam @@ -8,13 +8,14 @@ homepage: "https://github.com/xapi-project/stdext" bug-reports: "https://github.com/xapi-project/stdext/issues" depends: [ "dune" {>= "2.7"} - "ocaml" + "ocaml" {>= "4.13.0"} "alcotest" {>= "0.6.0" & with-test} "odoc" {with-doc} "bechamel" {with-test} "bechamel-notty" {with-test} "notty" {with-test} ] +available: arch != "arm32" & arch != "x86_32" build: [ ["dune" "subst"] {dev} [ diff --git a/xapi-stdext-std.opam b/xapi-stdext-std.opam index 833fc64b831..63e2c9ae142 100644 --- a/xapi-stdext-std.opam +++ b/xapi-stdext-std.opam @@ -8,7 +8,7 @@ homepage: "https://github.com/xapi-project/stdext" bug-reports: "https://github.com/xapi-project/stdext/issues" depends: [ "dune" {>= "2.7"} - "ocaml" + "ocaml" {>= "4.08.0"} "alcotest" {with-test} "odoc" {with-doc} ] diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam index e7e2b807a69..c3fd4c2a692 100644 --- a/xapi-stdext-unix.opam +++ b/xapi-stdext-unix.opam @@ -8,12 +8,14 @@ homepage: "https://github.com/xapi-project/stdext" bug-reports: "https://github.com/xapi-project/stdext/issues" depends: [ "dune" {>= "2.7"} - "ocaml" + "ocaml" {>= "4.12.0"} "base-unix" "fd-send-recv" {>= "2.0.0"} "odoc" {with-doc} "xapi-stdext-pervasives" {= version} ] +depexts: ["linux-headers"] {os-distribution = "alpine"} +available: [ os = "macos" | os = "linux" ] build: [ ["dune" "subst"] {dev} [ From aff670e0ba20dba1a72ac2d9141fa10e03ddba52 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 30 Oct 2023 11:09:04 +0000 Subject: [PATCH 189/199] changes: add log for missing versions Signed-off-by: Pau Ruiz Safont --- CHANGES.md | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 9ffce4a0c5c..581f1c96616 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,11 @@ +## v4.23.0 (30-Oct-2023) +- unix: fix blkgetsize return type mismatch (CA-382014) +- unix: add function to recursively remove files + +## v4.22.0 (24-May-2023) +- date, pervasive, std: remove deprecated code +- encodings: Optimize XML_UTF8.is_valid: avoid allocating an int32 for each unicode codepoint + ## v4.21.0 (29-Nov-2022) - unix: add permissions to write_{bytes,string}_to_file - Use a dune version with fixed metadata generation From 665a15f766d2df70ee3f28e02c1147cd2de05804 Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Wed, 22 Nov 2023 15:06:55 +0000 Subject: [PATCH 190/199] Apply OCaml format for `threadext.mli` Signed-off-by: Vincent Liu --- lib/xapi-stdext-threads/threadext.mli | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/lib/xapi-stdext-threads/threadext.mli b/lib/xapi-stdext-threads/threadext.mli index 7c154688011..62bb50d8c0b 100644 --- a/lib/xapi-stdext-threads/threadext.mli +++ b/lib/xapi-stdext-threads/threadext.mli @@ -11,17 +11,17 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -module Mutex : -sig +module Mutex : sig val execute : Mutex.t -> (unit -> 'a) -> 'a end -val thread_iter_all_exns: ('a -> unit) -> 'a list -> ('a * exn) list -val thread_iter: ('a -> unit) -> 'a list -> unit +val thread_iter_all_exns : ('a -> unit) -> 'a list -> ('a * exn) list -module Delay : -sig +val thread_iter : ('a -> unit) -> 'a list -> unit + +module Delay : sig type t + val make : unit -> t (** Blocks the calling thread for a given period of time with the option of returning early if someone calls 'signal'. Returns true if the full time From 2cf1b2f98fedd5ebfb27a74b9c5096b77a612305 Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Wed, 22 Nov 2023 15:07:26 +0000 Subject: [PATCH 191/199] Fix association of special comments in `threadext.mli` Signed-off-by: Vincent Liu --- lib/xapi-stdext-threads/threadext.mli | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/xapi-stdext-threads/threadext.mli b/lib/xapi-stdext-threads/threadext.mli index 62bb50d8c0b..8349ab71366 100644 --- a/lib/xapi-stdext-threads/threadext.mli +++ b/lib/xapi-stdext-threads/threadext.mli @@ -23,13 +23,13 @@ module Delay : sig type t val make : unit -> t + + val wait : t -> float -> bool (** Blocks the calling thread for a given period of time with the option of returning early if someone calls 'signal'. Returns true if the full time period elapsed and false if signalled. Note that multple 'signals' are coalesced; 'signals' sent before 'wait' is called are not lost. *) - val wait : t -> float -> bool - (** Sends a signal to a waiting thread. See 'wait' *) - val signal : t -> unit + (** Sends a signal to a waiting thread. See 'wait' *) end From 7f89e3f9ccabf9e56c2e1a5bc7fed49100fe7377 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 21 Nov 2023 11:25:48 +0000 Subject: [PATCH 192/199] [maintenance]: fix dune-project MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The opam files were hand edited, but they are generated from 'dune-project', so running 'dune build' would undo any changes. Fixes https://github.com/xapi-project/stdext/issues/78 Fixes: 42f237c ("opam: update metadata") No functional change. Signed-off-by: Edwin Török --- dune-project | 6 +++--- xapi-stdext-encodings.opam | 2 +- xapi-stdext-encodings.opam.template | 1 + xapi-stdext-unix-opam.template | 2 ++ xapi-stdext-unix.opam | 4 ++-- xapi-stdext-unix.opam.template | 2 ++ 6 files changed, 11 insertions(+), 6 deletions(-) create mode 100644 xapi-stdext-encodings.opam.template create mode 100644 xapi-stdext-unix-opam.template create mode 100644 xapi-stdext-unix.opam.template diff --git a/dune-project b/dune-project index 2f53c2c814a..4a5dce3ea07 100644 --- a/dune-project +++ b/dune-project @@ -41,7 +41,7 @@ (name xapi-stdext-encodings) (synopsis "Xapi's standard library extension, Encodings") (depends - (ocaml (>= 4.13)) + (ocaml (>= 4.13.0)) (alcotest (and (>= 0.6.0) :with-test)) (odoc :with-doc) (bechamel :with-test) @@ -65,7 +65,7 @@ (name xapi-stdext-std) (synopsis "Xapi's standard library extension, Stdlib") (depends - (ocaml (>= 4.08)) + (ocaml (>= 4.08.0)) (alcotest :with-test) (odoc :with-doc) ) @@ -87,7 +87,7 @@ (name xapi-stdext-unix) (synopsis "Xapi's standard library extension, Unix") (depends - (ocaml (>= 4.12)) + (ocaml (>= 4.12.0)) base-unix (fd-send-recv (>= 2.0.0)) (odoc :with-doc) diff --git a/xapi-stdext-encodings.opam b/xapi-stdext-encodings.opam index fc0eff53640..6de3223c96d 100644 --- a/xapi-stdext-encodings.opam +++ b/xapi-stdext-encodings.opam @@ -15,7 +15,6 @@ depends: [ "bechamel-notty" {with-test} "notty" {with-test} ] -available: arch != "arm32" & arch != "x86_32" build: [ ["dune" "subst"] {dev} [ @@ -31,3 +30,4 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/stdext.git" +available: arch != "arm32" & arch != "x86_32" diff --git a/xapi-stdext-encodings.opam.template b/xapi-stdext-encodings.opam.template new file mode 100644 index 00000000000..66595f2d564 --- /dev/null +++ b/xapi-stdext-encodings.opam.template @@ -0,0 +1 @@ +available: arch != "arm32" & arch != "x86_32" diff --git a/xapi-stdext-unix-opam.template b/xapi-stdext-unix-opam.template new file mode 100644 index 00000000000..ae75bf72ee5 --- /dev/null +++ b/xapi-stdext-unix-opam.template @@ -0,0 +1,2 @@ +depexts: ["linux-headers"] {os-distribution = "alpine"} +available: [ os = "macos" | os = "linux" ] diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam index c3fd4c2a692..1498e2bb763 100644 --- a/xapi-stdext-unix.opam +++ b/xapi-stdext-unix.opam @@ -14,8 +14,6 @@ depends: [ "odoc" {with-doc} "xapi-stdext-pervasives" {= version} ] -depexts: ["linux-headers"] {os-distribution = "alpine"} -available: [ os = "macos" | os = "linux" ] build: [ ["dune" "subst"] {dev} [ @@ -31,3 +29,5 @@ build: [ ] ] dev-repo: "git+https://github.com/xapi-project/stdext.git" +depexts: ["linux-headers"] {os-distribution = "alpine"} +available: [ os = "macos" | os = "linux" ] diff --git a/xapi-stdext-unix.opam.template b/xapi-stdext-unix.opam.template new file mode 100644 index 00000000000..ae75bf72ee5 --- /dev/null +++ b/xapi-stdext-unix.opam.template @@ -0,0 +1,2 @@ +depexts: ["linux-headers"] {os-distribution = "alpine"} +available: [ os = "macos" | os = "linux" ] From 93e205316f316ad20b79d4610196b316b9a4f247 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 28 Nov 2023 17:43:41 +0000 Subject: [PATCH 193/199] [maintenance]: run ocamlformat MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 'make format' with ocamlformat 0.22.4 No functional change. Signed-off-by: Edwin Török --- lib/xapi-stdext-date/date.mli | 4 +- .../bench/bechamel_simple_cli.ml | 36 +- .../bench/bench_encodings.ml | 17 +- lib/xapi-stdext-encodings/encodings.ml | 143 ++-- lib/xapi-stdext-encodings/encodings.mli | 18 +- lib/xapi-stdext-encodings/test.ml | 628 +++++++++------ lib/xapi-stdext-pervasives/pervasiveext.ml | 4 +- lib/xapi-stdext-std/listext.mli | 1 - lib/xapi-stdext-std/listext_test.ml | 2 +- lib/xapi-stdext-std/xstringext.ml | 3 +- lib/xapi-stdext-std/xstringext.mli | 2 +- lib/xapi-stdext-std/xstringext_test.ml | 5 +- lib/xapi-stdext-threads/semaphore.ml | 55 +- lib/xapi-stdext-threads/semaphore.mli | 12 +- lib/xapi-stdext-threads/threadext.ml | 121 +-- lib/xapi-stdext-unix/unixext.ml | 754 ++++++++++-------- lib/xapi-stdext-unix/unixext.mli | 168 ++-- lib/xapi-stdext-zerocheck/zerocheck.mli | 2 +- 18 files changed, 1135 insertions(+), 840 deletions(-) diff --git a/lib/xapi-stdext-date/date.mli b/lib/xapi-stdext-date/date.mli index 1255608bfce..62e894808bf 100644 --- a/lib/xapi-stdext-date/date.mli +++ b/lib/xapi-stdext-date/date.mli @@ -98,8 +98,8 @@ val of_string : string -> t val never : t (** Same as {!epoch} *) -type iso8601 = t (** Deprecated alias for {!t} *) +type iso8601 = t -type rfc822 = t (** Deprecated alias for {!t} *) +type rfc822 = t diff --git a/lib/xapi-stdext-encodings/bench/bechamel_simple_cli.ml b/lib/xapi-stdext-encodings/bench/bechamel_simple_cli.ml index d4e58e52c51..fef03cce765 100644 --- a/lib/xapi-stdext-encodings/bench/bechamel_simple_cli.ml +++ b/lib/xapi-stdext-encodings/bench/bechamel_simple_cli.ml @@ -10,10 +10,11 @@ let benchmark tests = let analyze raw_results = let ols = - Analyze.ols ~r_square:true ~bootstrap:0 ~predictors:[|Measure.run|] + Analyze.ols ~r_square:true ~bootstrap:0 ~predictors:[|Measure.run|] in let results = - List.map (fun instance -> Analyze.all ols instance raw_results) instances in + List.map (fun instance -> Analyze.all ols instance raw_results) instances + in (Analyze.merge ols instances results, raw_results) let () = @@ -26,26 +27,25 @@ let img (window, results) = open Notty_unix let cli tests = - Format.printf "@,Running benchmarks@."; + Format.printf "@,Running benchmarks@." ; let results, _ = tests |> benchmark |> analyze in - (* compute speed from duration *) let () = - Hashtbl.find results (Measure.label Instance.monotonic_clock) - |> Hashtbl.iter @@ fun name result -> - try - (* this relies on extracting input size from test name, - which works if Test.make_indexed* was used *) - Scanf.sscanf name "%_s@:%d" @@ fun length -> - match Analyze.OLS.estimates result with - | Some [duration] -> - (* unit is ns *) - let speed = 1e9 *. float length /. duration /. 1048576.0 in - Fmt.pf Fmt.stdout "@[%s = %.1f MiB/s@]@." name speed - | _ -> () - with Failure _ | Scanf.Scan_failure _ -> () + Hashtbl.find results (Measure.label Instance.monotonic_clock) + |> Hashtbl.iter @@ fun name result -> + try + (* this relies on extracting input size from test name, + which works if Test.make_indexed* was used *) + Scanf.sscanf name "%_s@:%d" @@ fun length -> + match Analyze.OLS.estimates result with + | Some [duration] -> + (* unit is ns *) + let speed = 1e9 *. float length /. duration /. 1048576.0 in + Fmt.pf Fmt.stdout "@[%s = %.1f MiB/s@]@." name speed + | _ -> + () + with Failure _ | Scanf.Scan_failure _ -> () in - let window = match winsize Unix.stdout with | Some (w, h) -> diff --git a/lib/xapi-stdext-encodings/bench/bench_encodings.ml b/lib/xapi-stdext-encodings/bench/bench_encodings.ml index 4bb2426c1b5..7308c756d8b 100644 --- a/lib/xapi-stdext-encodings/bench/bench_encodings.ml +++ b/lib/xapi-stdext-encodings/bench/bench_encodings.ml @@ -2,17 +2,14 @@ open Bechamel open Xapi_stdext_encodings.Encodings let test name f = - Test.make_indexed_with_resource ~name - ~args:[10; 1000; 10000] - Test.multiple (* TODO: Test.uniq segfaults here, bechamel bug *) - ~allocate:(fun i -> String.make i 'x') - ~free:ignore - (fun (_:int) -> Staged.stage f) + Test.make_indexed_with_resource ~name ~args:[10; 1000; 10000] + Test.multiple (* TODO: Test.uniq segfaults here, bechamel bug *) + ~allocate:(fun i -> String.make i 'x') + ~free:ignore + (fun (_ : int) -> Staged.stage f) let benchmarks = Test.make_grouped ~name:"Encodings.validate" - [ test "UTF8_XML" UTF8_XML.validate - ] + [test "UTF8_XML" UTF8_XML.validate] -let () = - Bechamel_simple_cli.cli benchmarks +let () = Bechamel_simple_cli.cli benchmarks diff --git a/lib/xapi-stdext-encodings/encodings.ml b/lib/xapi-stdext-encodings/encodings.ml index 2e1000556e9..62058acc73b 100644 --- a/lib/xapi-stdext-encodings/encodings.ml +++ b/lib/xapi-stdext-encodings/encodings.ml @@ -12,77 +12,76 @@ * GNU Lesser General Public License for more details. *) exception UCS_value_out_of_range + exception UCS_value_prohibited_in_UTF8 + exception UCS_value_prohibited_in_XML + exception UTF8_character_incomplete + exception UTF8_header_byte_invalid + exception UTF8_continuation_byte_invalid + exception UTF8_encoding_not_canonical + exception String_incomplete (* === Unicode Functions === *) module UCS = struct - - let is_non_character value = false - || (0xfdd0 <= value && value <= 0xfdef) (* case 1 *) - || (Int.logand 0xfffe value = 0xfffe) (* case 2 *) - [@@inline] - + let is_non_character value = + false + || (0xfdd0 <= value && value <= 0xfdef) (* case 1 *) + || Int.logand 0xfffe value = 0xfffe + (* case 2 *) + [@@inline] end module XML = struct - - let is_illegal_control_character value = let value = Uchar.to_int value in - value < 0x20 - && value <> 0x09 - && value <> 0x0a - && value <> 0x0d - [@@inline] - + let is_illegal_control_character value = + let value = Uchar.to_int value in + value < 0x20 && value <> 0x09 && value <> 0x0a && value <> 0x0d + [@@inline] end (* === UCS Validators === *) module type UCS_VALIDATOR = sig - val validate : Uchar.t -> unit [@@inline] - end module UTF8_UCS_validator = struct - let validate value = - if (UCS.is_non_character[@inlined]) (Uchar.to_int value) then raise UCS_value_prohibited_in_UTF8 + if (UCS.is_non_character [@inlined]) (Uchar.to_int value) then + raise UCS_value_prohibited_in_UTF8 [@@inline] - end module XML_UTF8_UCS_validator = struct - let validate value = - (UTF8_UCS_validator.validate[@inlined]) value; - if (XML.is_illegal_control_character[@inlined]) value - then raise UCS_value_prohibited_in_XML - + (UTF8_UCS_validator.validate [@inlined]) value ; + if (XML.is_illegal_control_character [@inlined]) value then + raise UCS_value_prohibited_in_XML end (* === String Validators === *) module type STRING_VALIDATOR = sig - val is_valid : string -> bool + val validate : string -> unit - val longest_valid_prefix : string -> string + val longest_valid_prefix : string -> string end exception Validation_error of int * exn module UTF8_XML : STRING_VALIDATOR = struct - let decode_continuation_byte byte = - if byte land 0b11000000 = 0b10000000 then byte land 0b00111111 else + if byte land 0b11000000 = 0b10000000 then + byte land 0b00111111 + else raise UTF8_continuation_byte_invalid let rec decode_continuation_bytes string last value index = @@ -90,69 +89,79 @@ module UTF8_XML : STRING_VALIDATOR = struct let chunk = decode_continuation_byte (Char.code string.[index]) in let value = (value lsl 6) lor chunk in decode_continuation_bytes string last value (index + 1) - else value + else + value let validate_character_utf8 string byte index = let value, width = - if byte land 0b10000000 = 0b00000000 then (byte, 1) else - if byte land 0b11100000 = 0b11000000 then (byte land 0b0011111, 2) else - if byte land 0b11110000 = 0b11100000 then (byte land 0b0001111, 3) else - if byte land 0b11111000 = 0b11110000 then (byte land 0b0000111, 4) else + if byte land 0b10000000 = 0b00000000 then + (byte, 1) + else if byte land 0b11100000 = 0b11000000 then + (byte land 0b0011111, 2) + else if byte land 0b11110000 = 0b11100000 then + (byte land 0b0001111, 3) + else if byte land 0b11111000 = 0b11110000 then + (byte land 0b0000111, 4) + else raise UTF8_header_byte_invalid in let value = - if width = 1 then value - else decode_continuation_bytes string (index+width-1) value (index+1) + if width = 1 then + value + else + decode_continuation_bytes string (index + width - 1) value (index + 1) in - XML_UTF8_UCS_validator.validate (Uchar.unsafe_of_int value); + XML_UTF8_UCS_validator.validate (Uchar.unsafe_of_int value) ; width - + let rec validate_aux string length index = - if index = length then () + if index = length then + () else - let width = - try - let byte = string.[index] |> Char.code in - validate_character_utf8 string byte index - with - | Invalid_argument _ -> raise String_incomplete - | error -> raise (Validation_error(index, error)) - in - validate_aux string length (index + width) - - let validate string = - validate_aux string (String.length string) 0 + let width = + try + let byte = string.[index] |> Char.code in + validate_character_utf8 string byte index + with + | Invalid_argument _ -> + raise String_incomplete + | error -> + raise (Validation_error (index, error)) + in + validate_aux string length (index + width) + + let validate string = validate_aux string (String.length string) 0 let rec validate_with_fastpath string stop pos = if pos < stop then - (* the compiler is smart enough to optimize the 'int32' away here, - and not allocate *) - let i32 = String.get_int32_ne string pos |> Int32.to_int in - (* test that for all bytes 0x20 <= byte < 0x80. + (* the compiler is smart enough to optimize the 'int32' away here, + and not allocate *) + let i32 = String.get_int32_ne string pos |> Int32.to_int in + (* test that for all bytes 0x20 <= byte < 0x80. If any is <0x20 it would cause a negative value to appear in that byte, which we can detect if we use 0x80 as a mask. Byte >= 0x80 can be similarly detected with a mask of 0x80 on each byte. We don't want to see a 0x80 from either of these, hence we bitwise or the 2 values together. - *) - if (i32 lor (i32 - 0x20_20_20_20)) land 0x80_80_80_80 = 0 then - validate_with_fastpath string stop (pos + 4) - else (* when the condition doesn't hold fall back to full UTF8 decoder *) - validate_aux string (String.length string) pos - else + *) + if i32 lor (i32 - 0x20_20_20_20) land 0x80_80_80_80 = 0 then + validate_with_fastpath string stop (pos + 4) + else (* when the condition doesn't hold fall back to full UTF8 decoder *) validate_aux string (String.length string) pos + else + validate_aux string (String.length string) pos let validate_with_fastpath string = - validate_with_fastpath string (String.length string - 3) 0 + validate_with_fastpath string (String.length string - 3) 0 let validate = - if Sys.word_size = 64 then validate_with_fastpath - else validate + if Sys.word_size = 64 then + validate_with_fastpath + else + validate - let is_valid string = - try validate string; true with _ -> false + let is_valid string = try validate string ; true with _ -> false let longest_valid_prefix string = - try validate string; string + try validate string ; string with Validation_error (index, _) -> String.sub string 0 index - end diff --git a/lib/xapi-stdext-encodings/encodings.mli b/lib/xapi-stdext-encodings/encodings.mli index f149b5134bb..2a139ae3786 100644 --- a/lib/xapi-stdext-encodings/encodings.mli +++ b/lib/xapi-stdext-encodings/encodings.mli @@ -17,14 +17,20 @@ (** {2 Exceptions} *) exception UCS_value_out_of_range + exception UCS_value_prohibited_in_UTF8 + exception UCS_value_prohibited_in_XML + exception UTF8_character_incomplete + exception UTF8_header_byte_invalid + exception UTF8_continuation_byte_invalid + exception UTF8_encoding_not_canonical -exception String_incomplete +exception String_incomplete (** {2 UCS Validators} *) @@ -38,10 +44,10 @@ end module XML_UTF8_UCS_validator : UCS_VALIDATOR module XML : sig + val is_illegal_control_character : Uchar.t -> bool (** Returns true if and only if the given value corresponds to * a illegal control character as defined in section 2.2 of * the XML specification, version 1.0. *) - val is_illegal_control_character : Uchar.t -> bool end (** {2 String Validators} *) @@ -49,16 +55,14 @@ end (** Provides functionality for validating and processing * strings according to a particular character encoding. *) module type STRING_VALIDATOR = sig - - (** Returns true if and only if the given string is validly-encoded. *) val is_valid : string -> bool + (** Returns true if and only if the given string is validly-encoded. *) + val validate : string -> unit (** Raises an encoding error if the given string is not validly-encoded. *) - val validate: string -> unit - (** Returns the longest validly-encoded prefix of the given string. *) val longest_valid_prefix : string -> string - + (** Returns the longest validly-encoded prefix of the given string. *) end (** Represents a validation error as a tuple [(i,e)], where: diff --git a/lib/xapi-stdext-encodings/test.ml b/lib/xapi-stdext-encodings/test.ml index ff27a10e191..e94825accae 100644 --- a/lib/xapi-stdext-encodings/test.ml +++ b/lib/xapi-stdext-encodings/test.ml @@ -12,8 +12,9 @@ * GNU Lesser General Public License for more details. *) module E = Xapi_stdext_encodings.Encodings + (* Pull in the infix operators from Encodings used in this test *) -let (---), (+++), (<<<) = Int.sub, Int.add, Int.shift_left +let ( --- ), ( +++ ), ( <<< ) = (Int.sub, Int.add, Int.shift_left) (* === Mock exceptions ==================================================== *) @@ -23,7 +24,9 @@ exception Decode_error (* === Mock types ===========================================================*) (** Generates mock character widths, in bytes. *) -module type WIDTH_GENERATOR = sig val next : unit -> int end +module type WIDTH_GENERATOR = sig + val next : unit -> int +end (* === Mock UCS validators ================================================= *) @@ -34,7 +37,6 @@ end (* === Mock character validators ============================================= *) - (** A validator that succeeds for all characters. *) module Universal_character_validator = struct let validate _ = () @@ -42,7 +44,7 @@ end (** A validator that fails for all characters. *) module Failing_character_validator = struct - let validate _ = raise Decode_error + let validate _ = raise Decode_error end (** A validator that succeeds for all characters except the letter 'F'. *) @@ -54,299 +56,378 @@ end (* === Test helpers ======================================================== *) let assert_true = Alcotest.(check bool) "true" true + let assert_false = Alcotest.(check bool) "false" false + let check_indices = Alcotest.(check (list int)) "indices" let assert_raises_match exception_match fn = try - fn (); + fn () ; Alcotest.fail "assert_raises_match: failure expected" with failure -> - if not (exception_match failure) - then raise failure - else () - + if not (exception_match failure) then + raise failure + else + () (* === Mock codecs ========================================================= *) module UCS = struct (* === Unicode Functions === *) let min_value = 0x000000 - let max_value = 0x10ffff (* used to be 0x1fffff, but this changed and Unicode won't allocate larger than 0x10ffff *) - let is_non_character value = false - || (0xfdd0 <= value && value <= 0xfdef) (* case 1 *) - || (Int.logand 0xfffe value = 0xfffe) (* case 2 *) + let max_value = 0x10ffff + (* used to be 0x1fffff, but this changed and Unicode won't allocate larger than 0x10ffff *) + + let is_non_character value = + false + || (0xfdd0 <= value && value <= 0xfdef) (* case 1 *) + || Int.logand 0xfffe value = 0xfffe + (* case 2 *) - let is_out_of_range value = - value < min_value || value > max_value + let is_out_of_range value = value < min_value || value > max_value - let is_surrogate value = - (0xd800 <= value && value <= 0xdfff) + let is_surrogate value = 0xd800 <= value && value <= 0xdfff (** A list of UCS non-characters values, including: a. non-characters within the basic multilingual plane; b. non-characters at the end of the basic multilingual plane; c. non-characters at the end of the private use area. *) - let non_characters = [ - 0x00fdd0; 0x00fdef; (* case a. *) - 0x00fffe; 0x00ffff; (* case b. *) - 0x1ffffe; 0x1fffff; (* case c. *) - ] + let non_characters = + [ + 0x00fdd0 + ; 0x00fdef + ; (* case a. *) + 0x00fffe + ; 0x00ffff + ; (* case b. *) + 0x1ffffe + ; 0x1fffff (* case c. *) + ] (** A list of UCS character values located immediately before or after UCS non-character values, including: a. non-characters within the basic multilingual plane; b. non-characters at the end of the basic multilingual plane; c. non-characters at the end of the private use area. *) - let valid_characters_next_to_non_characters = [ - 0x00fdcf; 0x00fdf0; (* case a. *) - 0x00fffd; 0x010000; (* case b. *) - 0x1ffffd; 0x200000; (* case c. *) - ] + let valid_characters_next_to_non_characters = + [ + 0x00fdcf + ; 0x00fdf0 + ; (* case a. *) + 0x00fffd + ; 0x010000 + ; (* case b. *) + 0x1ffffd + ; 0x200000 (* case c. *) + ] let test_is_non_character () = - List.iter (fun value -> assert_true (is_non_character (value))) - non_characters; - List.iter (fun value -> assert_false (is_non_character (value))) - valid_characters_next_to_non_characters + List.iter (fun value -> assert_true (is_non_character value)) non_characters ; + List.iter + (fun value -> assert_false (is_non_character value)) + valid_characters_next_to_non_characters let test_is_out_of_range () = - assert_true (is_out_of_range (min_value --- 1)); - assert_false (is_out_of_range (min_value)); - assert_false (is_out_of_range (max_value)); - assert_true (is_out_of_range (max_value +++ 1)) + assert_true (is_out_of_range (min_value --- 1)) ; + assert_false (is_out_of_range min_value) ; + assert_false (is_out_of_range max_value) ; + assert_true (is_out_of_range (max_value +++ 1)) let test_is_surrogate () = - assert_false (is_surrogate (0xd7ff)); - assert_true (is_surrogate (0xd800)); - assert_true (is_surrogate (0xdfff)); - assert_false (is_surrogate (0xe000)) + assert_false (is_surrogate 0xd7ff) ; + assert_true (is_surrogate 0xd800) ; + assert_true (is_surrogate 0xdfff) ; + assert_false (is_surrogate 0xe000) let tests = - [ "test_is_non_character", `Quick, test_is_non_character - ; "test_is_out_of_range", `Quick, test_is_out_of_range - ; "test_is_surrogate", `Quick, test_is_surrogate + [ + ("test_is_non_character", `Quick, test_is_non_character) + ; ("test_is_out_of_range", `Quick, test_is_out_of_range) + ; ("test_is_surrogate", `Quick, test_is_surrogate) ] - end module Lenient_UTF8_codec = struct let decode_header_byte byte = - if byte land 0b10000000 = 0b00000000 then (byte , 1) else - if byte land 0b11100000 = 0b11000000 then (byte land 0b0011111, 2) else - if byte land 0b11110000 = 0b11100000 then (byte land 0b0001111, 3) else - if byte land 0b11111000 = 0b11110000 then (byte land 0b0000111, 4) else + if byte land 0b10000000 = 0b00000000 then + (byte, 1) + else if byte land 0b11100000 = 0b11000000 then + (byte land 0b0011111, 2) + else if byte land 0b11110000 = 0b11100000 then + (byte land 0b0001111, 3) + else if byte land 0b11111000 = 0b11110000 then + (byte land 0b0000111, 4) + else raise E.UTF8_header_byte_invalid let decode_continuation_byte byte = - if byte land 0b11000000 = 0b10000000 then byte land 0b00111111 else + if byte land 0b11000000 = 0b10000000 then + byte land 0b00111111 + else raise E.UTF8_continuation_byte_invalid let width_required_for_ucs_value value = - if value < 0x000080 (* 1 lsl 7 *) then 1 else - if value < 0x000800 (* 1 lsl 11 *) then 2 else - if value < 0x010000 (* 1 lsl 16 *) then 3 else 4 + if value < 0x000080 (* 1 lsl 7 *) then + 1 + else if value < 0x000800 (* 1 lsl 11 *) then + 2 + else if value < 0x010000 (* 1 lsl 16 *) then + 3 + else + 4 let decode_character string index = let value, width = decode_header_byte (Char.code string.[index]) in - let value = if width = 1 then value - else begin + let value = + if width = 1 then + value + else let value = ref value in for index = index + 1 to index + width - 1 do let chunk = decode_continuation_byte (Char.code string.[index]) in value := (!value lsl 6) lor chunk - done; - if width > (width_required_for_ucs_value !value) - then raise E.UTF8_encoding_not_canonical; + done ; + if width > width_required_for_ucs_value !value then + raise E.UTF8_encoding_not_canonical ; !value - end in + in (value, width) end (* === Mock string validators ============================================== *) -module Mock_String_validator(Validator: E.UCS_VALIDATOR) : E.STRING_VALIDATOR = struct - (* no longer a functor in Encodings for performance reasons, - so modify the original string passed as argument instead replacing - characters that would be invalid with a known invalid XML char: 0x0B. - *) +module Mock_String_validator (Validator : E.UCS_VALIDATOR) : + E.STRING_VALIDATOR = struct + (* no longer a functor in Encodings for performance reasons, + so modify the original string passed as argument instead replacing + characters that would be invalid with a known invalid XML char: 0x0B. + *) let transform str = - let b = Buffer.create (String.length str) in - let rec loop pos = - if pos < String.length str then - let value, width = Lenient_UTF8_codec.decode_character str pos in - let () = try - let u = Uchar.of_int value in - Validator.validate u; - Buffer.add_utf_8_uchar b u + let b = Buffer.create (String.length str) in + let rec loop pos = + if pos < String.length str then + let value, width = Lenient_UTF8_codec.decode_character str pos in + let () = + try + let u = Uchar.of_int value in + Validator.validate u ; Buffer.add_utf_8_uchar b u with _ -> Buffer.add_char b '\x0B' - in - loop (pos + width) - in - loop 0; - Buffer.contents b + in + loop (pos + width) + in + loop 0 ; Buffer.contents b let is_valid str = E.UTF8_XML.is_valid (transform str) + let validate str = - try E.UTF8_XML.validate (transform str) - with E.Validation_error(pos, _) -> - raise (E.Validation_error(pos, Decode_error)) + try E.UTF8_XML.validate (transform str) + with E.Validation_error (pos, _) -> + raise (E.Validation_error (pos, Decode_error)) + let longest_valid_prefix str = E.UTF8_XML.longest_valid_prefix (transform str) end (** A validator that accepts all strings. *) -module Universal_string_validator = Mock_String_validator - (Universal_character_validator) +module Universal_string_validator = + Mock_String_validator (Universal_character_validator) (** A validator that rejects all strings. *) -module Failing_string_validator = Mock_String_validator - (Failing_character_validator) +module Failing_string_validator = + Mock_String_validator (Failing_character_validator) (** A validator that rejects strings containing the character 'F'. *) -module Selective_string_validator = Mock_String_validator - (Selective_character_validator) +module Selective_string_validator = + Mock_String_validator (Selective_character_validator) (* === Tests =============================================================== *) module String_validator = struct - let test_is_valid () = - assert_true (Universal_string_validator.is_valid "" ); - assert_true (Universal_string_validator.is_valid "123456789"); - assert_true (Selective_string_validator.is_valid "" ); - assert_true (Selective_string_validator.is_valid "123456789"); - assert_false (Selective_string_validator.is_valid "F23456789"); - assert_false (Selective_string_validator.is_valid "1234F6789"); - assert_false (Selective_string_validator.is_valid "12345678F"); + assert_true (Universal_string_validator.is_valid "") ; + assert_true (Universal_string_validator.is_valid "123456789") ; + assert_true (Selective_string_validator.is_valid "") ; + assert_true (Selective_string_validator.is_valid "123456789") ; + assert_false (Selective_string_validator.is_valid "F23456789") ; + assert_false (Selective_string_validator.is_valid "1234F6789") ; + assert_false (Selective_string_validator.is_valid "12345678F") ; assert_false (Selective_string_validator.is_valid "FFFFFFFFF") let test_longest_valid_prefix () = - Alcotest.(check string) "prefix" (Universal_string_validator.longest_valid_prefix "" ) "" ; - Alcotest.(check string) "prefix" (Universal_string_validator.longest_valid_prefix "123456789") "123456789"; - Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "" ) "" ; - Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "123456789") "123456789"; - Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "F23456789") "" ; - Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "1234F6789") "1234" ; - Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "12345678F") "12345678" ; - Alcotest.(check string) "prefix" (Selective_string_validator.longest_valid_prefix "FFFFFFFFF") "" - + Alcotest.(check string) + "prefix" + (Universal_string_validator.longest_valid_prefix "") + "" ; + Alcotest.(check string) + "prefix" + (Universal_string_validator.longest_valid_prefix "123456789") + "123456789" ; + Alcotest.(check string) + "prefix" + (Selective_string_validator.longest_valid_prefix "") + "" ; + Alcotest.(check string) + "prefix" + (Selective_string_validator.longest_valid_prefix "123456789") + "123456789" ; + Alcotest.(check string) + "prefix" + (Selective_string_validator.longest_valid_prefix "F23456789") + "" ; + Alcotest.(check string) + "prefix" + (Selective_string_validator.longest_valid_prefix "1234F6789") + "1234" ; + Alcotest.(check string) + "prefix" + (Selective_string_validator.longest_valid_prefix "12345678F") + "12345678" ; + Alcotest.(check string) + "prefix" + (Selective_string_validator.longest_valid_prefix "FFFFFFFFF") + "" (** Tests that validation does not fail for an empty string. *) - let test_validate_with_empty_string () = - E.UTF8_XML.validate "" + let test_validate_with_empty_string () = E.UTF8_XML.validate "" let test_validate_with_incomplete_string () = - Alcotest.check_raises - "Validation fails correctly for an incomplete string" - E.String_incomplete - (fun () -> E.UTF8_XML.validate "\xc2") + Alcotest.check_raises "Validation fails correctly for an incomplete string" + E.String_incomplete (fun () -> E.UTF8_XML.validate "\xc2" + ) let test_validate_with_failing_decoders () = - Failing_string_validator.validate ""; - assert_raises_match - (function E.Validation_error (0, Decode_error) -> true | _ -> false) - (fun () -> Selective_string_validator.validate "F"); - assert_raises_match - (function E.Validation_error (0, Decode_error) -> true | _ -> false) - (fun () -> Selective_string_validator.validate "F12345678"); - assert_raises_match - (function E.Validation_error (4, Decode_error) -> true | _ -> false) - (fun () -> Selective_string_validator.validate "0123F5678"); - assert_raises_match - (function E.Validation_error (8, Decode_error) -> true | _ -> false) - (fun () -> Selective_string_validator.validate "01234567F"); - assert_raises_match - (function E.Validation_error (0, Decode_error) -> true | _ -> false) - (fun () -> Selective_string_validator.validate "FFFFFFFFF") + Failing_string_validator.validate "" ; + assert_raises_match + (function E.Validation_error (0, Decode_error) -> true | _ -> false) + (fun () -> Selective_string_validator.validate "F") ; + assert_raises_match + (function E.Validation_error (0, Decode_error) -> true | _ -> false) + (fun () -> Selective_string_validator.validate "F12345678") ; + assert_raises_match + (function E.Validation_error (4, Decode_error) -> true | _ -> false) + (fun () -> Selective_string_validator.validate "0123F5678") ; + assert_raises_match + (function E.Validation_error (8, Decode_error) -> true | _ -> false) + (fun () -> Selective_string_validator.validate "01234567F") ; + assert_raises_match + (function E.Validation_error (0, Decode_error) -> true | _ -> false) + (fun () -> Selective_string_validator.validate "FFFFFFFFF") let tests = - [ "test_is_valid", `Quick, test_is_valid - ; "test_longest_valid_prefix", `Quick, test_longest_valid_prefix - ; "test_validate_with_empty_string", `Quick, test_validate_with_empty_string - ; "test_validate_with_incomplete_string", `Quick, test_validate_with_incomplete_string - ; "test_validate_with_failing_decoders", `Quick, test_validate_with_failing_decoders + [ + ("test_is_valid", `Quick, test_is_valid) + ; ("test_longest_valid_prefix", `Quick, test_longest_valid_prefix) + ; ( "test_validate_with_empty_string" + , `Quick + , test_validate_with_empty_string + ) + ; ( "test_validate_with_incomplete_string" + , `Quick + , test_validate_with_incomplete_string + ) + ; ( "test_validate_with_failing_decoders" + , `Quick + , test_validate_with_failing_decoders + ) ] - end -module XML = struct include E.XML +module XML = struct + include E.XML let test_is_illegal_control_character () = - assert_true (is_illegal_control_character (Uchar.of_int 0x00)); - assert_true (is_illegal_control_character (Uchar.of_int 0x19)); - assert_false (is_illegal_control_character (Uchar.of_int 0x09)); - assert_false (is_illegal_control_character (Uchar.of_int 0x0a)); - assert_false (is_illegal_control_character (Uchar.of_int 0x0d)); - assert_false (is_illegal_control_character (Uchar.of_int 0x20)) + assert_true (is_illegal_control_character (Uchar.of_int 0x00)) ; + assert_true (is_illegal_control_character (Uchar.of_int 0x19)) ; + assert_false (is_illegal_control_character (Uchar.of_int 0x09)) ; + assert_false (is_illegal_control_character (Uchar.of_int 0x0a)) ; + assert_false (is_illegal_control_character (Uchar.of_int 0x0d)) ; + assert_false (is_illegal_control_character (Uchar.of_int 0x20)) let tests = - [ "test_is_illegal_control_character", `Quick, test_is_illegal_control_character - ] - + [ + ( "test_is_illegal_control_character" + , `Quick + , test_is_illegal_control_character + ) + ] end (** Tests the XML-specific UTF-8 UCS validation function. *) -module XML_UTF8_UCS_validator = struct include E.XML_UTF8_UCS_validator +module XML_UTF8_UCS_validator = struct + include E.XML_UTF8_UCS_validator + let validate uchar = - if Uchar.is_valid uchar then validate @@ Uchar.of_int uchar + if Uchar.is_valid uchar then + validate @@ Uchar.of_int uchar + else if uchar < Uchar.to_int Uchar.min || uchar > Uchar.to_int Uchar.max + then + raise E.UCS_value_out_of_range else - if uchar < Uchar.to_int Uchar.min - || uchar > Uchar.to_int Uchar.max then - raise E.UCS_value_out_of_range - else - raise E.UCS_value_prohibited_in_UTF8 + raise E.UCS_value_prohibited_in_UTF8 let test_validate () = - let value = ref (UCS.min_value --- 1) in - while !value <= (UCS.max_value +++ 1) do - if UCS.is_out_of_range !value - then Alcotest.check_raises "should fail" E.UCS_value_out_of_range - (fun () -> validate !value) - else - if UCS.is_non_character !value - || UCS.is_surrogate !value - then Alcotest.check_raises "should fail" E.UCS_value_prohibited_in_UTF8 - (fun () -> validate !value) - else - if Uchar.is_valid !value && XML.is_illegal_control_character (Uchar.of_int !value) - then Alcotest.check_raises "should fail" E.UCS_value_prohibited_in_XML - (fun () -> validate !value) - else - validate !value; - value := !value +++ 1 - done - - let tests = - [ "test_validate", `Quick, test_validate - ] + let value = ref (UCS.min_value --- 1) in + while !value <= UCS.max_value +++ 1 do + if UCS.is_out_of_range !value then + Alcotest.check_raises "should fail" E.UCS_value_out_of_range (fun () -> + validate !value + ) + else if UCS.is_non_character !value || UCS.is_surrogate !value then + Alcotest.check_raises "should fail" E.UCS_value_prohibited_in_UTF8 + (fun () -> validate !value + ) + else if + Uchar.is_valid !value + && XML.is_illegal_control_character (Uchar.of_int !value) + then + Alcotest.check_raises "should fail" E.UCS_value_prohibited_in_XML + (fun () -> validate !value + ) + else + validate !value ; + value := !value +++ 1 + done + let tests = [("test_validate", `Quick, test_validate)] end module UTF8_codec = struct - (** A list of canonical encoding widths of UCS values, represented by tuples of the form (v, w), where: v = the UCS character value to be encoded; and w = the width of the encoded character, in bytes. *) let valid_ucs_value_widths = [ - (1 , 1); ((1 <<< 7) --- 1, 1); - (1 <<< 7, 2); ((1 <<< 11) --- 1, 2); - (1 <<< 11, 3); ((1 <<< 16) --- 1, 3); - (1 <<< 16, 4); ((1 <<< 21) --- 1, 4); + (1, 1) + ; ((1 <<< 7) --- 1, 1) + ; (1 <<< 7, 2) + ; ((1 <<< 11) --- 1, 2) + ; (1 <<< 11, 3) + ; ((1 <<< 16) --- 1, 3) + ; (1 <<< 16, 4) + ; ((1 <<< 21) --- 1, 4) ] - + let width_required_for_ucs_value value = - if value < 0x000080 (* 1 lsl 7 *) then 1 else - if value < 0x000800 (* 1 lsl 11 *) then 2 else - if value < 0x010000 (* 1 lsl 16 *) then 3 else 4 + if value < 0x000080 (* 1 lsl 7 *) then + 1 + else if value < 0x000800 (* 1 lsl 11 *) then + 2 + else if value < 0x010000 (* 1 lsl 16 *) then + 3 + else + 4 let test_width_required_for_ucs_value () = - List.iter - (fun (value, width) -> - Alcotest.(check int) "same ints" (width_required_for_ucs_value value) width) - valid_ucs_value_widths + List.iter + (fun (value, width) -> + Alcotest.(check int) + "same ints" + (width_required_for_ucs_value value) + width + ) + valid_ucs_value_widths (** A list of valid header byte decodings, represented by tuples of the form (b, (v, w)), where: @@ -355,27 +436,31 @@ module UTF8_codec = struct w = the total width of the encoded character, in bytes. *) let valid_header_byte_decodings = [ - (0b00000000, (0b00000000, 1)); - (0b00000001, (0b00000001, 1)); - (0b01111111, (0b01111111, 1)); - (0b11000000, (0b00000000, 2)); - (0b11000001, (0b00000001, 2)); - (0b11011111, (0b00011111, 2)); - (0b11100000, (0b00000000, 3)); - (0b11100001, (0b00000001, 3)); - (0b11101111, (0b00001111, 3)); - (0b11110000, (0b00000000, 4)); - (0b11110001, (0b00000001, 4)); - (0b11110111, (0b00000111, 4)); + (0b00000000, (0b00000000, 1)) + ; (0b00000001, (0b00000001, 1)) + ; (0b01111111, (0b01111111, 1)) + ; (0b11000000, (0b00000000, 2)) + ; (0b11000001, (0b00000001, 2)) + ; (0b11011111, (0b00011111, 2)) + ; (0b11100000, (0b00000000, 3)) + ; (0b11100001, (0b00000001, 3)) + ; (0b11101111, (0b00001111, 3)) + ; (0b11110000, (0b00000000, 4)) + ; (0b11110001, (0b00000001, 4)) + ; (0b11110111, (0b00000111, 4)) ] (** A list of invalid header bytes that should not be decodable. *) let invalid_header_bytes = [ - 0b10000000; 0b10111111; - 0b11111000; 0b11111011; - 0b11111100; 0b11111101; - 0b11111110; 0b11111111; + 0b10000000 + ; 0b10111111 + ; 0b11111000 + ; 0b11111011 + ; 0b11111100 + ; 0b11111101 + ; 0b11111110 + ; 0b11111111 ] (** A list of valid continuation byte decodings, represented @@ -384,22 +469,29 @@ module UTF8_codec = struct v = the partial value contained within the byte. *) let valid_continuation_byte_decodings = [ - (0b10000000, 0b00000000); - (0b10000001, 0b00000001); - (0b10111110, 0b00111110); - (0b10111111, 0b00111111); + (0b10000000, 0b00000000) + ; (0b10000001, 0b00000001) + ; (0b10111110, 0b00111110) + ; (0b10111111, 0b00111111) ] (** A list of invalid continuation bytes that should not be decodable. *) let invalid_continuation_bytes = [ - 0b00000000; 0b01111111; - 0b11000000; 0b11011111; - 0b11100000; 0b11101111; - 0b11110000; 0b11110111; - 0b11111000; 0b11111011; - 0b11111100; 0b11111101; - 0b11111111; 0b11111110; + 0b00000000 + ; 0b01111111 + ; 0b11000000 + ; 0b11011111 + ; 0b11100000 + ; 0b11101111 + ; 0b11110000 + ; 0b11110111 + ; 0b11111000 + ; 0b11111011 + ; 0b11111100 + ; 0b11111101 + ; 0b11111111 + ; 0b11111110 ] (** A list of valid character decodings represented by @@ -415,33 +507,57 @@ module UTF8_codec = struct v_min = the smallest UCS value encodable in b bytes. v_max = the greatest UCS value encodable in b bytes. *) - let valid_character_decodings = [ - (* 7654321 *) - (* 0b0xxxxxxx *) (* 00000000000000xxxxxxx *) - "\x00" (* 0b00000000 *), (0b000000000000000000000, 1); - "\x7f" (* 0b01111111 *), (0b000000000000001111111, 1); - (* 10987654321 *) - (* 0b110xxxsx 0b10xxxxxx *) (* 0000000000xxxsxxxxxxx *) - "\xc2\x80" (* 0b11000010 0b10000000 *), (0b000000000000010000000, 2); - "\xdf\xbf" (* 0b11011111 0b10111111 *), (0b000000000011111111111, 2); - (* 6543210987654321 *) - (* 0b1110xxxx 0b10sxxxxx 0b10xxxxxx *) (* xxxxsxxxxxxxxxxx *) - "\xe0\xa0\x80" (* 0b11100000 0b10100000 0b10000000 *), (0b000000000100000000000, 3); - "\xef\xbf\xbf" (* 0b11101111 0b10111111 0b10111111 *), (0b000001111111111111111, 3); - (* 109876543210987654321 *) - (* 0b11110xxx 0b10xsxxxx 0b10xxxxxx 0b10xxxxxx *) (* xxxxsxxxxxxxxxxxxxxxx *) - "\xf0\x90\x80\x80" (* 0b11110000 0b10010000 0b10000000 0b10000000 *), (0b000010000000000000000, 4); - "\xf7\xbf\xbf\xbf" (* 0b11110111 0b10111111 0b10111111 0b10111111 *), (0b111111111111111111111, 4); - ] + let valid_character_decodings = + [ + (* 7654321 *) + (* 0b0xxxxxxx *) + (* 00000000000000xxxxxxx *) + ( "\x00" (* 0b00000000 *) + , (0b000000000000000000000, 1) + ) + ; ( "\x7f" (* 0b01111111 *) + , (0b000000000000001111111, 1) + ) + ; (* 10987654321 *) + (* 0b110xxxsx 0b10xxxxxx *) + (* 0000000000xxxsxxxxxxx *) + ( "\xc2\x80" (* 0b11000010 0b10000000 *) + , (0b000000000000010000000, 2) + ) + ; ( "\xdf\xbf" (* 0b11011111 0b10111111 *) + , (0b000000000011111111111, 2) + ) + ; (* 6543210987654321 *) + (* 0b1110xxxx 0b10sxxxxx 0b10xxxxxx *) + (* xxxxsxxxxxxxxxxx *) + ( "\xe0\xa0\x80" (* 0b11100000 0b10100000 0b10000000 *) + , (0b000000000100000000000, 3) + ) + ; ( "\xef\xbf\xbf" (* 0b11101111 0b10111111 0b10111111 *) + , (0b000001111111111111111, 3) + ) + ; (* 109876543210987654321 *) + (* 0b11110xxx 0b10xsxxxx 0b10xxxxxx 0b10xxxxxx *) + (* xxxxsxxxxxxxxxxxxxxxx *) + ( "\xf0\x90\x80\x80" (* 0b11110000 0b10010000 0b10000000 0b10000000 *) + , (0b000010000000000000000, 4) + ) + ; ( "\xf7\xbf\xbf\xbf" (* 0b11110111 0b10111111 0b10111111 0b10111111 *) + , (0b111111111111111111111, 4) + ) + ] let uchar = Alcotest.int + let test_decode_character_when_valid () = - List.iter - (fun (string, (value, width)) -> - Alcotest.(check (pair uchar int)) "same pair" - (Lenient_UTF8_codec.decode_character string 0) - (value, width)) - valid_character_decodings + List.iter + (fun (string, (value, width)) -> + Alcotest.(check (pair uchar int)) + "same pair" + (Lenient_UTF8_codec.decode_character string 0) + (value, width) + ) + valid_character_decodings (** A list of strings containing overlong character encodings. For each byte length b in [2...4], this list contains the @@ -449,33 +565,43 @@ module UTF8_codec = struct than the smallest UCS value validly-encodable in b bytes. *) let overlong_character_encodings = [ - "\xc1\xbf" (* 0b11000001 0b10111111 *); - "\xe0\x9f\xbf" (* 0b11100000 0b10011111 0b10111111 *); - "\xf0\x8f\xbf\xbf" (* 0b11110000 0b10001111 0b10111111 0b10111111 *); + "\xc1\xbf" (* 0b11000001 0b10111111 *) + ; "\xe0\x9f\xbf" (* 0b11100000 0b10011111 0b10111111 *) + ; "\xf0\x8f\xbf\xbf" (* 0b11110000 0b10001111 0b10111111 0b10111111 *) ] let test_decode_character_when_overlong () = - List.iter - (fun string -> - Alcotest.check_raises "should fail" E.UTF8_encoding_not_canonical - (fun () -> Lenient_UTF8_codec.decode_character string 0 |> ignore)) - overlong_character_encodings + List.iter + (fun string -> + Alcotest.check_raises "should fail" E.UTF8_encoding_not_canonical + (fun () -> Lenient_UTF8_codec.decode_character string 0 |> ignore + ) + ) + overlong_character_encodings let tests = - [ "test_width_required_for_ucs_value", `Quick, test_width_required_for_ucs_value - ; "test_decode_character_when_valid", `Quick, test_decode_character_when_valid - ; "test_decode_character_when_overlong", `Quick, test_decode_character_when_overlong + [ + ( "test_width_required_for_ucs_value" + , `Quick + , test_width_required_for_ucs_value + ) + ; ( "test_decode_character_when_valid" + , `Quick + , test_decode_character_when_valid + ) + ; ( "test_decode_character_when_overlong" + , `Quick + , test_decode_character_when_overlong + ) ] - end let () = - Alcotest.run - "Encodings" + Alcotest.run "Encodings" [ - "UCS", UCS.tests - ; "XML", XML.tests - ; "String_validator", String_validator.tests - ; "XML_UTF8_UCS_validator", XML_UTF8_UCS_validator.tests - ; "UTF8_codec", UTF8_codec.tests + ("UCS", UCS.tests) + ; ("XML", XML.tests) + ; ("String_validator", String_validator.tests) + ; ("XML_UTF8_UCS_validator", XML_UTF8_UCS_validator.tests) + ; ("UTF8_codec", UTF8_codec.tests) ] diff --git a/lib/xapi-stdext-pervasives/pervasiveext.ml b/lib/xapi-stdext-pervasives/pervasiveext.ml index 8741b506a20..7d8e16c4346 100644 --- a/lib/xapi-stdext-pervasives/pervasiveext.ml +++ b/lib/xapi-stdext-pervasives/pervasiveext.ml @@ -33,13 +33,13 @@ let finally fct clean_f = m "finally: Error while running cleanup after failure of main \ function: %s" - (Printexc.to_string cleanup_exn)) + (Printexc.to_string cleanup_exn) + ) ) ; raise exn in clean_f () ; result - (** execute fct ignoring exceptions *) let ignore_exn fct = try fct () with _ -> () diff --git a/lib/xapi-stdext-std/listext.mli b/lib/xapi-stdext-std/listext.mli index f81b619e03d..08435d5a4d5 100644 --- a/lib/xapi-stdext-std/listext.mli +++ b/lib/xapi-stdext-std/listext.mli @@ -163,5 +163,4 @@ module List : sig val intersect : 'a list -> 'a list -> 'a list (** Returns the intersection of two lists. *) - end diff --git a/lib/xapi-stdext-std/listext_test.ml b/lib/xapi-stdext-std/listext_test.ml index 8fcedeb9ee7..dc141f25b8d 100644 --- a/lib/xapi-stdext-std/listext_test.ml +++ b/lib/xapi-stdext-std/listext_test.ml @@ -9,7 +9,7 @@ but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. - *) +*) module Listext = Xapi_stdext_std.Listext.List diff --git a/lib/xapi-stdext-std/xstringext.ml b/lib/xapi-stdext-std/xstringext.ml index 4f85ba949cc..8f5b713072f 100644 --- a/lib/xapi-stdext-std/xstringext.ml +++ b/lib/xapi-stdext-std/xstringext.ml @@ -170,7 +170,8 @@ module String = struct Bytes.blit_string s !orig_offset new_b !dest_offset len ; Bytes.blit_string t 0 new_b (!dest_offset + len) len_t ; orig_offset := !orig_offset + len + len_f ; - dest_offset := !dest_offset + len + len_t) + dest_offset := !dest_offset + len + len_t + ) indexes ; Bytes.blit_string s !orig_offset new_b !dest_offset (String.length s - !orig_offset) ; diff --git a/lib/xapi-stdext-std/xstringext.mli b/lib/xapi-stdext-std/xstringext.mli index 4c4c489dec5..e2587929916 100644 --- a/lib/xapi-stdext-std/xstringext.mli +++ b/lib/xapi-stdext-std/xstringext.mli @@ -16,9 +16,9 @@ module String : sig val of_char : char -> string + val rev_map : (char -> char) -> string -> string (** Map a string to a string, applying the given function in reverse order. *) - val rev_map : (char -> char) -> string -> string val rev_iter : (char -> unit) -> string -> unit (** Iterate over the characters in a string in reverse order. *) diff --git a/lib/xapi-stdext-std/xstringext_test.ml b/lib/xapi-stdext-std/xstringext_test.ml index 096ed58abd5..7d2766cbaf4 100644 --- a/lib/xapi-stdext-std/xstringext_test.ml +++ b/lib/xapi-stdext-std/xstringext_test.ml @@ -9,7 +9,7 @@ but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. - *) +*) module XString = Xapi_stdext_std.Xstringext.String @@ -77,7 +77,8 @@ let test_split = , [ ('.', "...", [""; ""; "."]) ; ('.', "foo.bar.baz", ["foo"; "bar"; "baz"]) - ] ) + ] + ) ; (4, [('.', "...", [""; ""; ""; ""])]) ] in diff --git a/lib/xapi-stdext-threads/semaphore.ml b/lib/xapi-stdext-threads/semaphore.ml index b1dc6707835..06621049c91 100644 --- a/lib/xapi-stdext-threads/semaphore.ml +++ b/lib/xapi-stdext-threads/semaphore.ml @@ -12,51 +12,46 @@ * GNU Lesser General Public License for more details. *) -type t = { - mutable n : int; - m : Mutex.t; - c : Condition.t; -} +type t = {mutable n: int; m: Mutex.t; c: Condition.t} let create n = if n <= 0 then - invalid_arg (Printf.sprintf - "Semaphore value must be positive, got %d" n); - let m = Mutex.create () - and c = Condition.create () in - { n; m; c; } + invalid_arg (Printf.sprintf "Semaphore value must be positive, got %d" n) ; + let m = Mutex.create () and c = Condition.create () in + {n; m; c} exception Inconsistent_state of string -let inconsistent_state fmt = Printf.ksprintf (fun msg -> - raise (Inconsistent_state msg)) fmt + +let inconsistent_state fmt = + Printf.ksprintf (fun msg -> raise (Inconsistent_state msg)) fmt let acquire s k = if k <= 0 then - invalid_arg (Printf.sprintf - "Semaphore acquisition requires a positive value, got %d" k); - Mutex.lock s.m; + invalid_arg + (Printf.sprintf "Semaphore acquisition requires a positive value, got %d" + k + ) ; + Mutex.lock s.m ; while s.n < k do - Condition.wait s.c s.m; - done; + Condition.wait s.c s.m + done ; if not (s.n >= k) then - inconsistent_state "Semaphore value cannot be smaller than %d, got %d" k s.n; - s.n <- s.n - k; - Condition.signal s.c; + inconsistent_state "Semaphore value cannot be smaller than %d, got %d" k s.n ; + s.n <- s.n - k ; + Condition.signal s.c ; Mutex.unlock s.m let release s k = if k <= 0 then - invalid_arg (Printf.sprintf - "Semaphore release requires a positive value, got %d" k); - Mutex.lock s.m; - s.n <- s.n + k; - Condition.signal s.c; + invalid_arg + (Printf.sprintf "Semaphore release requires a positive value, got %d" k) ; + Mutex.lock s.m ; + s.n <- s.n + k ; + Condition.signal s.c ; Mutex.unlock s.m let execute_with_weight s k f = - acquire s k; - Xapi_stdext_pervasives.Pervasiveext.finally f - (fun () -> release s k) + acquire s k ; + Xapi_stdext_pervasives.Pervasiveext.finally f (fun () -> release s k) -let execute s f = - execute_with_weight s 1 f +let execute s f = execute_with_weight s 1 f diff --git a/lib/xapi-stdext-threads/semaphore.mli b/lib/xapi-stdext-threads/semaphore.mli index 0db704ce9c8..207e612032d 100644 --- a/lib/xapi-stdext-threads/semaphore.mli +++ b/lib/xapi-stdext-threads/semaphore.mli @@ -12,29 +12,29 @@ * GNU Lesser General Public License for more details. *) - type t + exception Inconsistent_state of string +val create : int -> t (** [create n] create a semaphore with initial value [n] (a positive integer). Raise {!Invalid_argument} if [n] <= 0 *) -val create : int -> t +val acquire : t -> int -> unit (** [acquire k s] block until the semaphore value is >= [k] (a positive integer), then atomically decrement the semaphore value by [k]. Raise {!Invalid_argument} if [k] <= 0 *) -val acquire : t -> int -> unit +val release : t -> int -> unit (** [release k s] atomically increment the semaphore value by [k] (a positive integer). Raise {!Invalid_argument} if [k] <= 0 *) -val release : t -> int -> unit +val execute_with_weight : t -> int -> (unit -> 'a) -> 'a (** [execute_with_weight s k f] {!acquire} the semaphore with [k], then run [f ()], and finally {!release} the semaphore with the same value [k] (even in case of failure in the execution of [f]). Return the value of [f ()] or re-raise the exception if any. *) -val execute_with_weight : t -> int -> (unit -> 'a) -> 'a -(** [execute s f] same as [{execute_with_weight} s 1 f] *) val execute : t -> (unit -> 'a) -> 'a +(** [execute s f] same as [{execute_with_weight} s 1 f] *) diff --git a/lib/xapi-stdext-threads/threadext.ml b/lib/xapi-stdext-threads/threadext.ml index a58b34c73df..56025d51154 100644 --- a/lib/xapi-stdext-threads/threadext.ml +++ b/lib/xapi-stdext-threads/threadext.ml @@ -17,7 +17,7 @@ module M = Mutex module Mutex = struct (** execute the function f with the mutex hold *) let execute lock f = - Mutex.lock lock; + Mutex.lock lock ; Xapi_stdext_pervasives.Pervasiveext.finally f (fun () -> Mutex.unlock lock) end @@ -26,87 +26,88 @@ end let thread_iter_all_exns f xs = let exns = ref [] in let m = M.create () in - List.iter - Thread.join + List.iter Thread.join (List.map (fun x -> - Thread.create - (fun () -> - try - f x - with e -> Mutex.execute m (fun () -> exns := (x, e) :: !exns) - ) - () - ) xs); + Thread.create + (fun () -> + try f x + with e -> Mutex.execute m (fun () -> exns := (x, e) :: !exns) + ) + () + ) + xs + ) ; !exns (** Parallel List.iter. Remembers one exception (at random) and throws it in the error case. *) -let thread_iter f xs = match thread_iter_all_exns f xs with - | [] -> () - | (_, e) :: _ -> raise e +let thread_iter f xs = + match thread_iter_all_exns f xs with [] -> () | (_, e) :: _ -> raise e module Delay = struct (* Concrete type is the ends of a pipe *) type t = { - (* A pipe is used to wake up a thread blocked in wait: *) - mutable pipe_out: Unix.file_descr option; - mutable pipe_in: Unix.file_descr option; - (* Indicates that a signal arrived before a wait: *) - mutable signalled: bool; - m: M.t + (* A pipe is used to wake up a thread blocked in wait: *) + mutable pipe_out: Unix.file_descr option + ; mutable pipe_in: Unix.file_descr option + ; (* Indicates that a signal arrived before a wait: *) + mutable signalled: bool + ; m: M.t } let make () = - { pipe_out = None; - pipe_in = None; - signalled = false; - m = M.create () } + {pipe_out= None; pipe_in= None; signalled= false; m= M.create ()} exception Pre_signalled - let wait (x: t) (seconds: float) = + let wait (x : t) (seconds : float) = let finally = Xapi_stdext_pervasives.Pervasiveext.finally in - let to_close = ref [ ] in + let to_close = ref [] in let close' fd = - if List.mem fd !to_close then Unix.close fd; - to_close := List.filter (fun x -> fd <> x) !to_close in + if List.mem fd !to_close then Unix.close fd ; + to_close := List.filter (fun x -> fd <> x) !to_close + in finally (fun () -> - try - let pipe_out = Mutex.execute x.m - (fun () -> - if x.signalled then begin - x.signalled <- false; - raise Pre_signalled; - end; - let pipe_out, pipe_in = Unix.pipe () in - (* these will be unconditionally closed on exit *) - to_close := [ pipe_out; pipe_in ]; - x.pipe_out <- Some pipe_out; - x.pipe_in <- Some pipe_in; - x.signalled <- false; - pipe_out) in - let r, _, _ = Unix.select [ pipe_out ] [] [] seconds in - (* flush the single byte from the pipe *) - if r <> [] then ignore(Unix.read pipe_out (Bytes.create 1) 0 1); - (* return true if we waited the full length of time, false if we were woken *) - r = [] - with Pre_signalled -> false + try + let pipe_out = + Mutex.execute x.m (fun () -> + if x.signalled then ( + x.signalled <- false ; + raise Pre_signalled + ) ; + let pipe_out, pipe_in = Unix.pipe () in + (* these will be unconditionally closed on exit *) + to_close := [pipe_out; pipe_in] ; + x.pipe_out <- Some pipe_out ; + x.pipe_in <- Some pipe_in ; + x.signalled <- false ; + pipe_out + ) + in + let r, _, _ = Unix.select [pipe_out] [] [] seconds in + (* flush the single byte from the pipe *) + if r <> [] then ignore (Unix.read pipe_out (Bytes.create 1) 0 1) ; + (* return true if we waited the full length of time, false if we were woken *) + r = [] + with Pre_signalled -> false ) (fun () -> - Mutex.execute x.m - (fun () -> - x.pipe_out <- None; - x.pipe_in <- None; - List.iter close' !to_close) + Mutex.execute x.m (fun () -> + x.pipe_out <- None ; + x.pipe_in <- None ; + List.iter close' !to_close + ) ) - let signal (x: t) = - Mutex.execute x.m - (fun () -> - match x.pipe_in with - | Some fd -> ignore(Unix.write fd (Bytes.of_string "X") 0 1) - | None -> x.signalled <- true (* If the wait hasn't happened yet then store up the signal *) - ) + let signal (x : t) = + Mutex.execute x.m (fun () -> + match x.pipe_in with + | Some fd -> + ignore (Unix.write fd (Bytes.of_string "X") 0 1) + | None -> + x.signalled <- true + (* If the wait hasn't happened yet then store up the signal *) + ) end diff --git a/lib/xapi-stdext-unix/unixext.ml b/lib/xapi-stdext-unix/unixext.ml index ba8f418aef0..20f20de8e68 100644 --- a/lib/xapi-stdext-unix/unixext.ml +++ b/lib/xapi-stdext-unix/unixext.ml @@ -29,9 +29,10 @@ let mkdir_safe dir perm = let mkdir_rec dir perm = let rec p_mkdir dir = let p_name = Filename.dirname dir in - if p_name <> "/" && p_name <> "." - then p_mkdir p_name; - mkdir_safe dir perm in + if p_name <> "/" && p_name <> "." then + p_mkdir p_name ; + mkdir_safe dir perm + in p_mkdir dir (** removes a file or recursively removes files/directories below a directory without following @@ -58,31 +59,32 @@ let rm_rec ?(rm_top = true) path = (** write a pidfile file *) let pidfile_write filename = - let fd = Unix.openfile filename - [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ] - 0o640 in + let fd = + Unix.openfile filename [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC] 0o640 + in finally (fun () -> - let pid = Unix.getpid () in - let buf = string_of_int pid ^ "\n" in - let len = String.length buf in - if Unix.write fd (Bytes.unsafe_of_string buf) 0 len <> len - then failwith "pidfile_write failed"; + let pid = Unix.getpid () in + let buf = string_of_int pid ^ "\n" in + let len = String.length buf in + if Unix.write fd (Bytes.unsafe_of_string buf) 0 len <> len then + failwith "pidfile_write failed" ) (fun () -> Unix.close fd) (** read a pidfile file, return either Some pid or None *) let pidfile_read filename = - let fd = Unix.openfile filename [ Unix.O_RDONLY ] 0o640 in + let fd = Unix.openfile filename [Unix.O_RDONLY] 0o640 in finally (fun () -> - try - let buf = Bytes.create 80 in - let rd = Unix.read fd buf 0 (Bytes.length buf) in - if rd = 0 then - failwith "pidfile_read failed"; - Scanf.sscanf (Bytes.sub_string buf 0 rd) "%d" (fun i -> Some i) - with _ -> None) + try + let buf = Bytes.create 80 in + let rd = Unix.read fd buf 0 (Bytes.length buf) in + if rd = 0 then + failwith "pidfile_read failed" ; + Scanf.sscanf (Bytes.sub_string buf 0 rd) "%d" (fun i -> Some i) + with _ -> None + ) (fun () -> Unix.close fd) (** open a file, and make sure the close is always done *) @@ -92,24 +94,26 @@ let with_file file mode perms f = (fun () -> f fd) (fun () -> Unix.close fd) -(** daemonize a process *) (* !! Must call this before spawning any threads !! *) + +(** daemonize a process *) let daemonize () = match Unix.fork () with - | 0 -> - if Unix.setsid () == -1 then - failwith "Unix.setsid failed"; - - begin match Unix.fork () with + | 0 -> ( + if Unix.setsid () == -1 then + failwith "Unix.setsid failed" ; + match Unix.fork () with | 0 -> - with_file "/dev/null" [ Unix.O_WRONLY ] 0 - (fun nullfd -> - Unix.close Unix.stdin; - Unix.dup2 nullfd Unix.stdout; - Unix.dup2 nullfd Unix.stderr) - | _ -> exit 0 - end - | _ -> exit 0 + with_file "/dev/null" [Unix.O_WRONLY] 0 (fun nullfd -> + Unix.close Unix.stdin ; + Unix.dup2 nullfd Unix.stdout ; + Unix.dup2 nullfd Unix.stderr + ) + | _ -> + exit 0 + ) + | _ -> + exit 0 exception Break @@ -117,41 +121,33 @@ let lines_fold f start input = let accumulator = ref start in let running = ref true in while !running do - let line = - try Some (input_line input) - with End_of_file -> None - in + let line = try Some (input_line input) with End_of_file -> None in match line with - | Some line -> - begin - try accumulator := (f !accumulator line) - with Break -> running := false - end + | Some line -> ( + try accumulator := f !accumulator line with Break -> running := false + ) | None -> - running := false - done; + running := false + done ; !accumulator -let lines_iter f = lines_fold (fun () line -> ignore(f line)) () +let lines_iter f = lines_fold (fun () line -> ignore (f line)) () (** open a file, and make sure the close is always done *) let with_input_channel file f = let input = open_in file in - finally - (fun () -> f input) - (fun () -> close_in input) + finally (fun () -> f input) (fun () -> close_in input) - -let file_lines_fold f start file_path = with_input_channel file_path (lines_fold f start) +let file_lines_fold f start file_path = + with_input_channel file_path (lines_fold f start) let read_lines ~(path : string) : string list = - List.rev (file_lines_fold (fun acc line -> line::acc) [] path) + List.rev (file_lines_fold (fun acc line -> line :: acc) [] path) -let file_lines_iter f = file_lines_fold (fun () line -> ignore(f line)) () +let file_lines_iter f = file_lines_fold (fun () line -> ignore (f line)) () let readfile_line = file_lines_iter - (** [fd_blocks_fold block_size f start fd] folds [f] over blocks (strings) from the fd [fd] with initial value [start] *) let fd_blocks_fold block_size f start fd = @@ -160,7 +156,8 @@ let fd_blocks_fold block_size f start fd = let n = Unix.read fd block 0 block_size in (* Consider making the interface explicitly use Substrings *) let b = if n = block_size then block else Bytes.sub block 0 n in - if n = 0 then acc else fold (f acc b) in + if n = 0 then acc else fold (f acc b) + in fold start let with_directory dir f = @@ -170,60 +167,67 @@ let with_directory dir f = (fun () -> Unix.closedir dh) let buffer_of_fd fd = - fd_blocks_fold 1024 (fun b s -> Buffer.add_bytes b s; b) (Buffer.create 1024) fd + fd_blocks_fold 1024 + (fun b s -> Buffer.add_bytes b s ; b) + (Buffer.create 1024) fd let string_of_fd fd = Buffer.contents (buffer_of_fd fd) -let buffer_of_file file_path = with_file file_path [ Unix.O_RDONLY ] 0 buffer_of_fd +let buffer_of_file file_path = + with_file file_path [Unix.O_RDONLY] 0 buffer_of_fd let string_of_file file_path = Buffer.contents (buffer_of_file file_path) (** Write a file, ensures atomicity and durability. *) let atomic_write_to_file fname perms f = let dir_path = Filename.dirname fname in - let tmp_path, tmp_chan = Filename.open_temp_file ~temp_dir:dir_path "" ".tmp" in + let tmp_path, tmp_chan = + Filename.open_temp_file ~temp_dir:dir_path "" ".tmp" + in let tmp_fd = Unix.descr_of_out_channel tmp_chan in - let write_tmp_file () = let result = f tmp_fd in - Unix.fchmod tmp_fd perms; - Unix.fsync tmp_fd; - result + Unix.fchmod tmp_fd perms ; Unix.fsync tmp_fd ; result in let write_and_persist () = let result = finally write_tmp_file (fun () -> Stdlib.close_out tmp_chan) in - Unix.rename tmp_path fname; + Unix.rename tmp_path fname ; (* sync parent directory to make sure the file is persisted *) let dir_fd = Unix.openfile dir_path [O_RDONLY] 0 in - finally (fun () -> Unix.fsync dir_fd) (fun () -> Unix.close dir_fd); + finally (fun () -> Unix.fsync dir_fd) (fun () -> Unix.close dir_fd) ; result in finally write_and_persist (fun () -> unlink_safe tmp_path) - (** Atomically write a string to a file *) -let write_bytes_to_file ?(perms=0o644) fname b = +let write_bytes_to_file ?(perms = 0o644) fname b = atomic_write_to_file fname perms (fun fd -> let len = Bytes.length b in let written = Unix.write fd b 0 len in - if written <> len then (failwith "Short write occured!")) + if written <> len then failwith "Short write occured!" + ) -let write_string_to_file ?(perms=0o644) fname s = +let write_string_to_file ?(perms = 0o644) fname s = write_bytes_to_file fname ~perms (Bytes.unsafe_of_string s) let execv_get_output cmd args = - let (pipe_exit, pipe_entrance) = Unix.pipe () in - let r = try Unix.set_close_on_exec pipe_exit; true with _ -> false in + let pipe_exit, pipe_entrance = Unix.pipe () in + let r = + try + Unix.set_close_on_exec pipe_exit ; + true + with _ -> false + in match Unix.fork () with - | 0 -> - Unix.dup2 pipe_entrance Unix.stdout; - Unix.close pipe_entrance; - if not r then - Unix.close pipe_exit; - begin try Unix.execv cmd args with _ -> exit 127 end + | 0 -> ( + Unix.dup2 pipe_entrance Unix.stdout ; + Unix.close pipe_entrance ; + if not r then + Unix.close pipe_exit ; + try Unix.execv cmd args with _ -> exit 127 + ) | pid -> - Unix.close pipe_entrance; - pid, pipe_exit + Unix.close pipe_entrance ; (pid, pipe_exit) let copy_file_internal ?limit reader writer = let buffer = Bytes.make 65536 '\000' in @@ -231,226 +235,244 @@ let copy_file_internal ?limit reader writer = let finished = ref false in let total_bytes = ref 0L in let limit = ref limit in - while not(!finished) do + while not !finished do let requested = min (Option.value ~default:buffer_len !limit) buffer_len in let num = reader buffer 0 (Int64.to_int requested) in let num64 = Int64.of_int num in - - limit := Option.map (fun x -> Int64.sub x num64) !limit; - ignore_int (writer buffer 0 num); - total_bytes := Int64.add !total_bytes num64; - finished := num = 0 || !limit = Some 0L; - done; + limit := Option.map (fun x -> Int64.sub x num64) !limit ; + ignore_int (writer buffer 0 num) ; + total_bytes := Int64.add !total_bytes num64 ; + finished := num = 0 || !limit = Some 0L + done ; !total_bytes -let copy_file ?limit ifd ofd = copy_file_internal ?limit (Unix.read ifd) (Unix.write ofd) +let copy_file ?limit ifd ofd = + copy_file_internal ?limit (Unix.read ifd) (Unix.write ofd) let file_exists file_path = - try Unix.access file_path [Unix.F_OK]; true + try + Unix.access file_path [Unix.F_OK] ; + true with _ -> false let touch_file file_path = - let fd = Unix.openfile file_path - [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_NOCTTY; Unix.O_NONBLOCK] 0o666 in - Unix.close fd; + let fd = + Unix.openfile file_path + [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_NOCTTY; Unix.O_NONBLOCK] + 0o666 + in + Unix.close fd ; Unix.utimes file_path 0.0 0.0 let is_empty_file file_path = try let stats = Unix.stat file_path in stats.Unix.st_size = 0 - with Unix.Unix_error (Unix.ENOENT, _, _) -> - false + with Unix.Unix_error (Unix.ENOENT, _, _) -> false let delete_empty_file file_path = - if is_empty_file file_path - then (Sys.remove file_path; true) - else (false) + if is_empty_file file_path then ( + Sys.remove file_path ; true + ) else + false (** Create a new file descriptor, connect it to host:port and return it *) exception Host_not_found of string + let open_connection_fd host port = let open Unix in - let addrinfo = getaddrinfo host (string_of_int port) [AI_SOCKTYPE SOCK_STREAM] in + let addrinfo = + getaddrinfo host (string_of_int port) [AI_SOCKTYPE SOCK_STREAM] + in match addrinfo with | [] -> - failwith (Printf.sprintf "Couldn't resolve hostname: %s" host) - | ai :: _ -> - let s = socket ai.ai_family ai.ai_socktype 0 in - try - connect s ai.ai_addr; - s - with e -> - Backtrace.is_important e; - close s; - raise e + failwith (Printf.sprintf "Couldn't resolve hostname: %s" host) + | ai :: _ -> ( + let s = socket ai.ai_family ai.ai_socktype 0 in + try connect s ai.ai_addr ; s + with e -> Backtrace.is_important e ; close s ; raise e + ) let open_connection_unix_fd filename = let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in try - let addr = Unix.ADDR_UNIX(filename) in - Unix.connect s addr; - s - with e -> - Backtrace.is_important e; - Unix.close s; - raise e + let addr = Unix.ADDR_UNIX filename in + Unix.connect s addr ; s + with e -> Backtrace.is_important e ; Unix.close s ; raise e module CBuf = struct (** A circular buffer constructed from a string *) type t = { - mutable buffer: bytes; - mutable len: int; (** bytes of valid data in [buffer] *) - mutable start: int; (** index of first valid byte in [buffer] *) - mutable r_closed: bool; (** true if no more data can be read due to EOF *) - mutable w_closed: bool; (** true if no more data can be written due to EOF *) - } - - let empty length = { - buffer = Bytes.create length; - len = 0; - start = 0; - r_closed = false; - w_closed = false; + mutable buffer: bytes + ; mutable len: int (** bytes of valid data in [buffer] *) + ; mutable start: int (** index of first valid byte in [buffer] *) + ; mutable r_closed: bool (** true if no more data can be read due to EOF *) + ; mutable w_closed: bool + (** true if no more data can be written due to EOF *) } - let drop (x: t) n = - if n > x.len then failwith (Printf.sprintf "drop %d > %d" n x.len); - x.start <- (x.start + n) mod (Bytes.length x.buffer); + let empty length = + { + buffer= Bytes.create length + ; len= 0 + ; start= 0 + ; r_closed= false + ; w_closed= false + } + + let drop (x : t) n = + if n > x.len then failwith (Printf.sprintf "drop %d > %d" n x.len) ; + x.start <- (x.start + n) mod Bytes.length x.buffer ; x.len <- x.len - n - let should_read (x: t) = - not x.r_closed && (x.len < (Bytes.length x.buffer - 1)) - let should_write (x: t) = - not x.w_closed && (x.len > 0) + let should_read (x : t) = + (not x.r_closed) && x.len < Bytes.length x.buffer - 1 + + let should_write (x : t) = (not x.w_closed) && x.len > 0 + + let end_of_reads (x : t) = x.r_closed && x.len = 0 - let end_of_reads (x: t) = x.r_closed && x.len = 0 - let end_of_writes (x: t) = x.w_closed + let end_of_writes (x : t) = x.w_closed - let write (x: t) fd = + let write (x : t) fd = (* Offset of the character after the substring *) let next = min (Bytes.length x.buffer) (x.start + x.len) in let len = next - x.start in - let written = try Unix.single_write fd x.buffer x.start len with _ -> x.w_closed <- true; len in + let written = + try Unix.single_write fd x.buffer x.start len + with _ -> + x.w_closed <- true ; + len + in drop x written - let read (x: t) fd = + let read (x : t) fd = (* Offset of the next empty character *) - let next = (x.start + x.len) mod (Bytes.length x.buffer) in - let len = min (Bytes.length x.buffer - next) (Bytes.length x.buffer - x.len) in + let next = (x.start + x.len) mod Bytes.length x.buffer in + let len = + min (Bytes.length x.buffer - next) (Bytes.length x.buffer - x.len) + in let read = Unix.read fd x.buffer next len in - if read = 0 then x.r_closed <- true; + if read = 0 then x.r_closed <- true ; x.len <- x.len + read - end exception Process_still_alive -let kill_and_wait ?(signal = Sys.sigterm) ?(timeout=10.) pid = +let kill_and_wait ?(signal = Sys.sigterm) ?(timeout = 10.) pid = let proc_entry_exists pid = - try Unix.access (Printf.sprintf "/proc/%d" pid) [ Unix.F_OK ]; true + try + Unix.access (Printf.sprintf "/proc/%d" pid) [Unix.F_OK] ; + true with _ -> false in if pid > 0 && proc_entry_exists pid then ( let loop_time_waiting = 0.03 in let left = ref timeout in let readcmdline pid = - try string_of_file (Printf.sprintf "/proc/%d/cmdline" pid) - with _ -> "" + try string_of_file (Printf.sprintf "/proc/%d/cmdline" pid) with _ -> "" in let reference = readcmdline pid and quit = ref false in - Unix.kill pid signal; - + Unix.kill pid signal ; (* We cannot do a waitpid here, since we might not be parent of the process, so instead we are waiting for the /proc/%d to go away. Also we verify that the cmdline stay the same if it's still here to prevent the very very unlikely event that the pid get reused before we notice it's gone *) - while proc_entry_exists pid && not !quit && !left > 0. - do + while proc_entry_exists pid && (not !quit) && !left > 0. do let cmdline = readcmdline pid in if cmdline = reference then ( (* still up, let's sleep a bit *) - ignore (Unix.select [] [] [] loop_time_waiting); + ignore (Unix.select [] [] [] loop_time_waiting) ; left := !left -. loop_time_waiting - ) else ( - (* not the same, it's gone ! *) + ) else (* not the same, it's gone ! *) quit := true - ) - done; + done ; if !left <= 0. then - raise Process_still_alive; + raise Process_still_alive ) let string_of_signal x = - let table = [ - Sys.sigabrt, "SIGABRT"; - Sys.sigalrm, "SIGALRM"; - Sys.sigfpe, "SIGFPE"; - Sys.sighup, "SIGHUP"; - Sys.sigill, "SIGILL"; - Sys.sigint, "SIGINT"; - Sys.sigkill, "SIGKILL"; - Sys.sigpipe, "SIGPIPE"; - Sys.sigquit, "SIGQUIT"; - Sys.sigsegv, "SIGSEGV"; - Sys.sigterm, "SIGTERM"; - Sys.sigusr1, "SIGUSR1"; - Sys.sigusr2, "SIGUSR2"; - Sys.sigchld, "SIGCHLD"; - Sys.sigcont, "SIGCONT"; - Sys.sigstop, "SIGSTOP"; - Sys.sigttin, "SIGTTIN"; - Sys.sigttou, "SIGTTOU"; - Sys.sigvtalrm, "SIGVTALRM"; - Sys.sigprof, "SIGPROF"; - ] in - if List.mem_assoc x table - then List.assoc x table - else (Printf.sprintf "(ocaml signal %d with an unknown name)" x) - -let proxy (a: Unix.file_descr) (b: Unix.file_descr) = + let table = + [ + (Sys.sigabrt, "SIGABRT") + ; (Sys.sigalrm, "SIGALRM") + ; (Sys.sigfpe, "SIGFPE") + ; (Sys.sighup, "SIGHUP") + ; (Sys.sigill, "SIGILL") + ; (Sys.sigint, "SIGINT") + ; (Sys.sigkill, "SIGKILL") + ; (Sys.sigpipe, "SIGPIPE") + ; (Sys.sigquit, "SIGQUIT") + ; (Sys.sigsegv, "SIGSEGV") + ; (Sys.sigterm, "SIGTERM") + ; (Sys.sigusr1, "SIGUSR1") + ; (Sys.sigusr2, "SIGUSR2") + ; (Sys.sigchld, "SIGCHLD") + ; (Sys.sigcont, "SIGCONT") + ; (Sys.sigstop, "SIGSTOP") + ; (Sys.sigttin, "SIGTTIN") + ; (Sys.sigttou, "SIGTTOU") + ; (Sys.sigvtalrm, "SIGVTALRM") + ; (Sys.sigprof, "SIGPROF") + ] + in + if List.mem_assoc x table then + List.assoc x table + else + Printf.sprintf "(ocaml signal %d with an unknown name)" x + +let proxy (a : Unix.file_descr) (b : Unix.file_descr) = let size = 64 * 1024 in (* [a'] is read from [a] and will be written to [b] *) (* [b'] is read from [b] and will be written to [a] *) let a' = CBuf.empty size and b' = CBuf.empty size in - Unix.set_nonblock a; - Unix.set_nonblock b; - + Unix.set_nonblock a ; + Unix.set_nonblock b ; try while true do - let r = (if CBuf.should_read a' then [ a ] else []) @ (if CBuf.should_read b' then [ b ] else []) in - let w = (if CBuf.should_write a' then [ b ] else []) @ (if CBuf.should_write b' then [ a ] else []) in - + let r = + (if CBuf.should_read a' then [a] else []) + @ if CBuf.should_read b' then [b] else [] + in + let w = + (if CBuf.should_write a' then [b] else []) + @ if CBuf.should_write b' then [a] else [] + in (* If we can't make any progress (because fds have been closed), then stop *) - if r = [] && w = [] then raise End_of_file; - + if r = [] && w = [] then raise End_of_file ; let r, w, _ = Unix.select r w [] (-1.0) in (* Do the writing before the reading *) - List.iter (fun fd -> if a = fd then CBuf.write b' a else CBuf.write a' b) w; - List.iter (fun fd -> if a = fd then CBuf.read a' a else CBuf.read b' b) r; + List.iter + (fun fd -> if a = fd then CBuf.write b' a else CBuf.write a' b) + w ; + List.iter (fun fd -> if a = fd then CBuf.read a' a else CBuf.read b' b) r ; (* If there's nothing else to read or write then signal the other end *) List.iter (fun (buf, fd) -> - if CBuf.end_of_reads buf then Unix.shutdown fd Unix.SHUTDOWN_SEND; - if CBuf.end_of_writes buf then Unix.shutdown fd Unix.SHUTDOWN_RECEIVE - ) [ a', b; b', a ] + if CBuf.end_of_reads buf then Unix.shutdown fd Unix.SHUTDOWN_SEND ; + if CBuf.end_of_writes buf then Unix.shutdown fd Unix.SHUTDOWN_RECEIVE + ) + [(a', b); (b', a)] done - with _ -> - (try Unix.clear_nonblock a with _ -> ()); - (try Unix.clear_nonblock b with _ -> ()); - (try Unix.close a with _ -> ()); - (try Unix.close b with _ -> ()) + with _ -> ( + (try Unix.clear_nonblock a with _ -> ()) ; + (try Unix.clear_nonblock b with _ -> ()) ; + (try Unix.close a with _ -> ()) ; + try Unix.close b with _ -> () + ) let rec really_read fd string off n = - if n=0 then () else + if n = 0 then + () + else let m = Unix.read fd string off n in - if m = 0 then raise End_of_file; - really_read fd string (off+m) (n-m) + if m = 0 then raise End_of_file ; + really_read fd string (off + m) (n - m) let really_read_string fd length = let buf = Bytes.make length '\000' in - really_read fd buf 0 length; + really_read fd buf 0 length ; Bytes.unsafe_to_string buf let try_read_string ?limit fd = @@ -459,38 +481,43 @@ let try_read_string ?limit fd = let cache = Bytes.make chunk '\000' in let finished = ref false in while not !finished do - let to_read = match limit with - | Some x -> min (x - (Buffer.length buf)) chunk - | None -> chunk in + let to_read = + match limit with + | Some x -> + min (x - Buffer.length buf) chunk + | None -> + chunk + in let read_bytes = Unix.read fd cache 0 to_read in - Buffer.add_subbytes buf cache 0 read_bytes; + Buffer.add_subbytes buf cache 0 read_bytes ; if read_bytes = 0 then finished := true - done; + done ; Buffer.contents buf (* From https://ocaml.github.io/ocamlunix/ocamlunix.html#sec118 -The function write of the Unix module iterates the system call write until -all the requested bytes are effectively written. -val write : file_descr -> string -> int -> int -> int -However, when the descriptor is a pipe (or a socket, see chapter 6), writes -may block and the system call write may be interrupted by a signal. In this -case the OCaml call to Unix.write is interrupted and the error EINTR is raised. -The problem is that some of the data may already have been written by a -previous system call to write but the actual size that was transferred is -unknown and lost. This renders the function write of the Unix module useless -in the presence of signals. - -To address this problem, the Unix module also provides the “raw” system call -write under the name single_write. - -We can use multiple single_write calls to write exactly the requested -amount of data (but not atomically!). + The function write of the Unix module iterates the system call write until + all the requested bytes are effectively written. + val write : file_descr -> string -> int -> int -> int + However, when the descriptor is a pipe (or a socket, see chapter 6), writes + may block and the system call write may be interrupted by a signal. In this + case the OCaml call to Unix.write is interrupted and the error EINTR is raised. + The problem is that some of the data may already have been written by a + previous system call to write but the actual size that was transferred is + unknown and lost. This renders the function write of the Unix module useless + in the presence of signals. + + To address this problem, the Unix module also provides the “raw” system call + write under the name single_write. + + We can use multiple single_write calls to write exactly the requested + amount of data (but not atomically!). *) let rec restart_on_EINTR f x = try f x with Unix.Unix_error (Unix.EINTR, _, _) -> restart_on_EINTR f x + and really_write fd buffer offset len = let n = restart_on_EINTR (Unix.single_write_substring fd buffer offset) len in - if n < len then really_write fd buffer (offset + n) (len - n);; + if n < len then really_write fd buffer (offset + n) (len - n) (* Ideally, really_write would be implemented with optional arguments ?(off=0) ?(len=String.length string) *) let really_write_string fd string = @@ -504,28 +531,43 @@ exception Timeout (* Write as many bytes to a file descriptor as possible from data before a given clock time. *) (* Raises Timeout exception if the number of bytes written is less than the specified length. *) (* Writes into the file descriptor at the current cursor position. *) -let time_limited_write_internal (write : Unix.file_descr -> 'a -> int -> int -> int) filedesc length data target_response_time = +let time_limited_write_internal + (write : Unix.file_descr -> 'a -> int -> int -> int) filedesc length data + target_response_time = let total_bytes_to_write = length in let bytes_written = ref 0 in - let now = ref (Unix.gettimeofday()) in + let now = ref (Unix.gettimeofday ()) in while !bytes_written < total_bytes_to_write && !now < target_response_time do let remaining_time = target_response_time -. !now in - let (_, ready_to_write, _) = Unix.select [] [filedesc] [] remaining_time in (* Note: there is a possibility that the storage could go away after the select and before the write, so the write would block. *) - if List.mem filedesc ready_to_write then begin - let bytes_to_write = total_bytes_to_write - !bytes_written in - let bytes = (try write filedesc data !bytes_written bytes_to_write with Unix.Unix_error(Unix.EAGAIN,_,_) | Unix.Unix_error(Unix.EWOULDBLOCK,_,_) -> 0) in (* write from buffer=data from offset=bytes_written, length=bytes_to_write *) - bytes_written := bytes + !bytes_written; - end; - now := Unix.gettimeofday() - done; - if !bytes_written = total_bytes_to_write then () else (* we ran out of time *) raise Timeout + let _, ready_to_write, _ = Unix.select [] [filedesc] [] remaining_time in + (* Note: there is a possibility that the storage could go away after the select and before the write, so the write would block. *) + ( if List.mem filedesc ready_to_write then + let bytes_to_write = total_bytes_to_write - !bytes_written in + let bytes = + try write filedesc data !bytes_written bytes_to_write + with + | Unix.Unix_error (Unix.EAGAIN, _, _) + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) + -> + 0 + in + (* write from buffer=data from offset=bytes_written, length=bytes_to_write *) + bytes_written := bytes + !bytes_written + ) ; + now := Unix.gettimeofday () + done ; + if !bytes_written = total_bytes_to_write then + () + else (* we ran out of time *) + raise Timeout let time_limited_write filedesc length data target_response_time = - time_limited_write_internal Unix.write filedesc length data target_response_time + time_limited_write_internal Unix.write filedesc length data + target_response_time let time_limited_write_substring filedesc length data target_response_time = - time_limited_write_internal Unix.write_substring filedesc length data target_response_time - + time_limited_write_internal Unix.write_substring filedesc length data + target_response_time (* Read as many bytes to a file descriptor as possible before a given clock time. *) (* Raises Timeout exception if the number of bytes read is less than the desired number. *) @@ -534,130 +576,172 @@ let time_limited_read filedesc length target_response_time = let total_bytes_to_read = length in let bytes_read = ref 0 in let buf = Bytes.make total_bytes_to_read '\000' in - let now = ref (Unix.gettimeofday()) in + let now = ref (Unix.gettimeofday ()) in while !bytes_read < total_bytes_to_read && !now < target_response_time do let remaining_time = target_response_time -. !now in - let (ready_to_read, _, _) = Unix.select [filedesc] [] [] remaining_time in - if List.mem filedesc ready_to_read then begin - let bytes_to_read = total_bytes_to_read - !bytes_read in - let bytes = (try Unix.read filedesc buf !bytes_read bytes_to_read with Unix.Unix_error(Unix.EAGAIN,_,_) | Unix.Unix_error(Unix.EWOULDBLOCK,_,_) -> 0) in (* read into buffer=buf from offset=bytes_read, length=bytes_to_read *) - if bytes = 0 then raise End_of_file (* End of file has been reached *) - else bytes_read := bytes + !bytes_read - end; - now := Unix.gettimeofday() - done; - if !bytes_read = total_bytes_to_read then (Bytes.unsafe_to_string buf) else (* we ran out of time *) raise Timeout + let ready_to_read, _, _ = Unix.select [filedesc] [] [] remaining_time in + ( if List.mem filedesc ready_to_read then + let bytes_to_read = total_bytes_to_read - !bytes_read in + let bytes = + try Unix.read filedesc buf !bytes_read bytes_to_read + with + | Unix.Unix_error (Unix.EAGAIN, _, _) + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) + -> + 0 + in + (* read into buffer=buf from offset=bytes_read, length=bytes_to_read *) + if bytes = 0 then + raise End_of_file (* End of file has been reached *) + else + bytes_read := bytes + !bytes_read + ) ; + now := Unix.gettimeofday () + done ; + if !bytes_read = total_bytes_to_read then + Bytes.unsafe_to_string buf + else (* we ran out of time *) + raise Timeout (* --------------------------------------------------------------------------------------- *) (* Read a given number of bytes of data from the fd, or stop at EOF, whichever comes first. *) (* A negative ~max_bytes indicates that all the data should be read from the fd until EOF. This is the default. *) -let read_data_in_chunks_internal (sub : bytes -> int -> int -> 'a) (f : 'a -> int -> unit) ?(block_size = 1024) ?(max_bytes = -1) from_fd = +let read_data_in_chunks_internal (sub : bytes -> int -> int -> 'a) + (f : 'a -> int -> unit) ?(block_size = 1024) ?(max_bytes = -1) from_fd = let buf = Bytes.make block_size '\000' in let rec do_read acc = let remaining_bytes = max_bytes - acc in - if remaining_bytes = 0 then acc (* we've read the amount requested *) - else begin - let bytes_to_read = (if max_bytes < 0 || remaining_bytes > block_size then block_size else remaining_bytes) in + if remaining_bytes = 0 then + acc (* we've read the amount requested *) + else + let bytes_to_read = + if max_bytes < 0 || remaining_bytes > block_size then + block_size + else + remaining_bytes + in let bytes_read = Unix.read from_fd buf 0 bytes_to_read in - if bytes_read = 0 then acc (* we reached EOF *) - else begin - f (sub buf 0 bytes_read) bytes_read; + if bytes_read = 0 then + acc (* we reached EOF *) + else ( + f (sub buf 0 bytes_read) bytes_read ; do_read (acc + bytes_read) - end - end in + ) + in do_read 0 -let read_data_in_string_chunks (f : string -> int -> unit) ?(block_size = 1024) ?(max_bytes = -1) from_fd = +let read_data_in_string_chunks (f : string -> int -> unit) ?(block_size = 1024) + ?(max_bytes = -1) from_fd = read_data_in_chunks_internal Bytes.sub_string f ~block_size ~max_bytes from_fd -let read_data_in_chunks (f : bytes -> int -> unit) ?(block_size = 1024) ?(max_bytes = -1) from_fd = +let read_data_in_chunks (f : bytes -> int -> unit) ?(block_size = 1024) + ?(max_bytes = -1) from_fd = read_data_in_chunks_internal Bytes.sub f ~block_size ~max_bytes from_fd -let spawnvp ?(pid_callback=(fun _ -> ())) cmd args = +let spawnvp ?(pid_callback = fun _ -> ()) cmd args = match Unix.fork () with | 0 -> - Unix.execvp cmd args + Unix.execvp cmd args | pid -> - begin try pid_callback pid with _ -> () end; - snd (Unix.waitpid [] pid) + (try pid_callback pid with _ -> ()) ; + snd (Unix.waitpid [] pid) let double_fork f = match Unix.fork () with - | 0 -> - begin match Unix.fork () with - (* NB: use _exit (calls C lib _exit directly) to avoid - calling at_exit handlers and flushing output channels - which wouild cause intermittent deadlocks if we - forked from a threaded program *) - | 0 -> (try f () with _ -> ()); _exit 0 - | _ -> _exit 0 - end - | pid -> ignore(Unix.waitpid [] pid) - -external set_tcp_nodelay : Unix.file_descr -> bool -> unit = "stub_unixext_set_tcp_nodelay" -external set_sock_keepalives : Unix.file_descr -> int -> int -> int -> unit = "stub_unixext_set_sock_keepalives" + | 0 -> ( + match Unix.fork () with + (* NB: use _exit (calls C lib _exit directly) to avoid + calling at_exit handlers and flushing output channels + which wouild cause intermittent deadlocks if we + forked from a threaded program *) + | 0 -> + (try f () with _ -> ()) ; + _exit 0 + | _ -> + _exit 0 + ) + | pid -> + ignore (Unix.waitpid [] pid) + +external set_tcp_nodelay : Unix.file_descr -> bool -> unit + = "stub_unixext_set_tcp_nodelay" + +external set_sock_keepalives : Unix.file_descr -> int -> int -> int -> unit + = "stub_unixext_set_sock_keepalives" + external fsync : Unix.file_descr -> unit = "stub_unixext_fsync" + external blkgetsize64 : Unix.file_descr -> int64 = "stub_unixext_blkgetsize64" external get_max_fd : unit -> int = "stub_unixext_get_max_fd" -let int_of_file_descr (x: Unix.file_descr) : int = Obj.magic x -let file_descr_of_int (x: int) : Unix.file_descr = Obj.magic x +let int_of_file_descr (x : Unix.file_descr) : int = Obj.magic x + +let file_descr_of_int (x : int) : Unix.file_descr = Obj.magic x (** Forcibly closes all open file descriptors except those explicitly passed in as arguments. Useful to avoid accidentally passing a file descriptor opened in another thread to a process being concurrently fork()ed (there's a race between open/set_close_on_exec). NB this assumes that 'type Unix.file_descr = int' *) -let close_all_fds_except (fds: Unix.file_descr list) = +let close_all_fds_except (fds : Unix.file_descr list) = (* get at the file descriptor within *) let fds' = List.map int_of_file_descr fds in - let close' (x: int) = - try Unix.close(file_descr_of_int x) with _ -> () in - + let close' (x : int) = try Unix.close (file_descr_of_int x) with _ -> () in let highest_to_keep = List.fold_left max (-1) fds' in (* close all the fds higher than the one we want to keep *) - for i = highest_to_keep + 1 to get_max_fd () do close' i done; + for i = highest_to_keep + 1 to get_max_fd () do + close' i + done ; (* close all the rest *) for i = 0 to highest_to_keep - 1 do - if not(List.mem i fds') then close' i + if not (List.mem i fds') then close' i done - (** Remove "." and ".." from paths (NB doesn't attempt to resolve symlinks) *) -let resolve_dot_and_dotdot (path: string) : string = - let of_string (x: string): string list = +let resolve_dot_and_dotdot (path : string) : string = + let of_string (x : string) : string list = let rec rev_split path = let basename = Filename.basename path and dirname = Filename.dirname path in - let rest = if Filename.dirname dirname = dirname then [] else rev_split dirname in - basename :: rest in + let rest = + if Filename.dirname dirname = dirname then [] else rev_split dirname + in + basename :: rest + in let abs_path path = - if Filename.is_relative path - then Filename.concat "/" path (* no notion of a cwd *) - else path in - rev_split (abs_path x) in - - let to_string (x: string list) = List.fold_left Filename.concat "/" (List.rev x) in - + if Filename.is_relative path then + Filename.concat "/" path (* no notion of a cwd *) + else + path + in + rev_split (abs_path x) + in + let to_string (x : string list) = + List.fold_left Filename.concat "/" (List.rev x) + in (* Process all "." and ".." references *) - let rec remove_dots (n: int) (x: string list) = - match x, n with - | [], _ -> [] - | "." :: rest, _ -> remove_dots n rest (* throw away ".", don't count as parent for ".." *) - | ".." :: rest, _ -> remove_dots (n + 1) rest (* note the number of ".." *) - | x :: rest, 0 -> x :: (remove_dots 0 rest) - | _ :: rest, n -> remove_dots (n - 1) rest (* munch *) in + let rec remove_dots (n : int) (x : string list) = + match (x, n) with + | [], _ -> + [] + | "." :: rest, _ -> + remove_dots n rest (* throw away ".", don't count as parent for ".." *) + | ".." :: rest, _ -> + remove_dots (n + 1) rest (* note the number of ".." *) + | x :: rest, 0 -> + x :: remove_dots 0 rest + | _ :: rest, n -> + remove_dots (n - 1) rest (* munch *) + in to_string (remove_dots 0 (of_string path)) (** Seek to an absolute offset within a file descriptor *) -let seek_to fd pos = - Unix.lseek fd pos Unix.SEEK_SET +let seek_to fd pos = Unix.lseek fd pos Unix.SEEK_SET (** Seek to an offset within a file descriptor, relative to the current cursor position *) -let seek_rel fd diff = - Unix.lseek fd diff Unix.SEEK_CUR +let seek_rel fd diff = Unix.lseek fd diff Unix.SEEK_CUR (** Return the current cursor position within a file descriptor *) let current_cursor_pos fd = @@ -666,34 +750,34 @@ let current_cursor_pos fd = let wait_for_path path delay timeout = let rec inner ttl = - if ttl=0 then failwith "No path!"; - try - ignore(Unix.stat path) + if ttl = 0 then failwith "No path!" ; + try ignore (Unix.stat path) with _ -> - delay 0.5; + delay 0.5 ; inner (ttl - 1) in inner (timeout * 2) - -let _ = Callback.register_exception "unixext.unix_error" (Unix_error (0)) +let _ = Callback.register_exception "unixext.unix_error" (Unix_error 0) let send_fd = Fd_send_recv.send_fd + let send_fd_substring = Fd_send_recv.send_fd_substring + let recv_fd = Fd_send_recv.recv_fd type statvfs_t = { - f_bsize : int64; - f_frsize : int64; - f_blocks : int64; - f_bfree : int64; - f_bavail : int64; - f_files : int64; - f_ffree : int64; - f_favail : int64; - f_fsid : int64; - f_flag : int64; - f_namemax : int64; + f_bsize: int64 + ; f_frsize: int64 + ; f_blocks: int64 + ; f_bfree: int64 + ; f_bavail: int64 + ; f_files: int64 + ; f_ffree: int64 + ; f_favail: int64 + ; f_fsid: int64 + ; f_flag: int64 + ; f_namemax: int64 } external statvfs : string -> statvfs_t = "stub_statvfs" @@ -708,7 +792,8 @@ let domain_of_addr str = module Direct = struct type t = Unix.file_descr - external openfile : string -> Unix.open_flag list -> Unix.file_perm -> t = "stub_stdext_unix_open_direct" + external openfile : string -> Unix.open_flag list -> Unix.file_perm -> t + = "stub_stdext_unix_open_direct" let close = Unix.close @@ -716,14 +801,17 @@ module Direct = struct let t = openfile path flags perms in finally (fun () -> f t) (fun () -> close t) - external unsafe_write : t -> bytes -> int -> int -> int = "stub_stdext_unix_write" + external unsafe_write : t -> bytes -> int -> int -> int + = "stub_stdext_unix_write" let write fd buf ofs len = - if ofs < 0 || len < 0 || ofs > Bytes.length buf - len - then invalid_arg "Unixext.write" - else unsafe_write fd buf ofs len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then + invalid_arg "Unixext.write" + else + unsafe_write fd buf ofs len - let copy_from_fd ?limit socket fd = copy_file_internal ?limit (Unix.read socket) (write fd) + let copy_from_fd ?limit socket fd = + copy_file_internal ?limit (Unix.read socket) (write fd) let fsync x = fsync x diff --git a/lib/xapi-stdext-unix/unixext.mli b/lib/xapi-stdext-unix/unixext.mli index 032270d45fe..c6168150b54 100644 --- a/lib/xapi-stdext-unix/unixext.mli +++ b/lib/xapi-stdext-unix/unixext.mli @@ -14,169 +14,242 @@ (** A collection of extensions to the [Unix] module. *) val _exit : int -> unit + val unlink_safe : string -> unit + val mkdir_safe : string -> Unix.file_perm -> unit + val mkdir_rec : string -> Unix.file_perm -> unit +val rm_rec : ?rm_top:bool -> string -> unit (** removes a file or recursively removes files/directories below a directory without following symbolic links. If path is a directory, it is only itself removed if rm_top is true. If path is non-existent nothing happens, it does not lead to an error. *) -val rm_rec : ?rm_top:bool -> string -> unit val pidfile_write : string -> unit + val pidfile_read : string -> int option + val daemonize : unit -> unit -val with_file : string -> Unix.open_flag list -> Unix.file_perm -> (Unix.file_descr -> 'a) -> 'a + +val with_file : + string + -> Unix.open_flag list + -> Unix.file_perm + -> (Unix.file_descr -> 'a) + -> 'a + val with_input_channel : string -> (in_channel -> 'a) -> 'a + val with_directory : string -> (Unix.dir_handle -> 'a) -> 'a (** Exception to be raised in function to break out of [file_lines_fold]. *) exception Break -(** Folds function [f] over every line in the input channel *) val lines_fold : ('a -> string -> 'a) -> 'a -> in_channel -> 'a +(** Folds function [f] over every line in the input channel *) -(** Applies function [f] to every line in the input channel *) val lines_iter : (string -> unit) -> in_channel -> unit +(** Applies function [f] to every line in the input channel *) +val file_lines_fold : ('a -> string -> 'a) -> 'a -> string -> 'a (** Folds function [f] over every line in the file at [file_path] using the starting value [start]. *) -val file_lines_fold : ('a -> string -> 'a) -> 'a -> string -> 'a -(** [read_lines path] returns a list of lines in the file at [path]. *) val read_lines : path:string -> string list +(** [read_lines path] returns a list of lines in the file at [path]. *) -(** Applies function [f] to every line in the file at [file_path]. *) val file_lines_iter : (string -> unit) -> string -> unit +(** Applies function [f] to every line in the file at [file_path]. *) +val fd_blocks_fold : int -> ('a -> bytes -> 'a) -> 'a -> Unix.file_descr -> 'a (** [fd_blocks_fold block_size f start fd] folds [f] over blocks (strings) from the fd [fd] with initial value [start] *) -val fd_blocks_fold: int -> ('a -> bytes -> 'a) -> 'a -> Unix.file_descr -> 'a -(** Alias for function [file_lines_iter]. *) val readfile_line : (string -> 'a) -> string -> unit +(** Alias for function [file_lines_iter]. *) -(** [buffer_of_fd fd] returns a Buffer.t containing all data read from [fd] up to EOF *) val buffer_of_fd : Unix.file_descr -> Buffer.t +(** [buffer_of_fd fd] returns a Buffer.t containing all data read from [fd] up to EOF *) -(** [string_of_fd fd] returns a string containing all data read from [fd] up to EOF *) val string_of_fd : Unix.file_descr -> string +(** [string_of_fd fd] returns a string containing all data read from [fd] up to EOF *) -(** [buffer_of_file file] returns a Buffer.t containing the contents of [file] *) val buffer_of_file : string -> Buffer.t +(** [buffer_of_file file] returns a Buffer.t containing the contents of [file] *) -(** [string_of_file file] returns a string containing the contents of [file] *) val string_of_file : string -> string +(** [string_of_file file] returns a string containing the contents of [file] *) +val atomic_write_to_file : + string -> Unix.file_perm -> (Unix.file_descr -> 'a) -> 'a (** [atomic_write_to_file fname perms f] writes a file to path [fname] using the function [f] with permissions [perms]. In case of error during the operation the file with the path [fname] is not modified at all. *) -val atomic_write_to_file : string -> Unix.file_perm -> (Unix.file_descr -> 'a) -> 'a +val write_string_to_file : ?perms:Unix.file_perm -> string -> string -> unit (** [write_string_to_file fname contents] creates a file with path [fname] with the string [contents] as its contents, atomically *) -val write_string_to_file : ?perms:Unix.file_perm -> string -> string -> unit +val write_bytes_to_file : ?perms:Unix.file_perm -> string -> bytes -> unit (** [write_string_to_file fname contents] creates a file with path [fname] with the buffer [contents] as its contents, atomically *) -val write_bytes_to_file : ?perms:Unix.file_perm -> string -> bytes -> unit + val execv_get_output : string -> string array -> int * Unix.file_descr + val copy_file : ?limit:int64 -> Unix.file_descr -> Unix.file_descr -> int64 -(** Returns true if and only if a file exists at the given path. *) val file_exists : string -> bool +(** Returns true if and only if a file exists at the given path. *) +val touch_file : string -> unit (** Sets both the access and modification times of the file * at the given path to the current time. Creates an empty * file at the given path if no such file already exists. *) -val touch_file : string -> unit -(** Returns true if and only if an empty file exists at the given path. *) val is_empty_file : string -> bool +(** Returns true if and only if an empty file exists at the given path. *) +val delete_empty_file : string -> bool (** Safely deletes a file at the given path if (and only if) the * file exists and is empty. Returns true if a file was deleted. *) -val delete_empty_file : string -> bool exception Host_not_found of string + val open_connection_fd : string -> int -> Unix.file_descr -val open_connection_unix_fd : string -> Unix.file_descr +val open_connection_unix_fd : string -> Unix.file_descr exception Process_still_alive + val kill_and_wait : ?signal:int -> ?timeout:float -> int -> unit +val string_of_signal : int -> string (** [string_of_signal x] translates an ocaml signal number into * a string suitable for logging. *) -val string_of_signal : int -> string val proxy : Unix.file_descr -> Unix.file_descr -> unit + val really_read : Unix.file_descr -> bytes -> int -> int -> unit + val really_read_string : Unix.file_descr -> int -> string +val really_write : Unix.file_descr -> string -> int -> int -> unit (** [really_write] keeps repeating the write operation until all bytes * have been written or an error occurs. This is not atomic but is * robust against EINTR errors. * See: https://ocaml.github.io/ocamlunix/ocamlunix.html#sec118 *) -val really_write : Unix.file_descr -> string -> int -> int -> unit + val really_write_string : Unix.file_descr -> string -> unit -val try_read_string : ?limit: int -> Unix.file_descr -> string + +val try_read_string : ?limit:int -> Unix.file_descr -> string + exception Timeout + val time_limited_write : Unix.file_descr -> int -> bytes -> float -> unit -val time_limited_write_substring : Unix.file_descr -> int -> string -> float -> unit + +val time_limited_write_substring : + Unix.file_descr -> int -> string -> float -> unit + val time_limited_read : Unix.file_descr -> int -> float -> string -val read_data_in_string_chunks : (string -> int -> unit) -> ?block_size:int -> ?max_bytes:int -> Unix.file_descr -> int -val read_data_in_chunks : (bytes -> int -> unit) -> ?block_size:int -> ?max_bytes:int -> Unix.file_descr -> int + +val read_data_in_string_chunks : + (string -> int -> unit) + -> ?block_size:int + -> ?max_bytes:int + -> Unix.file_descr + -> int + +val read_data_in_chunks : + (bytes -> int -> unit) + -> ?block_size:int + -> ?max_bytes:int + -> Unix.file_descr + -> int + val spawnvp : - ?pid_callback:(int -> unit) -> - string -> string array -> Unix.process_status + ?pid_callback:(int -> unit) -> string -> string array -> Unix.process_status + val double_fork : (unit -> unit) -> unit + external set_tcp_nodelay : Unix.file_descr -> bool -> unit = "stub_unixext_set_tcp_nodelay" -external set_sock_keepalives : Unix.file_descr -> int -> int -> int -> unit = "stub_unixext_set_sock_keepalives" + +external set_sock_keepalives : Unix.file_descr -> int -> int -> int -> unit + = "stub_unixext_set_sock_keepalives" + external fsync : Unix.file_descr -> unit = "stub_unixext_fsync" + external get_max_fd : unit -> int = "stub_unixext_get_max_fd" + external blkgetsize64 : Unix.file_descr -> int64 = "stub_unixext_blkgetsize64" val int_of_file_descr : Unix.file_descr -> int + val file_descr_of_int : int -> Unix.file_descr + val close_all_fds_except : Unix.file_descr list -> unit + val resolve_dot_and_dotdot : string -> string val seek_to : Unix.file_descr -> int -> int + val seek_rel : Unix.file_descr -> int -> int + val current_cursor_pos : Unix.file_descr -> int val wait_for_path : string -> (float -> unit) -> int -> unit -val send_fd : Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> Unix.file_descr -> int -val send_fd_substring : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> Unix.file_descr -> int -val recv_fd : Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr * Unix.file_descr +val send_fd : + Unix.file_descr + -> bytes + -> int + -> int + -> Unix.msg_flag list + -> Unix.file_descr + -> int + +val send_fd_substring : + Unix.file_descr + -> string + -> int + -> int + -> Unix.msg_flag list + -> Unix.file_descr + -> int + +val recv_fd : + Unix.file_descr + -> bytes + -> int + -> int + -> Unix.msg_flag list + -> int * Unix.sockaddr * Unix.file_descr type statvfs_t = { - f_bsize : int64; - f_frsize : int64; - f_blocks : int64; - f_bfree : int64; - f_bavail : int64; - f_files : int64; - f_ffree : int64; - f_favail : int64; - f_fsid : int64; - f_flag : int64; - f_namemax : int64; + f_bsize: int64 + ; f_frsize: int64 + ; f_blocks: int64 + ; f_bfree: int64 + ; f_bavail: int64 + ; f_files: int64 + ; f_ffree: int64 + ; f_favail: int64 + ; f_fsid: int64 + ; f_flag: int64 + ; f_namemax: int64 } val statvfs : string -> statvfs_t -(** Returns Some Unix.PF_INET or Some Unix.PF_INET6 if passed a valid IP address, otherwise returns None. *) val domain_of_addr : string -> Unix.socket_domain option +(** Returns Some Unix.PF_INET or Some Unix.PF_INET6 if passed a valid IP address, otherwise returns None. *) module Direct : sig (** Perform I/O in O_DIRECT mode using 4KiB page-aligned buffers *) - type t (** represents a file open in O_DIRECT mode *) + type t val openfile : string -> Unix.open_flag list -> Unix.file_perm -> t (** [openfile name flags perm] behaves the same as [Unix.openfile] but includes the O_DIRECT flag *) @@ -184,7 +257,8 @@ module Direct : sig val close : t -> unit (** [close t] closes [t], a file open in O_DIRECT mode *) - val with_openfile : string -> Unix.open_flag list -> Unix.file_perm -> (t -> 'a) -> 'a + val with_openfile : + string -> Unix.open_flag list -> Unix.file_perm -> (t -> 'a) -> 'a (** [with_openfile name flags perm f] opens [name], applies the result to [f] and closes *) val write : t -> bytes -> int -> int -> int diff --git a/lib/xapi-stdext-zerocheck/zerocheck.mli b/lib/xapi-stdext-zerocheck/zerocheck.mli index 84489e637e8..08eb9b73d4e 100644 --- a/lib/xapi-stdext-zerocheck/zerocheck.mli +++ b/lib/xapi-stdext-zerocheck/zerocheck.mli @@ -12,5 +12,5 @@ * GNU Lesser General Public License for more details. *) -(** [is_all_zeroes x len] returns true if the substring is all zeroes *) external is_all_zeros : string -> int -> bool = "is_all_zeros" +(** [is_all_zeroes x len] returns true if the substring is all zeroes *) From d33900ee90023fd78e7d8668d8678dc356b8825a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 13 Dec 2023 14:04:22 +0000 Subject: [PATCH 194/199] [maintenance]: add missing dependencies MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Found by disabling `implicit_transitive_deps` Signed-off-by: Edwin Török --- dune-project | 1 + lib/xapi-stdext-date/dune | 2 +- lib/xapi-stdext-encodings/bench/dune | 2 +- lib/xapi-stdext-threads/dune | 2 +- lib/xapi-stdext-unix/dune | 1 + xapi-stdext-unix.opam | 1 + 6 files changed, 6 insertions(+), 3 deletions(-) diff --git a/dune-project b/dune-project index 4a5dce3ea07..a4973b11d9b 100644 --- a/dune-project +++ b/dune-project @@ -91,6 +91,7 @@ base-unix (fd-send-recv (>= 2.0.0)) (odoc :with-doc) + xapi-backtrace (xapi-stdext-pervasives (= :version)) ) ) diff --git a/lib/xapi-stdext-date/dune b/lib/xapi-stdext-date/dune index 75de1b43647..c2ed6c448da 100644 --- a/lib/xapi-stdext-date/dune +++ b/lib/xapi-stdext-date/dune @@ -12,5 +12,5 @@ (name test) (package xapi-stdext-date) (modules test) - (libraries alcotest xapi-stdext-date) + (libraries alcotest xapi-stdext-date ptime) ) diff --git a/lib/xapi-stdext-encodings/bench/dune b/lib/xapi-stdext-encodings/bench/dune index 11f37666064..9f12bcbf8ce 100644 --- a/lib/xapi-stdext-encodings/bench/dune +++ b/lib/xapi-stdext-encodings/bench/dune @@ -2,5 +2,5 @@ (name bench_encodings) (modes exe) (optional) - (libraries bechamel xapi_stdext_encodings bechamel-notty notty.unix) + (libraries bechamel xapi_stdext_encodings bechamel-notty notty.unix fmt) ) diff --git a/lib/xapi-stdext-threads/dune b/lib/xapi-stdext-threads/dune index ecf854e37d0..fe2cc6dd85a 100644 --- a/lib/xapi-stdext-threads/dune +++ b/lib/xapi-stdext-threads/dune @@ -2,7 +2,7 @@ (public_name xapi-stdext-threads) (name xapi_stdext_threads) (libraries - threads + threads.posix unix xapi-stdext-pervasives) ) diff --git a/lib/xapi-stdext-unix/dune b/lib/xapi-stdext-unix/dune index 9cfcbb96bd7..da0b509d2d2 100644 --- a/lib/xapi-stdext-unix/dune +++ b/lib/xapi-stdext-unix/dune @@ -4,6 +4,7 @@ (libraries fd-send-recv unix + xapi-backtrace xapi-stdext-pervasives) (foreign_stubs (language c) diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam index 1498e2bb763..8c6a38299a8 100644 --- a/xapi-stdext-unix.opam +++ b/xapi-stdext-unix.opam @@ -12,6 +12,7 @@ depends: [ "base-unix" "fd-send-recv" {>= "2.0.0"} "odoc" {with-doc} + "xapi-backtrace" "xapi-stdext-pervasives" {= version} ] build: [ From 9e074eb5c383c56b182ff5edb4ecd49209547639 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 13 Dec 2023 16:33:41 +0000 Subject: [PATCH 195/199] CI: update package repos to avoid 404 error MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- .github/workflows/ocaml-ci.yml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.github/workflows/ocaml-ci.yml b/.github/workflows/ocaml-ci.yml index 5f13703fc83..bb2125411ec 100644 --- a/.github/workflows/ocaml-ci.yml +++ b/.github/workflows/ocaml-ci.yml @@ -23,6 +23,9 @@ jobs: id: dotenv uses: falti/dotenv-action@v0.2.4 + - name: Update package repos + run: sudo apt-get update -y + - name: Use ocaml uses: avsm/setup-ocaml@v1 with: From a8661d1271b7e33c622212d66859233e162ca589 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 16 Jan 2024 15:08:32 +0000 Subject: [PATCH 196/199] CA-387588: Unixext.really_read: restart on EINTR MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit To reproduce a forkexecd unit test failure I've run it under 'rr'. This caused a different failure: EINTR from read. Unixext already has code to defend against EINTR on write, but not on read: add missing loop. Signed-off-by: Edwin Török --- lib/xapi-stdext-unix/unixext.ml | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/lib/xapi-stdext-unix/unixext.ml b/lib/xapi-stdext-unix/unixext.ml index 20f20de8e68..4cf628d45e9 100644 --- a/lib/xapi-stdext-unix/unixext.ml +++ b/lib/xapi-stdext-unix/unixext.ml @@ -462,19 +462,6 @@ let proxy (a : Unix.file_descr) (b : Unix.file_descr) = try Unix.close b with _ -> () ) -let rec really_read fd string off n = - if n = 0 then - () - else - let m = Unix.read fd string off n in - if m = 0 then raise End_of_file ; - really_read fd string (off + m) (n - m) - -let really_read_string fd length = - let buf = Bytes.make length '\000' in - really_read fd buf 0 length ; - Bytes.unsafe_to_string buf - let try_read_string ?limit fd = let buf = Buffer.create 0 in let chunk = match limit with None -> 4096 | Some x -> x in @@ -523,6 +510,19 @@ and really_write fd buffer offset len = let really_write_string fd string = really_write fd string 0 (String.length string) +let rec really_read fd string off n = + if n = 0 then + () + else + let m = restart_on_EINTR (Unix.read fd string off) n in + if m = 0 then raise End_of_file ; + really_read fd string (off + m) (n - m) + +let really_read_string fd length = + let buf = Bytes.make length '\000' in + really_read fd buf 0 length ; + Bytes.unsafe_to_string buf + (* --------------------------------------------------------------------------------------- *) (* Functions to read and write to/from a file descriptor with a given latest response time *) From 9a3ac882935ec919e4fb620103046972bbad66cf Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 16 Jan 2024 14:26:48 +0000 Subject: [PATCH 197/199] xapi-stdext-std: add Listext.List.find_minimum Useful to get the lowest or highest element in a list in linear time, as it avoids sorting the whole list. Signed-off-by: Pau Ruiz Safont --- CHANGES.md | 3 ++ lib/xapi-stdext-std/listext.ml | 4 ++ lib/xapi-stdext-std/listext.mli | 7 ++++ lib/xapi-stdext-std/listext_test.ml | 61 +++++++++++++++++++++++++++-- 4 files changed, 72 insertions(+), 3 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 581f1c96616..df8783f9adb 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,6 @@ +## Unreleased +- std: add Listext.List.find_minimum + ## v4.23.0 (30-Oct-2023) - unix: fix blkgetsize return type mismatch (CA-382014) - unix: add function to recursively remove files diff --git a/lib/xapi-stdext-std/listext.ml b/lib/xapi-stdext-std/listext.ml index c3ffc20e294..39ebb6c6ea6 100644 --- a/lib/xapi-stdext-std/listext.ml +++ b/lib/xapi-stdext-std/listext.ml @@ -196,4 +196,8 @@ module List = struct aux ((upper - 1) :: accu) (upper - 1) in aux [] + + let find_minimum compare = + let min a b = if compare a b <= 0 then a else b in + function [] -> None | x :: xs -> Some (List.fold_left min x xs) end diff --git a/lib/xapi-stdext-std/listext.mli b/lib/xapi-stdext-std/listext.mli index 08435d5a4d5..d3fcfdf79f0 100644 --- a/lib/xapi-stdext-std/listext.mli +++ b/lib/xapi-stdext-std/listext.mli @@ -49,6 +49,13 @@ module List : sig val iteri_right : (int -> 'a -> unit) -> 'a list -> unit (** [iteri_right f l] is {!Stdlib.List.iteri}[ f (]{!Stdlib.List.rev}[ l)] *) + (** {1 List searching} *) + + val find_minimum : ('a -> 'a -> int) -> 'a list -> 'a option + (** [find_minimum cmp l] returns the lowest element in [l] according to + the sort order of [cmp], or [None] if the list is empty. When two ore + more elements match the lowest value, the left-most is returned. *) + (** {1 Using indices to manipulate lists} *) val chop : int -> 'a list -> 'a list * 'a list diff --git a/lib/xapi-stdext-std/listext_test.ml b/lib/xapi-stdext-std/listext_test.ml index dc141f25b8d..2ff7961760e 100644 --- a/lib/xapi-stdext-std/listext_test.ml +++ b/lib/xapi-stdext-std/listext_test.ml @@ -17,8 +17,8 @@ let test_list tested_f (name, case, expected) = let check () = Alcotest.(check @@ list int) name expected (tested_f case) in (name, `Quick, check) -let test_option tested_f (name, case, expected) = - let check () = Alcotest.(check @@ option int) name expected (tested_f case) in +let test_option typ tested_f (name, case, expected) = + let check () = Alcotest.(check @@ option typ) name expected (tested_f case) in (name, `Quick, check) let test_chopped_list tested_f (name, case, expected) = @@ -180,6 +180,61 @@ let test_sub = let tests = List.map test specs in ("sub", tests) +let test_find_minimum (name, pp, typ, specs) = + let test ((cmp, cmp_name), input, expected) = + let name = Printf.sprintf "%s of [%s]" cmp_name (pp input) in + test_option typ (Listext.find_minimum cmp) (name, input, expected) + in + let tests = List.map test specs in + (Printf.sprintf "find_minimum (%s)" name, tests) + +let test_find_minimum_int = + let ascending = (Int.compare, "ascending") in + let descending = ((fun a b -> Int.compare b a), "descending") in + let specs_int = + ( "int" + , (fun a -> String.concat "; " (List.map string_of_int a)) + , Alcotest.int + , [ + (ascending, [], None) + ; (ascending, [1; 2; 3; 4; 5], Some 1) + ; (ascending, [2; 3; 1; 5; 4], Some 1) + ; (descending, [], None) + ; (descending, [1; 2; 3; 4; 5], Some 5) + ; (descending, [2; 3; 1; 5; 4], Some 5) + ] + ) + in + test_find_minimum specs_int + +let test_find_minimum_tuple = + let ascending = ((fun (a, _) (b, _) -> Int.compare a b), "ascending") in + let descending = ((fun (a, _) (b, _) -> Int.compare b a), "descending") in + let specs_tuple = + ( "tuple" + , (fun a -> + String.concat "; " + (List.map (fun (a, b) -> "(" ^ string_of_int a ^ ", " ^ b ^ ")") a) + ) + , Alcotest.(pair int string) + , [ + (ascending, [(1, "fst"); (1, "snd")], Some (1, "fst")) + ; (descending, [(1, "fst"); (1, "snd")], Some (1, "fst")) + ; (ascending, [(1, "fst"); (1, "snd"); (2, "nil")], Some (1, "fst")) + ; (descending, [(1, "nil"); (2, "fst"); (2, "snd")], Some (2, "fst")) + ] + ) + in + test_find_minimum specs_tuple + let () = Alcotest.run "Listext" - [test_iteri_right; test_take; test_drop; test_chop; test_sub] + [ + test_iteri_right + ; test_take + ; test_drop + ; test_chop + ; test_sub + ; test_find_minimum_int + ; test_find_minimum_tuple + ] From 7f4472cba22c8fce36ec56f206ff4241570a994a Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 17 Jan 2024 10:37:00 +0000 Subject: [PATCH 198/199] reformat with newer version of ocamlformat Signed-off-by: Pau Ruiz Safont --- lib/xapi-stdext-encodings/encodings.ml | 8 ++++---- lib/xapi-stdext-std/xstringext.ml | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/lib/xapi-stdext-encodings/encodings.ml b/lib/xapi-stdext-encodings/encodings.ml index 62058acc73b..8d6d07e012a 100644 --- a/lib/xapi-stdext-encodings/encodings.ml +++ b/lib/xapi-stdext-encodings/encodings.ml @@ -34,15 +34,15 @@ module UCS = struct false || (0xfdd0 <= value && value <= 0xfdef) (* case 1 *) || Int.logand 0xfffe value = 0xfffe - (* case 2 *) - [@@inline] + (* case 2 *) + [@@inline] end module XML = struct let is_illegal_control_character value = let value = Uchar.to_int value in value < 0x20 && value <> 0x09 && value <> 0x0a && value <> 0x0d - [@@inline] + [@@inline] end (* === UCS Validators === *) @@ -55,7 +55,7 @@ module UTF8_UCS_validator = struct let validate value = if (UCS.is_non_character [@inlined]) (Uchar.to_int value) then raise UCS_value_prohibited_in_UTF8 - [@@inline] + [@@inline] end module XML_UTF8_UCS_validator = struct diff --git a/lib/xapi-stdext-std/xstringext.ml b/lib/xapi-stdext-std/xstringext.ml index 8f5b713072f..7fb16aba6f8 100644 --- a/lib/xapi-stdext-std/xstringext.ml +++ b/lib/xapi-stdext-std/xstringext.ml @@ -74,8 +74,8 @@ module String = struct let aux h t = ( if List.mem_assoc h rules then List.assoc h rules - else - of_char h + else + of_char h ) :: t in From 38f9acbe5a3c00f2d4f905128dc5eae93f04ca34 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 17 Jan 2024 10:20:06 +0000 Subject: [PATCH 199/199] prepare for release Signed-off-by: Pau Ruiz Safont --- CHANGES.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index df8783f9adb..0973572d6da 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,4 +1,5 @@ -## Unreleased +## v4.24.0 (17-Jan-2024) +- unix: really_read now retries reads on EINTR - std: add Listext.List.find_minimum ## v4.23.0 (30-Oct-2023)