diff -Nru ocaml-sqlexpr-0.4.1/configure ocaml-sqlexpr-0.5.5/configure --- ocaml-sqlexpr-0.4.1/configure 2011-03-19 17:04:45.000000000 +0000 +++ ocaml-sqlexpr-0.5.5/configure 2013-06-15 18:14:27.000000000 +0000 @@ -1,8 +1,27 @@ #!/bin/sh # OASIS_START -# DO NOT EDIT (digest: ed33e59fe00e48bc31edf413bbc8b8d6) +# DO NOT EDIT (digest: 425187ed8bfdbdd207fd76392dd243a7) set -e -ocaml setup.ml -configure $* +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 -Nru ocaml-sqlexpr-0.4.1/debian/changelog ocaml-sqlexpr-0.5.5/debian/changelog --- ocaml-sqlexpr-0.4.1/debian/changelog 2013-12-24 09:01:05.000000000 +0000 +++ ocaml-sqlexpr-0.5.5/debian/changelog 2014-05-08 20:20:12.000000000 +0000 @@ -1,8 +1,18 @@ -ocaml-sqlexpr (0.4.1-2build1) trusty; urgency=medium +ocaml-sqlexpr (0.5.5-2) unstable; urgency=medium - * Rebuild for ocaml-4.01. + * Add ${shlibs:Depends} to Depends field of each binary package + to avoid raising the "missing-dependency-on-libc needed by sqlexpr.cmxs" + error. - -- Matthias Klose Tue, 24 Dec 2013 09:01:05 +0000 + -- Mehdi Dogguy Thu, 08 May 2014 22:20:12 +0200 + +ocaml-sqlexpr (0.5.5-1) unstable; urgency=medium + + * Team upload. + * New upstream release (Closes: #731685). + - Reresh patches. + + -- Mehdi Dogguy Thu, 08 May 2014 20:49:21 +0200 ocaml-sqlexpr (0.4.1-2) unstable; urgency=low diff -Nru ocaml-sqlexpr-0.4.1/debian/control ocaml-sqlexpr-0.5.5/debian/control --- ocaml-sqlexpr-0.4.1/debian/control 2013-09-03 22:24:53.000000000 +0000 +++ ocaml-sqlexpr-0.5.5/debian/control 2014-05-08 20:20:12.000000000 +0000 @@ -23,7 +23,7 @@ Package: libsqlexpr-ocaml-dev Architecture: any -Depends: ${ocaml:Depends}, ${misc:Depends} +Depends: ${ocaml:Depends}, ${misc:Depends}, ${shlibs:Depends} Provides: ${ocaml:Provides} Recommends: ocaml-findlib Description: type-safe, convenient SQLite database access (development) @@ -42,7 +42,7 @@ Package: libsqlexpr-ocaml Architecture: any -Depends: ${ocaml:Depends}, ${misc:Depends} +Depends: ${ocaml:Depends}, ${misc:Depends}, ${shlibs:Depends} Provides: ${ocaml:Provides} Description: type-safe, convenient SQLite database access (runtime) Minimalistic library and syntax extension for type-safe, convenient execution diff -Nru ocaml-sqlexpr-0.4.1/debian/patches/0001-Remove-buggy-param-directive.patch ocaml-sqlexpr-0.5.5/debian/patches/0001-Remove-buggy-param-directive.patch --- ocaml-sqlexpr-0.4.1/debian/patches/0001-Remove-buggy-param-directive.patch 2013-09-03 22:02:14.000000000 +0000 +++ ocaml-sqlexpr-0.5.5/debian/patches/0001-Remove-buggy-param-directive.patch 2014-05-08 20:20:12.000000000 +0000 @@ -5,10 +5,10 @@ ocamldoc doesn't like it. --- sqlexpr_sqlite.mli | 2 +- - 1 files changed, 1 insertions(+), 1 deletions(-) + 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sqlexpr_sqlite.mli b/sqlexpr_sqlite.mli -index 122f51a..bf501a5 100644 +index ac4fc67..efa1682 100644 --- a/sqlexpr_sqlite.mli +++ b/sqlexpr_sqlite.mli @@ -53,7 +53,7 @@ sig diff -Nru ocaml-sqlexpr-0.4.1/.gitignore ocaml-sqlexpr-0.5.5/.gitignore --- ocaml-sqlexpr-0.4.1/.gitignore 2011-03-19 17:04:45.000000000 +0000 +++ ocaml-sqlexpr-0.5.5/.gitignore 2013-06-15 18:14:27.000000000 +0000 @@ -24,5 +24,6 @@ /setup.data /setup.log /sqlexpr.mllib +/sqlexpr.odocl /sqlexpr_syntax.mllib - +/toplevel diff -Nru ocaml-sqlexpr-0.4.1/INSTALL ocaml-sqlexpr-0.5.5/INSTALL --- ocaml-sqlexpr-0.4.1/INSTALL 2011-03-19 17:04:45.000000000 +0000 +++ ocaml-sqlexpr-0.5.5/INSTALL 2013-06-15 18:14:27.000000000 +0000 @@ -11,7 +11,7 @@ * findlib * estring * csv -* extlib +* batteries * sqlite3 * lwt * unix diff -Nru ocaml-sqlexpr-0.4.1/META ocaml-sqlexpr-0.5.5/META --- ocaml-sqlexpr-0.4.1/META 2011-03-19 17:04:45.000000000 +0000 +++ ocaml-sqlexpr-0.5.5/META 2013-06-15 18:14:27.000000000 +0000 @@ -1,19 +1,17 @@ # OASIS_START -# DO NOT EDIT (digest: 645f51dbf47e3de250d39b320fdf3b7d) -version = "0.4.1" +# DO NOT EDIT (digest: 241cffd68e9612eb6fa812c6118b726f) +version = "0.5.5" description = "SQLite database access." -requires - = - "csv batteries sqlite3 estring lwt lwt.syntax lwt.unix unix threads" +requires = "csv batteries sqlite3 estring lwt lwt.syntax lwt.unix unix threads" archive(byte) = "sqlexpr.cma" archive(native) = "sqlexpr.cmxa" exists_if = "sqlexpr.cma" package "syntax" ( - version = "0.4.1" + version = "0.5.5" description = "Syntax extension for SQL statements/expressions" requires = "camlp4 estring" - archive(syntax,preprocessor) = "sqlexpr_syntax.cma" - archive(syntax,toploop) = "sqlexpr_syntax.cma" + archive(syntax, preprocessor) = "sqlexpr_syntax.cma" + archive(syntax, toploop) = "sqlexpr_syntax.cma" exists_if = "sqlexpr_syntax.cma" ) # OASIS_STOP diff -Nru ocaml-sqlexpr-0.4.1/myocamlbuild.ml ocaml-sqlexpr-0.5.5/myocamlbuild.ml --- ocaml-sqlexpr-0.4.1/myocamlbuild.ml 2011-03-19 17:04:45.000000000 +0000 +++ ocaml-sqlexpr-0.5.5/myocamlbuild.ml 2013-06-15 18:14:27.000000000 +0000 @@ -1,12 +1,12 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 2e2fc98f12633494ff4152f6f97453b6) *) +(* DO NOT EDIT (digest: 4b0b54727d86f5e35ee2bb2cd5d0d6c7) *) module OASISGettext = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/OASISGettext.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISGettext.ml" - let ns_ str = + let ns_ str = str - let s_ str = + let s_ str = str let f_ (str : ('a, 'b, 'c, 'd) format4) = @@ -18,13 +18,13 @@ else fmt2^^"" - let init = + let init = [] end module OASISExpr = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/OASISExpr.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISExpr.ml" @@ -46,18 +46,18 @@ type 'a choices = (t * 'a) list let eval var_get t = - let rec eval' = + let rec eval' = function | EBool b -> b - | ENot e -> + | ENot e -> not (eval' e) | EAnd (e1, e2) -> (eval' e1) && (eval' e2) - | EOr (e1, e2) -> + | EOr (e1, e2) -> (eval' e1) || (eval' e2) | EFlag nm -> @@ -76,19 +76,19 @@ eval' t let choose ?printer ?name var_get lst = - let rec choose_aux = + let rec choose_aux = function | (cond, vl) :: tl -> - if eval var_get cond then - vl + if eval var_get cond then + vl else choose_aux tl | [] -> - let str_lst = + let str_lst = if lst = [] then s_ "" else - String.concat + String.concat (s_ ", ") (List.map (fun (cond, vl) -> @@ -97,10 +97,10 @@ | None -> s_ "") lst) in - match name with + match name with | Some nm -> failwith - (Printf.sprintf + (Printf.sprintf (f_ "No result for the choice list '%s': %s") nm str_lst) | None -> @@ -115,14 +115,14 @@ module BaseEnvLight = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/base/BaseEnvLight.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseEnvLight.ml" module MapString = Map.Make(String) type t = string MapString.t let default_filename = - Filename.concat + Filename.concat (Sys.getcwd ()) "setup.data" @@ -138,23 +138,23 @@ let line = ref 1 in - let st_line = + let st_line = Stream.from (fun _ -> try - match Stream.next st with + match Stream.next st with | '\n' -> incr line; Some '\n' | c -> Some c with Stream.Failure -> None) in - let lexer = + let lexer = Genlex.make_lexer ["="] st_line in let rec read_file mp = - match Stream.npeek 3 lexer with + match Stream.npeek 3 lexer with | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lexer; - Stream.junk lexer; + Stream.junk lexer; + Stream.junk lexer; Stream.junk lexer; read_file (MapString.add nm value mp) | [] -> @@ -177,8 +177,8 @@ end else begin - failwith - (Printf.sprintf + failwith + (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end @@ -188,23 +188,23 @@ let buff = Buffer.create ((String.length str) * 2) in - Buffer.add_substitute + Buffer.add_substitute buff - (fun var -> - try + (fun var -> + try var_expand (MapString.find var env) with Not_found -> - failwith - (Printf.sprintf + failwith + (Printf.sprintf "No variable %s defined when trying to expand %S." - var + var str)) str; Buffer.contents buff in var_expand (MapString.find name env) - let var_choose lst env = + let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst @@ -212,7 +212,7 @@ module MyOCamlbuildFindlib = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild @@ -311,6 +311,7 @@ * 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"]) @@ -320,7 +321,7 @@ end module MyOCamlbuildBase = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -329,19 +330,24 @@ open Ocamlbuild_plugin + module OC = Ocamlbuild_pack.Ocaml_compiler type dir = string type file = string type name = string type tag = string -# 55 "/home/mfp/mess/2010/44/oasis-0.2.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" +# 56 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/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 = @@ -354,6 +360,12 @@ (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 @@ -381,40 +393,123 @@ Options.ext_dll, "ext_dll"; ] + | Before_rules -> + (* TODO: move this into its own file and conditionnaly include it, if + * needed. + *) + (* OCaml cmxs rules: cmxs available in ocamlopt but not ocamlbuild. + Copied from ocaml_specific.ml in ocamlbuild sources. *) + let has_native_dynlink = + try + bool_of_string (BaseEnvLight.var_get "native_dynlink" env) + with Not_found -> + false + in + if has_native_dynlink && String.sub Sys.ocaml_version 0 4 = "3.11" then + begin + let ext_lib = !Options.ext_lib in + let ext_obj = !Options.ext_obj in + let ext_dll = !Options.ext_dll in + let x_o = "%"-.-ext_obj in + let x_a = "%"-.-ext_lib in + let x_dll = "%"-.-ext_dll in + let x_p_o = "%.p"-.-ext_obj in + let x_p_a = "%.p"-.-ext_lib in + let x_p_dll = "%.p"-.-ext_dll in + + rule "ocaml: mldylib & p.cmx* & p.o* -> p.cmxs & p.so" + ~tags:["ocaml"; "native"; "profile"; "shared"; "library"] + ~prods:["%.p.cmxs"; x_p_dll] + ~dep:"%.mldylib" + (OC.native_profile_shared_library_link_mldylib + "%.mldylib" "%.p.cmxs"); + + rule "ocaml: mldylib & cmx* & o* -> cmxs & so" + ~tags:["ocaml"; "native"; "shared"; "library"] + ~prods:["%.cmxs"; x_dll] + ~dep:"%.mldylib" + (OC.native_shared_library_link_mldylib + "%.mldylib" "%.cmxs"); + + rule "ocaml: p.cmx & p.o -> p.cmxs & p.so" + ~tags:["ocaml"; "native"; "profile"; "shared"; "library"] + ~prods:["%.p.cmxs"; x_p_dll] + ~deps:["%.p.cmx"; x_p_o] + (OC.native_shared_library_link ~tags:["profile"] + "%.p.cmx" "%.p.cmxs"); + + rule "ocaml: p.cmxa & p.a -> p.cmxs & p.so" + ~tags:["ocaml"; "native"; "profile"; "shared"; "library"] + ~prods:["%.p.cmxs"; x_p_dll] + ~deps:["%.p.cmxa"; x_p_a] + (OC.native_shared_library_link ~tags:["profile"; "linkall"] + "%.p.cmxa" "%.p.cmxs"); + + rule "ocaml: cmx & o -> cmxs" + ~tags:["ocaml"; "native"; "shared"; "library"] + ~prods:["%.cmxs"] + ~deps:["%.cmx"; x_o] + (OC.native_shared_library_link "%.cmx" "%.cmxs"); + + rule "ocaml: cmx & o -> cmxs & so" + ~tags:["ocaml"; "native"; "shared"; "library"] + ~prods:["%.cmxs"; x_dll] + ~deps:["%.cmx"; x_o] + (OC.native_shared_library_link "%.cmx" "%.cmxs"); + + rule "ocaml: cmxa & a -> cmxs & so" + ~tags:["ocaml"; "native"; "shared"; "library"] + ~prods:["%.cmxs"; x_dll] + ~deps:["%.cmxa"; x_a] + (OC.native_shared_library_link ~tags:["linkall"] + "%.cmxa" "%.cmxs"); + end + | After_rules -> (* Declare OCaml libraries *) List.iter (function - | lib, [] -> - ocaml_lib lib; - | lib, dir :: tl -> - ocaml_lib ~dir:dir lib; + | nm, [] -> + ocaml_lib nm + | nm, dir :: tl -> + ocaml_lib ~dir:dir (dir^"/"^nm); List.iter (fun dir -> - flag - ["ocaml"; "use_"^lib; "compile"] - (S[A"-I"; P 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"; "use_lib"^lib] - (S[A"-dllib"; A("-l"^lib); A"-cclib"; A("-l"^lib)]); + 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"; "use_lib"^lib] - (S[A"-cclib"; A("-l"^lib)]); + flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] + (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); - flag ["link"; "program"; "ocaml"; "byte"; "use_lib"^lib] - (S[A"-dllib"; A("dll"^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"; "use_lib"^lib] - [dir/"lib"^lib^"."^(!Options.ext_lib)]; + 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 *) @@ -454,10 +549,12 @@ MyOCamlbuildBase.lib_ocaml = [("sqlexpr_syntax", []); ("sqlexpr", [])]; lib_c = []; flags = []; + includes = []; } ;; let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; +# 559 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff -Nru ocaml-sqlexpr-0.4.1/_oasis ocaml-sqlexpr-0.5.5/_oasis --- ocaml-sqlexpr-0.4.1/_oasis 2011-03-19 17:04:45.000000000 +0000 +++ ocaml-sqlexpr-0.5.5/_oasis 2013-06-15 18:14:27.000000000 +0000 @@ -1,10 +1,11 @@ -OASISFormat: 0.2 +OASISFormat: 0.3 Name: ocaml-sqlexpr -Version: 0.4.1 +Version: 0.5.5 Synopsis: Type-safe, convenient SQLite database access. Authors: Mauricio Fernandez +Maintainers: Mauricio Fernandez License: LGPL-2.1 with OCaml linking exception -Plugins: DevFiles (0.2), META (0.2) +Plugins: DevFiles (0.3), META (0.3) BuildTools: ocamlbuild Homepage: http://github.com/mfp/ocaml-sqlexpr Description: @@ -51,7 +52,7 @@ Document sqlexpr Title: API reference for Sqlexpr - Type: ocamlbuild (0.2) + Type: ocamlbuild (0.3) InstallDir: $htmldir/sqlexpr BuildTools+: ocamldoc XOCamlbuildPath: . diff -Nru ocaml-sqlexpr-0.4.1/README ocaml-sqlexpr-0.5.5/README --- ocaml-sqlexpr-0.4.1/README 2011-03-19 17:04:45.000000000 +0000 +++ ocaml-sqlexpr-0.5.5/README 2013-06-15 18:14:27.000000000 +0000 @@ -33,6 +33,12 @@ See also example.ml. +Dependencies +============ + +csv, batteries, sqlite3, estring, lwt (>= 2.2.0), lwt.syntax, lwt.unix, +unix, threads + Syntax extension ================ diff -Nru ocaml-sqlexpr-0.4.1/setup.ml ocaml-sqlexpr-0.5.5/setup.ml --- ocaml-sqlexpr-0.4.1/setup.ml 2011-03-19 17:04:45.000000000 +0000 +++ ocaml-sqlexpr-0.5.5/setup.ml 2013-06-15 18:14:27.000000000 +0000 @@ -1,19 +1,19 @@ -(* setup.ml generated for the first time by OASIS v0.2.0 *) +(* setup.ml generated for the first time by OASIS v0.3.0~rc3 *) (* OASIS_START *) -(* DO NOT EDIT (digest: a2353b15e55bdc275c165825646e05ba) *) +(* DO NOT EDIT (digest: ccd9eaf3540d2c44a7a4a4bea21eb33a) *) (* - Regenerated by OASIS v0.2.0 + Regenerated by OASIS v0.3.0~rc3 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/OASISGettext.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISGettext.ml" - let ns_ str = + let ns_ str = str - let s_ str = + let s_ str = str let f_ (str : ('a, 'b, 'c, 'd) format4) = @@ -25,55 +25,53 @@ else fmt2^^"" - let init = + let init = [] end module OASISContext = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/OASISContext.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISContext.ml" - open OASISGettext + open OASISGettext type level = [ `Debug - | `Info + | `Info | `Warning | `Error] type t = { - verbose: bool; - debug: bool; - ignore_plugins: bool; - printf: level -> string -> unit; + verbose: bool; + debug: bool; + ignore_plugins: bool; + ignore_unknown_fields: bool; + printf: level -> string -> unit; } - let printf lvl str = - let beg = - match lvl with + let printf lvl str = + let beg = + match lvl with | `Error -> s_ "E: " | `Warning -> s_ "W: " | `Info -> s_ "I: " | `Debug -> s_ "D: " in - match lvl with - | `Error -> - prerr_endline (beg^str) - | _ -> - print_endline (beg^str) + prerr_endline (beg^str) let default = - ref + ref { - verbose = true; - debug = false; - ignore_plugins = false; - printf = printf; + verbose = true; + debug = false; + ignore_plugins = false; + ignore_unknown_fields = false; + printf = printf; } - let quiet = - {!default with + let quiet = + {!default with verbose = false; debug = false; } @@ -90,7 +88,9 @@ end module OASISUtils = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/OASISUtils.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISUtils.ml" + + open OASISGettext module MapString = Map.Make(String) @@ -103,7 +103,7 @@ module SetString = Set.Make(String) let set_string_add_list st lst = - List.fold_left + List.fold_left (fun acc e -> SetString.add e acc) st lst @@ -113,15 +113,15 @@ SetString.empty - let compare_csl s1 s2 = + let compare_csl s1 s2 = String.compare (String.lowercase s1) (String.lowercase s2) - module HashStringCsl = + module HashStringCsl = Hashtbl.Make (struct type t = string - let equal s1 s2 = + let equal s1 s2 = (String.lowercase s1) = (String.lowercase s2) let hash s = @@ -135,16 +135,16 @@ let rec split_aux acc pos = if pos < str_len then ( - let pos_sep = + let pos_sep = try String.index_from str pos sep with Not_found -> str_len in - let part = - String.sub str pos (pos_sep - pos) + let part = + String.sub str pos (pos_sep - pos) in - let acc = + let acc = part :: acc in if pos_sep >= str_len then @@ -170,14 +170,14 @@ split_aux [] 0 - let varname_of_string ?(hyphen='_') s = + let varname_of_string ?(hyphen='_') s = if String.length s = 0 then begin - invalid_arg "varname_of_string" + invalid_arg "varname_of_string" end else begin - let buff = + let buff = Buffer.create (String.length s) in (* Start with a _ if digit *) @@ -186,10 +186,10 @@ String.iter (fun c -> - if ('a' <= c && c <= 'z') - || - ('A' <= c && c <= 'Z') - || + if ('a' <= c && c <= 'z') + || + ('A' <= c && c <= 'Z') + || ('0' <= c && c <= '9') then Buffer.add_char buff c else @@ -199,8 +199,8 @@ String.lowercase (Buffer.contents buff) end - let varname_concat ?(hyphen='_') p s = - let p = + let varname_concat ?(hyphen='_') p s = + let p = let p_len = String.length p in @@ -209,7 +209,7 @@ else p in - let s = + let s = let s_len = String.length s in @@ -221,54 +221,59 @@ Printf.sprintf "%s%c%s" p hyphen s - let is_varname str = + let is_varname str = str = varname_of_string str - let failwithf1 fmt a = - failwith (Printf.sprintf fmt a) - - let failwithf2 fmt a b = - failwith (Printf.sprintf fmt a b) - - let failwithf3 fmt a b c = - failwith (Printf.sprintf fmt a b c) + let failwithf fmt = Printf.ksprintf failwith fmt - let failwithf4 fmt a b c d = - failwith (Printf.sprintf fmt a b c d) - - let failwithf5 fmt a b c d e = - failwith (Printf.sprintf fmt a b c d e) + let file_exists 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 end module PropList = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/PropList.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/PropList.ml" open OASISGettext type name = string - exception Not_set of name * string option + exception Not_set of name * string option exception No_printer of name exception Unknown_field of name * name - let string_of_exception = - function - | Not_set (nm, Some rsn) -> - Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn - | Not_set (nm, None) -> - Printf.sprintf (f_ "Field '%s' is not set") nm - | No_printer nm -> - Printf.sprintf (f_ "No default printer for value %s") nm - | Unknown_field (nm, schm) -> - Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm - | e -> - raise e + 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 = + type t = (name, unit -> unit) Hashtbl.t let create () = @@ -277,10 +282,10 @@ let clear t = Hashtbl.clear t -# 59 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/PropList.ml" +# 71 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/PropList.ml" end - module Schema = + module Schema = struct type ('ctxt, 'extra) value = @@ -299,43 +304,43 @@ name_norm: string -> string; } - let create ?(case_insensitive=false) nm = + let create ?(case_insensitive=false) nm = { name = nm; fields = Hashtbl.create 13; order = Queue.create (); - name_norm = - (if case_insensitive then + name_norm = + (if case_insensitive then String.lowercase else fun s -> s); } - let add t nm set get extra help = - let key = + 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 + (Printf.sprintf (f_ "Field '%s' is already defined in schema '%s'") nm t.name); - Hashtbl.add - t.fields - key + Hashtbl.add + t.fields + key { - set = set; - get = get; + set = set; + get = get; help = help; extra = extra; }; - Queue.add nm t.order + Queue.add nm t.order let mem t nm = - Hashtbl.mem t.fields nm + Hashtbl.mem t.fields nm - let find t nm = + let find t nm = try Hashtbl.find t.fields (t.name_norm nm) with Not_found -> @@ -345,28 +350,28 @@ (find t nm).get data let set t data nm ?context x = - (find t nm).set - data - ?context + (find t nm).set + data + ?context x let fold f acc t = - Queue.fold + Queue.fold (fun acc k -> let v = find t k in f acc k v.extra v.help) - acc + acc t.order let iter f t = - fold + fold (fun () -> f) () t - let name t = + let name t = t.name end @@ -383,7 +388,7 @@ extra: 'extra; } - let new_id = + let new_id = let last_id = ref 0 in @@ -391,20 +396,20 @@ let create ?schema ?name ?parse ?print ?default ?update ?help extra = (* Default value container *) - let v = - ref None + let v = + ref None in (* If name is not given, create unique one *) - let nm = - match name with + 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 + let default () = + match default with | Some d -> d | None -> raise (Not_set (nm, Some (s_ "no default value"))) in @@ -412,22 +417,22 @@ (* Get data *) let get data = (* Get value *) - try + try (Hashtbl.find data nm) (); - match !v with - | Some x -> x + 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 + let set data ?context x = + let x = + match update with | Some f -> begin - try + try f ?context (get data) x with Not_set _ -> x @@ -435,21 +440,21 @@ | None -> x in - Hashtbl.replace - data - nm - (fun () -> v := Some x) + Hashtbl.replace + data + nm + (fun () -> v := Some x) in (* Parse string value, if possible *) let parse = - match parse with - | Some f -> + match parse with + | Some f -> f | None -> fun ?context s -> - failwith - (Printf.sprintf + failwith + (Printf.sprintf (f_ "Cannot parse field '%s' when setting value %S") nm s) @@ -474,8 +479,8 @@ print (get data) in - begin - match schema with + begin + match schema with | Some t -> Schema.add t nm sets gets extra help | None -> @@ -491,7 +496,7 @@ extra = extra; } - let fset data t ?context x = + let fset data t ?context x = t.set data ?context x let fget data t = @@ -501,7 +506,7 @@ t.sets data ?context s let fgets data t = - t.gets data + t.gets data end @@ -509,7 +514,7 @@ struct let create ?schema ?name ?parse ?print ?default ?update ?help extra = - let fld = + let fld = Field.create ?schema ?name ?parse ?print ?default ?update ?help extra in fun data -> Field.fget data fld @@ -518,20 +523,20 @@ end module OASISMessage = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/OASISMessage.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISMessage.ml" open OASISGettext open OASISContext let generic_message ~ctxt lvl fmt = - let cond = - match lvl with + let cond = + match lvl with | `Debug -> ctxt.debug | _ -> ctxt.verbose in - Printf.ksprintf - (fun str -> + Printf.ksprintf + (fun str -> if cond then begin ctxt.printf lvl str @@ -541,7 +546,7 @@ let debug ~ctxt fmt = generic_message ~ctxt `Debug fmt - let info ~ctxt fmt = + let info ~ctxt fmt = generic_message ~ctxt `Info fmt let warning ~ctxt fmt = @@ -550,24 +555,10 @@ let error ~ctxt fmt = generic_message ~ctxt `Error fmt - - let string_of_exception e = - try - PropList.string_of_exception e - with - | Failure s -> - s - | e -> - Printexc.to_string e - - (* TODO - let register_exn_printer f = - *) - end module OASISVersion = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/OASISVersion.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISVersion.ml" open OASISGettext @@ -577,7 +568,7 @@ type t = string - type comparator = + type comparator = | VGreater of t | VGreaterEqual of t | VEqual of t @@ -595,17 +586,17 @@ ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') let is_special = - function + function | '.' | '+' | '-' | '~' -> true | _ -> false let rec version_compare v1 v2 = if v1 <> "" || v2 <> "" then begin - (* Compare ascii string, using special meaning for version + (* Compare ascii string, using special meaning for version * related char *) - let val_ascii c = + let val_ascii c = if c = '~' then -1 else if is_digit c then 0 else if c = '\000' then 0 @@ -619,16 +610,16 @@ let p = ref 0 in (** Compare ascii part *) - let compare_vascii () = + 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 + 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] + val_ascii v1.[!p] else if !cmp = 0 && !p = len1 && !p < len2 then - (val_ascii v2.[!p]) else @@ -636,17 +627,21 @@ in (** Compare digit part *) - let compare_digit () = + let compare_digit () = let extract_int v p = let start_p = !p in - while !p < String.length v && is_digit v.[!p] do + while !p < String.length v && is_digit v.[!p] do incr p done; - match String.sub v start_p (!p - start_p) with - | "" -> 0, - v - | s -> int_of_string s, - String.sub v !p ((String.length v) - !p) + 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 @@ -656,7 +651,7 @@ match compare_vascii () with | 0 -> begin - match compare_digit () with + match compare_digit () with | 0, tl1, tl2 -> if tl1 <> "" && is_digit tl1.[0] then 1 @@ -677,13 +672,13 @@ let version_of_string str = - String.iter + String.iter (fun c -> if is_alpha c || is_digit c || is_special c then () else failwith - (Printf.sprintf + (Printf.sprintf (f_ "Char %C is not allowed in version '%s'") c str)) str; @@ -692,10 +687,10 @@ let string_of_version t = t - let chop t = - try - let pos = - String.rindex t '.' + let chop t = + try + let pos = + String.rindex t '.' in String.sub t 0 pos with Not_found -> @@ -719,25 +714,25 @@ (comparator_apply v op1) && (comparator_apply v op2) let rec string_of_comparator = - function + 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) -> + | VOr (c1, c2) -> (string_of_comparator c1)^" || "^(string_of_comparator c2) - | VAnd (c1, c2) -> + | VAnd (c1, c2) -> (string_of_comparator c1)^" && "^(string_of_comparator c2) let rec varname_of_comparator = - let concat p v = + let concat p v = OASISUtils.varname_concat - p - (OASISUtils.varname_of_string + p + (OASISUtils.varname_of_string (string_of_version v)) in - function + function | VGreater v -> concat "gt" v | VLesser v -> concat "lt" v | VEqual v -> concat "eq" v @@ -751,7 +746,7 @@ end module OASISLicense = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/OASISLicense.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISLicense.ml" (** License for _oasis fields @author Sylvain Le Gall @@ -763,13 +758,13 @@ type license_exception = string - type license_version = + type license_version = | Version of OASISVersion.t | VersionOrLater of OASISVersion.t | NoVersion - type license_dep_5 = + type license_dep_5 = { license: license; exceptions: license_exception list; @@ -784,7 +779,7 @@ end module OASISExpr = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/OASISExpr.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISExpr.ml" @@ -806,18 +801,18 @@ type 'a choices = (t * 'a) list let eval var_get t = - let rec eval' = + let rec eval' = function | EBool b -> b - | ENot e -> + | ENot e -> not (eval' e) | EAnd (e1, e2) -> (eval' e1) && (eval' e2) - | EOr (e1, e2) -> + | EOr (e1, e2) -> (eval' e1) || (eval' e2) | EFlag nm -> @@ -836,19 +831,19 @@ eval' t let choose ?printer ?name var_get lst = - let rec choose_aux = + let rec choose_aux = function | (cond, vl) :: tl -> - if eval var_get cond then - vl + if eval var_get cond then + vl else choose_aux tl | [] -> - let str_lst = + let str_lst = if lst = [] then s_ "" else - String.concat + String.concat (s_ ", ") (List.map (fun (cond, vl) -> @@ -857,10 +852,10 @@ | None -> s_ "") lst) in - match name with + match name with | Some nm -> failwith - (Printf.sprintf + (Printf.sprintf (f_ "No result for the choice list '%s': %s") nm str_lst) | None -> @@ -874,7 +869,7 @@ end module OASISTypes = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/OASISTypes.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISTypes.ml" @@ -900,34 +895,34 @@ | Best - type dependency = + type dependency = | FindlibPackage of findlib_full * OASISVersion.comparator option | InternalLibrary of name type tool = | ExternalTool of name - | InternalExecutable of name + | InternalExecutable of name - type vcs = - | Darcs - | Git - | Svn - | Cvs - | Hg - | Bzr - | Arch + type vcs = + | Darcs + | Git + | Svn + | Cvs + | Hg + | Bzr + | Arch | Monotone | OtherVCS of url - type plugin_kind = - [ `Configure - | `Build - | `Doc - | `Test - | `Install + type plugin_kind = + [ `Configure + | `Build + | `Doc + | `Test + | `Install | `Extra ] @@ -947,18 +942,18 @@ type 'a plugin = 'a * name * OASISVersion.t option - type all_plugin = plugin_kind plugin + type all_plugin = plugin_kind plugin type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -# 102 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/OASISTypes.ml" +# 102 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISTypes.ml" type 'a conditional = 'a OASISExpr.choices - type custom = + type custom = { pre_command: (command_line option) conditional; - post_command: (command_line option) conditional; + post_command: (command_line option) conditional; } @@ -989,28 +984,29 @@ } - type library = + 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 = + type executable = { exec_custom: bool; exec_main_is: unix_filename; } - type flag = + type flag = { flag_description: string option; flag_default: bool conditional; } - type source_repository = + type source_repository = { src_repo_type: vcs; src_repo_location: url; @@ -1021,7 +1017,7 @@ src_repo_subdir: unix_filename option; } - type test = + type test = { test_type: [`Test] plugin; test_command: command_line conditional; @@ -1065,6 +1061,9 @@ | Doc of common_section * doc + type section_kind = + [ `Library | `Executable | `Flag | `SrcRepo | `Test | `Doc ] + type package = { oasis_version: OASISVersion.t; @@ -1105,7 +1104,7 @@ end module OASISUnixPath = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/OASISUnixPath.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISUnixPath.ml" type unix_filename = string type unix_dirname = string @@ -1117,7 +1116,7 @@ let parent_dir_name = ".." - let concat f1 f2 = + let concat f1 f2 = if f1 = current_dir_name then f2 else if f2 = current_dir_name then @@ -1142,7 +1141,7 @@ current_dir_name let basename f = - try + try let pos_start = (String.rindex f '/') + 1 in @@ -1151,14 +1150,14 @@ f let chop_extension f = - try + try let last_dot = String.rindex f '.' in let sub = String.sub f 0 last_dot in - try + try let last_slash = String.rindex f '/' in @@ -1172,47 +1171,49 @@ 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 OASISSection = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/OASISSection.ml" - - (** Manipulate section - @author Sylvain Le Gall - *) +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISSection.ml" open OASISTypes - type section_kind = - | KLibrary - | KExecutable - | KFlag - | KSrcRepo - | KTest - | KDoc - - (** Extract generic information - *) let section_kind_common = function | Library (cs, _, _) -> - KLibrary, cs + `Library, cs | Executable (cs, _, _) -> - KExecutable, cs + `Executable, cs | Flag (cs, _) -> - KFlag, cs + `Flag, cs | SrcRepo (cs, _) -> - KSrcRepo, cs + `SrcRepo, cs | Test (cs, _) -> - KTest, cs + `Test, cs | Doc (cs, _) -> - KDoc, cs + `Doc, cs - (** Common section of a section - *) 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 = @@ -1226,23 +1227,23 @@ section_id sct in (match k with - | KLibrary -> "library" - | KExecutable -> "executable" - | KFlag -> "flag" - | KSrcRepo -> "src repository" - | KTest -> "test" - | KDoc -> "doc") + | `Library -> "library" + | `Executable -> "executable" + | `Flag -> "flag" + | `SrcRepo -> "src repository" + | `Test -> "test" + | `Doc -> "doc") ^" "^nm end module OASISBuildSection = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/OASISBuildSection.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISBuildSection.ml" end module OASISExecutable = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/OASISExecutable.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISExecutable.ml" open OASISTypes @@ -1266,14 +1267,14 @@ if not is_native_exec && not exec.exec_custom && bs.bs_c_sources <> [] then - Some (dir^"/dll"^cs.cs_name^(ext_dll ())) + Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) else None end module OASISLibrary = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/OASISLibrary.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISLibrary.ml" open OASISTypes open OASISUtils @@ -1281,40 +1282,116 @@ type library_name = name - let generated_unix_files ~ctxt (cs, bs, lib) - source_file_exists is_native ext_lib ext_dll = - (* The headers that should be compiled along *) - let headers = + (* 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 hdrs modul -> - try - let base_fn = - List.find - (fun fn -> - source_file_exists (fn^".ml") || - source_file_exists (fn^".mli") || - source_file_exists (fn^".mll") || - source_file_exists (fn^".mly")) - (List.map - (OASISUnixPath.concat bs.bs_path) - [modul; - String.uncapitalize modul; - String.capitalize modul]) - in - [base_fn^".cmi"] :: hdrs - with Not_found -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in library %s") - modul cs.cs_name; - (List.map (OASISUnixPath.concat bs.bs_path) - [modul^".cmi"; - String.uncapitalize modul ^ ".cmi"; - String.capitalize modul ^ ".cmi"]) - :: hdrs) + (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 [] - lib.lib_modules + 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 = @@ -1323,28 +1400,39 @@ (* 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 = - [cs.cs_name^".cma"] :: acc + add_pack_header ([cs.cs_name^".cma"] :: acc) in let native acc = - [cs.cs_name^".cmxa"] :: [cs.cs_name^(ext_lib ())] :: acc + let acc = [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc in + add_pack_header + (if has_native_dynlink then + [cs.cs_name^".cmxs"] :: acc + else acc) in - match bs.bs_compiled_object with + match bs.bs_compiled_object with | Native -> byte (native acc_nopath) - | Best when is_native () -> + | Best when is_native -> byte (native acc_nopath) | Byte | Best -> byte acc_nopath in (* Add C library to be built *) - let acc_nopath = + let acc_nopath = if bs.bs_c_sources <> [] then begin - ["lib"^cs.cs_name^(ext_lib ())] + ["lib"^cs.cs_name^"_stubs"^ext_lib] :: - ["dll"^cs.cs_name^(ext_dll ())] + ["dll"^cs.cs_name^"_stubs"^ext_dll] :: acc_nopath end @@ -1358,15 +1446,15 @@ (List.rev_map (OASISUnixPath.concat bs.bs_path)) acc_nopath) - headers + (headers @ cmxs) - type group_t = + type group_t = | Container of findlib_name * (group_t list) - | Package of (findlib_name * + | Package of (findlib_name * common_section * - build_section * - library * + build_section * + library * (group_t list)) let group_libs pkg = @@ -1377,11 +1465,11 @@ function | Library (cs, bs, lib) -> begin - match lib.lib_findlib_parent with + match lib.lib_findlib_parent with | Some p_nm -> begin let children = - try + try MapString.find p_nm mp with Not_found -> [] @@ -1399,7 +1487,7 @@ (* Compute findlib name of a single node *) let findlib_name (cs, _, lib) = - match lib.lib_findlib_name with + match lib.lib_findlib_name with | Some nm -> nm | None -> cs.cs_name in @@ -1410,15 +1498,12 @@ | hd :: tl -> Container (hd, [tree_of_library tl acc]) | [] -> - (* TODO: allow merging containers with the same - * name - *) Package (findlib_name acc, cs, bs, lib, - (try - List.rev_map + (try + List.rev_map (fun ((_, _, child_lib) as child_acc) -> - tree_of_library + tree_of_library child_lib.lib_findlib_containers child_acc) (MapString.find cs.cs_name children) @@ -1426,21 +1511,52 @@ [])) in + (** Merge containers with the same name *) + let rec merge_containers groups = + (* Collect packages and create the map "container name -> merged children" *) + let packages, containers = + List.fold_left + (fun (packages, containers) group -> + match group with + | Container(name, children) -> + let children' = + try + MapString.find name containers + with Not_found -> + [] + in + (packages, + MapString.add name (children' @ children) containers) + | Package(name, cs, bs, lib, children) -> + (Package(name, cs, bs, lib, merge_containers children) :: packages, + containers)) + ([], MapString.empty) + groups + in + (* Recreate the list of groups *) + packages @ + (MapString.fold + (fun name children acc -> + Container(name, merge_containers children) :: acc) + containers []) + in + (* TODO: check that libraries are unique *) - List.fold_left - (fun acc -> - function - | Library (cs, bs, lib) when lib.lib_findlib_parent = None -> - (tree_of_library lib.lib_findlib_containers (cs, bs, lib)) :: acc - | _ -> - acc) - [] - pkg.sections + merge_containers + (List.fold_left + (fun acc -> + function + | Library (cs, bs, lib) when lib.lib_findlib_parent = None -> + (tree_of_library lib.lib_findlib_containers (cs, bs, lib)) :: acc + | _ -> + acc) + [] + pkg.sections) (** Compute internal to findlib library matchings, including subpackage and return a map of it. *) - let findlib_name_map pkg = + let findlib_name_map pkg = (* Compute names in a tree *) let rec findlib_names_aux path mp grp = @@ -1448,7 +1564,7 @@ match grp with | Container (fndlb_nm, children) -> fndlb_nm, children, mp - + | Package (fndlb_nm, {cs_name = nm}, _, _, children) -> fndlb_nm, children, (MapString.add nm (path, fndlb_nm) mp) in @@ -1471,47 +1587,47 @@ let findlib_of_name ?(recurse=false) map nm = - try - let (path, fndlb_nm) = + try + let (path, fndlb_nm) = MapString.find nm map in - match path with + match path with | Some pth when recurse -> pth^"."^fndlb_nm | _ -> fndlb_nm with Not_found -> - failwithf1 + failwithf (f_ "Unable to translate internal library '%s' to findlib name") nm let name_findlib_map pkg = - let mp = + let mp = findlib_name_map pkg in MapString.fold - (fun nm _ acc -> + (fun nm _ acc -> let fndlb_nm_full = - findlib_of_name - ~recurse:true - mp + findlib_of_name + ~recurse:true + mp nm in MapString.add fndlb_nm_full nm acc) mp MapString.empty - let findlib_of_group = + let findlib_of_group = function - | Container (fndlb_nm, _) + | Container (fndlb_nm, _) | Package (fndlb_nm, _, _, _, _) -> fndlb_nm let root_of_group grp = let rec root_lib_aux = - function + function | Container (_, children) -> - root_lib_lst children + root_lib_lst children | Package (_, cs, bs, lib, children) -> - if lib.lib_findlib_parent = None then + if lib.lib_findlib_parent = None then cs, bs, lib else root_lib_lst children @@ -1528,7 +1644,7 @@ try root_lib_aux grp with Not_found -> - failwithf1 + failwithf (f_ "Unable to determine root library of findlib library '%s'") (findlib_of_group grp) @@ -1536,40 +1652,40 @@ end module OASISFlag = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/OASISFlag.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISFlag.ml" end module OASISPackage = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/OASISPackage.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISPackage.ml" end module OASISSourceRepository = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/OASISSourceRepository.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISSourceRepository.ml" end module OASISTest = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/OASISTest.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISTest.ml" end module OASISDocument = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/oasis/OASISDocument.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/oasis/OASISDocument.ml" end module BaseEnvLight = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/base/BaseEnvLight.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseEnvLight.ml" module MapString = Map.Make(String) type t = string MapString.t let default_filename = - Filename.concat + Filename.concat (Sys.getcwd ()) "setup.data" @@ -1585,23 +1701,23 @@ let line = ref 1 in - let st_line = + let st_line = Stream.from (fun _ -> try - match Stream.next st with + match Stream.next st with | '\n' -> incr line; Some '\n' | c -> Some c with Stream.Failure -> None) in - let lexer = + let lexer = Genlex.make_lexer ["="] st_line in let rec read_file mp = - match Stream.npeek 3 lexer with + match Stream.npeek 3 lexer with | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lexer; - Stream.junk lexer; + Stream.junk lexer; + Stream.junk lexer; Stream.junk lexer; read_file (MapString.add nm value mp) | [] -> @@ -1624,8 +1740,8 @@ end else begin - failwith - (Printf.sprintf + failwith + (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end @@ -1635,23 +1751,23 @@ let buff = Buffer.create ((String.length str) * 2) in - Buffer.add_substitute + Buffer.add_substitute buff - (fun var -> - try + (fun var -> + try var_expand (MapString.find var env) with Not_found -> - failwith - (Printf.sprintf + failwith + (Printf.sprintf "No variable %s defined when trying to expand %S." - var + var str)) str; Buffer.contents buff in var_expand (MapString.find name env) - let var_choose lst env = + let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst @@ -1659,20 +1775,20 @@ module BaseContext = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/base/BaseContext.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseContext.ml" - open OASISContext + open OASISContext - let args = args + let args = args let default = default end module BaseMessage = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/base/BaseMessage.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseMessage.ml" - (** Message to user, overrid for Base + (** Message to user, overrid for Base @author Sylvain Le Gall *) open OASISMessage @@ -1686,12 +1802,10 @@ let error fmt = error ~ctxt:!default fmt - let string_of_exception = string_of_exception - end module BaseFilePath = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/base/BaseFilePath.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseFilePath.ml" open Filename @@ -1699,7 +1813,7 @@ module Unix = OASISUnixPath let make = - function + function | [] -> invalid_arg "BaseFilename.make" | hd :: tl -> @@ -1723,16 +1837,15 @@ end module BaseEnv = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/base/BaseEnv.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseEnv.ml" - open OASISTypes open OASISGettext open OASISUtils open PropList module MapString = BaseEnvLight.MapString - type origin_t = + type origin_t = | ODefault | OGetEnv | OFileLoad @@ -1758,36 +1871,36 @@ Schema.create "environment" (* Environment data *) - let env = + let env = Data.create () (* Environment data from file *) - let env_from_file = + let env_from_file = ref MapString.empty (* Lexer for var *) - let var_lxr = + let var_lxr = Genlex.make_lexer [] let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) in - Buffer.add_substitute + Buffer.add_substitute buff - (fun var -> - try - (* TODO: this is a quick hack to allow calling Test.Command + (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 + * 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 + match Stream.npeek 3 st with | [Genlex.Ident "utoh"; Genlex.Ident nm] -> BaseFilePath.of_unix (var_get nm) | [Genlex.Ident "utoh"; Genlex.String s] -> @@ -1799,18 +1912,18 @@ | [Genlex.Ident nm] -> var_get nm | _ -> - failwithf2 + failwithf (f_ "Unknown expression '%s' in variable expansion of %s.") var str - with + with | Unknown_field (_, _) -> - failwithf2 + failwithf (f_ "No variable %s defined when trying to expand %S.") - var + var str - | Stream.Error e -> - failwithf3 + | Stream.Error e -> + failwithf (f_ "Syntax error when parsing '%s' when trying to \ expand %S: %s") var @@ -1820,12 +1933,12 @@ Buffer.contents buff and var_get name = - let vl = - try + let vl = + try Schema.get schema env name with Unknown_field _ as e -> begin - try + try MapString.find name !env_from_file with Not_found -> raise e @@ -1834,43 +1947,43 @@ var_expand vl let var_choose ?printer ?name lst = - OASISExpr.choose + OASISExpr.choose ?printer ?name - var_get + var_get lst - let var_protect vl = - let buff = + let var_protect vl = + let buff = Buffer.create (String.length vl) in String.iter - (function + (function | '$' -> Buffer.add_string buff "\\$" | c -> Buffer.add_char buff c) vl; Buffer.contents buff - let var_define - ?(hide=false) - ?(dump=true) + let var_define + ?(hide=false) + ?(dump=true) ?short_desc ?(cli=CLINone) ?arg_help - ?group + ?group name (* TODO: type constraint on the fact that name must be a valid OCaml id *) dflt = let default = [ - OFileLoad, lazy (MapString.find name !env_from_file); + OFileLoad, (fun () -> MapString.find name !env_from_file); ODefault, dflt; - OGetEnv, lazy (Sys.getenv name); + OGetEnv, (fun () -> Sys.getenv name); ] in - let extra = + let extra = { hide = hide; dump = dump; @@ -1880,16 +1993,16 @@ } in - (* Try to find a value that can be defined + (* Try to find a value that can be defined *) - let var_get_low lst = + let var_get_low lst = let errors, res = List.fold_left - (fun (errors, res) (_, v) -> + (fun (errors, res) (o, v) -> if res = None then begin - try - errors, Some (Lazy.force v) + try + errors, Some (v ()) with | Not_found -> errors, res @@ -1903,15 +2016,10 @@ ([], None) (List.sort (fun (o1, _) (o2, _) -> - if o1 < o2 then - 1 - else if o1 = o2 then - 0 - else - -1) + Pervasives.compare o2 o1) lst) in - match res, errors with + match res, errors with | Some v, _ -> v | None, [] -> @@ -1921,16 +2029,16 @@ in let help = - match short_desc with + match short_desc with | Some fs -> Some fs | None -> None in - let var_get_lst = + let var_get_lst = FieldRO.create ~schema ~name - ~parse:(fun ?(context=ODefault) s -> [context, lazy s]) + ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) ~print:var_get_low ~default ~update:(fun ?context x old_x -> x @ old_x) @@ -1941,49 +2049,50 @@ fun () -> var_expand (var_get_low (var_get_lst env)) - let var_redefine + let var_redefine ?hide ?dump ?short_desc ?cli ?arg_help - ?group - name + ?group + name dflt = if Schema.mem schema name then begin - Schema.set schema env ~context:ODefault name (Lazy.force dflt); + (* 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 + var_define ?hide ?dump ?short_desc ?cli ?arg_help - ?group - name + ?group + name dflt end - let var_ignore (e : unit -> string) = + let var_ignore (e : unit -> string) = () let print_hidden = - var_define + var_define ~hide:true ~dump:false ~cli:CLIAuto ~arg_help:"Print even non-printable variable. (debug)" "print_hidden" - (lazy "false") + (fun () -> "false") let var_all () = List.rev (Schema.fold - (fun acc nm def _ -> + (fun acc nm def _ -> if not def.hide || bool_of_string (print_hidden ()) then nm :: acc else @@ -1997,48 +2106,59 @@ let load ?allow_empty ?filename () = env_from_file := BaseEnvLight.load ?allow_empty ?filename () - let unload () = - (* TODO: reset lazy values *) + let unload () = env_from_file := MapString.empty; Data.clear env - let dump ?(filename=default_filename) () = + let dump ?(filename=default_filename) () = let chn = open_out_bin filename in - Schema.iter - (fun nm def _ -> + 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 + try let value = - Schema.get - schema - env + Schema.get + schema + env nm in - Printf.fprintf chn "%s = %S\n" nm value + output nm value with Not_set _ -> () - end) - schema; + 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 -> + (fun acc nm def short_descr_opt -> if not def.hide || bool_of_string (print_hidden ()) then begin - try - let value = - Schema.get + try + let value = + Schema.get schema env nm in - let txt = - match short_descr_opt with + let txt = + match short_descr_opt with | Some s -> s () | None -> nm in @@ -2051,7 +2171,7 @@ [] schema in - let max_length = + let max_length = List.fold_left max 0 (List.rev_map String.length (List.rev_map fst printable_vars)) @@ -2060,15 +2180,12 @@ String.make ((max_length - (String.length str)) + 3) '.' in - print_newline (); - print_endline "Configuration: "; - print_newline (); - List.iter - (fun (name,value) -> - Printf.printf "%s: %s %s\n" name (dot_pad name) value) - printable_vars; - Printf.printf "%!"; - print_newline () + 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 = @@ -2085,12 +2202,12 @@ [ Arg.Set_string rvr; Arg.Set_string rvl; - Arg.Unit - (fun () -> - Schema.set + Arg.Unit + (fun () -> + Schema.set schema env - ~context:OCommandLine + ~context:OCommandLine !rvr !rvl) ] @@ -2099,51 +2216,51 @@ ] @ - List.flatten + List.flatten (Schema.fold (fun acc name def short_descr_opt -> - let var_set s = - Schema.set + let var_set s = + Schema.set schema env - ~context:OCommandLine + ~context:OCommandLine name s in - let arg_name = + let arg_name = OASISUtils.varname_of_string ~hyphen:'-' name in let hlp = - match short_descr_opt with + match short_descr_opt with | Some txt -> txt () | None -> "" in let arg_hlp = - match def.arg_help with + match def.arg_help with | Some s -> s | None -> "str" in - let default_value = - try - Printf.sprintf + let default_value = + try + Printf.sprintf (f_ " [%s]") (Schema.get schema env name) - with Not_set _ -> + with Not_set _ -> "" in - let args = - match def.cli with - | CLINone -> + let args = + match def.cli with + | CLINone -> [] - | CLIAuto -> + | CLIAuto -> [ arg_concat "--" arg_name, Arg.String var_set, @@ -2156,23 +2273,21 @@ Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIEnable -> - [ - arg_concat "--enable-" arg_name, - Arg.Unit (fun () -> var_set "true"), - Printf.sprintf (f_ " %s%s") hlp - (if default_value = " [true]" then - (s_ " [default]") - else - ""); - - arg_concat "--disable-" arg_name, - Arg.Unit (fun () -> var_set "false"), - Printf.sprintf (f_ " %s%s") hlp - (if default_value = " [false]" then - (s_ " [default]") - else - ""); - ] + 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 @@ -2182,7 +2297,7 @@ end module BaseExec = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/base/BaseExec.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseExec.ml" open OASISGettext open OASISUtils @@ -2193,22 +2308,22 @@ String.concat " " (cmd :: args) in info (f_ "Running command '%s'") cmdline; - match f_exit_code, Sys.command cmdline with + match f_exit_code, Sys.command cmdline with | None, 0 -> () | None, i -> - failwithf2 + failwithf (f_ "Command '%s' terminated with error code %d") cmdline i - | Some f, i -> + | Some f, i -> f i - let run_read_output cmd args = - let fn = + let run_read_output ?f_exit_code cmd args = + let fn = Filename.temp_file "oasis-" ".txt" in - let () = + let () = try - run cmd (args @ [">"; Filename.quote fn]) + run ?f_exit_code cmd (args @ [">"; Filename.quote fn]) with e -> Sys.remove fn; raise e @@ -2221,7 +2336,7 @@ in ( try - while true do + while true do routput := (input_line chn) :: !routput done with End_of_file -> @@ -2231,40 +2346,40 @@ Sys.remove fn; List.rev !routput - let run_read_one_line cmd args = - match run_read_output cmd args with - | [fst] -> + let run_read_one_line ?f_exit_code cmd args = + match run_read_output ?f_exit_code cmd args with + | [fst] -> fst - | lst -> - failwithf1 + | lst -> + failwithf (f_ "Command return unexpected output %S") (String.concat "\n" lst) end module BaseFileUtil = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/base/BaseFileUtil.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseFileUtil.ml" open OASISGettext - let find_file paths exts = + let find_file paths exts = (* Cardinal product of two list *) - let ( * ) lst1 lst2 = - List.flatten - (List.map - (fun a -> - List.map - (fun b -> a,b) - lst2) + let ( * ) lst1 lst2 = + List.flatten + (List.map + (fun a -> + List.map + (fun b -> a,b) + lst2) lst1) in - let rec combined_paths lst = + let rec combined_paths lst = match lst with | p1 :: p2 :: tl -> - let acc = - (List.map - (fun (a,b) -> Filename.concat a b) + let acc = + (List.map + (fun (a,b) -> Filename.concat a b) (p1 * p2)) in combined_paths (acc :: tl) @@ -2275,51 +2390,51 @@ in let alternatives = - List.map - (fun (p,e) -> + List.map + (fun (p,e) -> if String.length e > 0 && e.[0] <> '.' then p ^ "." ^ e else - p ^ e) + p ^ e) ((combined_paths paths) * exts) in - List.find - Sys.file_exists + List.find + OASISUtils.file_exists alternatives let which prg = let path_sep = - match Sys.os_type with + match Sys.os_type with | "Win32" -> ';' | _ -> ':' in let path_lst = - OASISUtils.split - path_sep + OASISUtils.split + path_sep (Sys.getenv "PATH") in - let exec_ext = - match Sys.os_type with + let exec_ext = + match Sys.os_type with | "Win32" -> - "" - :: - (OASISUtils.split - path_sep + "" + :: + (OASISUtils.split + path_sep (Sys.getenv "PATHEXT")) | _ -> [""] in - find_file [path_lst; [prg]] exec_ext + find_file [path_lst; [prg]] exec_ext (**/**) - let rec fix_dir dn = - (* Windows hack because Sys.file_exists "src\\" = false when + let rec fix_dir dn = + (* Windows hack because Sys.file_exists "src\\" = false when * Sys.file_exists "src" = true *) - let ln = - String.length dn + 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)) @@ -2329,28 +2444,28 @@ let q = Filename.quote (**/**) - let cp src tgt = + let cp src tgt = BaseExec.run - (match Sys.os_type with + (match Sys.os_type with | "Win32" -> "copy" | _ -> "cp") [q src; q tgt] let mkdir tgt = - BaseExec.run - (match Sys.os_type with - | "Win32" -> "md" + BaseExec.run + (match Sys.os_type with + | "Win32" -> "md" | _ -> "mkdir") [q tgt] let rec mkdir_parent f tgt = - let tgt = + let tgt = fix_dir tgt in - if Sys.file_exists tgt then + if OASISUtils.file_exists tgt then begin if not (Sys.is_directory tgt) then - OASISUtils.failwithf1 + OASISUtils.failwithf (f_ "Cannot create directory '%s', a file of the same name already \ exists") tgt @@ -2358,7 +2473,7 @@ else begin mkdir_parent f (Filename.dirname tgt); - if not (Sys.file_exists tgt) then + if not (OASISUtils.file_exists tgt) then begin f tgt; mkdir tgt @@ -2368,15 +2483,15 @@ let rmdir tgt = if Sys.readdir tgt = [||] then begin - match Sys.os_type with + match Sys.os_type with | "Win32" -> BaseExec.run "rd" [q tgt] | _ -> BaseExec.run "rm" ["-r"; q tgt] end - let glob fn = - let basename = + let glob fn = + let basename = Filename.basename fn in if String.length basename >= 2 && @@ -2386,7 +2501,7 @@ let ext_len = (String.length basename) - 2 in - let ext = + let ext = String.sub basename 2 ext_len in let dirname = @@ -2394,11 +2509,11 @@ in Array.fold_left (fun acc fn -> - try - let fn_ext = - String.sub - fn - ((String.length fn) - ext_len) + try + let fn_ext = + String.sub + fn + ((String.length fn) - ext_len) ext_len in if fn_ext = ext then @@ -2412,7 +2527,7 @@ end else begin - if Sys.file_exists fn then + if OASISUtils.file_exists fn then [fn] else [] @@ -2420,7 +2535,7 @@ end module BaseArgExt = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/base/BaseArgExt.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseArgExt.ml" open OASISUtils open OASISGettext @@ -2436,9 +2551,9 @@ ~current:current (Array.concat [[|"none"|]; argv]) (Arg.align args) - (failwithf1 (f_ "Don't know what to do with arguments: '%s'")) + (failwithf (f_ "Don't know what to do with arguments: '%s'")) (s_ "configure options:") - with + with | Arg.Help txt -> print_endline txt; exit 0 @@ -2448,7 +2563,7 @@ end module BaseCheck = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/base/BaseCheck.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseCheck.ml" open BaseEnv open BaseMessage @@ -2457,89 +2572,89 @@ let prog_best prg prg_lst = var_redefine - prg - (lazy - (let alternate = - List.fold_left - (fun res e -> - match res with - | Some _ -> - res - | None -> - try - Some (BaseFileUtil.which e) - with Not_found -> - None) - None - prg_lst - in - match alternate with - | Some prg -> prg - | None -> raise Not_found)) + prg + (fun () -> + let alternate = + List.fold_left + (fun res e -> + match res with + | Some _ -> + res + | None -> + try + Some (BaseFileUtil.which 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 = + let prog_opt prg = prog_best prg [prg^".opt"; prg] - let ocamlfind = + let ocamlfind = prog "ocamlfind" - let version - var_prefix + let version + var_prefix cmp - fversion - () = + fversion + () = (* Really compare version provided *) - let var = + let var = var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) in - var_redefine - ~hide:true + var_redefine + ~hide:true var - (lazy - (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 - failwithf3 - (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") - var_prefix - (OASISVersion.string_of_comparator cmp) - version_str)) + (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 = - BaseExec.run_read_one_line + BaseExec.run_read_one_line (ocamlfind ()) ["query"; "-format"; "%v"; pkg] let package ?version_comparator pkg () = let var = - OASISUtils.varname_concat - "pkg_" + OASISUtils.varname_concat + "pkg_" (OASISUtils.varname_of_string pkg) in - let findlib_dir pkg = - let dir = + let findlib_dir pkg = + let dir = BaseExec.run_read_one_line (ocamlfind ()) ["query"; "-format"; "%d"; pkg] @@ -2547,7 +2662,7 @@ if Sys.file_exists dir && Sys.is_directory dir then dir else - failwithf2 + failwithf (f_ "When looking for findlib package %s, \ directory %s return doesn't exist") pkg dir @@ -2555,26 +2670,26 @@ let vl = var_redefine var - (lazy (findlib_dir pkg)) + (fun () -> findlib_dir pkg) () in ( - match version_comparator with + match version_comparator with | Some ver_cmp -> ignore - (version + (version var ver_cmp (fun _ -> package_version pkg) ()) - | None -> + | None -> () ); vl end module BaseOCamlcConfig = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/base/BaseOCamlcConfig.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseOCamlcConfig.ml" open BaseEnv @@ -2583,34 +2698,34 @@ module SMap = Map.Make(String) - let ocamlc = + let ocamlc = BaseCheck.prog_opt "ocamlc" let ocamlc_config_map = - (* Map name to value for ocamlc -config output - (name ^": "^value) + (* Map name to value for ocamlc -config output + (name ^": "^value) *) - let rec split_field mp lst = - match lst with + 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 + if pos_semicolon > 1 then ( let name = - String.sub line 0 pos_semicolon + 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) + String.sub + line + (pos_semicolon + 2) (linelen - pos_semicolon - 2) else "" @@ -2631,52 +2746,65 @@ mp in + let cache = + lazy + (var_protect + (Marshal.to_string + (split_field + SMap.empty + (BaseExec.run_read_output + (ocamlc ()) ["-config"])) + [])) + in var_redefine "ocamlc_config_map" ~hide:true ~dump:false - (lazy - (var_protect - (Marshal.to_string - (split_field - SMap.empty - (BaseExec.run_read_output - (ocamlc ()) ["-config"])) - []))) + (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 + let avlbl_config_get () = + Marshal.from_string (ocamlc_config_map ()) 0 in - let nm_config = - match nm with - | "ocaml_version" -> "version" - | _ -> nm + 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 - (lazy - (try - let map = - avlbl_config_get () - in - let value = - SMap.find nm_config map - in - value - with Not_found -> - failwithf2 - (f_ "Cannot find field '%s' in '%s -config' output") - nm - (ocamlc ()))) + 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/mfp/mess/2010/44/oasis-0.2.0/src/base/BaseStandardVar.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseStandardVar.ml" open OASISGettext @@ -2692,29 +2820,29 @@ (**/**) - let rpkg = + let rpkg = ref None let pkg_get () = - match !rpkg with + match !rpkg with | Some pkg -> pkg | None -> failwith (s_ "OASIS Package is not set") (**/**) - let pkg_name = + let pkg_name = var_define ~short_desc:(fun () -> s_ "Package name") "pkg_name" - (lazy (pkg_get ()).name) + (fun () -> (pkg_get ()).name) let pkg_version = var_define ~short_desc:(fun () -> s_ "Package version") "pkg_version" - (lazy + (fun () -> (OASISVersion.string_of_version (pkg_get ()).version)) - let c = BaseOCamlcConfig.var_define + let c = BaseOCamlcConfig.var_define let os_type = c "os_type" let system = c "system" @@ -2739,204 +2867,245 @@ (**/**) - let p name hlp dflt = + let p name hlp dflt = var_define - ~short_desc:hlp - ~cli:CLIAuto - ~arg_help:"dir" - name - dflt + ~short_desc:hlp + ~cli:CLIAuto + ~arg_help:"dir" + name + dflt - let (/) a b = + let (/) a b = if os_type () = Sys.os_type then - Filename.concat a b + Filename.concat a b else if os_type () = "Unix" then - BaseFilePath.Unix.concat a b + BaseFilePath.Unix.concat a b else - OASISUtils.failwithf1 - (f_ "Cannot handle os_type %s filename concat") + OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") (os_type ()) (**/**) - let prefix = + let prefix = p "prefix" (fun () -> s_ "Install architecture-independent files dir") - (lazy - (match os_type () with - | "Win32" -> - let program_files = - Sys.getenv "PROGRAMFILES" - in - program_files/(pkg_name ()) - | _ -> - "/usr/local")) + (fun () -> + match os_type () with + | "Win32" -> + let program_files = + Sys.getenv "PROGRAMFILES" + in + program_files/(pkg_name ()) + | _ -> + "/usr/local") - let exec_prefix = + let exec_prefix = p "exec_prefix" (fun () -> s_ "Install architecture-dependent files in dir") - (lazy "$prefix") + (fun () -> "$prefix") let bindir = p "bindir" (fun () -> s_ "User executables") - (lazy ("$exec_prefix"/"bin")) + (fun () -> "$exec_prefix"/"bin") let sbindir = p "sbindir" (fun () -> s_ "System admin executables") - (lazy ("$exec_prefix"/"sbin")) + (fun () -> "$exec_prefix"/"sbin") let libexecdir = p "libexecdir" (fun () -> s_ "Program executables") - (lazy ("$exec_prefix"/"libexec")) + (fun () -> "$exec_prefix"/"libexec") let sysconfdir = p "sysconfdir" (fun () -> s_ "Read-only single-machine data") - (lazy ("$prefix"/"etc")) + (fun () -> "$prefix"/"etc") let sharedstatedir = p "sharedstatedir" (fun () -> s_ "Modifiable architecture-independent data") - (lazy ("$prefix"/"com")) + (fun () -> "$prefix"/"com") let localstatedir = p "localstatedir" (fun () -> s_ "Modifiable single-machine data") - (lazy ("$prefix"/"var")) + (fun () -> "$prefix"/"var") let libdir = p "libdir" (fun () -> s_ "Object code libraries") - (lazy ("$exec_prefix"/"lib")) + (fun () -> "$exec_prefix"/"lib") let datarootdir = p "datarootdir" (fun () -> s_ "Read-only arch-independent data root") - (lazy ("$prefix"/"share")) + (fun () -> "$prefix"/"share") let datadir = p "datadir" (fun () -> s_ "Read-only architecture-independent data") - (lazy ("$datarootdir")) + (fun () -> "$datarootdir") let infodir = p "infodir" (fun () -> s_ "Info documentation") - (lazy ("$datarootdir"/"info")) + (fun () -> "$datarootdir"/"info") let localedir = p "localedir" (fun () -> s_ "Locale-dependent data") - (lazy ("$datarootdir"/"locale")) + (fun () -> "$datarootdir"/"locale") let mandir = p "mandir" (fun () -> s_ "Man documentation") - (lazy ("$datarootdir"/"man")) + (fun () -> "$datarootdir"/"man") let docdir = p "docdir" (fun () -> s_ "Documentation root") - (lazy ("$datarootdir"/"doc"/"$pkg_name")) + (fun () -> "$datarootdir"/"doc"/"$pkg_name") let htmldir = p "htmldir" (fun () -> s_ "HTML documentation") - (lazy ("$docdir")) + (fun () -> "$docdir") let dvidir = p "dvidir" (fun () -> s_ "DVI documentation") - (lazy ("$docdir")) + (fun () -> "$docdir") let pdfdir = p "pdfdir" (fun () -> s_ "PDF documentation") - (lazy ("$docdir")) + (fun () -> "$docdir") let psdir = p "psdir" (fun () -> s_ "PS documentation") - (lazy ("$docdir")) + (fun () -> "$docdir") let destdir = p "destdir" (fun () -> s_ "Prepend a path when installing package") - (lazy - (raise - (PropList.Not_set - ("destdir", - Some (s_ "undefined by construct"))))) + (fun () -> + raise + (PropList.Not_set + ("destdir", + Some (s_ "undefined by construct")))) let findlib_version = var_define "findlib_version" - (lazy - (BaseCheck.package_version "findlib")) + (fun () -> + BaseCheck.package_version "findlib") let is_native = var_define "is_native" - (lazy - (try - let _s : string = - ocamlopt () - in - "true" - with PropList.Not_set _ -> - let _s : string = - ocamlc () - in - "false")) + (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" - (lazy - (match os_type () with - | "Win32" -> ".exe" - | _ -> "" - )) + (fun () -> + match os_type () with + | "Win32" -> ".exe" + | _ -> "") let rm = var_define ~short_desc:(fun () -> s_ "Remove a file.") "rm" - (lazy - (match os_type () with - | "Win32" -> "del" - | _ -> "rm -f")) + (fun () -> + match os_type () with + | "Win32" -> "del" + | _ -> "rm -f") let rmdir = var_define ~short_desc:(fun () -> s_ "Remove a directory.") "rmdir" - (lazy - (match os_type () with - | "Win32" -> "rd" - | _ -> "rm -rf")) + (fun () -> + match os_type () with + | "Win32" -> "rd" + | _ -> "rm -rf") let debug = var_define - ~short_desc:(fun () -> s_ "Compile with ocaml debug flag on.") + ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") + ~cli:CLIEnable "debug" - (lazy "true") + (fun () -> "true") let profile = var_define - ~short_desc:(fun () -> s_ "Compile with ocaml profile flag on.") + ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") + ~cli:CLIEnable "profile" - (lazy "false") + (fun () -> "false") + + let tests = + var_define + ~short_desc:(fun () -> + s_ "Compile tests executable and library and run them") + ~cli:CLIEnable + "tests" + (fun () -> "false") + + let docs = + var_define + ~short_desc:(fun () -> s_ "Create documentations") + ~cli:CLIEnable + "docs" + (fun () -> "true") + + let native_dynlink = + var_define + ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") + ~cli:CLINone + "native_dynlink" + (fun () -> + let res = + if bool_of_string (is_native ()) then + begin + let ocamlfind = ocamlfind () in + try + let fn = + BaseExec.run_read_one_line + ocamlfind + ["query"; "-predicates"; "native"; "dynlink"; + "-format"; "%d/%a"] + in + Sys.file_exists fn + with _ -> + false + end + else + false + in + string_of_bool res) - let init pkg = + let init pkg = rpkg := Some pkg end module BaseFileAB = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/base/BaseFileAB.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseFileAB.ml" open BaseEnv open OASISGettext @@ -2947,7 +3116,7 @@ BaseFilePath.of_unix fn in if not (Filename.check_suffix fn ".ab") then - warning + warning (f_ "File '%s' doesn't have '.ab' extension") fn; Filename.chop_extension fn @@ -2984,42 +3153,42 @@ end module BaseLog = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/base/BaseLog.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseLog.ml" open OASISUtils let default_filename = - Filename.concat + Filename.concat (Filename.dirname BaseEnv.default_filename) "setup.log" module SetTupleString = Set.Make - (struct + (struct type t = string * string - let compare (s11, s12) (s21, s22) = - match String.compare s11 s21 with + let compare (s11, s12) (s21, s22) = + match String.compare s11 s21 with | 0 -> String.compare s12 s22 | n -> n end) - let load () = + let load () = if Sys.file_exists default_filename then begin - let chn = + let chn = open_in default_filename in - let scbuf = + 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 = + let acc = + try + Scanf.bscanf scbuf "%S %S\n" + (fun e d -> + let t = e, d in if SetTupleString.mem t st then @@ -3028,9 +3197,9 @@ SetTupleString.add t st, t :: lst) with Scanf.Scan_failure _ -> - failwith + failwith (Scanf.bscanf scbuf - "%l" + "%l" (fun line -> Printf.sprintf "Malformed log file '%s' at line %d" @@ -3062,7 +3231,7 @@ let unregister event data = if Sys.file_exists default_filename then begin - let lst = + let lst = load () in let chn_out = @@ -3071,7 +3240,7 @@ let write_something = ref false in - List.iter + List.iter (fun (e, d) -> if e <> event || d <> data then begin @@ -3087,12 +3256,12 @@ let filter events = let st_events = List.fold_left - (fun st e -> + (fun st e -> SetString.add e st) SetString.empty events in - List.filter + List.filter (fun (e, _) -> SetString.mem e st_events) (load ()) @@ -3103,7 +3272,7 @@ end module BaseBuilt = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/base/BaseBuilt.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseBuilt.ml" open OASISTypes open OASISGettext @@ -3118,7 +3287,7 @@ let to_log_event_file t nm = "built_"^ - (match t with + (match t with | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" @@ -3128,22 +3297,22 @@ let to_log_event_done t nm = "is_"^(to_log_event_file t nm) - let register t nm lst = + let register t nm lst = BaseLog.register (to_log_event_done t nm) "true"; List.iter (fun alt -> - let registered = + let registered = List.fold_left (fun registered fn -> - if Sys.file_exists fn then + if OASISUtils.file_exists fn then begin - BaseLog.register + BaseLog.register (to_log_event_file t nm) (if Filename.is_relative fn then Filename.concat (Sys.getcwd ()) fn - else + else fn); true end @@ -3162,26 +3331,26 @@ List.iter (fun (e, d) -> BaseLog.unregister e d) - (BaseLog.filter - [to_log_event_file t nm; + (BaseLog.filter + [to_log_event_file t nm; to_log_event_done t nm]) - let fold t nm f acc = - List.fold_left + let fold t nm f acc = + List.fold_left (fun acc (_, fn) -> - if Sys.file_exists fn then + if OASISUtils.file_exists fn then begin f acc fn end else begin - warning + warning (f_ "File '%s' has been marked as built \ for %s but doesn't exist") fn (Printf.sprintf - (match t with - | BExec | BExecLib -> + (match t with + | BExec | BExecLib -> (f_ "executable %s") | BLib -> (f_ "library %s") @@ -3197,7 +3366,7 @@ let is_built t nm = List.fold_left (fun is_built (_, d) -> - (try + (try bool_of_string d with _ -> false)) @@ -3205,17 +3374,17 @@ (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 + 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 + (fun () -> + bool_of_string (is_native ())) ext_dll ext_program in - let evs = + let evs = (BExec, cs.cs_name, [[ffn unix_exec_is]]) :: (match unix_dll_opt with @@ -3228,17 +3397,17 @@ unix_exec_is, unix_dll_opt - let of_library ffn (cs, bs, lib) = - let unix_lst = + let of_library ffn (cs, bs, lib) = + let unix_lst = OASISLibrary.generated_unix_files ~ctxt:!BaseContext.default + ~source_file_exists:(fun fn -> + OASISUtils.file_exists (BaseFilePath.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) - (fun fn -> - Sys.file_exists (BaseFilePath.of_unix fn)) - (fun () -> - bool_of_string (is_native ())) - ext_lib - ext_dll in let evs = [BLib, @@ -3250,7 +3419,7 @@ end module BaseCustom = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/base/BaseCustom.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseCustom.ml" open BaseEnv open BaseMessage @@ -3258,33 +3427,33 @@ open OASISGettext let run cmd args extra_args = - BaseExec.run + BaseExec.run (var_expand cmd) - (List.map + (List.map var_expand (args @ (Array.to_list extra_args))) let hook ?(failsafe=false) cstm f e = - let optional_command lst = + let optional_command lst = let printer = - function + function | Some (cmd, args) -> String.concat " " (cmd :: args) | None -> s_ "No command" in - match - var_choose + match + var_choose ~name:(s_ "Pre/Post Command") - ~printer - lst with + ~printer + lst with | Some (cmd, args) -> begin - try + try run cmd args [||] with e when failsafe -> - warning + warning (f_ "Command '%s' fail with error: %s") (String.concat " " (cmd :: args)) - (match e with + (match e with | Failure msg -> msg | e -> Printexc.to_string e) end @@ -3300,7 +3469,7 @@ end module BaseDynVar = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/base/BaseDynVar.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseDynVar.ml" open OASISTypes @@ -3309,34 +3478,35 @@ open BaseBuilt let init pkg = - List.iter + List.iter (function | Executable (cs, bs, exec) -> - 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) - cs.cs_name - (lazy - (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)))))) + 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) + 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 _ -> ()) @@ -3344,7 +3514,7 @@ end module BaseTest = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/base/BaseTest.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseTest.ml" open BaseEnv open BaseMessage @@ -3355,20 +3525,20 @@ let test lst pkg extra_args = let one_test (failure, n) (test_plugin, cs, test) = - if var_choose + if var_choose ~name:(Printf.sprintf (f_ "test %s run") cs.cs_name) ~printer:string_of_bool test.test_run then begin - let () = + let () = info (f_ "Running test '%s'") cs.cs_name in - let back_cwd = - match test.test_working_directory with - | Some dir -> - let cwd = + let back_cwd = + match test.test_working_directory with + | Some dir -> + let cwd = Sys.getcwd () in let chdir d = @@ -3378,15 +3548,15 @@ chdir dir; fun () -> chdir cwd - | None -> + | None -> fun () -> () in - try + try let failure_percent = - BaseCustom.hook + BaseCustom.hook test.test_custom (test_plugin pkg (cs, test)) - extra_args + extra_args in back_cwd (); (failure_percent +. failure, n + 1) @@ -3414,7 +3584,7 @@ else failed /. (float_of_int n) in - let msg = + let msg = Printf.sprintf (f_ "Tests had a %.2f%% failure rate") (100. *. failure_percent) @@ -3426,7 +3596,7 @@ end module BaseDoc = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/base/BaseDoc.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseDoc.ml" open BaseEnv open BaseMessage @@ -3435,10 +3605,10 @@ let doc lst pkg extra_args = - let one_doc (doc_plugin, cs, doc) = - if var_choose - ~name:(Printf.sprintf - (f_ "documentation %s build") + 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 @@ -3450,13 +3620,13 @@ extra_args end in - List.iter + List.iter one_doc lst end module BaseSetup = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/base/BaseSetup.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/base/BaseSetup.ml" open BaseEnv open BaseMessage @@ -3465,36 +3635,40 @@ open OASISGettext open OASISUtils - type std_args_fun = + type std_args_fun = package -> string array -> unit - type ('a, 'b) section_args_fun = + 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; - version: string; - } + 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; + } (* 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 + match filter_map sct with | Some e -> e :: acc | None -> @@ -3504,26 +3678,43 @@ (* Search for plugin data associated with a section name *) let lookup_plugin_section plugin action nm lst = - try + try List.assoc nm lst with Not_found -> - failwithf3 + failwithf (f_ "Cannot find plugin %s matching section %s for %s action") plugin nm action - let configure t args = + let configure t args = (* Run configure *) - BaseCustom.hook + BaseCustom.hook t.package.conf_custom - (t.configure t.package) - args; + (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 @@ -3534,45 +3725,55 @@ 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 + if bool_of_string (BaseStandardVar.docs ()) then + 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 + else + BaseMessage.warning + "Docs are turned off, consider enabling with \ + 'ocaml setup.ml -configure --enable-docs'" + + let test t args = + if bool_of_string (BaseStandardVar.tests ()) then + 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 + else + BaseMessage.warning + "Tests are turned off, consider enabling with \ + 'ocaml setup.ml -configure --enable-tests'" let all t args = - let rno_doc = + let rno_doc = ref false in let rno_test = @@ -3580,8 +3781,8 @@ in Arg.parse_argv ~current:(ref 0) - (Array.of_list - ((Sys.executable_name^" all") :: + (Array.of_list + ((Sys.executable_name^" all") :: (Array.to_list args))) [ "-no-doc", @@ -3592,18 +3793,18 @@ Arg.Set rno_test, s_ "Don't run test target"; ] - (failwithf1 (f_ "Don't know what to do with '%s'")) + (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"; @@ -3640,19 +3841,19 @@ uninstall t args; install t args - let clean, distclean = + let clean, distclean = let failsafe f a = - try + try f a with e -> - warning + warning (f_ "Action fail with error: %s") - (match e with + (match e with | Failure msg -> msg | e -> Printexc.to_string e) in - let generic_clean t cstm mains docs tests args = + let generic_clean t cstm mains docs tests args = BaseCustom.hook ~failsafe:true cstm @@ -3662,7 +3863,7 @@ (function | Test (cs, test) -> let f = - try + try List.assoc cs.cs_name tests with Not_found -> fun _ _ _ -> () @@ -3673,22 +3874,22 @@ | Doc (cs, doc) -> let f = try - List.assoc cs.cs_name docs + List.assoc cs.cs_name docs with Not_found -> fun _ _ _ -> () in - failsafe + failsafe (f t.package (cs, doc)) args - | Library _ + | Library _ | Executable _ - | Flag _ + | Flag _ | SrcRepo _ -> ()) t.package.sections; (* Clean whole package *) List.iter - (fun f -> + (fun f -> failsafe (f t.package) args) @@ -3697,12 +3898,12 @@ in let clean t args = - generic_clean - t + generic_clean + t t.package.clean_custom - t.clean - t.clean_doc - t.clean_test + t.clean + t.clean_doc + t.clean_test args in @@ -3718,35 +3919,162 @@ info (f_ "Remove '%s'") fn; Sys.remove fn end) - (BaseEnv.default_filename - :: + (BaseEnv.default_filename + :: BaseLog.default_filename :: (List.rev_map BaseFileAB.to_filename t.package.files_ab)); - + (* Call distclean code *) - generic_clean - t + generic_clean + t t.package.distclean_custom - t.distclean - t.distclean_doc - t.distclean_test + t.distclean + t.distclean_doc + t.distclean_test args in clean, distclean - let version t _ = - print_endline t.version + let version t _ = + print_endline t.oasis_version - let setup t = + 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 = + BaseExec.run_read_one_line + ~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 + BaseExec.run + ~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); + BaseExec.run 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 _ -> - failwithf2 + ref (fun _ -> + failwithf (f_ "No action defined, run '%s %s -help'") Sys.executable_name Sys.argv.(0)) @@ -3755,7 +4083,7 @@ let extra_args_ref = ref [] in - let allow_empty_env_ref = + let allow_empty_env_ref = ref false in let arg_handle ?(allow_empty_env=false) act = @@ -3763,14 +4091,14 @@ [ Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); - Arg.Unit - (fun () -> + Arg.Unit + (fun () -> allow_empty_env_ref := allow_empty_env; act_ref := act); ] in - Arg.parse + Arg.parse (Arg.align [ "-configure", @@ -3807,7 +4135,7 @@ 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."; @@ -3823,9 +4151,11 @@ "-no-catch-exn", Arg.Clear catch_exn, s_ " Don't catch exception, useful for debugging."; - ] + + no_update_setup_ml_cli; + ] @ (BaseContext.args ())) - (failwithf1 (f_ "Don't know what to do with '%s'")) + (failwithf (f_ "Don't know what to do with '%s'")) (s_ "Setup and run build process current package\n"); (* Build initial environment *) @@ -3834,30 +4164,31 @@ (** Initialize flags *) List.iter (function - | Flag (cs, {flag_description = hlp; + | Flag (cs, {flag_description = hlp; flag_default = choices}) -> begin - let apply ?short_desc () = + let apply ?short_desc () = var_ignore (var_define ~cli:CLIEnable ?short_desc (OASISUtils.varname_of_string cs.cs_name) - (lazy (string_of_bool - (var_choose - ~name:(Printf.sprintf - (f_ "default value of flag %s") - cs.cs_name) - ~printer:string_of_bool - choices)))) + (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 + match hlp with | Some hlp -> apply ~short_desc:(fun () -> hlp) () | None -> apply () end - | _ -> + | _ -> ()) t.package.sections; @@ -3865,74 +4196,18 @@ BaseDynVar.init t.package; - !act_ref t (Array.of_list (List.rev !extra_args_ref)) + if not (update_setup_ml t) then + !act_ref t (Array.of_list (List.rev !extra_args_ref)) with e when !catch_exn -> - error "%s" (string_of_exception e); + error "%s" (Printexc.to_string e); exit 1 end -module BaseDev = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/base/BaseDev.ml" - - - - open OASISGettext - open BaseMessage - - type t = - { - oasis_cmd: string; - } - - let update_and_run t = - (* Command line to run setup-dev *) - let oasis_args = - "setup-dev" :: "-run" :: - Sys.executable_name :: - (Array.to_list Sys.argv) - in - - let exit_on_child_error = - function - | 0 -> () - | 2 -> - (* Bad CLI arguments *) - error - (f_ "The command '%s %s' exit with code 2. It often means that we \ - don't use the right command-line arguments, rerun \ - 'oasis setup-dev'.") - t.oasis_cmd - (String.concat " " oasis_args) - - | 127 -> - (* Cannot find OASIS *) - error - (f_ "Cannot find executable '%s', check where 'oasis' is located \ - and rerun 'oasis setup-dev'") - t.oasis_cmd - - | i -> - exit i - in - - let () = - (* Run OASIS to generate a temporary setup.ml - *) - BaseExec.run - ~f_exit_code:exit_on_child_error - t.oasis_cmd - oasis_args - in - - () - -end - module InternalConfigurePlugin = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/plugins/internal/InternalConfigurePlugin.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/plugins/internal/InternalConfigurePlugin.ml" (** Configure using internal scheme @author Sylvain Le Gall @@ -3948,14 +4223,14 @@ * and then output corresponding file. *) let configure pkg argv = - let var_ignore_eval var = + let var_ignore_eval var = let _s : string = var () - in + in () in - let errors = + let errors = ref SetString.empty in @@ -3973,16 +4248,16 @@ in let warn_exception e = - warning "%s" (string_of_exception e) + warning "%s" (Printexc.to_string e) in (* Check tools *) let check_tools lst = - List.iter + List.iter (function - | ExternalTool tool -> + | ExternalTool tool -> begin - try + try var_ignore_eval (BaseCheck.prog tool) with e -> warn_exception e; @@ -3992,8 +4267,8 @@ (* Check that matching tool is built *) List.iter (function - | Executable ({cs_name = nm2}, - {bs_build = build}, + | Executable ({cs_name = nm2}, + {bs_build = build}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors @@ -4011,7 +4286,7 @@ begin if bs.bs_compiled_object = Native then begin - try + try var_ignore_eval BaseStandardVar.ocamlopt with e -> warn_exception e; @@ -4024,11 +4299,11 @@ check_tools bs.bs_build_tools; (* Check depends *) - List.iter + List.iter (function | FindlibPackage (findlib_pkg, version_comparator) -> begin - try + try var_ignore_eval (BaseCheck.package ?version_comparator findlib_pkg) with e -> @@ -4049,7 +4324,7 @@ List.iter (function | Library ({cs_name = nm2}, - {bs_build = build}, + {bs_build = build}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors @@ -4068,18 +4343,18 @@ (* OCaml version *) begin - match pkg.ocaml_version with + match pkg.ocaml_version with | Some ver_cmp -> begin - try + try var_ignore_eval - (BaseCheck.version - "ocaml" - ver_cmp + (BaseCheck.version + "ocaml" + ver_cmp BaseStandardVar.ocaml_version) with e -> warn_exception e; - add_errors + add_errors (f_ "OCaml version %s doesn't match version constraint %s") (BaseStandardVar.ocaml_version ()) (OASISVersion.string_of_comparator ver_cmp) @@ -4087,21 +4362,21 @@ | None -> () end; - + (* Findlib version *) begin - match pkg.findlib_version with + match pkg.findlib_version with | Some ver_cmp -> begin - try + try var_ignore_eval - (BaseCheck.version - "findlib" - ver_cmp + (BaseCheck.version + "findlib" + ver_cmp BaseStandardVar.findlib_version) with e -> warn_exception e; - add_errors + add_errors (f_ "Findlib version %s doesn't match version constraint %s") (BaseStandardVar.findlib_version ()) (OASISVersion.string_of_comparator ver_cmp) @@ -4126,19 +4401,34 @@ ()) pkg.sections; - (* Save and print environment *) - if SetString.empty = !errors then - begin - dump (); - print () - end - else + (* 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); - failwithf1 - (fn_ + failwithf + (fn_ "%d configuration error" "%d configuration errors" (SetString.cardinal !errors)) @@ -4148,7 +4438,7 @@ end module InternalInstallPlugin = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/plugins/internal/InternalInstallPlugin.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/plugins/internal/InternalInstallPlugin.ml" (** Install using internal scheme @author Sylvain Le Gall @@ -4171,7 +4461,7 @@ let doc_hook = ref (fun (cs, doc) -> cs, doc) - let install_file_ev = + let install_file_ev = "install-file" let install_dir_ev = @@ -4183,9 +4473,9 @@ let install pkg argv = let in_destdir = - try + try let destdir = - destdir () + destdir () in (* Practically speaking destdir is prepended * at the beginning of the target filename @@ -4195,17 +4485,21 @@ fun fn -> fn in - let install_file src_file envdir = - let tgt_dir = + let install_file ?tgt_fn src_file envdir = + let tgt_dir = in_destdir (envdir ()) in let tgt_file = - Filename.concat + Filename.concat tgt_dir - (Filename.basename src_file) + (match tgt_fn with + | Some fn -> + fn + | None -> + Filename.basename src_file) in (* Create target directory if needed *) - BaseFileUtil.mkdir_parent + BaseFileUtil.mkdir_parent (fun dn -> info (f_ "Creating directory '%s'") dn; BaseLog.register install_dir_ev dn) @@ -4219,57 +4513,57 @@ (* Install data into defined directory *) let install_data srcdir lst tgtdir = - let tgtdir = + let tgtdir = BaseFilePath.of_unix (var_expand tgtdir) in List.iter (fun (src, tgt_opt) -> - let real_srcs = - BaseFileUtil.glob + let real_srcs = + BaseFileUtil.glob (Filename.concat srcdir src) in if real_srcs = [] then - failwithf1 + failwithf (f_ "Wildcard '%s' doesn't match any files") src; - List.iter - (fun fn -> - install_file - fn - (fun () -> - match tgt_opt with - | Some s -> + List.iter + (fun fn -> + install_file + fn + (fun () -> + match tgt_opt with + | Some s -> BaseFilePath.of_unix (var_expand s) - | None -> + | None -> tgtdir)) real_srcs) lst - in + in (** Install all libraries *) let install_libs pkg = - let files_of_library (f_data, acc) data_lib = + 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 && + if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then begin - let acc = + let acc = (* Start with acc + lib_extra *) List.rev_append lib_extra acc in - let acc = + let acc = (* Add uncompiled header from the source tree *) - let path = + let path = BaseFilePath.of_unix bs.bs_path in List.fold_left (fun acc modul -> - try + try List.find - Sys.file_exists + OASISUtils.file_exists (List.map (Filename.concat path) [modul^".mli"; @@ -4281,7 +4575,7 @@ :: acc with Not_found -> begin - warning + warning (f_ "Cannot find source header for module %s \ in library %s") modul cs.cs_name; @@ -4291,10 +4585,10 @@ lib.lib_modules in - let acc = + let acc = (* Get generated files *) - BaseBuilt.fold - BaseBuilt.BLib + BaseBuilt.fold + BaseBuilt.BLib cs.cs_name (fun acc fn -> fn :: acc) acc @@ -4305,7 +4599,7 @@ install_data bs.bs_path bs.bs_data_files - (Filename.concat + (Filename.concat (datarootdir ()) pkg.name); f_data () @@ -4320,11 +4614,11 @@ in (* Install one group of library *) - let install_group_lib grp = + 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 + let data_and_files, children = + match grp with | Container (_, children) -> data_and_files, children | Package (_, cs, bs, lib, children) -> @@ -4352,7 +4646,7 @@ in (* Really install, if there is something to install *) - if files = [] then + if files = [] then begin warning (f_ "Nothing to install for findlib library '%s'") @@ -4360,28 +4654,56 @@ end else begin - let meta = + let meta = (* Search META file *) - let (_, bs, _) = + let (_, bs, _) = root_lib in - let res = + let res = Filename.concat bs.bs_path "META" in - if not (Sys.file_exists res) then - failwithf2 + if not (OASISUtils.file_exists res) then + failwithf (f_ "Cannot find file '%s' for findlib library %s") res findlib_name; res in - info + 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; - BaseExec.run - (ocamlfind ()) + BaseExec.run + (ocamlfind ()) ("install" :: findlib_name :: meta :: files); - BaseLog.register install_findlib_ev findlib_name + BaseLog.register install_findlib_ev findlib_name end; (* Install data files *) @@ -4390,12 +4712,12 @@ in (* We install libraries in groups *) - List.iter + List.iter install_group_lib (group_libs pkg) in - let install_execs pkg = + let install_execs pkg = let install_exec data_exec = let (cs, bs, exec) = !exec_hook data_exec @@ -4404,7 +4726,7 @@ BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then begin let exec_libdir () = - Filename.concat + Filename.concat (libdir ()) pkg.name in @@ -4413,6 +4735,7 @@ cs.cs_name (fun () fn -> install_file + ~tgt_fn:cs.cs_name fn bindir) (); @@ -4427,7 +4750,7 @@ install_data bs.bs_path bs.bs_data_files - (Filename.concat + (Filename.concat (datarootdir ()) pkg.name) end @@ -4441,7 +4764,7 @@ pkg.sections in - let install_docs pkg = + let install_docs pkg = let install_doc data = let (cs, doc) = !doc_hook data @@ -4456,8 +4779,8 @@ BaseBuilt.BDoc cs.cs_name (fun () fn -> - install_file - fn + install_file + fn (fun () -> tgt_dir)) (); install_data @@ -4474,18 +4797,18 @@ ()) pkg.sections in - + install_libs pkg; install_execs pkg; install_docs pkg (* Uninstall already installed data *) let uninstall _ argv = - List.iter + List.iter (fun (ev, data) -> if ev = install_file_ev then begin - if Sys.file_exists data then + if OASISUtils.file_exists data then begin info (f_ "Removing file '%s'") @@ -4498,10 +4821,10 @@ (f_ "File '%s' doesn't exist anymore") data end - end + end else if ev = install_dir_ev then begin - if Sys.file_exists data && Sys.is_directory data then + if OASISUtils.file_exists data && Sys.is_directory data then begin if Sys.readdir data = [||] then begin @@ -4512,16 +4835,16 @@ end else begin - warning + warning (f_ "Directory '%s' is not empty (%s)") data - (String.concat - ", " - (Array.to_list + (String.concat + ", " + (Array.to_list (Sys.readdir data))) end end - else + else begin warning (f_ "Directory '%s' doesn't exist anymore") @@ -4534,12 +4857,12 @@ BaseExec.run (ocamlfind ()) ["remove"; data] end else - failwithf1 (f_ "Unknown log event '%s'") ev; + failwithf (f_ "Unknown log event '%s'") ev; BaseLog.unregister ev data) (* We process event in reverse order *) - (List.rev - (BaseLog.filter - [install_file_ev; + (List.rev + (BaseLog.filter + [install_file_ev; install_dir_ev; install_findlib_ev;])) @@ -4547,7 +4870,7 @@ module OCamlbuildCommon = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/plugins/ocamlbuild/OCamlbuildCommon.ml" (** Functions common to OCamlbuild build and doc plugin *) @@ -4563,7 +4886,7 @@ var_define ~short_desc:(fun () -> "OCamlbuild additional flags") "ocamlbuildflags" - (lazy "") + (fun () -> "") (** Fix special arguments depending on environment *) let fix_args args extra_argv = @@ -4571,18 +4894,18 @@ [ if (os_type ()) = "Win32" then [ - "-classic-display"; - "-no-log"; + "-classic-display"; + "-no-log"; "-no-links"; - "-install-lib-dir"; + "-install-lib-dir"; (Filename.concat (standard_library ()) "ocamlbuild") - ] + ] else []; - + if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then [ - "-byte-plugin" + "-byte-plugin" ] else []; @@ -4613,9 +4936,9 @@ begin BaseExec.run (ocamlbuild ()) (fix_args ["-clean"] extra_argv); BaseLog.register ocamlbuild_clean_ev extra_cli; - at_exit + at_exit (fun () -> - try + try BaseLog.unregister ocamlbuild_clean_ev extra_cli with _ -> ()) @@ -4639,7 +4962,7 @@ search_args dir tl | _ :: tl -> search_args dir tl - | [] -> + | [] -> dir in search_args "_build" (fix_args [] extra_argv) @@ -4647,9 +4970,9 @@ end module OCamlbuildPlugin = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" - (** Build using ocamlbuild + (** Build using ocamlbuild @author Sylvain Le Gall *) @@ -4661,10 +4984,6 @@ open BaseStandardVar open BaseMessage - type target = - | Std of string list - | StdRename of string * string - let cond_targets_hook = ref (fun lst -> lst) @@ -4672,8 +4991,8 @@ (* Return the filename in build directory *) let in_build_dir fn = - Filename.concat - (build_dir argv) + Filename.concat + (build_dir argv) fn in @@ -4685,11 +5004,11 @@ let cond_targets = List.fold_left (fun acc -> - function + function | Library (cs, bs, lib) when var_choose bs.bs_build -> begin let evs, unix_files = - BaseBuilt.of_library + BaseBuilt.of_library in_build_dir_of_unix (cs, bs, lib) in @@ -4700,65 +5019,62 @@ in (String.length fn >= nd_len) && - (String.sub + (String.sub fn (String.length fn - nd_len) nd_len) = nd in let tgts = - List.filter - (fun l -> l <> []) - (List.map - (List.filter - (fun fn -> - ends_with ".cma" fn || - ends_with ".cmxa" fn || - ends_with (ext_lib ()) fn || - ends_with (ext_dll ()) fn)) - unix_files) + 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 - | hd :: tl -> - (evs, Std hd) - :: - (List.map (fun tgts -> [], Std tgts) tl) - @ - acc + match tgts with + | _ :: _ -> + (evs, tgts) :: acc | [] -> - failwithf2 - (f_ "No possible ocamlbuild targets \ - in generated files %s for library %s") - (String.concat (s_ ", " ) (List.map (String.concat (s_ ", ")) tgts)) + 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 + BaseBuilt.of_executable in_build_dir_of_unix (cs, bs, exec) in - let host_exec_is = - in_build_dir_of_unix unix_exec_is - in - let target ext = - let unix_tgt = + let unix_tgt = (BaseFilePath.Unix.concat bs.bs_path - (BaseFilePath.Unix.chop_extension + (BaseFilePath.Unix.chop_extension exec.exec_main_is))^ext in - - evs, - (if unix_tgt = unix_exec_is then - Std [unix_tgt] - else - StdRename (unix_tgt, host_exec_is)) + 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 *) @@ -4775,7 +5091,7 @@ acc end - | Library _ | Executable _ | Test _ + | Library _ | Executable _ | Test _ | SrcRepo _ | Flag _ | Doc _ -> acc) [] @@ -4784,97 +5100,34 @@ in (* Check and register built files *) - let check_and_register (bt, bnm, lst) = + let check_and_register (bt, bnm, lst) = List.iter (fun fns -> - if not (List.exists Sys.file_exists fns) then - failwithf1 + if not (List.exists OASISUtils.file_exists 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) + (BaseBuilt.register bt bnm lst) in - (* Run a list of target + post process *) - let run_ocamlbuild rtargets = + let cond_targets = + (* Run the hook *) + !cond_targets_hook cond_targets + in + + (* Run a list of target... *) run_ocamlbuild - (List.rev_map snd rtargets) + (List.flatten + (List.map snd cond_targets)) argv; + (* ... and register events *) List.iter check_and_register - (List.flatten (List.rev_map fst rtargets)) - in + (List.flatten (List.map fst cond_targets)) - (* Compare two files, return true if they differ *) - let diff fn1 fn2 = - if Sys.file_exists fn1 && Sys.file_exists fn2 then - begin - let chn1 = open_in fn1 in - let chn2 = open_in fn2 in - let res = - if in_channel_length chn1 = in_channel_length chn2 then - begin - let len = - 4096 - in - let str1 = - String.make len '\000' - in - let str2 = - String.copy str1 - in - try - while (String.compare str1 str2) = 0 do - really_input chn1 str1 0 len; - really_input chn2 str2 0 len - done; - true - with End_of_file -> - false - end - else - true - in - close_in chn1; close_in chn2; - res - end - else - true - in - - let last_rtargets = - List.fold_left - (fun acc (built, tgt) -> - match tgt with - | Std nms -> - (built, List.hd nms) :: acc - | StdRename (src, tgt) -> - begin - (* We run with a fake list for event registering *) - run_ocamlbuild (([], src) :: acc); - (* And then copy and register *) - begin - let src_fn = - in_build_dir_of_unix src - in - if diff src_fn tgt then - BaseFileUtil.cp src_fn tgt - else - info - (f_ "No need to copy file '%s' to '%s', same content") - src_fn tgt - end; - List.iter check_and_register built; - [] - end) - [] - (!cond_targets_hook cond_targets) - in - if last_rtargets <> [] then - run_ocamlbuild last_rtargets - - let clean pkg extra_args = + let clean pkg extra_args = run_clean extra_args; List.iter (function @@ -4890,7 +5143,7 @@ end module OCamlbuildDocPlugin = struct -# 21 "/home/mfp/mess/2010/44/oasis-0.2.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" +# 21 "/home/mfp/src/ocsigen-bundle-2.2.2/others/oasis-0.3.0~rc3/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall @@ -4927,7 +5180,7 @@ BaseBuilt.register BaseBuilt.BDoc cs.cs_name - [BaseFileUtil.glob + [BaseFileUtil.glob (Filename.concat tgt_dir glb)]) ["*.html"; "*.css"] @@ -4956,11 +5209,11 @@ distclean_doc = []; package = { - oasis_version = "0.2"; + oasis_version = "0.3"; ocaml_version = None; findlib_version = None; name = "ocaml-sqlexpr"; - version = "0.4.1"; + version = "0.5.5"; license = OASISLicense.DEP5License { @@ -4970,27 +5223,27 @@ }; license_file = None; copyrights = []; - maintainers = []; + maintainers = ["Mauricio Fernandez "]; authors = ["Mauricio Fernandez "]; homepage = Some "http://github.com/mfp/ocaml-sqlexpr"; synopsis = "Type-safe, convenient SQLite database access."; description = Some - "Minimalistic library and syntax extension for type-safe, convenient execution\nof SQL statements. Currently compatible with Sqlite3.\n\nSqlexpr features:\n\n* automated prepared statement caching, param binding, data extraction, error\nchecking (including automatic stmt reset to avoid BUSY/LOCKED errors in\nsubsequent queries), stmt finalization on db close, etc.\n\n* HOFs like iter, fold, transaction\n\n* support for different concurrency models: everything is functorized over a\nTHREAD monad, so you can for instance do concurrent folds/iters with Lwt\n\n* support for SQL stmt syntax checks and some extra semantic checking (column\nnames, etc)"; + "Minimalistic library and syntax extension for type-safe, convenient execution\nof SQL statements. Currently compatible with Sqlite3.\n\nSqlexpr features:\n\n* automated prepared statement caching, param binding, data extraction, error\n checking (including automatic stmt reset to avoid BUSY/LOCKED errors in\n subsequent queries), stmt finalization on db close, etc.\n\n* HOFs like iter, fold, transaction\n\n* support for different concurrency models: everything is functorized over a\n THREAD monad, so you can for instance do concurrent folds/iters with Lwt\n\n* support for SQL stmt syntax checks and some extra semantic checking (column\n names, etc)"; categories = []; - conf_type = (`Configure, "internal", Some "0.2"); + 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.2"); + 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.2"); + install_type = (`Install, "internal", Some "0.3"); install_custom = { pre_command = [(OASISExpr.EBool true, None)]; @@ -5014,21 +5267,33 @@ files_ab = []; sections = [ - SrcRepo + Doc ({ - cs_name = "github"; + cs_name = "sqlexpr"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { - src_repo_type = Git; - src_repo_location = - "git://github.com/mfp/ocaml-sqlexpr.git"; - src_repo_browser = None; - src_repo_module = None; - src_repo_branch = None; - src_repo_tag = None; - src_repo_subdir = None; + doc_type = (`Doc, "ocamlbuild", Some "0.3"); + doc_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + doc_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "docs", true) + ]; + doc_install = [(OASISExpr.EBool true, true)]; + doc_install_dir = "$htmldir/sqlexpr"; + doc_title = "API reference for Sqlexpr"; + doc_authors = []; + doc_abstract = None; + doc_format = OtherDoc; + doc_data_files = []; + doc_build_tools = + [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"]; }); Library ({ @@ -5059,35 +5324,12 @@ }, { lib_modules = ["Pa_sql"]; + lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "sqlexpr"; lib_findlib_name = Some "syntax"; lib_findlib_containers = []; }); - Doc - ({ - cs_name = "sqlexpr"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - doc_type = (`Doc, "ocamlbuild", Some "0.2"); - doc_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - doc_build = [(OASISExpr.EBool true, true)]; - doc_install = [(OASISExpr.EBool true, true)]; - doc_install_dir = "$htmldir/sqlexpr"; - doc_title = "API reference for Sqlexpr"; - doc_authors = []; - doc_abstract = None; - doc_format = OtherDoc; - doc_data_files = []; - doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"]; - }); Library ({ cs_name = "sqlexpr"; @@ -5132,21 +5374,43 @@ "Sqlexpr_sqlite"; "Sqlexpr_sqlite_lwt" ]; + lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = []; + }); + SrcRepo + ({ + cs_name = "github"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + src_repo_type = Git; + src_repo_location = + "git://github.com/mfp/ocaml-sqlexpr.git"; + src_repo_browser = None; + src_repo_module = None; + src_repo_branch = None; + src_repo_tag = None; + src_repo_subdir = None; }) ]; plugins = - [(`Extra, "DevFiles", Some "0.2"); (`Extra, "META", Some "0.2")]; + [(`Extra, "DevFiles", Some "0.3"); (`Extra, "META", Some "0.3")]; schema_data = PropList.Data.create (); plugin_data = []; }; - version = "0.2.0"; + oasis_fn = Some "_oasis"; + oasis_version = "0.3.0~rc3"; + oasis_digest = Some "\bG\174\172EN\182VF8\027\012\023k\029_"; + oasis_exec = None; + oasis_setup_args = []; };; let setup () = BaseSetup.setup setup_t;; +# 5415 "setup.ml" (* OASIS_STOP *) let () = setup ();; diff -Nru ocaml-sqlexpr-0.4.1/sqlexpr_concurrency.ml ocaml-sqlexpr-0.5.5/sqlexpr_concurrency.ml --- ocaml-sqlexpr-0.4.1/sqlexpr_concurrency.ml 2011-03-19 17:04:45.000000000 +0000 +++ ocaml-sqlexpr-0.5.5/sqlexpr_concurrency.ml 2013-06-15 18:14:27.000000000 +0000 @@ -1,3 +1,13 @@ + +module type THREAD_LOCAL_STATE = +sig + type 'a t + type 'a key + val new_key : unit -> 'a key + val get : 'a key -> 'a option + val with_value : 'a key -> 'a option -> (unit -> 'b t) -> 'b t +end + module type THREAD = sig type 'a t @@ -13,6 +23,10 @@ val create_recursive_mutex : unit -> mutex val with_lock : mutex -> (unit -> 'a t) -> 'a t + + val register_finaliser : ('a -> unit t) -> 'a -> unit + + include THREAD_LOCAL_STATE with type 'a t := 'a t end module Id = @@ -36,6 +50,16 @@ type mutex = unit let create_recursive_mutex () = () let with_lock () f = f () + + type 'a key = 'a Lwt.key + + let new_key = Lwt.new_key + let get = Lwt.get + let with_value = Lwt.with_value + + let register_finaliser f x = + (* FIXME: should run finalisers sequentially in separate thread *) + Gc.finalise f x end @@ -67,4 +91,7 @@ | Some s -> Lwt_mutex.with_lock m.m (fun () -> Lwt.with_value locks (Some (LOCKS.add m.id s)) f) + + let register_finaliser = Lwt_gc.finalise end + diff -Nru ocaml-sqlexpr-0.4.1/sqlexpr_concurrency.mli ocaml-sqlexpr-0.5.5/sqlexpr_concurrency.mli --- ocaml-sqlexpr-0.4.1/sqlexpr_concurrency.mli 2011-03-19 17:04:45.000000000 +0000 +++ ocaml-sqlexpr-0.5.5/sqlexpr_concurrency.mli 2013-06-15 18:14:27.000000000 +0000 @@ -1,5 +1,15 @@ (** Concurrency monad. *) +(** Thread local state. *) +module type THREAD_LOCAL_STATE = +sig + type 'a t + type 'a key + val new_key : unit -> 'a key + val get : 'a key -> 'a option + val with_value : 'a key -> 'a option -> (unit -> 'b t) -> 'b t +end + (** The THREAD monad. *) module type THREAD = sig @@ -23,15 +33,19 @@ (* [with_lock m f] blocks until the [m] mutex can be locked, runs [f ()] and * unlocks the mutex (also if [f ()] raises an exception) *) val with_lock : mutex -> (unit -> 'a t) -> 'a t + + val register_finaliser : ('a -> unit t) -> 'a -> unit + + include THREAD_LOCAL_STATE with type 'a t := 'a t end (** Identity concurrency monad. Note that [Id.mutex] is a dummy type that * doesn't actually work like a mutex (i.e., [Id.with_lock m f] is equivalent - * to [f ()]. This is so because n ocaml-sqlexpr's context [Sqlite] handles + * to [f ()]. This is so because in ocaml-sqlexpr's context [Sqlite] handles * can only be used from the thread where they were created, so there's no * need for mutual exclusion because trying to use the same handle from * different threads would be an error anyway. *) -module Id : THREAD with type 'a t = 'a +module Id : THREAD with type 'a t = 'a and type 'a key = 'a Lwt.key (** Lwt concurrency monad. *) -module Lwt : THREAD with type 'a t = 'a Lwt.t +module Lwt : THREAD with type 'a t = 'a Lwt.t and type 'a key = 'a Lwt.key diff -Nru ocaml-sqlexpr-0.4.1/sqlexpr_sqlite_lwt.ml ocaml-sqlexpr-0.5.5/sqlexpr_sqlite_lwt.ml --- ocaml-sqlexpr-0.4.1/sqlexpr_sqlite_lwt.ml 2011-03-19 17:04:45.000000000 +0000 +++ ocaml-sqlexpr-0.5.5/sqlexpr_sqlite_lwt.ml 2013-06-15 18:14:27.000000000 +0000 @@ -34,6 +34,7 @@ mutable workers : worker list; free_workers : WSet.t; db_waiters : worker Lwt.u Lwt_sequence.t; + tx_key : unit Lwt.key; } and thread = { @@ -84,6 +85,8 @@ type stmt = worker * Stmt.t type 'a result = 'a Lwt.t + module TLS = Lwt + (* Pool of threads: *) let threads : thread Queue.t = Queue.create () @@ -115,6 +118,8 @@ let n = ref 0 in fun () -> incr n; !n + let transaction_key db = db.tx_key + let open_db ?(init = fun _ -> ()) file = let id = new_id () in let r = @@ -124,9 +129,10 @@ free_workers = WSet.create (); db_waiters = Lwt_sequence.create (); db_finished = false; + tx_key = Lwt.new_key (); } in - Gc.finalise close_db r; + Lwt_gc.finalise (fun db -> close_db db; return ()) r; r let rec thread_loop thread = @@ -261,10 +267,11 @@ | None -> detach worker (fun dbh () -> Sqlite3.errmsg dbh) () in try_lwt return (do_raise_error ?sql ?params ~errmsg errcode) - let rec run ?stmt ?sql ?params worker f x = detach worker f x >>= function + let rec run ?(retry_on_busy = false) ?stmt ?sql ?params worker f x = + detach worker f x >>= function Sqlite3.Rc.OK | Sqlite3.Rc.ROW | Sqlite3.Rc.DONE as r -> return r - | Sqlite3.Rc.BUSY | Sqlite3.Rc.LOCKED -> - Lwt_unix.sleep 0.010 >> run ?sql ?stmt ?params worker f x + | Sqlite3.Rc.BUSY when retry_on_busy -> + Lwt_unix.sleep 0.010 >> run ~retry_on_busy ?sql ?stmt ?params worker f x | code -> lwt errmsg = detach worker (fun dbh () -> Sqlite3.errmsg dbh) () in begin match stmt with @@ -273,8 +280,8 @@ end >> raise_error worker ?sql ?params ~errmsg code - let check_ok ?stmt ?sql ?params worker f x = - lwt _ = run ?stmt ?sql ?params worker f x in return () + let check_ok ?retry_on_busy ?stmt ?sql ?params worker f x = + lwt _ = run ?retry_on_busy ?stmt ?sql ?params worker f x in return () (* Wait for worker to be available, then return it: *) let rec get_worker db = @@ -348,7 +355,10 @@ | None -> return ()) let borrow_worker db f = - let db' = { open_db ~init:db.init_func db.file with max_workers = 1 } in + let db' = + { open_db ~init:db.init_func db.file with max_workers = 1; + tx_key = db.tx_key; + } in lwt worker = get_worker db in add_worker db' { worker with db = db' } ; add_worker db worker; @@ -360,7 +370,10 @@ return () let steal_worker db f = - let db' = { open_db ~init:db.init_func db.file with max_workers = 1 } in + let db' = + { open_db ~init:db.init_func db.file with max_workers = 1; + tx_key = db.tx_key; + } in lwt worker = get_worker db in add_worker db' { worker with db = db' } ; try_lwt @@ -385,10 +398,10 @@ let row_data (worker, stmt) = detach worker (fun _ -> Stmt.row_data) stmt - let unsafe_execute db sql = + let unsafe_execute db ?retry_on_busy sql = lwt worker = get_worker db in try_lwt - check_ok ~sql worker (fun dbh sql -> Sqlite3.exec dbh sql) sql + check_ok ?retry_on_busy ~sql worker (fun dbh sql -> Sqlite3.exec dbh sql) sql finally add_worker db worker; return () diff -Nru ocaml-sqlexpr-0.4.1/sqlexpr_sqlite.ml ocaml-sqlexpr-0.5.5/sqlexpr_sqlite.ml --- ocaml-sqlexpr-0.4.1/sqlexpr_sqlite.ml 2011-03-19 17:04:45.000000000 +0000 +++ ocaml-sqlexpr-0.5.5/sqlexpr_sqlite.ml 2013-06-15 18:14:27.000000000 +0000 @@ -7,6 +7,8 @@ exception Error of string * exn exception Sqlite_error of string * Sqlite3.Rc.t +let tx_id_counter = ref 0 + let curr_thread_id () = Thread.id (Thread.self ()) let raise_thread_error ?msg expected = @@ -183,27 +185,28 @@ let failwithfmt fmt = ksprintf failwith fmt - let error s = - failwithfmt "Sqlexpr_sqlite error: bad data (expected %s)" s + let error s x = + failwithfmt "Sqlexpr_sqlite error: bad data (expected %s but got %s)" + s (Sqlite3.Data.to_string_debug x) let text = function TEXT s | BLOB s -> s | INT n -> Int64.to_string n | FLOAT f -> string_of_float f - | _ -> error "text" + | x -> error "text" x - let blob = function BLOB s | TEXT s -> s | _ -> error "blob" + let blob = function BLOB s | TEXT s -> s | x -> error "blob" x - let int = function INT n -> Int64.to_int n | _ -> error "int" - let int32 = function INT n -> Int64.to_int32 n | _ -> error "int" - let int64 = function INT n -> n | _ -> error "int" + let int = function INT n -> Int64.to_int n | x -> error "int" x + let int32 = function INT n -> Int64.to_int32 n | x -> error "int" x + let int64 = function INT n -> n | x -> error "int" x - let bool = function INT 0L -> false | INT _ -> true | _ -> error "int" + let bool = function INT 0L -> false | INT _ -> true | x -> error "int" x let float = function INT n -> Int64.to_float n | FLOAT n -> n - | _ -> error "float" + | x -> error "float" x let maybe f = function NULL -> None @@ -226,6 +229,12 @@ (Unix.getenv "OCAML_SQLEXPR_PROFILE")) with Not_found -> None +let raw_profile_ch = + try + Some (open_out_gen [Open_append; Open_creat; Open_binary] 0o644 + (Unix.getenv "OCAML_SQLEXPR_LOG")) + with Not_found -> None + let profile_uuid = let uuid = sprintf "%s %d %d %g %s %g" @@ -296,6 +305,16 @@ [ "name"; Digest.to_hex (Digest.string sql); "portal"; " " ] in profile_op "execute" details f + let profile_execute_sql sql ?(full_sql=sql) ?params f = + let param_str = match params with + None -> "" + | Some l -> String.concat "\t" (List.rev_map string_of_param l) + in + Option.may + (fun ch -> fprintf ch "%s\t%s\n%!" (String.escaped full_sql) param_str) + raw_profile_ch; + profile_execute_sql sql ?params f + let profile_prepare_stmt sql f = match profile_ch with None -> f () @@ -308,6 +327,9 @@ module type POOL = sig type 'a result + + module TLS : Sqlexpr_concurrency.THREAD_LOCAL_STATE with type 'a t := 'a result + type db type stmt val open_db : ?init:(Sqlite3.db -> unit) -> string -> db @@ -323,9 +345,12 @@ val raise_error : stmt -> ?sql:string -> ?params:Sqlite3.Data.t list -> ?errmsg:string -> Sqlite3.Rc.t -> 'a result - val unsafe_execute : db -> string -> unit result + + val unsafe_execute : db -> ?retry_on_busy:bool -> string -> unit result val borrow_worker : db -> (db -> 'a result) -> 'a result val steal_worker : db -> (db -> 'a result) -> 'a result + + val transaction_key : db -> unit TLS.key end module WT = Weak.Make(struct @@ -343,7 +368,9 @@ stmt_cache : Stmt_cache.t; } -module IdentityPool(M: THREAD) = +let identity_pool_transaction_key_table = Hashtbl.create 13 + +module IdentityPool(M: THREAD with type 'a key = 'a Lwt.key) = struct module Lwt = M open Lwt @@ -357,6 +384,17 @@ let get_handle db = db.handle + let transaction_key = + let t = identity_pool_transaction_key_table in + (fun db -> + try + Hashtbl.find t db.id + with Not_found -> + let k = M.new_key () in + Hashtbl.add t db.id k; + register_finaliser (fun db -> Hashtbl.remove t db.id; return ()) db; + k) + let handle db = if db.thread_id <> curr_thread_id () then try_lwt (raise_thread_error ~msg:"in IdentityPool.handle" db.thread_id) @@ -387,7 +425,8 @@ with Not_found -> let m = M.create_recursive_mutex () in Hashtbl.add mutex_tbl id m; - Gc.finalise (fun _ -> Hashtbl.remove mutex_tbl id) db; + M.register_finaliser + (fun _ -> Hashtbl.remove mutex_tbl id; return ()) db; m let make handle = @@ -414,17 +453,17 @@ sprintf "%s with params %s" msg (string_of_params (List.rev params)) in M.fail (Error (msg, Sqlite_error (msg, errcode))) - let rec run ?stmt ?sql ?params db f x = match f x with + let rec run ?(retry_on_busy=false) ?stmt ?sql ?params db f x = match f x with Sqlite3.Rc.OK | Sqlite3.Rc.ROW | Sqlite3.Rc.DONE as r -> return r - | Sqlite3.Rc.BUSY | Sqlite3.Rc.LOCKED -> - M.sleep 0.010 >> run ?sql ?stmt ?params db f x + | Sqlite3.Rc.BUSY when retry_on_busy -> + M.sleep 0.010 >> run ~retry_on_busy ?sql ?stmt ?params db f x | code -> let errmsg = Sqlite3.errmsg db in Option.may (fun stmt -> ignore (Stmt.reset stmt)) stmt; raise_error db ?sql ?params ~errmsg code - let check_ok ?stmt ?sql ?params db f x = - lwt _ = run ?stmt ?sql ?params db f x in return () + let check_ok ?retry_on_busy ?stmt ?sql ?params db f x = + lwt _ = run ?retry_on_busy ?stmt ?sql ?params db f x in return () let prepare db f (params, nparams, sql, stmt_id) = lwt dbh = handle db in @@ -466,7 +505,7 @@ iteri (fun n v -> check_ok ~sql ~stmt dbh (Stmt.bind stmt (nparams - n)) v) params >> - profile_execute_sql sql ~params + profile_execute_sql ~full_sql:sql sql ~params (fun () -> try_lwt f stmt sql params @@ -490,12 +529,14 @@ let reset stmt = ignore (Stmt.reset stmt); return () let row_data stmt = return (Stmt.row_data stmt) - let unsafe_execute db sql = + let unsafe_execute db ?retry_on_busy sql = lwt dbh = handle db in - check_ok ~sql dbh (Sqlite3.exec dbh) sql + check_ok ?retry_on_busy ~sql dbh (Sqlite3.exec dbh) sql let raise_error stmt ?sql ?params ?errmsg errcode = raise_error (Stmt.db_handle stmt) ?sql ?params ?errmsg errcode + + module TLS = M end module type S = @@ -533,7 +574,11 @@ val select_one_f : db -> ('a -> 'b result) -> ('c, 'a, 'b result) expression -> 'c val select_one_f_maybe : db -> ('a -> 'b result) -> ('c, 'a, 'b option result) expression -> 'c - val transaction : db -> (db -> 'a result) -> 'a result + + val transaction : + db -> ?kind:[`DEFERRED | `IMMEDIATE | `EXCLUSIVE] -> + (db -> 'a result) -> 'a result + val fold : db -> ('a -> 'b -> 'a result) -> 'a -> ('c, 'b, 'a result) expression -> 'c val iter : db -> ('a -> unit result) -> ('b, 'a, unit result) expression -> 'b @@ -699,32 +744,61 @@ let new_tx_id = let pid = Unix.getpid () in - let n = ref 0 in - fun () -> incr n; sprintf "__sqlexpr_sqlite_tx_%d_%d" pid !n + fun () -> + (* No allocation here, so cannot have a context change until the + * sprintf, at least in native code. *) + let n = !tx_id_counter in + incr tx_id_counter; + if !tx_id_counter < 0 then tx_id_counter := 0; + sprintf "__sqlexpr_sqlite_tx_%d_%d" pid n - let unsafe_execute db fmt = - ksprintf (POOL.unsafe_execute db) fmt + let unsafe_execute db ?retry_on_busy fmt = + ksprintf (POOL.unsafe_execute db ?retry_on_busy) fmt - let unsafe_execute_prof text db fmt = + let unsafe_execute_prof text db ?retry_on_busy fmt = ksprintf (fun sql -> profile_prepare_stmt text (fun () -> return ()) >> - profile_execute_sql text (fun () -> POOL.unsafe_execute db sql)) + profile_execute_sql ~full_sql:sql text (fun () -> POOL.unsafe_execute db ?retry_on_busy sql)) fmt - let transaction db f = + (* wrap in BEGIN/COMMIT only for outermost txs *) + let outer_transaction_wrap ~kind f db = + match POOL.TLS.get (POOL.transaction_key db) with + Some _ -> f db + | None -> + let tx_kind = match kind with + `DEFERRED -> "DEFERRED" + | `IMMEDIATE -> "IMMEDIATE" + | `EXCLUSIVE -> "EXCLUSIVE" + in + unsafe_execute_prof ~retry_on_busy:true "BEGIN" db "BEGIN %s" tx_kind >> + match_lwt + try_lwt + lwt x = POOL.TLS.with_value + (POOL.transaction_key db) (Some ()) (fun () -> f db) + in + return (`OK x) + with exn -> return (`EXN exn) + with + | `OK x -> unsafe_execute_prof ~retry_on_busy:true + "COMMIT" db "COMMIT" >> return x + | `EXN exn -> unsafe_execute_prof "ROLLBACK" db "ROLLBACK" >> fail exn + + let transaction db ?(kind = `DEFERRED) f = let txid = new_tx_id () in POOL.steal_worker db - (fun db -> - unsafe_execute db "SAVEPOINT %s" txid >> + (outer_transaction_wrap ~kind begin fun db -> + unsafe_execute_prof "SAVEPOINT" db "SAVEPOINT %s" txid >> try_lwt lwt x = f db in unsafe_execute_prof "RELEASE" db "RELEASE %s" txid >> return x with e -> unsafe_execute_prof "ROLLBACK" db "ROLLBACK TO %s" txid >> - unsafe_execute db "RELEASE %s" txid >> - fail e) + unsafe_execute_prof "RELEASE" db "RELEASE %s" txid >> + fail e + end) let fold db f init expr = do_select @@ -765,7 +839,7 @@ expr.statement end -module Make(M : THREAD) = struct +module Make(M : THREAD with type 'a key = 'a Lwt.key) = struct module Id = IdentityPool(M) include Make_gen(M)(Id) let make = Id.make diff -Nru ocaml-sqlexpr-0.4.1/sqlexpr_sqlite.mli ocaml-sqlexpr-0.5.5/sqlexpr_sqlite.mli --- ocaml-sqlexpr-0.4.1/sqlexpr_sqlite.mli 2011-03-19 17:04:45.000000000 +0000 +++ ocaml-sqlexpr-0.5.5/sqlexpr_sqlite.mli 2013-06-15 18:14:27.000000000 +0000 @@ -118,8 +118,23 @@ (** Run the provided function in a DB transaction. A rollback is performed if an exception is raised inside the transaction. - The worker is used exclusively by only one thread per instantiated module - (see {!steal_worker}). + If the BEGIN or COMMIT SQL statements from the outermost transaction fail + with [SQLITE_BUSY], they will be retried until they can be executed. + A [SQLITE_BUSY] (or any other) error code in any other operation inside + a transaction will result in an [Error (_, Sqlite_error (code, _))] + exception being thrown, and a rollback performed. + + One consequence of this is that concurrency control is very simple if + you use [`EXCLUSIVE] transactions: the code can be written + straightforwardly as [S.transaction db (fun db -> ...)], and their + execution will be serialized (across both threads and processes). + Note that, for [`IMMEDIATE] and [`DEFERRED] transactions, you will + have to retry manually if an + [Error (_, Sqlite_error (Sqlite3.Rc.Busy, _))] is raised. + + All SQL operations performed within a transaction will use the same + worker. This worker is used exclusively by only one thread per + instantiated module (see {!steal_worker}). That is, given {[ module S1 = Sqlexpr_sqlite.Make(Sqlexpr_concurrency.Id) @@ -127,8 +142,13 @@ let db = S1.open_db somefile ]} there is no exclusion between functions from [S1] and those from [S2]. + + @param kind transaction kind, only meaningful for outermost transaction + (default [`DEFERRED]) *) - val transaction : db -> (db -> 'a result) -> 'a result + val transaction : + db -> ?kind:[`DEFERRED | `IMMEDIATE | `EXCLUSIVE] -> + (db -> 'a result) -> 'a result (** [fold db f a expr ...] is [f (... (f (f a r1) r2) ...) rN] @@ -188,7 +208,7 @@ (** [db] type shared by single-worker ("identity pool") {!S} implementations. *) type single_worker_db -module Make : functor (M : Sqlexpr_concurrency.THREAD) -> +module Make : functor (M : Sqlexpr_concurrency.THREAD with type 'a key = 'a Lwt.key) -> sig include S with type 'a result = 'a M.t and type db = single_worker_db @@ -201,6 +221,9 @@ module type POOL = sig type 'a result + + module TLS : Sqlexpr_concurrency.THREAD_LOCAL_STATE with type 'a t := 'a result + type db type stmt val open_db : ?init:(Sqlite3.db -> unit) -> string -> db @@ -216,9 +239,11 @@ val raise_error : stmt -> ?sql:string -> ?params:Sqlite3.Data.t list -> ?errmsg:string -> Sqlite3.Rc.t -> 'a result - val unsafe_execute : db -> string -> unit result + val unsafe_execute : db -> ?retry_on_busy:bool -> string -> unit result val borrow_worker : db -> (db -> 'a result) -> 'a result val steal_worker : db -> (db -> 'a result) -> 'a result + + val transaction_key : db -> unit TLS.key end module Make_gen : @@ -255,7 +280,8 @@ module Profile : functor (M : Sqlexpr_concurrency.THREAD) -> sig val profile_execute_sql : - string -> ?params:Sqlite3.Data.t list -> (unit -> 'b M.t) -> 'b M.t + string -> ?full_sql:string -> ?params:Sqlite3.Data.t list -> + (unit -> 'b M.t) -> 'b M.t val profile_prepare_stmt : string -> (unit -> 'a M.t) -> 'a M.t end diff -Nru ocaml-sqlexpr-0.4.1/_tags ocaml-sqlexpr-0.5.5/_tags --- ocaml-sqlexpr-0.4.1/_tags 2011-03-19 17:04:45.000000000 +0000 +++ ocaml-sqlexpr-0.5.5/_tags 2013-06-15 18:14:27.000000000 +0000 @@ -1,11 +1,26 @@ <**/*.ml>: syntax_camlp4o # OASIS_START -# DO NOT EDIT (digest: d037109b1814e37f0bda2729d44d608c) +# DO NOT EDIT (digest: dfffe6ec960f8ff3b4403d34c7548c58) +# 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 sqlexpr_syntax +"sqlexpr_syntax.cmxs": use_sqlexpr_syntax <*.ml{,i}>: pkg_camlp4.quotations.r <*.ml{,i}>: pkg_camlp4.lib # Library sqlexpr +"sqlexpr.cmxs": use_sqlexpr <*.ml{,i}>: pkg_unix <*.ml{,i}>: pkg_threads <*.ml{,i}>: pkg_sqlite3 diff -Nru ocaml-sqlexpr-0.4.1/t_sqlexpr_sqlite.ml ocaml-sqlexpr-0.5.5/t_sqlexpr_sqlite.ml --- ocaml-sqlexpr-0.4.1/t_sqlexpr_sqlite.ml 2011-03-19 17:04:45.000000000 +0000 +++ ocaml-sqlexpr-0.5.5/t_sqlexpr_sqlite.ml 2013-06-15 18:14:27.000000000 +0000 @@ -188,6 +188,30 @@ get_rows db >|= aeq [1, "foo"]; end () + let test_retry_begin () = + + let count_rows db = + S.select_one db sqlc"SELECT @d{COUNT(*)} FROM foo" in + + let insert v db = + (* SELECT acquires a SHARED lock if needed *) + lwt _ = count_rows db in + Lwt.sleep 0.010 >> + (* RESERVED lock acquired if needed *) + S.insert db sqlc"INSERT INTO foo VALUES(%d)" v in + + let fname = Filename.temp_file "t_sqlexpr_sqlite_excl_retry" "" in + let db1 = S.open_db fname in + let db2 = S.open_db fname in + + S.execute db1 sqlc"CREATE TABLE foo(id INTEGER PRIMARY KEY)" >> + (* these 2 TXs are serialized because they are EXCLUSIVE *) + lwt _ = S.transaction ~kind:`EXCLUSIVE db1 (insert 1) + and _ = S.transaction ~kind:`EXCLUSIVE db2 (insert 2) in + lwt n = count_rows db1 in + aeq_int ~msg:"number of rows inserted" 2 n; + return () + let test_fold_and_iter () = with_db begin fun db () -> S.execute db sql"CREATE TABLE foo(n INTEGER NOT NULL)" >> @@ -274,6 +298,7 @@ "Outputs" >::: test_outputs; "Directives in output exprs" >:: test_oexpr_directives; "Transactions" >:: test_transaction; + "Auto-retry BEGIN" >:: test_retry_begin; "Fold and iter" >:: test_fold_and_iter; "Nested fold and iter" >:: test_nested_iter_and_fold; "Borrow worker" >:: test_borrow_worker has_real_borrow_worker;