From e4bc44a25ef298d06ee6ec1e68340f2dbcd59f88 Mon Sep 17 00:00:00 2001 From: Gerd Stolpmann Date: Fri, 20 Mar 2020 14:43:16 +0000 Subject: [PATCH 01/17] detect the availablity of automatic library linking in core ocaml --- configure | 2 +- findlib.files | 1 + src/findlib/Makefile | 7 ++++--- src/findlib/frontend.ml | 20 ++++++++++---------- 4 files changed, 16 insertions(+), 14 deletions(-) diff --git a/configure b/configure index 64656f2..bb7b8ec 100755 --- a/configure +++ b/configure @@ -614,7 +614,7 @@ printf "Detecting compiler arguments: " ( cd tools/extract_args && make ) >ocargs.log 2>&1 if [ "$?" -eq 0 ]; then printf "(extractor built) " - tools/extract_args/extract_args -o src/findlib/ocaml_args.ml ocamlc ocamlcp ocamloptp ocamlmklib ocamlmktop ocamlopt ocamldep ocamldoc >>ocargs.log 2>&1 + tools/extract_args/extract_args -o src/findlib/fl_ocaml_args.ml ocamlc ocamlcp ocamloptp ocamlmklib ocamlmktop ocamlopt ocamldep ocamldoc >>ocargs.log 2>&1 # ocamlbrowser does not work! if [ $? -eq 0 ]; then echo "ok" diff --git a/findlib.files b/findlib.files index ff55c5c..03efeb0 100644 --- a/findlib.files +++ b/findlib.files @@ -122,6 +122,7 @@ f src/findlib/topfind.ml.in x src/findlib/fl_meta.ml x src/findlib/findlib_config.ml x src/findlib/ocaml_args.ml +x src/findlib/fl_ocaml_args.ml x src/findlib/topfind.ml p src/findlib/.*\.ml p src/findlib/.*\.mli diff --git a/src/findlib/Makefile b/src/findlib/Makefile index 6ec8a71..1ff6c8d 100644 --- a/src/findlib/Makefile +++ b/src/findlib/Makefile @@ -21,7 +21,8 @@ OCAMLLEX = ocamllex #CAMLP4O = camlp4 pa_o.cmo pa_op.cmo pr_dump.cmo -- -OBJECTS = findlib_config.cmo fl_split.cmo fl_metatoken.cmo fl_meta.cmo \ +OBJECTS = fl_ocaml_args.cmo findlib_config.cmo fl_split.cmo \ + fl_metatoken.cmo fl_meta.cmo \ fl_metascanner.cmo fl_topo.cmo fl_package_base.cmo \ findlib.cmo fl_args.cmo fl_lint.cmo TOBJECTS = topfind.cmo @@ -29,8 +30,8 @@ TOBJECTS = topfind.cmo XOBJECTS = $(OBJECTS:.cmo=.cmx) TXOBJECTS = topfind.cmx -OCAMLFIND_OBJECTS = ocaml_args.cmo frontend.cmo -OCAMLFIND_XOBJECTS = ocaml_args.cmx frontend.cmx +OCAMLFIND_OBJECTS = frontend.cmo +OCAMLFIND_XOBJECTS = frontend.cmx NUMTOP_OBJECTS = num_top_printers.cmo num_top.cmo diff --git a/src/findlib/frontend.ml b/src/findlib/frontend.ml index db724cf..eee21e5 100644 --- a/src/findlib/frontend.ml +++ b/src/findlib/frontend.ml @@ -963,12 +963,12 @@ let ocamlc which () = let native_spec_opt = match which with - | "ocamlc" -> Ocaml_args.ocamlc_spec - | "ocamlcp" -> Ocaml_args.ocamlcp_spec - | "ocamlmklib" -> Ocaml_args.ocamlmklib_spec - | "ocamlmktop" -> Ocaml_args.ocamlmktop_spec - | "ocamlopt" -> Ocaml_args.ocamlopt_spec - | "ocamloptp" -> Ocaml_args.ocamloptp_spec + | "ocamlc" -> Fl_ocaml_args.ocamlc_spec + | "ocamlcp" -> Fl_ocaml_args.ocamlcp_spec + | "ocamlmklib" -> Fl_ocaml_args.ocamlmklib_spec + | "ocamlmktop" -> Fl_ocaml_args.ocamlmktop_spec + | "ocamlopt" -> Fl_ocaml_args.ocamlopt_spec + | "ocamloptp" -> Fl_ocaml_args.ocamloptp_spec | _ -> None in let native_spec = match native_spec_opt with @@ -1430,7 +1430,7 @@ let ocamldoc() = let options = ref [] in let native_spec = - match Ocaml_args.ocamldoc_spec with + match Fl_ocaml_args.ocamldoc_spec with | None -> failwith "Not supported in your configuration: ocamldoc" | Some s -> s in @@ -1636,7 +1636,7 @@ let ocamldep () = Arg.String (fun s -> packages := !packages @ (Fl_split.in_words s)) in let native_spec = - match Ocaml_args.ocamldep_spec with + match Fl_ocaml_args.ocamldep_spec with | None -> failwith "Not supported in your configuration: ocamldep" | Some s -> s in @@ -2631,9 +2631,9 @@ let main() = prerr_endline " or: ocamlfind ocamlcp [-help | other options] ..."; prerr_endline " or: ocamlfind ocamlmklib [-help | other options] ..."; prerr_endline " or: ocamlfind ocamlmktop [-help | other options] ..."; - if Ocaml_args.ocamlopt_spec <> None then + if Fl_ocaml_args.ocamlopt_spec <> None then prerr_endline " or: ocamlfind ocamlopt [-help | other options] ..."; - if Ocaml_args.ocamloptp_spec <> None then + if Fl_ocaml_args.ocamloptp_spec <> None then prerr_endline " or: ocamlfind ocamloptp [-help | other options] ..."; prerr_endline " or: ocamlfind ocamldep [-help | other options] ..."; prerr_endline " or: ocamlfind ocamlbrowser [-help | other options]"; From 7096d3a96606413de281e01869202c1aefbf97a9 Mon Sep 17 00:00:00 2001 From: Gerd Stolpmann Date: Fri, 20 Mar 2020 15:09:23 +0000 Subject: [PATCH 02/17] missing code --- src/findlib/findlib_config.mlp | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/findlib/findlib_config.mlp b/src/findlib/findlib_config.mlp index 64b4840..c05ea28 100644 --- a/src/findlib/findlib_config.mlp +++ b/src/findlib/findlib_config.mlp @@ -11,6 +11,11 @@ let ocaml_ldconf = Filename.concat ocaml_stdlib "ld.conf";; let ocaml_has_autolinking = @AUTOLINK@;; +let ocaml_has_autoliblinking = + match Fl_ocaml_args.ocamlc_spec with + | None -> false + | Some spec -> List.exists (fun (n,_,_) -> n = "-require") spec;; + let libexec_name = "stublibs";; let system = "@SYSTEM@";; From b568aeeb674049b41d8e97ea3adaee7bf2b4353f Mon Sep 17 00:00:00 2001 From: Gerd Stolpmann Date: Fri, 20 Mar 2020 23:19:39 +0000 Subject: [PATCH 03/17] added some basic scanning of bare packages that lack a META file, and some integration into findlib by emulating a META file --- doc/README.xml | 8 +++ src/findlib/Makefile | 15 ++-- src/findlib/findlib.ml | 4 +- src/findlib/findlib.mli | 2 +- src/findlib/fl_package_base.ml | 124 +++++++++++++++++++++++--------- src/findlib/fl_package_base.mli | 14 +++- src/findlib/frontend.ml | 39 ++++++++-- 7 files changed, 156 insertions(+), 50 deletions(-) diff --git a/doc/README.xml b/doc/README.xml index 3ab0886..0da7ebd 100644 --- a/doc/README.xml +++ b/doc/README.xml @@ -109,6 +109,14 @@ configuration files, and library routines in detail.

List of Changes
    +
  • +

    2.0+DEV: Adapted to automatic library linking, as + available in ocaml-XXX. Now, using META files is optional if + certain conventions are followed. This implies the following + list of detailed changes:

    +

    Replaced Findlib.package_meta by Findlib.package_path.

    +
    • +

  • 1.8.1: Adapted to upcoming ocaml-4.09.

    New API Findlib.list_packages' can specify a package prefix.

    diff --git a/src/findlib/Makefile b/src/findlib/Makefile index 1ff6c8d..0da86cd 100644 --- a/src/findlib/Makefile +++ b/src/findlib/Makefile @@ -23,7 +23,8 @@ OCAMLLEX = ocamllex OBJECTS = fl_ocaml_args.cmo findlib_config.cmo fl_split.cmo \ fl_metatoken.cmo fl_meta.cmo \ - fl_metascanner.cmo fl_topo.cmo fl_package_base.cmo \ + fl_metascanner.cmo fl_barescanner.cmo \ + fl_topo.cmo fl_package_base.cmo \ findlib.cmo fl_args.cmo fl_lint.cmo TOBJECTS = topfind.cmo @@ -48,11 +49,15 @@ opt: ocamlfind_opt$(EXEC_SUFFIX) findlib.cmxa findlib_top.cmxa topfind \ num-top: num_top.cma ocamlfind$(EXEC_SUFFIX): findlib.cma $(OCAMLFIND_OBJECTS) - $(OCAMLC) $(CUSTOM) -o ocamlfind$(EXEC_SUFFIX) -g findlib.cma unix.cma \ + $(OCAMLC) $(CUSTOM) -o ocamlfind$(EXEC_SUFFIX) -g -I +compiler-libs \ + ocamlcommon.cma ocamlbytecomp.cma ocamloptcomp.cma \ + findlib.cma unix.cma \ $(OCAMLC_FLAGS) $(OCAMLFIND_OBJECTS) ocamlfind_opt$(EXEC_SUFFIX): findlib.cmxa $(OCAMLFIND_XOBJECTS) - $(OCAMLOPT) -o ocamlfind_opt$(EXEC_SUFFIX) findlib.cmxa unix.cmxa \ + $(OCAMLOPT) -o ocamlfind_opt$(EXEC_SUFFIX) -I +compiler-libs \ + ocamlcommon.cmxa ocamlbytecomp.cmxa ocamloptcomp.cmxa \ + findlib.cmxa unix.cmxa \ $(OCAMLOPT_FLAGS) $(OCAMLFIND_XOBJECTS) test_parser$(EXEC_SUFFIX): fl_metascanner.cmx test_parser.cmx fl_metatoken.cmx fl_meta.cmx @@ -160,10 +165,10 @@ depend: *.ml *.mli fl_meta.ml fl_metascanner.ml findlib_config.ml topfind.ml $(OCAMLOPT) $(OPAQUE) -thread -c -impl $< .ml.cmx: - $(OCAMLOPT) $(OPAQUE) -c $< + $(OCAMLOPT) $(OPAQUE) -I +compiler-libs -c $< .ml.cmo: - $(OCAMLC) $(OPAQUE) -g -c $< + $(OCAMLC) $(OPAQUE) -I +compiler-libs -g -c $< .mli.cmi: $(OCAMLC) $(OPAQUE) -c $< diff --git a/src/findlib/findlib.ml b/src/findlib/findlib.ml index dc9b2b4..94052fd 100644 --- a/src/findlib/findlib.ml +++ b/src/findlib/findlib.ml @@ -365,9 +365,9 @@ let package_directory pkg = ;; -let package_meta_file pkg = +let package_path pkg = lazy_init(); - (Fl_package_base.query pkg).Fl_package_base.package_meta + (Fl_package_base.query pkg).Fl_package_base.package_path ;; diff --git a/src/findlib/findlib.mli b/src/findlib/findlib.mli index b6073fa..efc8ad5 100644 --- a/src/findlib/findlib.mli +++ b/src/findlib/findlib.mli @@ -149,7 +149,7 @@ val package_directory : string -> string * Raises [No_such_package] if the package cannot be found. *) -val package_meta_file : string -> string +val package_path : string -> Fl_package_base.package_path (** Get the absolute path of the META file of the given package *) val ignore_dups_in : unit -> string list diff --git a/src/findlib/fl_package_base.ml b/src/findlib/fl_package_base.ml index aac6070..3919123 100644 --- a/src/findlib/fl_package_base.ml +++ b/src/findlib/fl_package_base.ml @@ -8,10 +8,14 @@ open Fl_metascanner exception No_such_package of string * string (* (name, reason) *) +type package_path = + | Pkg_with_META of string + | Pkg_bare of string + type package = { package_name : string; package_dir : string; - package_meta : string; + package_path : package_path; package_defs : Fl_metascanner.pkg_definition list; package_priv : package_priv } @@ -65,6 +69,12 @@ let init path stdlib ignore_dups_in = conf_ignore_dups_in := ignore_dups_in ;; +let dir_of_type = + function + | Pkg_with_META f -> + Filename.dirname f + | Pkg_bare dir -> + dir let packages_in_meta_file ?(directory_required = false) ~name:package_name ~dir:package_dir ~meta_file () = @@ -122,7 +132,7 @@ let packages_in_meta_file ?(directory_required = false) let p = { package_name = p_name; package_dir = d'; - package_meta = meta_file; + package_path = Pkg_with_META meta_file; package_defs = pkg_expr.pkg_defs; package_priv = { missing_reqs = [] } } in @@ -162,6 +172,20 @@ let packages_in_meta_file ?(directory_required = false) raise any ;; +let packages_in_bare_dir ~name:package_name ~dir:package_dir () = + let rec flatten_bare_pkg p = + p :: (List.map flatten_bare_pkg Fl_barescanner.(p.bare_children) + |> List.flatten) in + let as_package p = + { package_name = Fl_barescanner.(p.bare_name); + package_dir = Fl_barescanner.(p.bare_directory); + package_path = Pkg_bare Fl_barescanner.(p.bare_directory); + package_defs = Fl_barescanner.to_pkg_definition p; + package_priv = { missing_reqs = [] } + } in + Fl_barescanner.scan_bare_pkg package_name package_dir + |> flatten_bare_pkg + |> List.map as_package let query package_name = @@ -169,19 +193,28 @@ let query package_name = if package_name_comps = [] then invalid_arg "Fl_package_base.query"; let main_name = List.hd package_name_comps in - let process_file_and_lookup ?directory_required package_dir meta_file = + let lookup packages = + try + List.find + (fun p -> p.package_name = package_name) + packages + with + Not_found -> + raise (No_such_package (package_name, "")) in + + let process_meta_file_and_lookup ?directory_required package_dir meta_file = let packages = packages_in_meta_file ?directory_required ~name:main_name ~dir:package_dir ~meta_file () in - let p = - ( try - List.find - (fun p -> p.package_name = package_name) - packages - with - Not_found -> - raise (No_such_package (package_name, "")) - ) in + let p = lookup packages in + List.iter (Fl_metastore.add store) packages; + p + in + + let process_bare_dir_and_lookup main_name package_dir = + let packages = + packages_in_bare_dir ~name:main_name ~dir:package_dir () in + let p = lookup packages in List.iter (Fl_metastore.add store) packages; p in @@ -194,15 +227,18 @@ let query package_name = let meta_file_1 = Filename.concat package_dir "META" in let meta_file_2 = Filename.concat dir ("META." ^ main_name) in if Sys.file_exists meta_file_1 then - process_file_and_lookup package_dir meta_file_1 + process_meta_file_and_lookup package_dir meta_file_1 else if Sys.file_exists meta_file_2 then - process_file_and_lookup ~directory_required:true dir meta_file_2 + process_meta_file_and_lookup ~directory_required:true dir meta_file_2 (* Note: It is allowed to have relative "directory" directives. * The base directory is [dir] in this case. *) - else - run_ocamlpath path' + else + if Fl_barescanner.is_bare_pkg package_dir then + process_bare_dir_and_lookup main_name package_dir + else + run_ocamlpath path' in try @@ -436,12 +472,16 @@ let package_definitions ~search_path package_name = let meta_file_1 = Filename.concat package_dir "META" in let meta_file_2 = Filename.concat dir ("META." ^ main_name) in if Sys.file_exists meta_file_1 then - meta_file_1 :: run_ocamlpath path' + Pkg_with_META meta_file_1 :: run_ocamlpath path' else - if Sys.file_exists meta_file_2 then - meta_file_2 :: run_ocamlpath path' - else - run_ocamlpath path' + if Sys.file_exists meta_file_2 then + Pkg_with_META meta_file_2 :: run_ocamlpath path' + else + if Fl_barescanner.is_bare_pkg dir then + let bare = Fl_barescanner.scan_bare_pkg main_name dir in + Pkg_bare Fl_barescanner.(bare.bare_directory) :: run_ocamlpath path' + else + run_ocamlpath path' in run_ocamlpath search_path ;; @@ -512,10 +552,11 @@ let package_conflict_report_1 identify_dir () = [] | [_] -> () - | _ -> + | _ -> + let names = List.map dir_of_type c in Printf.eprintf "findlib: [WARNING] Package %s has multiple definitions in %s\n" pkg.package_name - (String.concat ", " c) + (String.concat ", " names) ) | _ -> () @@ -551,7 +592,7 @@ let load_base ?prefix () = [] in - let process_file ?directory_required main_name package_dir meta_file = + let process_meta_file ?directory_required main_name package_dir meta_file = try let _ = Fl_metastore.find store main_name in (* Note: If the main package is already loaded into the graph, we @@ -561,16 +602,31 @@ let load_base ?prefix () = with Not_found -> let packages = - try - packages_in_meta_file - ?directory_required ~name:main_name ~dir:package_dir ~meta_file () - with + try + packages_in_meta_file + ?directory_required ~name:main_name ~dir:package_dir ~meta_file () + with Failure s -> prerr_endline ("findlib: [WARNING] " ^ s); [] in List.iter (Fl_metastore.add store) packages; - (* Nothing evil can happen! *) - in + (* Nothing evil can happen! *) in + + let process_bare_dir main_name package_dir = + try + let _ = Fl_metastore.find store main_name in () + with + | Not_found -> + let packages = + try + packages_in_bare_dir ~name:main_name ~dir:package_dir () + with + Failure s -> + prerr_endline ("findlib: [WARNING] " ^ s); [] + in + List.iter (Fl_metastore.add store) packages; + (* Nothing evil can happen! *) in + let rec run_ocamlpath path = match path with @@ -585,7 +641,7 @@ let load_base ?prefix () = let package_dir = Filename.concat dir f in let meta_file_1 = Filename.concat package_dir "META" in if Sys.file_exists meta_file_1 then - process_file f package_dir meta_file_1 + process_meta_file f package_dir meta_file_1 else (* If f is META.pkgname: Add package pkgname *) (* We skip over filenames ending in '~' *) @@ -593,8 +649,10 @@ let load_base ?prefix () = String.sub f (String.length f - 1) 1 <> "~" then begin let name = String.sub f 5 (String.length f - 5) in let meta_file_2 = Filename.concat dir f in - process_file ~directory_required:true name dir meta_file_2 - end; + process_meta_file ~directory_required:true name dir meta_file_2 + end else + if Fl_barescanner.is_bare_pkg package_dir then + process_bare_dir f package_dir ) files; run_ocamlpath path' diff --git a/src/findlib/fl_package_base.mli b/src/findlib/fl_package_base.mli index 3e54b8a..965b2b2 100644 --- a/src/findlib/fl_package_base.mli +++ b/src/findlib/fl_package_base.mli @@ -5,6 +5,10 @@ (** Direct access to the package graph and package files *) +type package_path = + | Pkg_with_META of string (** absolute path of META file *) + | Pkg_bare of string (** directory of package *) + type package = { package_name : string; (** The fully qualified package name, i.e. for subpackages the @@ -13,7 +17,7 @@ type package = *) package_dir : string; (** The directory where to lookup package files *) - package_meta : string; + package_path : package_path; (** The path to the META file *) package_defs : Fl_metascanner.pkg_definition list; (** The definitions in the META file *) @@ -171,7 +175,13 @@ val packages_in_meta_file : * the function will fail. *) -val package_definitions : search_path:string list -> string -> string list +val packages_in_bare_dir : + name:string -> dir:string -> unit -> package list + (** Scans the directory [dir] for bare packages [name], plus + sub packages. + *) + +val package_definitions : search_path:string list -> string -> package_path list (** Return all META files defining this package that occur in the * directories mentioned in [search_path]. The package name must be * fully-qualified. For simplicity, however, only the name of the main diff --git a/src/findlib/frontend.ml b/src/findlib/frontend.ml index eee21e5..ed39fff 100644 --- a/src/findlib/frontend.ml +++ b/src/findlib/frontend.ml @@ -73,6 +73,10 @@ let out_path ?(prefix="") s = | _ -> prefix ^ slashify s +let out_ppath ?prefix = + function + | Fl_package_base.Pkg_with_META m -> out_path ?prefix m + | Fl_package_base.Pkg_bare d -> out_path ?prefix d let percent_subst ?base spec lookup s = @@ -682,7 +686,7 @@ let expand predicates eff_packages format = (* format: * %p package name * %d package directory - * %m META file + * %m META file (or dir of bare package) * %D description * %v version * %a archive file(s) @@ -699,7 +703,7 @@ let expand predicates eff_packages format = let spec = [ "%p", [pkg]; "%d", [out_path dir]; - "%m", [out_path (package_meta_file pkg)]; + "%m", [out_ppath (package_path pkg)]; "%D", [try package_property predicates pkg "description" with Not_found -> "[n/a]"]; "%v", [try package_property predicates pkg "version" @@ -970,16 +974,23 @@ let ocamlc which () = | "ocamlopt" -> Fl_ocaml_args.ocamlopt_spec | "ocamloptp" -> Fl_ocaml_args.ocamloptp_spec | _ -> None in + let native_excludes = + [ "-require" ] in let native_spec = match native_spec_opt with | None -> failwith ("Not supported in your configuration: " ^ which) - | Some s -> s in + | Some s -> + List.filter + (fun (name,_,_) -> not (List.mem name native_excludes)) + s in let arg_spec = List.flatten [ [ "-package", add_pkg, " Refer to package when compiling"; + "-require", add_pkg, + " Same as -package"; "-linkpkg", Arg.Set linkpkg, " Link the packages in"; "-predicates", add_pred, @@ -1392,6 +1403,10 @@ let ocamlc which () = i_options @ (* Generated -I options from package analysis *) pp_command @ (* Optional preprocessor command *) ppx_commands @ (* Optional ppx extension commands *) + (if !linkpkg && Findlib_config.ocaml_has_autoliblinking then + [ "-noautoliblink" ] + else + []) @ (if !linkpkg then l_options else []) @ (* Generated -ccopt -L options *) (if !linkpkg then archives else []) @ (* Gen file names to link *) pass_files' @ (* File names from cmd line *) @@ -1434,15 +1449,21 @@ let ocamldoc() = | None -> failwith "Not supported in your configuration: ocamldoc" | Some s -> s in + let add_pkg s = + packages := !packages @ Fl_split.in_words s in + parse_args ~align:false ( Arg.align [ "-package", - Arg.String (fun s -> - packages := !packages @ Fl_split.in_words s), + Arg.String add_pkg, " Add this package to the search path"; - "-predicates", + "-require", + Arg.String add_pkg, + " Same as -package"; + + "-predicates", Arg.String (fun s -> predicates := !predicates @ Fl_split.in_words s), "

    Add predicate

    when calculating dependencies"; @@ -1646,6 +1667,8 @@ let ocamldep () = "

    Use preprocessor with predicate

    "; "-package", add_pkg, "

    Add preprocessor package

    "; + "-require", add_pkg, + " Same as -package"; "-predicates", add_pred, "

    Add predicate

    when calculating dependencies"; "-ppopt", add_pp_opt, @@ -1763,7 +1786,9 @@ let ocamlbrowser () = "-all", Arg.Set add_all, " Add all packages to include path"; "-package", add_pkg, - "

    Add package

    to include path"; + "

    Add package

    to include path"; + "-require", add_pkg, + " Same as -package"; "-passopt", Arg.String (fun s -> pass_options := !pass_options @ [s]), " Pass option directly to ocamlbrowser"; "-passrest", Arg.Rest (fun s -> pass_options := !pass_options @ [s]), From 85c8ea5d3ea2696f458f7b8bd6b5c8066149b9b8 Mon Sep 17 00:00:00 2001 From: Gerd Stolpmann Date: Wed, 29 Apr 2020 09:39:45 +0000 Subject: [PATCH 04/17] add missing files --- src/findlib/fl_barescanner.ml | 157 +++++++++++++++++++++++++++++++++ src/findlib/fl_barescanner.mli | 41 +++++++++ 2 files changed, 198 insertions(+) create mode 100644 src/findlib/fl_barescanner.ml create mode 100644 src/findlib/fl_barescanner.mli diff --git a/src/findlib/fl_barescanner.ml b/src/findlib/fl_barescanner.ml new file mode 100644 index 0000000..704c8f7 --- /dev/null +++ b/src/findlib/fl_barescanner.ml @@ -0,0 +1,157 @@ +(** Extract information from bare packages *) + +open Fl_metascanner + +type bare_definition = + { bare_name : string; + bare_mainname : string; + bare_subname : string; + bare_directory : string; + bare_byte_archive : string option; + bare_byte_requires : string list; + bare_native_archive : string option; + bare_native_requires : string list; + bare_shared_archive : string option; + bare_shared_requires : string list; + bare_children : bare_definition list; + } + +let is_bare_pkg dir = + not (Sys.file_exists (Filename.concat dir "META")) && + ( Sys.file_exists (Filename.concat dir "lib.cma") || + Sys.file_exists (Filename.concat dir "lib.cmxa") || + Sys.file_exists (Filename.concat dir "lib.cmxs") + ) + +(* TODO: also support: + - older versions of ocaml: no package is bare + - missing native compiler: Cmx_format is unavailable + *) + +let input_toc name exp_magic = + let ic = open_in_bin name in + let magic = really_input_string ic (String.length exp_magic) in + if magic <> exp_magic then ( + close_in ic; + failwith ("bad magic number: " ^ name) + ); + let toc_pos = input_binary_int ic in + seek_in ic toc_pos; + let toc = input_value ic in + close_in ic; + toc + +let scan_bare_pkg mainname dir = + let sub_add subname n = + if subname = "" then n else subname ^ "." ^ n in + let rec scan subname name dir = + let file_cma = Filename.concat dir "lib.cma" in + let file_cma_exists = Sys.file_exists file_cma in + let file_cmxa = Filename.concat dir "lib.cmxa" in + let file_cmxa_exists = Sys.file_exists file_cmxa in + let req_cma = + if file_cma_exists then ( + Cmo_format.((input_toc file_cma Config.cma_magic_number).lib_requires) + |> List.map Lib.Name.to_string + ) else + [] in + let req_cmxa = + if file_cmxa_exists then ( + Cmx_format.((input_toc file_cmxa Config.cma_magic_number).lib_requires) + |> List.map Lib.Name.to_string + ) else + [] in + let dir_files = + if Sys.is_directory dir then Sys.readdir dir else [| |] in + let bare_children = + Array.to_list dir_files + |> List.filter (fun n -> is_bare_pkg (Filename.concat dir n)) + |> List.map (fun n -> + scan (sub_add subname n) (name ^ "." ^ n) (Filename.concat dir n)) in + { bare_name = name; + bare_mainname = mainname; + bare_subname = subname; + bare_directory = dir; + bare_byte_archive = if file_cma_exists then Some "lib.cma" else None; + bare_byte_requires = req_cma; + bare_native_archive = if file_cmxa_exists then Some "lib.cmxa" else None; + bare_native_requires = req_cmxa; + bare_shared_archive = None; (* TODO *) + bare_shared_requires = []; (* TODO *) + bare_children; + } in + scan "" mainname dir + +let to_pkg_definition bare = + let pkg_defs_byte = + match bare.bare_byte_archive with + | None -> [] + | Some file_cma -> + [ { def_var = "archive"; + def_flav = `BaseDef; + def_preds = [ `Pred "byte" ]; + def_value = file_cma + }; + { def_var = "plugin"; + def_flav = `BaseDef; + def_preds = [ `Pred "byte" ]; + def_value = file_cma + } + ] in + let pkg_defs_native = + match bare.bare_native_archive with + | None -> [] + | Some file_cmxa -> + [ { def_var = "archive"; + def_flav = `BaseDef; + def_preds = [ `Pred "native" ]; + def_value = file_cmxa + } + ] in + let pkg_defs_shared = + match bare.bare_shared_archive with + | None -> [] + | Some file_cmxs -> + [ { def_var = "plugin"; + def_flav = `BaseDef; + def_preds = [ `Pred "native" ]; + def_value = file_cmxs + } + ] in + let requires = + if bare.bare_byte_archive <> None then + bare.bare_byte_requires + else + if bare.bare_native_archive <> None then + bare.bare_native_requires + else + if bare.bare_shared_archive <> None then + bare.bare_shared_requires + else + [] in + let pkg_defs_base = + [ { def_var = "name"; + def_flav = `BaseDef; + def_preds = []; + def_value = bare.bare_name + }; + { def_var = "directory"; + def_flav = `BaseDef; + def_preds = []; + def_value = bare.bare_directory + }; + { def_var = "requires"; + def_flav = `BaseDef; + def_preds = []; + def_value = String.concat "," requires; + } + ] in + pkg_defs_base @ pkg_defs_byte @ pkg_defs_native @ pkg_defs_shared + +let rec to_pkg_expr bare = + { pkg_defs = + to_pkg_definition bare; + pkg_children = + List.map (fun b -> (b.bare_subname, to_pkg_expr b)) bare.bare_children + } + diff --git a/src/findlib/fl_barescanner.mli b/src/findlib/fl_barescanner.mli new file mode 100644 index 0000000..4ce22ad --- /dev/null +++ b/src/findlib/fl_barescanner.mli @@ -0,0 +1,41 @@ +(** Extract information from bare packages *) + +(** A bare package doesn't have a META file. In the directory there is + at least one archive with the fixed names "lib.cma", "lib.cmxa", or + "lib.cmxs". These archive files contain further information about + the package, in particular the list of required packages. + *) + +type bare_definition = + { bare_name : string; (** dot-separated name *) + bare_mainname : string; (** main package name *) + bare_subname : string; (** name without main name *) + bare_directory : string; (** directory of package *) + bare_byte_archive : string option; (** cma path if any *) + bare_byte_requires : string list; (** dot-separated names *) + bare_native_archive : string option; (** cmxa path if any *) + bare_native_requires : string list; (** dot-separated names *) + bare_shared_archive : string option; (** cmxs path if any *) + bare_shared_requires : string list; (** dot-separated names *) + bare_children : bare_definition list; (** sub packages *) + } + +val is_bare_pkg : string -> bool + (** whether the given directory is a bare package *) + +val scan_bare_pkg : string -> string -> bare_definition + (** [scan_bare_pkg name dir]: scans the given directory [dir] for + bare archives. The name of this package is assumed as [name] + (a dot-separated path). The subdirectories are recursively + scanned, too. + *) + +val to_pkg_expr : bare_definition -> Fl_metascanner.pkg_expr + (** Converts the bare definition into an expression, as if a META + file with the same information was present. + *) + +val to_pkg_definition : bare_definition -> Fl_metascanner.pkg_definition list + (** Converts the bare definition into a pkg definition, as if a META + file with the same information was present. + *) From 1b1fa9f868427aa410e23ab6a09e673103a31065 Mon Sep 17 00:00:00 2001 From: Gerd Stolpmann Date: Wed, 29 Apr 2020 11:49:37 +0000 Subject: [PATCH 05/17] adding Fl_metachecker for checking whether a META file is compatible with the new lean library format. --- src/findlib/Makefile | 2 +- src/findlib/fl_barescanner.ml | 72 ++++++++++------ src/findlib/fl_barescanner.mli | 10 ++- src/findlib/fl_metachecker.ml | 152 +++++++++++++++++++++++++++++++++ src/findlib/fl_metachecker.mli | 23 +++++ 5 files changed, 229 insertions(+), 30 deletions(-) create mode 100644 src/findlib/fl_metachecker.ml create mode 100644 src/findlib/fl_metachecker.mli diff --git a/src/findlib/Makefile b/src/findlib/Makefile index 0da86cd..1e8b4c3 100644 --- a/src/findlib/Makefile +++ b/src/findlib/Makefile @@ -24,7 +24,7 @@ OCAMLLEX = ocamllex OBJECTS = fl_ocaml_args.cmo findlib_config.cmo fl_split.cmo \ fl_metatoken.cmo fl_meta.cmo \ fl_metascanner.cmo fl_barescanner.cmo \ - fl_topo.cmo fl_package_base.cmo \ + fl_topo.cmo fl_package_base.cmo fl_metachecker.cmo \ findlib.cmo fl_args.cmo fl_lint.cmo TOBJECTS = topfind.cmo diff --git a/src/findlib/fl_barescanner.ml b/src/findlib/fl_barescanner.ml index 704c8f7..d011302 100644 --- a/src/findlib/fl_barescanner.ml +++ b/src/findlib/fl_barescanner.ml @@ -28,8 +28,7 @@ let is_bare_pkg dir = - missing native compiler: Cmx_format is unavailable *) -let input_toc name exp_magic = - let ic = open_in_bin name in +let input_toc name exp_magic ic = let magic = really_input_string ic (String.length exp_magic) in if magic <> exp_magic then ( close_in ic; @@ -41,43 +40,60 @@ let input_toc name exp_magic = close_in ic; toc +let scan_bare_files mainname dir open_archive = + let name_cma = Filename.concat dir "lib.cma" in + let name_cmxa = Filename.concat dir "lib.cmxa" in + let chan_cma = open_archive "lib.cma" in + let chan_cmxa = open_archive "lib.cmxa" in + let req_cma = + match chan_cma with + | Some ic -> + Cmo_format.((input_toc name_cma Config.cma_magic_number ic).lib_requires) + |> List.map Lib.Name.to_string + | None -> + [] in + let req_cmxa = + match chan_cmxa with + | Some ic -> + Cmx_format.((input_toc name_cmxa Config.cma_magic_number ic).lib_requires) + |> List.map Lib.Name.to_string + | None -> + [] in + { bare_name = mainname; + bare_mainname = mainname; + bare_subname = ""; + bare_directory = ""; + bare_byte_archive = if chan_cma <> None then Some "lib.cma" else None; + bare_byte_requires = req_cma; + bare_native_archive = if chan_cmxa <> None then Some "lib.cmxa" else None; + bare_native_requires = req_cmxa; + bare_shared_archive = None; (* TODO *) + bare_shared_requires = []; (* TODO *) + bare_children = []; + } + let scan_bare_pkg mainname dir = let sub_add subname n = if subname = "" then n else subname ^ "." ^ n in + let open_archive dir file_name = + let path = Filename.concat dir file_name in + if Sys.file_exists path then + Some(open_in_bin path) + else + None in let rec scan subname name dir = - let file_cma = Filename.concat dir "lib.cma" in - let file_cma_exists = Sys.file_exists file_cma in - let file_cmxa = Filename.concat dir "lib.cmxa" in - let file_cmxa_exists = Sys.file_exists file_cmxa in - let req_cma = - if file_cma_exists then ( - Cmo_format.((input_toc file_cma Config.cma_magic_number).lib_requires) - |> List.map Lib.Name.to_string - ) else - [] in - let req_cmxa = - if file_cmxa_exists then ( - Cmx_format.((input_toc file_cmxa Config.cma_magic_number).lib_requires) - |> List.map Lib.Name.to_string - ) else - [] in - let dir_files = - if Sys.is_directory dir then Sys.readdir dir else [| |] in + let bare = scan_bare_files name dir (open_archive dir) in let bare_children = - Array.to_list dir_files + (if Sys.is_directory dir then Sys.readdir dir else [| |]) + |> Array.to_list |> List.filter (fun n -> is_bare_pkg (Filename.concat dir n)) |> List.map (fun n -> scan (sub_add subname n) (name ^ "." ^ n) (Filename.concat dir n)) in - { bare_name = name; + { bare with + bare_name = name; bare_mainname = mainname; bare_subname = subname; bare_directory = dir; - bare_byte_archive = if file_cma_exists then Some "lib.cma" else None; - bare_byte_requires = req_cma; - bare_native_archive = if file_cmxa_exists then Some "lib.cmxa" else None; - bare_native_requires = req_cmxa; - bare_shared_archive = None; (* TODO *) - bare_shared_requires = []; (* TODO *) bare_children; } in scan "" mainname dir diff --git a/src/findlib/fl_barescanner.mli b/src/findlib/fl_barescanner.mli index 4ce22ad..49c6639 100644 --- a/src/findlib/fl_barescanner.mli +++ b/src/findlib/fl_barescanner.mli @@ -23,11 +23,19 @@ type bare_definition = val is_bare_pkg : string -> bool (** whether the given directory is a bare package *) +val scan_bare_files : string -> string -> (string -> in_channel option) -> bare_definition + (** [scan_bare_files name dir open_archive]: pre-fills the definition + from the archives. The archives (e.g. "lib.cma") are opened by + calling [open_archive]. If this function returns a channel, + the file is scanned. If it returns [None], the archive is assumed + to be non-existing. + *) + val scan_bare_pkg : string -> string -> bare_definition (** [scan_bare_pkg name dir]: scans the given directory [dir] for bare archives. The name of this package is assumed as [name] (a dot-separated path). The subdirectories are recursively - scanned, too. + scanned, too (unless ignore_chdilren). *) val to_pkg_expr : bare_definition -> Fl_metascanner.pkg_expr diff --git a/src/findlib/fl_metachecker.ml b/src/findlib/fl_metachecker.ml new file mode 100644 index 0000000..849053e --- /dev/null +++ b/src/findlib/fl_metachecker.ml @@ -0,0 +1,152 @@ +open Fl_metascanner +open Fl_barescanner +open Fl_package_base +open Printf + +type incompat_reasons = + | Incompat_not_declared_lean + | Incompat_bad_lean_decl + | Incompat_uses_directory + | Incompat_uses_linkopts + | Incompat_bad_archive of string * string + | Incompat_bad_requires of string + | Incompat_inline_subpackage + +let token_if p token = + if p then [token] else [] + +let check_incompat_with_lean_meta name open_archive meta = + (* List of checks: + - must set "lean=true" + - no "directory" variable + - no "linkopts" variable + - "archive" must match bare archives + - "requires" must match bare requires + *) + let has_bad_lean_decl = + List.exists + (fun def -> + def.def_var = "lean" && + (def.def_flav <> `BaseDef || def.def_preds <> [] || + def.def_value <> "true") + ) + meta.pkg_defs in + if has_bad_lean_decl then + [ Incompat_bad_lean_decl ] + else + let is_declared_lean = + List.exists + (fun def -> + def.def_var = "lean" && def.def_flav = `BaseDef && + def.def_preds = [] && def.def_value = "true" + ) + meta.pkg_defs in + if is_declared_lean then ( + let uses_directory = + List.exists (fun def -> def.def_var = "directory") meta.pkg_defs in + let uses_linkopts = + List.exists (fun def -> def.def_var = "linkopts") meta.pkg_defs in + let archive_byte = + try Some(lookup "archive" ["byte"] meta.pkg_defs) + with Not_found -> None in + let archive_byte_ok = + archive_byte = None || archive_byte = Some "lib.cma" in + let archive_byte_plugin = + try Some(lookup "archive" ["byte"; "plugin"] meta.pkg_defs) + with Not_found -> None in + let archive_byte_plugin_ok = + archive_byte_plugin = None || archive_byte = Some "lib.cma" in + let archive_native = + try Some(lookup "archive" ["native"] meta.pkg_defs) + with Not_found -> None in + let archive_native_ok = + archive_native = None || archive_native = Some "lib.cmxa" in + let archive_native_plugin = + try Some(lookup "archive" ["native"; "plugin"] meta.pkg_defs) + with Not_found -> None in + let archive_native_plugin_ok = + archive_native_plugin = None || archive_native_plugin = Some "lib.cmxs" in + let uses_inline_subpkg = + meta.pkg_children <> [] in + let reasons_1 = + [ token_if uses_directory Incompat_uses_directory; + token_if uses_linkopts Incompat_uses_linkopts; + token_if uses_inline_subpkg Incompat_inline_subpackage; + token_if (not archive_byte_ok) (Incompat_bad_archive("byte","not named lib.cma")); + token_if (not archive_byte_plugin_ok) (Incompat_bad_archive("byte,plugin","not named lib.cma")); + token_if (not archive_native_ok) (Incompat_bad_archive("native","not named lib.cmxa")); + token_if (not archive_native_plugin_ok) (Incompat_bad_archive("native,plugin","not named lib.cmxs")); + ] |> List.flatten in + if reasons_1 = [] then ( + let bare = scan_bare_files name "" open_archive in + let reqs = + try + lookup "requires" [] meta.pkg_defs + |> Fl_split.in_words + |> List.sort String.compare + with Not_found -> [] in + let reqs_ok l = + reqs = List.sort String.compare l in + [ token_if + (archive_byte <> None && bare.bare_byte_archive = None) + (Incompat_bad_archive("byte","missing file lib.cma")); + token_if + (archive_byte = None && bare.bare_byte_archive <> None) + (Incompat_bad_archive("byte","missing entry: lib.cma")); + token_if + (archive_byte_plugin <> None && bare.bare_byte_archive = None) + (Incompat_bad_archive("byte,plugin","missing file lib.cma")); + token_if + (archive_byte_plugin = None && bare.bare_byte_archive <> None) + (Incompat_bad_archive("byte,plugin","missing entry: lib.cma")); + token_if + (archive_native <> None && bare.bare_native_archive = None) + (Incompat_bad_archive("native","missing file lib.cmxa")); + token_if + (archive_native = None && bare.bare_native_archive <> None) + (Incompat_bad_archive("native","missing entry: lib.cmxa")); + token_if + (archive_native_plugin <> None && bare.bare_shared_archive = None) + (Incompat_bad_archive("native,plugin","missing file lib.cmxs")); + token_if + (archive_native_plugin = None && bare.bare_shared_archive <> None) + (Incompat_bad_archive("native,plugin","missing entry: lib.cmxs")); + token_if + (bare.bare_byte_archive <> None && not(reqs_ok bare.bare_byte_requires)) + (Incompat_bad_requires "lib.cma"); + token_if + (bare.bare_native_archive <> None && not(reqs_ok bare.bare_native_requires)) + (Incompat_bad_requires "lib.cmxa"); + token_if + (bare.bare_shared_archive <> None && not(reqs_ok bare.bare_shared_requires)) + (Incompat_bad_requires "lib.cmxs"); + ] |> List.flatten + ) else + reasons_1 + ) else + [ Incompat_not_declared_lean ] + + +let token_to_text token = + match token with + | Incompat_not_declared_lean -> + " - The META file misses a 'lean = true' setting.\n" + | Incompat_bad_lean_decl -> + " - The META file has a bad setting for the 'lean' variable.\n" + | Incompat_uses_directory -> + " - The META file defines the 'directory' variable which is not permitted for lean libraries.\n" + | Incompat_uses_linkopts -> + " - The META file defines the 'linkopts' variable which is not permitted for lean libraries.\n" + | Incompat_bad_archive(which,what) -> + sprintf " - bad variable 'archive(%s)': %s\n" which what + | Incompat_bad_requires file -> + sprintf " - bad setting for the 'requires' variable which differs from what the file %s specifies.\n" file + | Incompat_inline_subpackage -> + " - The META file contains inline subpackages, which is not supported for lean libraries. Subpackages need to go into subdirectories.\n" + +let incompat_to_text tokens = + if tokens = [] then + "This library is a fully-compatible lean library.\n" + else + "This library is not lean. The following incompatibilities have been detected:\n" + ^ (String.concat "\n" (List.map token_to_text tokens)) diff --git a/src/findlib/fl_metachecker.mli b/src/findlib/fl_metachecker.mli new file mode 100644 index 0000000..9840875 --- /dev/null +++ b/src/findlib/fl_metachecker.mli @@ -0,0 +1,23 @@ +type incompat_reasons = + | Incompat_not_declared_lean + | Incompat_bad_lean_decl + | Incompat_uses_directory + | Incompat_uses_linkopts + | Incompat_bad_archive of string * string + | Incompat_bad_requires of string + | Incompat_inline_subpackage + +val check_incompat_with_lean_meta : string -> + (string -> in_channel option) -> + Fl_metascanner.pkg_expr -> + incompat_reasons list + (** [check_incompat_with_lean_meta name open_archive meta]: checks whether + the lib with the META file [meta] can be regarded as a lean lib. + If so, the empty list is returned. If not, the list describes + the incompatibilities. + + [open_archive]: see {!Fl_barescanner.scan_bare_files} + *) + +val incompat_to_text : incompat_reasons list -> string + (** Converts the tokens to a multi-line human-readable text *) From 46a030a6d793291ec3f343596de8a49c60062075 Mon Sep 17 00:00:00 2001 From: Gerd Stolpmann Date: Fri, 1 May 2020 15:53:38 +0000 Subject: [PATCH 06/17] remove "findlib-toolbox" --- INSTALL | 5 - Makefile.config.pattern | 5 +- configure | 17 - src/findlib-toolbox/Makefile | 37 - src/findlib-toolbox/directory.xpm | 6 - src/findlib-toolbox/make_wizard.ml | 1559 ----------------------- src/findlib-toolbox/make_wizard.pattern | 494 ------- src/findlib-toolbox/selected.xpm | 6 - src/findlib-toolbox/tree_editor.ml | 1008 --------------- src/findlib-toolbox/unselected.xpm | 6 - src/findlib/frontend.ml | 10 + 11 files changed, 12 insertions(+), 3141 deletions(-) delete mode 100644 src/findlib-toolbox/Makefile delete mode 100644 src/findlib-toolbox/directory.xpm delete mode 100644 src/findlib-toolbox/make_wizard.ml delete mode 100644 src/findlib-toolbox/make_wizard.pattern delete mode 100644 src/findlib-toolbox/selected.xpm delete mode 100644 src/findlib-toolbox/tree_editor.ml delete mode 100644 src/findlib-toolbox/unselected.xpm diff --git a/INSTALL b/INSTALL index 2dc821f..8cadcfd 100644 --- a/INSTALL +++ b/INSTALL @@ -61,11 +61,6 @@ options: because #use "topfind" will not work when this option is enabled.) - -with-toolbox - also compile and install the "toolbox". This requires - that labltk is available. The toolbox contains the - "make_wizard" to easily create findlib-enabled Makefiles. - -cygpath Cygwin environment only: If "ocamlc -where" does not output a Unix-style path, this option can be used diff --git a/Makefile.config.pattern b/Makefile.config.pattern index 658bfdc..2c8d4cb 100644 --- a/Makefile.config.pattern +++ b/Makefile.config.pattern @@ -50,10 +50,9 @@ EXEC_SUFFIX= LIB_SUFFIX=.a #---------------------------------------------------------------------- -# Which parts are to be built: findlib, findlib-toolbox (space-separated -# list) +# Which parts are to be built: findlib, (space-separated list) #---------------------------------------------------------------------- -PARTS=findlib findlib-toolbox +PARTS=findlib #---------------------------------------------------------------------- # Whether the "topfind" script is installed in $(OCAML_CORE_STDLIB): diff --git a/configure b/configure index bb7b8ec..3c6ffd2 100755 --- a/configure +++ b/configure @@ -114,7 +114,6 @@ ocamlfind_bin="" ocamlfind_man="" ocaml_sitelib="" ocamlfind_config="" -with_toolbox=0 with_topfind=1 with_camlp4=1 custom=-custom @@ -144,9 +143,6 @@ while [ "$#" != "0" ]; do -system) system=$2 shift 2 ;; - -with-toolbox) with_toolbox=1 - shift - ;; -no-topfind) with_topfind=0 shift ;; @@ -164,7 +160,6 @@ while [ "$#" != "0" ]; do echo " -config path set the location of the configuration file" 1>&2 echo " -no-custom don't link in custom runtime mode" 1>&2 echo " -system override system type (esp. mingw and win32)" 1>&2 - echo " -with-toolbox also build the toolbox" 1>&2 echo " -no-topfind don't install topfind script into stdlib directory" 1>&2 echo " -no-camlp4 don't install the camlp4 META file" 1>&2 exit @@ -448,9 +443,6 @@ if [ -f "${ocaml_core_stdlib}/labltk/labltk.cma" ]; then else llabltk='' echo "labltk: not present" - if [ $with_toolbox -gt 0 ]; then - echo "Sorry, toolbox requires labltk - omitting toolbox." - fi with_toolbox=0 fi @@ -631,9 +623,6 @@ fi # Write Makefile.config parts="findlib" -if [ $with_toolbox -gt 0 ]; then - parts="$parts findlib-toolbox" -fi if [ $cbytes -gt 0 ]; then parts="$parts bytes" fi @@ -696,12 +685,6 @@ else echo "Topfind ppxopt support: no" fi -if [ $with_toolbox -gt 0 ]; then - echo "Toolbox: yes" -else - echo "Toolbox: no" -fi - if [ -z "$custom" ]; then echo "Link custom runtime: no" else diff --git a/src/findlib-toolbox/Makefile b/src/findlib-toolbox/Makefile deleted file mode 100644 index 574cd8e..0000000 --- a/src/findlib-toolbox/Makefile +++ /dev/null @@ -1,37 +0,0 @@ -TOP=../.. -include $(TOP)/Makefile.config - -.PHONY: all opt install uninstall clean - -all: make_wizard$(EXEC_SUFFIX) - -opt: - true - -make_wizard$(EXEC_SUFFIX): make_wizard.ml - ocamlc -o make_wizard$(EXEC_SUFFIX) -I +labltk -I ../findlib unix.cma str.cma labltk.cma \ - findlib.cma make_wizard.ml - -install: - cp make_wizard$(EXEC_SUFFIX) make_wizard.pattern $(prefix)$(OCAML_SITELIB)/findlib - -# uninstall: Nothing to do, because the removal of the findlib core also -# deinstalls the make_wizard -uninstall: - true - -# ---------------------------------------------------------------------- - -tree: lx_spots.mli lx_spots.ml lx_tree.mli lx_tree.ml test_tree.ml - ocamlfind ocamlc -o tree -package labltk,unix,str -linkpkg \ - lx_spots.mli lx_spots.ml lx_tree.mli lx_tree.ml test_tree.ml - -tree_editor: lx_spots.mli lx_spots.ml lx_tree.mli lx_tree.ml tree_editor.ml - ocamlfind ocamlc -o tree_editor -package labltk,unix,str -linkpkg \ - lx_spots.mli lx_spots.ml lx_tree.mli lx_tree.ml tree_editor.ml - -# ---------------------------------------------------------------------- - -clean: - rm -f *.cmi *.cmo - rm -f make_wizard$(EXEC_SUFFIX) # tree tree_editor diff --git a/src/findlib-toolbox/directory.xpm b/src/findlib-toolbox/directory.xpm deleted file mode 100644 index a657b82..0000000 --- a/src/findlib-toolbox/directory.xpm +++ /dev/null @@ -1,6 +0,0 @@ -#define directory_width 16 -#define directory_height 16 -static unsigned char directory_bits[] = { - 0xf8, 0x01, 0xfc, 0x03, 0xfe, 0x7f, 0x01, 0x80, 0x55, 0xd5, 0x01, 0x80, - 0xab, 0xaa, 0x01, 0x80, 0x55, 0xd5, 0x01, 0x80, 0xab, 0xaa, 0x01, 0x80, - 0xfe, 0x7f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; diff --git a/src/findlib-toolbox/make_wizard.ml b/src/findlib-toolbox/make_wizard.ml deleted file mode 100644 index fb7b0e2..0000000 --- a/src/findlib-toolbox/make_wizard.ml +++ /dev/null @@ -1,1559 +0,0 @@ -(* $Id$ - * ---------------------------------------------------------------------- - * - *) - - -open Tk;; -open Widget;; - -(**********************************************************************) -(* GLOBAL VARIABLES *) -(**********************************************************************) - -(* General *) - -let wiz_package_name = ref "";; -let wiz_package_version = ref "";; -let wiz_package_description = ref "";; - -(* Preprocessor *) - -let wiz_enable_camlp4 = ref false;; -let wiz_camlp4_syntax = ref "camlp4o";; -let wiz_camlp4_extensions = ref [];; (* list of package names *) -let wiz_camlp4_selected = ref [];; (* subset of wiz_camlp4_extensions *) -let wiz_camlp4_options = ref "";; - -(* Prerequisites *) - -let wiz_all_packages = ref [];; (* list of package names *) -let wiz_required_packages = ref [];; (* subset of wiz_all_packages *) - -(* Build Library *) - -let wiz_available = ref [];; (* list of module names *) -let wiz_byte_enable = ref true;; -let wiz_nat_enable = ref true;; -let wiz_objects = ref [];; (* subset of wiz_available *) -let wiz_source_suffixes = ref ".ml .mli .mll .mly";; - -(* Build Executables *) - -let wiz_executables = ref [];; (* list of executable names *) -let wiz_exec_objects = (ref [] : (string * (string list ref)) list ref);; - (* an alist: for every executable, the corresponding list of modules is - * stored. - *) -let wiz_exec_native = (ref [] : (string * bool ref) list ref);; - (* an alist: for every executable, whether it is natively compiled or not *) - -(* Generate *) - -let wiz_makefile_name = ref "Makefile";; -let wiz_local_makefile_name = ref "";; -let wiz_make_default = ref "byte" ;; - - -(**********************************************************************) -(* AUXILIARY FUNCTIONS *) -(**********************************************************************) - -let find_pos x l = - let rec find k l = - match l with - h :: l' -> - if x = h then k else find (k+1) l' - | [] -> - raise Not_found - in - find 0 l -;; - - -let rec delete_at k l = - match l with - h :: l' -> if k <= 0 then l' else h :: (delete_at (k-1) l') - | [] -> [] -;; - - -let rec insert_at k x l = - if k <= 0 then - x :: l - else - match l with - h :: l' -> h :: (insert_at (k-1) x l') - | [] -> [] (* insert beyond end *) -;; - - -let rec remove_dups l = - (* Remove duplicate members in a sorted list *) - match l with - x :: (y :: l' as l1) when x = y -> - remove_dups l1 - | x :: l' -> - x :: remove_dups l' - | [] -> - [] -;; - - -(**********************************************************************) -(* SAVE/LOAD STATE *) -(**********************************************************************) - -let save_var name printer out var = - output_string out ("V" ^ name ^ "\n"); - printer out var -;; - -let save_string out var = - (* [var] must not contain linefeeds *) - output_string out ("S" ^ var ^ "\n") -;; - -let save_bool out var = - output_string out ("B" ^ string_of_bool var ^ "\n") -;; - -let save_list printer out var = - output_string out ("L" ^ string_of_int (List.length var) ^ "\n"); - List.iter (printer out) var -;; - -let save_pair lprinter rprinter out (lvar,rvar) = - output_string out "P\n"; - lprinter out lvar; - rprinter out rvar -;; - -let save_ref printer out var = - (* Actually doesn't save the reference! *) - printer out !var -;; - -let save_state out = - save_var "wiz_package_name" save_string out !wiz_package_name; - save_var "wiz_package_version" save_string out !wiz_package_version; - save_var "wiz_package_description" save_string out !wiz_package_description; - save_var "wiz_enable_camlp4" save_bool out !wiz_enable_camlp4; - save_var "wiz_camlp4_syntax" save_string out !wiz_camlp4_syntax; - save_var "wiz_camlp4_extensions" (save_list save_string) out - !wiz_camlp4_extensions; - save_var "wiz_camlp4_selected" (save_list save_string) out - !wiz_camlp4_selected; - save_var "wiz_camlp4_options" save_string out !wiz_camlp4_options; - save_var "wiz_all_packages" (save_list save_string) out - !wiz_all_packages; - save_var "wiz_required_packages" (save_list save_string) out - !wiz_required_packages; - save_var "wiz_available" (save_list save_string) out - !wiz_available; - save_var "wiz_byte_enable" save_bool out !wiz_byte_enable; - save_var "wiz_nat_enable" save_bool out !wiz_nat_enable; - save_var "wiz_objects" (save_list save_string) out - !wiz_objects; - save_var "wiz_source_suffixes" save_string out !wiz_source_suffixes; - save_var "wiz_executables" (save_list save_string) out - !wiz_executables; - save_var "wiz_exec_objects" - (save_list (save_pair save_string (save_ref (save_list save_string)))) - out - !wiz_exec_objects; - save_var "wiz_exec_native" - (save_list (save_pair save_string (save_ref save_bool))) - out - !wiz_exec_native; - save_var "wiz_makefile_name" save_string out !wiz_makefile_name; - save_var "wiz_local_makefile_name" save_string out !wiz_local_makefile_name; - save_var "wiz_make_default" save_string out !wiz_make_default; -;; - -let save() = - let f = open_out ".make-wizard" in - save_state f; - close_out f -;; - -let check_char inch c_expected = - let c = input_char inch in - if c <> c_expected then failwith "Cannot read .make-wizard" -;; - -let load_string inch = - check_char inch 'S'; - let line = input_line inch in - (* prerr_endline ("String = " ^ line); *) - line -;; - -let load_bool inch = - check_char inch 'B'; - bool_of_string(input_line inch) -;; - -let load_list parse inch = - check_char inch 'L'; - let n = int_of_string(input_line inch) in - let l = ref [] in - for i = 1 to n do - l := parse inch :: !l; - done; - List.rev !l -;; - -let load_pair lparse rparse inch = - check_char inch 'P'; - ignore(input_line inch); - let l = lparse inch in - let r = rparse inch in - (l,r) -;; - -let load_ref parse inch = - ref(parse inch) -;; - -let load_var var parse inch = - let value = parse inch in - var := value -;; - -let load_variables spec inch = - try - while true do - try - check_char inch 'V'; - let name = input_line inch in - (* prerr_endline name;*) - let loader = List.assoc name spec in (* or Not_found *) - loader inch - with - Not_found -> - () - done; - assert false - with - End_of_file -> - () -;; - -let load_state inch = - load_variables - [ "wiz_package_name", - (load_var wiz_package_name load_string); - "wiz_package_version", - (load_var wiz_package_version load_string); - "wiz_package_description", - (load_var wiz_package_description load_string); - "wiz_enable_camlp4", - (load_var wiz_enable_camlp4 load_bool); - "wiz_camlp4_syntax", - (load_var wiz_camlp4_syntax load_string); - "wiz_camlp4_extensions", - (load_var wiz_camlp4_extensions (load_list load_string)); - "wiz_camlp4_selected", - (load_var wiz_camlp4_selected (load_list load_string)); - "wiz_camlp4_options", - (load_var wiz_camlp4_options load_string); - "wiz_all_packages", - (load_var wiz_all_packages (load_list load_string)); - "wiz_required_packages", - (load_var wiz_required_packages (load_list load_string)); - "wiz_available", - (load_var wiz_available (load_list load_string)); - "wiz_byte_enable", - (load_var wiz_byte_enable load_bool); - "wiz_nat_enable", - (load_var wiz_nat_enable load_bool); - "wiz_objects", - (load_var wiz_objects (load_list load_string)); - "wiz_source_suffixes", - (load_var wiz_source_suffixes load_string); - "wiz_executables", - (load_var wiz_executables (load_list load_string)); - "wiz_exec_objects", - (load_var wiz_exec_objects (load_list - (load_pair - load_string - (load_ref (load_list load_string))))); - "wiz_exec_native", - (load_var wiz_exec_native (load_list - (load_pair - load_string - (load_ref load_bool)))); - "wiz_makefile_name", - (load_var wiz_makefile_name load_string); - "wiz_local_makefile_name", - (load_var wiz_local_makefile_name load_string); - "wiz_make_default", - (load_var wiz_make_default load_string); - ] - inch -;; - - -let load() = - let f = open_in ".make-wizard" in - load_state f; - close_in f -;; - - -(**********************************************************************) -(* PARSE PATTERN FILE *) -(**********************************************************************) - -type sectiondata = - Sect_const of string - | Sect_var of string - -let section_re = Str.regexp "^\\[\\([A-Za-z_0-9-]+\\)\\]$" ;; -let var_re = Str.regexp "\\[\\([A-Za-z_0-9-]+\\)\\]" ;; - -let parse_pattern inch = - let rec parse_section name sect = - try - let line = input_line inch in - if String.length line >= 2 && line.[0] = '#' && line.[1] = '#' then - (* Comment line *) - parse_section name sect - else - if Str.string_match section_re line 0 then - (* New section begins *) - let name' = Str.matched_group 1 line in - (name, List.rev sect) :: parse_section name' [] - else - (* Normal data region *) - let plist = Str.full_split var_re line in - let slist = - List.map - (function - Str.Text t -> Sect_const t - | Str.Delim d -> Sect_var (String.sub d 1 (String.length d - 2)) - ) - plist @ [ Sect_const "\n" ] in - parse_section name (List.rev slist @ sect) - with - End_of_file -> - [ name, List.rev sect ] - in - - parse_section "_preamble_" [] -;; - -let load_pattern() = - let where = Filename.dirname (Sys.argv.(0)) in - let name = Filename.concat where "make_wizard.pattern" in - let f = open_in name in - let p = parse_pattern f in - close_in f; - p -;; - -(**********************************************************************) -(* MAKEFILE GENERATOR *) -(**********************************************************************) - -let dollar_re = Str.regexp "\\$";; -let meta_re = Str.regexp "[\\\\\\\"]";; - -let mkquote s = - (* Quote "$" *) - Str.global_replace dollar_re "$$" s -;; - -let metaquote s = - (* Quote backslash and double quotes for META files *) - Str.global_replace meta_re "\\\\0" s -;; - -let makemake() = - let b = Buffer.create 1024 in - let sections = load_pattern() in - - let write section vars = - let sectlist = - try List.assoc section sections - with Not_found -> failwith ("Cannot find section: " ^ section) in - List.iter - (function - Sect_const s -> - Buffer.add_string b s - | Sect_var v -> - let s = - try List.assoc v vars - with Not_found -> failwith ("No such variable: " ^ v) in - Buffer.add_string b s - ) - sectlist - in - - let is_byte_exec execname = - try not (!(List.assoc execname !wiz_exec_native)) - with Not_found -> true - in - - let byte_execs = - List.map - fst - (List.filter - (fun (execname,_) -> is_byte_exec execname) - !wiz_exec_objects - ) - in - - let nat_execs = - List.map - fst - (List.filter - (fun (execname,_) -> not(is_byte_exec execname)) - !wiz_exec_objects - ) - in - - let byte_exec_modules = - remove_dups - (List.sort compare - (List.flatten - (List.map - (fun (_, l) -> !l) - (List.filter - (fun (execname, _) -> is_byte_exec execname) - !wiz_exec_objects - ) - ) - ) - ) - in - - let nat_exec_modules = - remove_dups - (List.sort compare - (List.flatten - (List.map - (fun (_, l) -> !l) - (List.filter - (fun (execname, _) -> not(is_byte_exec execname)) - !wiz_exec_objects - ) - ) - ) - ) - in - - let required_packages = - (* magically add "camlp4" if missing *) - if !wiz_enable_camlp4 then ( - ( if not (List.mem "camlp4" !wiz_required_packages) then - [ "camlp4" ] - else - [] - ) @ !wiz_camlp4_selected @ !wiz_required_packages - ) - else - !wiz_required_packages - in - - let variables = - [ "name", - mkquote !wiz_package_name; - "makefile_name", - mkquote !wiz_makefile_name; - "version", - mkquote(metaquote !wiz_package_version); - "description", - mkquote(metaquote !wiz_package_description); - "byte_objects", - String.concat " " (List.map - (fun m -> String.uncapitalize m ^ ".cmo") - !wiz_objects); - "nat_objects", - String.concat " " (List.map - (fun m -> String.uncapitalize m ^ ".cmx") - !wiz_objects); - "byte_executables", - String.concat " " byte_execs; - "byte_exec_objects", - String.concat " " (List.map - (fun m -> String.uncapitalize m ^ ".cmo") - byte_exec_modules); - "nat_executables", - String.concat " " nat_execs; - "nat_exec_objects", - String.concat " " (List.map - (fun m -> String.uncapitalize m ^ ".cmx") - nat_exec_modules); - "prereqs", - String.concat " " required_packages; - "ppopts", - if !wiz_enable_camlp4 then - "-syntax " ^ !wiz_camlp4_syntax ^ - (String.concat " " - (List.map - (fun opt -> " -ppopt " ^ mkquote(Filename.quote opt)) - (Fl_split.in_words_ws !wiz_camlp4_options) - )) - else - ""; - "mtopts", - if List.mem "threads" !wiz_required_packages then "-thread" else ""; - "default_target", - !wiz_make_default; - ] in - - write "intro" variables; - write "def_general" variables; - if !wiz_byte_enable then write "def_byte_archive" variables; - if !wiz_nat_enable then write "def_native_archive" variables; - write "def_byte_exec" variables; - write "def_nat_exec" variables; - write "def_props" variables; - write "def_tools" variables; - write "rules" variables; - write "default_target" variables; - write "suffix_rules" variables; - write "generate" variables; - List.iter - (fun (execname, modlist) -> - let switches = - if is_byte_exec execname then - "-bytecode-filter" - else - "-native-filter" in - let deptargets = - String.concat " " (List.map - (fun m -> - let m' = String.uncapitalize m in - m' ^ ".ml " ^ m' ^ ".mli") - !modlist) in - write "makemake_exec" ( [ "switches", switches; - "execname", execname; - "deptargets", deptargets ] @ variables ) - ) - !wiz_exec_objects; - write "byte" variables; - write "opt" variables; - if !wiz_byte_enable then write "byte_archive" variables; - if !wiz_nat_enable then write "native_archive" variables; - List.iter - (fun (execname, modlist) -> - if is_byte_exec execname then begin - let execobjs = - String.concat " " (List.map - (fun m -> String.uncapitalize m ^ ".cmo") - !modlist) in - write "byte_exec" ( ["execname", execname; - "execobjs", execobjs ] @ variables ) - end - ) - !wiz_exec_objects; - List.iter - (fun (execname, modlist) -> - if not (is_byte_exec execname) then begin - let execobjs = - String.concat " " (List.map - (fun m -> String.uncapitalize m ^ ".cmx") - !modlist) in - write "nat_exec" ( ["execname", execname; - "execobjs", execobjs ] @ variables ) - end - ) - !wiz_exec_objects; - write "clean" variables; - write "install" variables; - - if !wiz_local_makefile_name<> "" && - Sys.file_exists !wiz_local_makefile_name then - begin - write "local" variables; - let f = open_in !wiz_local_makefile_name in - try - while true do - let s = input_line f in - Buffer.add_string b s; - Buffer.add_char b '\n'; - done; - assert false - with - End_of_file -> - close_in f - end; - - Buffer.contents b -;; - -(**********************************************************************) -(* GUI *) -(**********************************************************************) - -let headline_font = "-*-helvetica-bold-r-normal-*-*-140-*-*-*-*-iso8859-1" ;; -let font = "-*-helvetica-medium-r-normal-*-*-120-*-*-*-*-iso8859-1" ;; - -(**********************************************************************) - -let top = ref Widget.default_toplevel;; -let topframe = ref Widget.dummy;; -let screens = ref [];; -let current_screen = ref 0;; - -let ( !! ) = fun x -> !(!x);; - -let add_screen func = - screens := !screens @ [ func ] -;; - -let add_headline frame text = - let s1 = Frame.create ~height:15 frame in - let w = Label.create ~text ~font:headline_font ~anchor:`W frame in - let s2 = Frame.create ~height:10 frame in - pack [ s1 ]; - pack ~anchor:`W [ w ]; - pack [ s2 ] -;; - -let add_para frame text = - let s1 = Frame.create ~height:5 frame in - let w = Message.create ~padx:0 ~text ~font ~anchor:`W ~width:(pixels (`Pt 400.0)) frame in - let s2 = Frame.create ~height:5 frame in - pack [ s1 ]; - pack ~anchor:`W [ w ]; - pack [ s2 ] -;; - - -let dialog ~parent ~title ~message ~buttons ?(default = (-1)) () = - (* Like Dialog.create, but our own style. *) - let popup = Toplevel.create parent in - Wm.title_set popup title; - Wm.transient_set popup ~master:(Winfo.toplevel parent); - add_headline popup title; - add_para popup message; - let f_buttons = Frame.create popup in - let n = ref 0 in - let r = ref (-1) in - List.iter - (fun text -> - let k = !n in - let b = - Button.create ~font ~text ~command:(fun () -> r := k; destroy popup) - f_buttons in - (* --- Default buttons not yet supported because of deficiency in - * labltk: - if k = default then Button.configure ~default:`Active b; - *) - pack ~side:`Left [b]; - incr n; - ) - buttons; - pack [f_buttons]; - Grab.set popup; - Tkwait.window popup; - !r -;; - - -let ask_and_save frame = - let reply = - dialog ~parent:frame ~title:"Save .make-wizard?" - ~message:"Do you want to save the current state in the file .make-wizard?" - ~buttons:["Yes"; "No"; "Cancel"] - ~default:0 - () - in - if reply = 0 then save(); - reply < 2 -;; - - -let string_tv ?(onchange = fun () -> ()) frame v = - let textvariable = Textvariable.create ~on:frame () in - Textvariable.set textvariable !v; - let rec set_handle() = - Textvariable.handle textvariable - ~callback:(fun () -> - v := Textvariable.get textvariable; - onchange(); - set_handle()); - in - set_handle(); - textvariable -;; - - -let bool_tv ?(onchange = fun () -> ()) frame v = - let textvariable = Textvariable.create ~on:frame () in - Textvariable.set textvariable (if !v then "1" else "0"); - let rec set_handle() = - Textvariable.handle textvariable - ~callback:(fun () -> - v := Textvariable.get textvariable = "1"; - onchange(); - set_handle()); - in - set_handle(); - textvariable -;; - - -let label_box frame box = - let sub = Frame.create frame in - let row = ref 0 in - List.iter - (fun (l, v) -> - let label = Label.create ~font ~text:l ~anchor:`E sub in - let textvariable = string_tv frame v in - let var = Entry.create ~font ~textvariable ~width:40 sub in - grid ~row:!row ~column:0 ~sticky:"e" [ label ]; - grid ~row:!row ~column:1 ~sticky:"w" [ var ]; - incr row; - ) - box; - pack ~anchor:`W [ sub ] -;; - - -let scrolled_listbox ?(click = fun _ _ -> ()) ?(context = fun _ _ -> ()) - ?(separator = true) ?(height = 8) frame = - let f = Frame.create frame in - let lb = Listbox.create ~selectmode:`Multiple ~width:20 ~height - ~exportselection:false f in - let sb = Scrollbar.create ~orient:`Vertical - ~command:(Listbox.yview lb) - f in - Listbox.configure ~yscrollcommand:(Scrollbar.set sb) ~font lb; - let sep = Frame.create ~width:30 f in - pack ~side:`Left [ lb ]; - pack ~side:`Left ~fill:`Y [ sb ]; - if separator then pack ~side:`Left [ sep ]; - - bind ~events:[ `ButtonPressDetail 1 ] ~fields:[ `MouseY ] - ~action:(fun einfo -> - let `Num row = Listbox.nearest lb ~y:(einfo.Tk.ev_MouseY) in - Timer.set ~ms:0 ~callback:(fun () -> click lb row) - ) - lb; - bind ~events:[ `ButtonPressDetail 3 ] ~fields:[ `MouseY ] - ~action:(fun einfo -> - let `Num row = Listbox.nearest lb ~y:(einfo.Tk.ev_MouseY) in - Timer.set ~ms:0 ~callback:(fun () -> context lb row) - ) - lb; - - (f, lb) -;; - - -let listbox_select lb selection = - Listbox.selection_clear lb ~first:(`Num 0) ~last:`End; - for i = 0 to Listbox.size lb do - let s = Listbox.get lb (`Num i) in - if List.mem s selection then - Listbox.selection_set lb ~first:(`Num i) ~last:(`Num i) - done -;; - - -let listbox_get_selection lb = - List.map - (fun index -> Listbox.get lb ~index) - (Listbox.curselection lb) -;; - - -let indented_cond_frame frame enablers = - (* Returns a subframe of [frame] that is only mapped if the boolean - * variable [!enable] is true. [enable_text] is the text for the - * checkbox that toggles [!enable]. - *) - let onchange_enable = ref (fun () -> ()) in - - List.iter - (fun (enable, enable_text) -> - let enable_tv = bool_tv - ~onchange:(fun () -> !onchange_enable()) - frame enable in - let cb = Checkbutton.create - ~font ~text:enable_text ~variable:enable_tv frame in - pack ~anchor:`W [cb]; - ) - enablers; - - let is_enabled() = - let p = ref false in - List.iter (fun (enable, _) -> p := !p || !enable) enablers; - !p - in - - let frame' = Frame.create frame in - let indent = Frame.create ~width:30 frame' in - let frame'' = Frame.create frame' in - pack ~anchor:`W [frame']; - - let frame''_is_packed = ref false in - let frame''_pack b = - if b <> !frame''_is_packed then begin - if b then - pack ~side:`Left [indent; frame''] - else - Pack.forget [ frame'' ]; - frame''_is_packed := b - end - in - frame''_pack (is_enabled()); - onchange_enable := (fun () -> frame''_pack (is_enabled())); - frame'' -;; - - -let double_listbox frame available objects scan = - let boxes = Frame.create frame in - let (f_left,lb_left) = scrolled_listbox boxes in - let (f_right,lb_right) = scrolled_listbox ~separator:false boxes in - let f_buttons = Frame.create boxes in - let b_add = Button.create ~font ~text:"Add >>" f_buttons in - let b_del = Button.create ~font ~text:"<< Del" f_buttons in - let b_up = Button.create ~font ~text:"Up ^" f_buttons in - let b_down= Button.create ~font ~text:"Down v" f_buttons in - let b_scan= Button.create ~font ~text:"Rescan" f_buttons in - let f_sep = Frame.create ~width:30 boxes in - pack ~fill:`X [ b_add; b_del; b_up; b_down; b_scan ]; - pack ~side:`Left [ coe f_left; coe f_buttons; coe f_sep; coe f_right ]; - pack [ boxes ]; - - let update() = - let still_available = (* available - objects *) - List.filter (fun m -> not (List.mem m !!objects)) !!available in - Listbox.delete lb_left ~first:(`Num 0) ~last:`End; - Listbox.insert lb_left ~index:`End ~texts:still_available; - Listbox.delete lb_right ~first:(`Num 0) ~last:`End; - Listbox.insert lb_right ~index:`End ~texts:!!objects; - in - - let rescan() = - !available := scan(); - update() - in - - let add() = - if Listbox.curselection lb_left = [] then begin - let popup = Toplevel.create frame in - Wm.title_set popup "Add File"; - Wm.transient_set popup ~master:(Winfo.toplevel frame); - add_headline popup "Add File"; - add_para popup "Enter the name of the module to add. Note that you can also select the modules in the left box and press 'Add' to quickly move the modules to the right box."; - - let modname = ref "" in - label_box popup [ "Name of new module: ", modname ]; - - let p_buttons = Frame.create popup in - let b_ok = Button.create ~font ~text:"OK" - ~command:(fun () -> - if !modname <> "" then - !objects := !!objects @ [ !modname ]; - update(); - destroy popup) p_buttons in - let b_cancel = Button.create ~font ~text:"Cancel" - ~command:(fun () -> destroy popup) p_buttons in - pack ~side:`Left [b_ok; b_cancel]; - - add_para popup ""; - - pack [p_buttons]; - end - else begin - let items = - List.map - (fun index -> Listbox.get lb_left ~index) - (Listbox.curselection lb_left) - in - !objects := !!objects @ items; - update() - end - in - - let del() = - if Listbox.curselection lb_right = [] then begin - ignore - (dialog - ~parent:!top - ~title:"Nothing selected" - ~message:"Please select the modules you want to delete in the right box!" - ~buttons:[ "OK" ] - ~default:0 - ()) - end - else begin - let items = - List.map - (fun index -> Listbox.get lb_right ~index) - (Listbox.curselection lb_right) - in - !objects := List.filter (fun m -> not (List.mem m items)) !!objects; - update() - end - in - - let move_dlg() = - ignore - (dialog - ~parent:!top - ~title:"Bad Selection" - ~message:"Please select the (single) module you want to move in the right box!" - ~buttons:[ "OK" ] - ~default:0 - ()) - in - - let move g () = - if List.length (Listbox.curselection lb_right) <> 1 then - move_dlg() - else begin - let index = List.hd (Listbox.curselection lb_right) in - let `Num n = index in - let n' = g n in - if n' >= 0 && n' < List.length !!objects then begin - let item = Listbox.get lb_right ~index:(index :> Tk.listbox_index) in - !objects := delete_at n !!objects; - !objects := insert_at n' item !!objects; - update(); - Listbox.selection_set lb_right ~first:(`Num n') ~last:(`Num n'); - end - end - in - - if !!available = [] then rescan() else update(); - Button.configure ~command:add b_add; - Button.configure ~command:del b_del; - Button.configure ~command:(move pred) b_up; - Button.configure ~command:(move succ) b_down; - Button.configure ~command:rescan b_scan; - - (* Returns the [update] function *) - update -;; - - -let redraw() = - destroy !topframe; - let f = Frame.create !top in - let f1 = Frame.create ~width:5 f in - let f2 = Frame.create f in - let f3 = Frame.create ~width:5 f in - pack ~expand:true ~fill:`Y [f]; - pack ~side:`Left [f1]; - pack ~side:`Left ~fill:`Y [f2]; - pack ~side:`Left [f3]; - let func = List.nth !screens !current_screen in - topframe := coe f; - func f2 -;; - - -let footer frame = - let box = Frame.create frame in - pack ~side:`Bottom ~fill:`X [box]; - let sep1 = Frame.create ~height:15 box in - let b = Frame.create ~height:1 ~background:`Black box in - let sep2 = Frame.create ~height:15 box in - pack [ sep1 ]; - pack ~fill:`X ~expand:true [b]; - pack [ sep2 ]; - - let f = Frame.create box in - let m1 = Frame.create f in - pack ~fill:`X ~expand:true ~side:`Left [ m1 ]; - let prev_b = - Button.create ~font ~text:"Previous" ~state:`Disabled - ~command:(fun () -> decr current_screen; redraw()) m1 in - pack ~side:`Left [prev_b]; - if !current_screen > 0 then - Button.configure ~state:`Normal prev_b; - let m2 = Frame.create f in - let k = ref 0 in - List.iter - (fun scr -> - let k' = !k in - let b = - Button.create ~font ~text:(string_of_int (!k+1)) - ~command:(fun () -> current_screen := k'; redraw()) m2 in - if k' = !current_screen then - Button.configure - ~background:`Blue ~activebackground:`Blue ~foreground:`White b; - pack ~side:`Left [b]; - incr k - ) - !screens; - pack ~side:`Left [m2]; - let m3 = Frame.create f in - pack ~fill:`X ~expand:true ~side:`Left [ m3 ]; - let next_b = - Button.create ~font ~text:"Next" ~state:`Disabled - ~command:(fun () -> incr current_screen; redraw()) m3 in - pack ~side:`Right [next_b]; - if !current_screen < List.length !screens - 1 then - Button.configure ~state:`Normal next_b; - pack ~fill:`X [ f ] -;; - - -(**********************************************************************) - -let first_time = ref true;; - -let intro_screen frame = - add_headline frame "The Makefile and META wizard"; - add_para frame "This wizard helps you creating Makefiles and META \ -files for simple projects. It assumes that all your source files \ -reside in a single directory, and that all source files are O'Caml \ -files (no support for mixed O'Caml/C projects). ocamllex, ocamlyacc, \ -and camlp4 are supported."; - add_para frame "The wizard generates a Makefile, and the Makefile \ -produces the META file. The Makefile is not perfect, and is not the ideal \ -choice for everybody, but it is a starting point for your project. \ -You can later fine-tune the contents of the Makefile by adding your own rules, \ -and by overriding the definitions. The Makefile is commented, and not \ -overly complicated."; - add_para frame "The settings you enter here can be stored in a file \ -containing the state of the wizard. This file is called .make-wizard. \ -It is recommended to use this feature to save the state between the \ -wizard sessions."; - (* "" *) - - footer frame; - update(); - - if !first_time && Sys.file_exists ".make-wizard" then begin - match dialog ~parent:frame ~title:"Load .make-wizard?" - ~message:"Do you want to load the file .make-wizard, and continue your last session?" - ~buttons:[ "Yes, please load the file"; "No, start with empty fields" ] - ~default:0 - () - with - 0 -> load() - | _ -> () - end; - first_time := false; - -;; - - -add_screen intro_screen;; - -(**********************************************************************) - -let general_screen frame = - add_headline frame "General"; - add_para frame "Please enter the name of the package, the version number, \ -and the description first. The name must be a single, alphanumeric string \ -(including _ and -). The version is an arbitrary string, like the description. \ -All fields are mandatory."; (* "" *) - - label_box frame - [ "Package name: ", wiz_package_name; - "Package version: ", wiz_package_version; - "Package description: ", wiz_package_description ]; - footer frame -;; - -add_screen general_screen;; - -(**********************************************************************) - -let pkginfo lb row = (* when the user right-clicks at a listbox row *) - let pkg = Listbox.get lb (`Num row) in - let version = - try Findlib.package_property [] pkg "version" with Not_found -> "N/A" in - let description = - try Findlib.package_property [] pkg "description" with Not_found -> "N/A" - in - let popup = Toplevel.create !top in - Wm.transient_set popup ~master:(Winfo.toplevel !top); - let f = Frame.create popup in - let title = "About " ^ pkg ^ " (" ^ version ^ ")" in - add_headline f title; - Wm.title_set popup title; - add_para f ("Description: " ^ description); - add_para f "Modules:"; - let click sublb _ = - Listbox.selection_clear sublb ~first:(`Num 0) ~last:`End in - let (f_sublb, sublb) = scrolled_listbox ~click f in - let modules = - try - Fl_split.in_words - (Findlib.package_property [] pkg "browse_interfaces") - with - Not_found -> - let dir = Findlib.package_directory pkg in - let files = Array.to_list(Sys.readdir dir) in - List.map - (fun name -> - String.capitalize (Filename.chop_suffix name ".cmi")) - (List.filter - (fun name -> - Filename.check_suffix name ".cmi") - files - ) - in - Listbox.insert sublb ~index:`End ~texts:modules; - pack ~anchor:`W [ f_sublb ]; - pack ~anchor:`W [ f ]; - let close = Button.create ~text:"Close" ~font - ~command:(fun () -> destroy popup) f_sublb in - pack ~anchor:`Nw ~fill:`X [close] -;; - -(**********************************************************************) - -let preprocessor_scan_extensions() = - (* Find out all packages with a "preprocessor" predicate *) - let packages = Fl_package_base.list_packages() in - let plist = - List.filter - (fun pkg -> - try - let _ = - Findlib.package_property [ "preprocessor"; "syntax" ] pkg "archive" - in true - with - Not_found -> false - ) - packages in - (* Add all selected extensions, if they do not occur yet: *) - let plist' = - List.filter - (fun pkg -> - not (List.mem pkg plist) - ) - !wiz_camlp4_selected in - List.sort Pervasives.compare (plist @ plist') -;; - - -let preprocessor_screen frame = - add_headline frame "Preprocessing"; - add_para frame "Here you can specify whether your source files are \ -preprocessed by camlp4. Simply skip this page if you do not want to \ -invoke a preprocessor, or if you don't know what this means."; (* "" *) - - let frame'' = indented_cond_frame frame - [ wiz_enable_camlp4, "Enable camlp4" ] in - - let tv = string_tv frame'' wiz_camlp4_syntax in - let rb_o = Radiobutton.create - ~font ~text:"Standard syntax" ~variable:tv ~value:"camlp4o" - frame'' in - let rb_r = Radiobutton.create - ~font ~text:"Revised syntax" ~variable:tv ~value:"camlp4r" - frame'' in - pack ~anchor:`W [rb_o; rb_r]; - - add_para frame'' "Use the following packaged syntax extensions (click the \ -right mouse button to find out more about a package):"; (* "" *) - - if !wiz_camlp4_extensions = [] then - wiz_camlp4_extensions := preprocessor_scan_extensions(); - - let click lb row = (* when the user clicks at a listbox row *) - wiz_camlp4_selected := listbox_get_selection lb; - in - - let (f_lb,lb) = scrolled_listbox ~click ~context:pkginfo frame'' in - Listbox.insert lb ~index:`End ~texts:!wiz_camlp4_extensions; - listbox_select lb !wiz_camlp4_selected; - pack ~anchor:`W [f_lb]; - - let rescan = Button.create ~text:"Rescan" ~font - ~command:(fun () -> - wiz_camlp4_extensions := preprocessor_scan_extensions(); - Listbox.delete lb ~first:(`Num 0) ~last:`End; - Listbox.insert lb ~index:`End ~texts:!wiz_camlp4_extensions; - listbox_select lb !wiz_camlp4_selected; - ) - f_lb in - let clear = Button.create ~text:"Clear" ~font - ~command:(fun () -> - wiz_camlp4_selected := []; - listbox_select lb []) - f_lb in - - pack ~anchor:`Nw ~fill:`X [ rescan; clear ]; - - add_para frame'' "Specify here further options to the camlp4 invocation. \ -For example, you can load camlp4 modules like pa_ifdef.cmo, and pass the -D \ -options to it."; (* "" *) - - label_box frame'' [ "Camlp4 options: ", wiz_camlp4_options ]; - - footer frame -;; - -add_screen preprocessor_screen;; - -(**********************************************************************) - -let prerequisites_scan_packages() = - (* Find out all packages *) - List.sort Pervasives.compare (Fl_package_base.list_packages()) -;; - - -let prerequisites_screen frame = - add_headline frame "Prerequisites"; - add_para frame "If your modules use packages, you can specify these \ -prerequisites here. It is sufficient to select the packages on which \ -your modules depend directly. Indirect dependencies can be resolved \ -by findlib automatically. Click the right mouse button to find out \ -more about a package."; (* "" *) - - if !wiz_all_packages = [] then - wiz_all_packages := prerequisites_scan_packages(); - - let click lb row = (* when the user clicks at a listbox row *) - wiz_required_packages := listbox_get_selection lb; - in - - let (f_lb,lb) = scrolled_listbox ~height:18 ~click ~context:pkginfo frame in - Listbox.insert lb ~index:`End ~texts:!wiz_all_packages; - listbox_select lb !wiz_required_packages; - pack ~anchor:`W [f_lb]; - - let rescan = Button.create ~text:"Rescan" ~font - ~command:(fun () -> - wiz_all_packages := prerequisites_scan_packages(); - Listbox.delete lb ~first:(`Num 0) ~last:`End; - Listbox.insert lb ~index:`End ~texts:!wiz_all_packages; - listbox_select lb !wiz_required_packages; - ) - f_lb in - let clear = Button.create ~text:"Clear" ~font - ~command:(fun () -> - wiz_required_packages := []; - listbox_select lb []) - f_lb in - - pack ~anchor:`Nw ~fill:`X [ rescan; clear ]; - - footer frame -;; - -add_screen prerequisites_screen;; - -(**********************************************************************) - -let buildlib_scan_modules() = - let files = Array.to_list(Sys.readdir ".") in - let suffixes = Fl_split.in_words_ws !wiz_source_suffixes in - let files' = - List.filter - (fun f -> - List.exists (Filename.check_suffix f) suffixes - ) - files in - let files'' = - List.map - (fun f -> - String.capitalize (Filename.chop_extension f) - ) - files' in - remove_dups (List.sort Pervasives.compare files'') -;; - - -let buildlib_screen frame = - add_headline frame "Build Library"; - add_para frame "The next question is how to build the library, i.e. the \ -cma or cmxa archive. It is recommended to create such an archive even if \ -the real target of the build process is an executable, because you can load \ -it into the toploop at once. However, make sure that you do not put the \ -main program of the executable into the archive, as it is usually stripped \ -off from the executable, and nothing would happen when you start it."; -(* - add_para frame "You can select whether you want to create only a bytecode \ -archive, a native archive, or both. In the latter case, the simplest way \ -is to begin with the bytecode archive, and to copy your specification to \ -the native box by pressing the button \"Like bytecode\"."; - add_para frame "If you do not want to create an archive at all, \ -skip this page."; -*) -(* "" *) - - let frame' = indented_cond_frame frame - [ wiz_byte_enable, "Enable bytecode archive"; - wiz_nat_enable, "Enable native archive"; ] in - add_para frame' "Move the available modules to the right-hand box in the required order."; - - let update = - double_listbox frame' (ref wiz_available) (ref wiz_objects) buildlib_scan_modules in - - add_para frame "By default, only the suffixes .ml, .mli, .mll, and .mly are used to recognize source code files. You can add here additional suffixes (this requires that you extend the Makefile by your own rules)."; - - label_box frame [ "Source code suffixes: ", wiz_source_suffixes ]; - - footer frame -;; - -add_screen buildlib_screen;; - -(**********************************************************************) - -let enter_name parent followup = - let popup = Toplevel.create parent in - let title = "New Executable" in - Wm.transient_set popup ~master:(Winfo.toplevel parent); - Wm.title_set popup title; - let frame = Frame.create popup in - pack [frame]; - add_headline frame title; - add_para frame "Of course, the new executable must have a name."; - let name = ref "" in - label_box frame [ "Name: ", name ]; - pack [ Frame.create ~height:10 frame ]; - let buttons = Frame.create frame in - let ok_b = Button.create ~font ~text:"OK" - ~command:(fun () -> destroy popup; followup !name) buttons in - let cancel_b = Button.create ~font ~text:"Cancel" - ~command:(fun () -> destroy popup) buttons in - pack ~side:`Left [ ok_b; cancel_b ]; - pack [buttons] -;; - - -let buildexec_screen frame = - add_headline frame "Build Executables"; - add_para frame "You can specify the executables to build in the following \ -way. Press \"New\" and enter the name of the excutable, then add the modules \ -to link in the box that appears. The cma/cmxa archive from the previous \ -screen is linked anyway, so its modules cannot be selected again."; - add_para frame "Leave the list of executables empty if you do not want to \ -build any."; - (* "" *) - - let update_listbox = ref (fun () -> ()) in - let show = ref (fun _ -> ()) in - let hide = ref (fun _ -> ()) in - - let click lb row = - let name = Listbox.get lb ~index:(`Num row) in - !show name - in - - let newexec() = - enter_name - frame - (fun name -> - (* This function is called after the user pressed "OK" *) - if List.mem name !wiz_executables then begin - (* It is not allowed to enter the same name twice *) - ignore( - dialog ~parent:frame ~title:"Already exists" - ~message:"This name already exists!" ~buttons:["OK"] ()) - end - else begin - wiz_executables := - List.sort Pervasives.compare (name :: !wiz_executables); - wiz_exec_objects := (name, ref []) :: !wiz_exec_objects; - wiz_exec_native := (name, ref false) :: !wiz_exec_native; - !update_listbox(); - !show name - end - ) - in - - let remexec lb () = - let sel = listbox_get_selection lb in - if sel = [] then begin - ignore( - dialog ~parent:frame ~title:"Nothing selected" - ~message:"Select the executable to remove first!" ~buttons:["OK"] ()) - end - else begin - wiz_executables := - List.filter (fun n -> not (List.mem n sel)) !wiz_executables; - wiz_exec_objects := - List.filter (fun (n,_) -> not (List.mem n sel)) !wiz_exec_objects; - wiz_exec_native := - List.filter (fun (n,_) -> not (List.mem n sel)) !wiz_exec_native; - !update_listbox(); - !hide() - end - in - - let (f_lb,lb) = scrolled_listbox ~click ~height:3 frame in - Listbox.configure ~selectmode:`Single lb; - Listbox.insert lb ~index:`End ~texts:!wiz_executables; - pack ~anchor:`W [f_lb]; - - let new_b = - Button.create ~font ~text:"New" ~command:newexec f_lb in - let remove_b = - Button.create ~font ~text:"Remove" ~command:(remexec lb) f_lb in - - pack ~anchor:`Nw ~fill:`X [ new_b; remove_b ]; - - let f1 = Frame.create frame in - pack [f1]; - let frame' = Frame.create f1 in - let frame'_packed = ref false in - let modbox_available = ref (ref []) in - let modbox_objects = ref (ref []) in - let modbox_scan() = - let mlist = buildlib_scan_modules() in - List.filter - (fun m -> not (List.mem m !wiz_objects)) mlist - in - add_para frame' "Move the available modules to the right-hand box in the required order."; - let update_modbox = - double_listbox frame' modbox_available modbox_objects modbox_scan in - - add_para frame' "Select the type of the executable:"; - let radio = Frame.create frame' in - let type_ref = ref false in - let type_ref_ref = ref type_ref in - let type_tv = bool_tv - ~onchange:(fun () -> !type_ref_ref := !type_ref) - frame' type_ref in - let byte_r = Radiobutton.create ~font ~text:"Bytecode executable" - ~variable:type_tv ~value:"0" radio in - let nat_r = Radiobutton.create ~font ~text:"Native executable" - ~variable:type_tv ~value:"1" radio in - pack ~side:`Left [byte_r; nat_r ]; - pack ~anchor:`W [radio]; - let update_radio() = - Textvariable.set type_tv (if !!type_ref_ref then "1" else "0") - in - - footer frame; - - update_listbox := (fun () -> - Listbox.delete lb ~first:(`Num 0) ~last:`End; - Listbox.insert lb ~index:`End ~texts:!wiz_executables; - ); - show := (fun name -> - let k = find_pos name !wiz_executables in - Listbox.selection_clear lb ~first:( `Num 0 ) ~last:`End; - Listbox.selection_set lb ~first:(`Num k) ~last:(`Num k); - if not !frame'_packed then ( - pack [frame']; - frame'_packed := true; - ); - modbox_objects := List.assoc name !wiz_exec_objects; - type_ref_ref := List.assoc name !wiz_exec_native; - update_modbox(); - update_radio() - ); - hide := (fun () -> - if !frame'_packed then ( - Pack.forget [frame']; - frame'_packed := false; - ); - ) -;; - -add_screen buildexec_screen;; - -(**********************************************************************) - -let generate_screen frame = - add_headline frame "Generate Makefile"; - add_para frame "Finally, the Makefile can be generated from your inputs. \ -You can set the name of the Makefile to a non-standard name. Furthermore, \ -you can specify a second file that will be appended to the generated Makefile, \ -this is useful to extend the Makefile rules by your own additions."; - (* "" *) - - label_box frame [ "Name of Makefile: ", wiz_makefile_name; - "Local extensions in: ", wiz_local_makefile_name ; - "Default target of 'make': ", wiz_make_default; - ]; - - add_para frame ""; - - let show_b = - Button.create ~font ~text:"Show Makefile" - ~command:(fun () -> - let maketext = makemake() in - let popup = Toplevel.create frame in - Wm.title_set popup "Generated Makefile"; - add_headline popup "Generated Makefile"; - let t = Text.create ~width:80 ~height:25 popup in - pack [t]; - Text.insert ~index:(`End,[]) ~text:maketext t; - ) - frame in - let save_b = - Button.create ~font ~text:"Save Makefile" - ~command:(fun () -> - let maketext = makemake() in - let cont = - not (Sys.file_exists !wiz_makefile_name) || ( - dialog ~parent:frame ~title:"File already exists" - ~message:("The file " ^ !wiz_makefile_name ^ - " already exists. Overwrite?") - ~buttons:[ "OK"; "Cancel" ] () = 0) in - if cont then begin - let f = open_out !wiz_makefile_name in - output_string f maketext; - close_out f - end - ) - frame in - - pack [show_b; save_b]; - - add_headline frame "Quit"; - - add_para frame "The following button quits the wizard. You are asked whether you want to save the state first."; - - let quit_b = - Button.create ~font ~text:"Finish & Quit" - ~command:(fun () -> - if ask_and_save frame then destroy !top) - frame in - - - - pack [show_b; quit_b]; - - footer frame -;; - -add_screen generate_screen;; - - -(**********************************************************************) - -Findlib.init(); -top := openTk(); -(* current_screen := 5; *) -Wm.title_set !top "findlib/make-wizard"; -Wm.protocol_set !top ~name:"WM_DELETE_WINDOW" - ~command:(fun () -> if ask_and_save !top then destroy !top); -Toplevel.configure ~width:(pixels(`Pt 450.0)) - ~height:(pixels (`Pt 650.0)) (Winfo.toplevel !top); -Pack.propagate_set !top false; -topframe := coe(Frame.create !top); -redraw(); -mainLoop();; - - -(* ====================================================================== - * History: - * - * $Log: make_wizard.ml,v $ - * Revision 1.3 2002/09/22 20:12:35 gerd - * Renamed modules (prefix fl_) - * - * Revision 1.2 2002/07/29 19:52:23 gerd - * Fixes for O'Caml 3.05 - * - * Revision 1.1 2002/05/26 14:09:07 gerd - * Renaming - * - * Revision 1.1 2002/05/05 20:40:26 gerd - * Initial revision - * - * - *) diff --git a/src/findlib-toolbox/make_wizard.pattern b/src/findlib-toolbox/make_wizard.pattern deleted file mode 100644 index 90116e9..0000000 --- a/src/findlib-toolbox/make_wizard.pattern +++ /dev/null @@ -1,494 +0,0 @@ -## $Id$ -## ---------------------------------------------------------------------- -## - -## This is the pattern for the Makefile. It consists of several sections, -## every section begins with [name] on a single line, and ends where the -## next section starts. Inside the sections, variables are written as -## [name], too. -## Comments that must not be copied to the output file begin with two -## hash marks. - -[intro] -# ---------------------------------------------------------------------- -# How to build the package [name]: -# ---------------------------------------------------------------------- -# -# make: Same as "make all" -# make all: Normally "make byte", but can also be set to "make opt" -# make byte: Makes the bytecode archive and the bytecode executables -# make opt: Makes the native archive and the native executable -# make install: Install all installable files as package -# make uninstall: Uninstall the package -# make clean: Delete all files that can be remade -# -# The usual order of invocation is: -# - make byte -# - (optionally) make opt -# - make install -# - make clean -# -# You may want to give the -s option if you do not want to see the details -# of the build process (e.g. make -s all). -# -# ---------------------------------------------------------------------- -# Important for developers -# ---------------------------------------------------------------------- -# -# This Makefile writes a copy of itself with appended dependencies. -# The copy is usually stored in the file .make-wizard.[makefile_name]. -# If you want to invoke "make" for targets where the dependencies are -# involved, you have to specify -f .make-wizard.[makefile_name] on -# the command line, e.g. -# -# make -f .make-wizard.[makefile_name] sample.cmo -# -# Otherwise, the dependencies are ignored, and you get errors that are -# hard to explain. -# -# If you want to modify this Makefile, it is a good idea to put the -# modifications into a second file, and to enable the local Makefile -# extension in the wizard. This effects that the modifications are appended -# to this Makefile, so you can add rules and override variables without -# coming into conflict with the wizard. - -[def_general] -# ---------------------------------------------------------------------- -# Definitions -# ---------------------------------------------------------------------- - -NAME = [name] -# The name of the package. - -MFNAME = [makefile_name] -# The name of this Makefile. (You must change this definition if you rename -# the Makefile!) - -MF2NAME = .make-wizard.$(MFNAME) -# The name of the generated Makefile (a copy of this Makefile plus the -# dependencies) - -TEMPNAME = .make-wizard.temps -# The name of a file containing the names of temporary files - -VERSION = [version] -# The version of this package - -DESCRIPTION = [description] -# The description of this package - -GENERATOR_EXTS = .mll .mly -# These suffixes indicate that a generator must be called for them - -MAKE_META = _meta -# Make the META file by this rule. (An empty definition turns META generation -# off.) - -INSTALL = _findlib_install -# Which rule to use for installation - -UNINSTALL = _findlib_uninstall -# Which rule to use for deinstallation - -MAKEMAKE_HOOK = -# Set this to the name of a rule to add your own definitions to $(MF2NAME) - - -## The def_byte_archive section is only included if the byte archive is -## enabled: - -[def_byte_archive] -BYTE_ARCHIVE = $(NAME).cma -# The name of the resulting bytecode archive. - -BYTE_OBJECTS = [byte_objects] -# The cmo objects that are linked together, and are put into the byte archive. - -BYTE_FILES = $(BYTE_OBJECTS) $(BYTE_OBJECTS:.cmo=.cmi) $(BYTE_ARCHIVE) -# The files that are generated in order to make the byte archive. Note -# that .ml and .mli files are missing that are generated from -# .mly and .mll files. - -BYTE_INST = $(BYTE_OBJECTS:cmo=cmi) $(BYTE_OBJECTS:.cmo=.mli) $(BYTE_ARCHIVE) -# The files that will be installed after the byte archive is made. Not -# every file exists. - - -## The def_native_archive section is only included if the native archive is -## enabled: - -[def_native_archive] -NAT_ARCHIVE = $(NAME).cmxa -# The name of the resulting native archive. - -NAT_OBJECTS = [nat_objects] -# The cmx objects that are linked together, and are put into the native archive. - -NAT_FILES = $(NAT_OBJECTS) $(NAT_OBJECTS:.cmx=.o) $(NAT_OBJECTS:.cmo=.cmi) \ - $(NAT_ARCHIVE) $(NAT_ARCHIVE:.cmxa=.a) -# The files that are generated in order to make the native archive. Note -# that .ml and .mli files are missing that are generated from -# .mly and .mll files. - -NAT_INST = $(NAT_OBJECTS:.cmo=.cmi) $(NAT_OBJECTS:.cmo=.mli) $(NAT_ARCHIVE) \ - $(NAT_ARCHIVE:.cmxa=.a) -# The files that will be installed after the native archive is made. Not -# every file exists. - - -[def_byte_exec] -BYTE_EXEC_TARGETS = [byte_executables] -# The list of bytecode executables. - -BYTE_EXEC_OBJECTS = [byte_exec_objects] -# The list of cmo modules that are linked into bytecode executables - -BYTE_EXEC_FILES = $(BYTE_EXEC_OBJECTS) $(BYTE_EXEC_OBJECTS:.cmo=.cmi) \ - $(BYTE_EXEC_TARGETS) -# The list of files that are generated in order to make the bytecode -# executables. Note that .ml and .mli files are missing that are generated -# from .mly and .mll files. - -BYTE_EXEC_INST = $(BYTE_EXEC_TARGETS) -# The files to install as bytecode executables. - - -[def_nat_exec] -NAT_EXEC_TARGETS = [nat_executables] -# The list of native executables. - -NAT_EXEC_OBJECTS = [nat_exec_objects] -# The list of cmx modules that are linked into native executables - -NAT_EXEC_FILES = $(NAT_EXEC_OBJECTS) $(NAT_EXEC_OBJECTS:.cmx=.cmi) \ - $(NAT_EXEC_OBJECTS:.cmx=.o) $(NAT_EXEC_TARGETS) -# The list of files that are generated in order to make the native -# executables. Note that .ml and .mli files are missing that are generated -# from .mly and .mll files. - -NAT_EXEC_INST = $(NAT_EXEC_TARGETS) -# The files to install as native executables. - - -[def_props] -PREREQUISITES = [prereqs] -# The required packages. - -PPOPTS = [ppopts] -# Preprocessor options. - -MTOPTS = [mtopts] -# Multi-threading options - -INCOPTS = -# -I options (currently unused, but this may change in the future) - -OTHER_INST = META -# Files to install that are not mentioned in the other XXX_INST variables - -#TASKBYTELINKOPTS = -custom -# Uncomment this line to create stand-alone executables - -[def_tools] -# Tools and tasks: "Tools" are the commands to call, and "tasks" are the tools -# to use for certain situations. - -OCAMLFIND = ocamlfind -OCAMLLEX = ocamllex -OCAMLYACC = ocamlyacc -OCAMLDEP = $(OCAMLFIND) ocamldep -OCAMLC = $(OCAMLFIND) ocamlc -OCAMLCP = $(OCAMLFIND) ocamlcp -OCAMLOPT = $(OCAMLFIND) ocamlopt -# -# These are the tools. - -TASKLEX = $(OCAMLLEX) $(TASKLEXOPTS) -TASKYACC = $(OCAMLYACC) $(TASKYACCOPTS) -TASKDEP = $(OCAMLDEP) $(INCOPTS) $(PPOPTS) -package "$(PREREQUISITES)" $(TASKDEPOPTS) -TASKCI = $(OCAMLC) $(INCOPTS) $(PPOPTS) -package "$(PREREQUISITES)" -c $(TASKCIOPTS) -TASKBYTECO = $(OCAMLC) $(INCOPTS) $(PPOPTS) $(MTOPTS) -package "$(PREREQUISITES)" -c -g $(TASKBYTECOOPTS) -TASKBYTELINK = $(OCAMLC) $(INCOPTS) $(PPOPTS) $(MTOPTS) -package "$(PREREQUISITES)" -linkpkg $(TASKBYTELINKOPTS) -TASKBYTEAR = $(OCAMLC) -a $(TASKBYTEAROPTS) -TASKNATCO = $(OCAMLOPT) $(INCOPTS) $(PPOPTS) $(MTOPTS) -package "$(PREREQUISITES)" -c $(TASKNATCOOPTS) -TASKNATLINK = $(OCAMLOPT) $(INCOPTS) $(PPOPTS) $(MTOPTS) -package "$(PREREQUISITES)" -linkpkg $(TASKNATLINKOPTS) -TASKNATAR = $(OCAMLOPT) -a $(TASKNATAROPTS) -TASKINSTALL = $(OCAMLFIND) install $(NAME) $(TASKINSTALLOPTS) -TASKREMOVE = $(OCAMLFIND) remove $(NAME) $(TASKREMOVEOPTS) -# -# These are the tasks. The names mean the following: -# TASKLEX: Used to create a lexer -# TASKYACC: Used to create a parser -# TASKDEP: Used to analyze the dependencies -# TASKCI: Used to compile interface files -# TASKBYTECO, TASKNATCO: Used to compile implementation files -# TASKBYTELINK, TASKNATLINK: Used to create executables -# TASKBYTEAR, TASKNATAR: Used to create archives -# TASKINSTALL: Used to install the package -# TASKREMOVE: Used to remove the package -# INCOPTS: -I options -# PPOPTS: Options to specify the preprocessor -# MTOPTS: -thread (if necessary) -# NATONLY: -native (if necessary) -# For every task , there is a variable for task-specific options OPTS. - - -[rules] -# ---------------------------------------------------------------------- -# Rules -# ---------------------------------------------------------------------- - - -[default_target] -.PHONY: all -all: [default_target] - - -[suffix_rules] -# The suffix rules: They specify how to make a file ending in suffix X from -# a source file ending in suffix Y. For every suffix rule, there is a task -# defining what to do. - -.SUFFIXES: .ml .mli .cmo .cmx .cmi .mll .mly - -.mli.cmi: - @echo "" - $(TASKCI) $< - -.ml.cmo: - @echo "" - $(TASKBYTECO) $< - -.ml.cmx: - @echo "" - $(TASKNATCO) $< - -# The generator rules record the generated files: The "grep" checks whether -# the filename already occurs in $(TEMPNAME), and the "echo" appends the -# filename when missing. - -.mll.ml: - @echo "" - $(TASKLEX) $< - touch $(TEMPNAME) - grep -F -x -q -e "$@" $(TEMPNAME) || echo "$@" >>$(TEMPNAME) - -.mly.ml: - @echo "" - $(TASKYACC) $< - touch $(TEMPNAME) - grep -F -x -q -e "$@" $(TEMPNAME) || echo "$@" >>$(TEMPNAME) - -# The _dummy rule does nothing: - -_dummy: - : - -[generate] -# The following rule checks which lex and yacc targets exist, and calls -# MAKE recursively. - -.PHONY: _meta -_meta: - @echo "" - echo "name = \"$(NAME)\"" >META - echo "version = \"$(VERSION)\"" >>META - echo "description = \"$(DESCRIPTION)\"" >>META - echo "requires = \"$(PREREQUISITES)\"" >>META - test -z "$(BYTE_ARCHIVE)" || \ - echo "archive(byte) = \"$(BYTE_ARCHIVE)\"" >>META - test -z "$(NAT_ARCHIVE)" || \ - echo "archive(native) = \"$(NAT_ARCHIVE)\"" >>META - -.PHONY: _generator -_generator: $(MAKE_META) - @echo "" - targets=$$( \ - { \ - for obj in _dummy $(BYTE_OBJECTS) $(BYTE_EXEC_OBJECTS); do \ - test "_dummy" != "$$obj" || continue; \ - for ext in $(GENERATOR_EXTS); do \ - if [ -f "$${obj%.cmo}$$ext" ]; then \ - echo "$${obj%.cmo}.ml"; \ - fi; \ - done; \ - done && \ - for obj in _dummy $(NAT_OBJECTS) $(NAT_EXEC_OBJECTS); do \ - test "_dummy" != "$$obj" || continue; \ - for ext in $(GENERATOR_EXTS); do \ - if [ -f "$${obj%.cmx}$$ext" ]; then \ - echo "$${obj%.cmx}.ml"; \ - fi; \ - done; \ - done; \ - } | sort | uniq \ - ) && \ - { test -z "$$targets" || $(MAKE) -f $(MFNAME) $$targets; } - -# The following rule calls ocamldep for the right files, and creates -# a file that consists of the contents of this Makefile, and of the output -# of ocamldep. - -.PHONY: _makemake -_makemake: _generator - @echo "" - cat $(MFNAME) >$(MF2NAME) - test -z "$(MAKEMAKE_HOOK)" || $(MAKE) -f $(MFNAME) $(MAKEMAKE_HOOK) - echo "# ---------------------------------------- dependencies:" >>$(MF2NAME) - targets=$$( \ - { \ - nat=-native-filter && \ - byte=-bytecode-filter && \ - for obj in _dummy $(BYTE_OBJECTS); do \ - test "_dummy" != "$$obj" || continue; \ - echo "$${obj%.cmo}.ml"; \ - echo "$${obj%.cmo}.mli"; \ - nat=""; \ - done && \ - for obj in _dummy $(NAT_OBJECTS); do \ - test "_dummy" != "$$obj" || continue; \ - echo "$${obj%.cmx}.ml"; \ - echo "$${obj%.cmx}.mli"; \ - byte=""; \ - done; \ - echo "$$byte $$nat"; \ - } | sort | uniq \ - ) && \ - $(TASKDEP) $$targets >>$(MF2NAME) -## The following section is appended to _makemake for every executable: -[makemake_exec] - echo "# --- dependencies for [execname]:" >>$(MF2NAME) - $(TASKDEP) [switches] [deptargets] >>$(MF2NAME) -## Begin next section immediately to avoid empty lines: -[dummy] - -[byte] - - -.PHONY: byte -byte: _byte - -.PHONY: _byte -_byte: _makemake - @echo "" - if [ -n "$(BYTE_ARCHIVE)" ]; then \ - $(MAKE) -f $(MF2NAME) $(BYTE_ARCHIVE); \ - fi - if [ -n "$(BYTE_EXEC_TARGETS)" ]; then \ - $(MAKE) -f $(MF2NAME) $(BYTE_EXEC_TARGETS); \ - fi - @echo "" - - -[opt] -.PHONY: opt -opt: _opt - -.PHONY: _opt -_opt: _makemake - @echo "" - if [ -n "$(NAT_ARCHIVE)" ]; then \ - $(MAKE) -f $(MF2NAME) $(NAT_ARCHIVE); \ - fi - if [ -n "$(NAT_EXEC_TARGETS)" ]; then \ - $(MAKE) -f $(MF2NAME) $(NAT_EXEC_TARGETS); \ - fi - @echo "" - - -[byte_archive] -$(BYTE_ARCHIVE): $(BYTE_OBJECTS) - @echo "" - $(TASKBYTEAR) -o $(BYTE_ARCHIVE) $(BYTE_OBJECTS) - - -[native_archive] -$(NAT_ARCHIVE): $(NAT_OBJECTS) - @echo "" - $(TASKNATAR) -o $(NAT_ARCHIVE) $(NAT_OBJECTS) - - -## The following section is included for every bytecode executable again. - -[byte_exec] -[execname]: $(BYTE_ARCHIVE) [execobjs] - @echo "" - $(TASKBYTELINK) -o [execname] $(BYTE_ARCHIVE) [execobjs] - - -[nat_exec] -[execname]: $(NAT_ARCHIVE) [execobjs] - @echo "" - $(TASKNATLINK) -o [execname] $(NAT_ARCHIVE) [execobjs] - - -[clean] -.PHONY: clean -clean: - @echo "" - touch $(TEMPNAME) - rm -f $(BYTE_FILES) $(NAT_FILES) $(BYTE_EXEC_FILES) $(NAT_EXEC_FILES) - rm -f $(MF2NAME) - cat $(TEMPNAME) | xargs rm -f - rm -f $(TEMPNAME) - -.PHONY: CLEAN -CLEAN: clean - -.PHONY: distclean -distclean: clean - - -[install] -.PHONY: install -install: $(INSTALL) - -.PHONY: _findlib_install -_findlib_install: - @echo "" - files=$$( \ - for f in $(BYTE_INST) $(NAT_INST) $(BYTE_EXEC_INST) $(NAT_EXEC_INST) $(OTHER_INST); do \ - if [ -f "$$f" ]; then echo $$f; fi; \ - done; \ - ) && \ - $(TASKINSTALL) $$files - -.PHONY: uninstall -uninstall: $(UNINSTALL) - -.PHONY: _findlib_uninstall -_findlib_uninstall: - @echo "" - $(TASKREMOVE) - -# The following rules just print some variables. - -.PHONY: _print_name -_print_name: - echo "$(NAME)" - -.PHONY: _print_version -_print_version: - echo "$(VERSION)" - -[local] -# ---------------------------------------------------------------------- -# Local additions -# ---------------------------------------------------------------------- - -[trailer] -## ====================================================================== -## History: -## -## $Log: make_wizard.pattern,v $ -## Revision 1.2 2003/01/13 00:37:45 gerd -## Bugfix NATIVE_ARCHIVE ==> NAT_ARCHIVE (reported by -## Matt Gushee) -## -## Revision 1.1 2002/05/26 14:09:07 gerd -## Renaming -## -## Revision 1.1 2002/05/05 20:40:26 gerd -## Initial revision -## -## diff --git a/src/findlib-toolbox/selected.xpm b/src/findlib-toolbox/selected.xpm deleted file mode 100644 index 6b7ff72..0000000 --- a/src/findlib-toolbox/selected.xpm +++ /dev/null @@ -1,6 +0,0 @@ -#define selected_width 16 -#define selected_height 16 -static unsigned char selected_bits[] = { - 0x55, 0x55, 0x00, 0x80, 0x01, 0x1c, 0x00, 0x82, 0x01, 0x02, 0x00, 0x81, - 0x01, 0x01, 0x80, 0x80, 0x81, 0x00, 0x98, 0x80, 0xa1, 0x00, 0xa0, 0x80, - 0xc1, 0x00, 0xc0, 0x80, 0x01, 0x00, 0xaa, 0xaa}; diff --git a/src/findlib-toolbox/tree_editor.ml b/src/findlib-toolbox/tree_editor.ml deleted file mode 100644 index a40becf..0000000 --- a/src/findlib-toolbox/tree_editor.ml +++ /dev/null @@ -1,1008 +0,0 @@ -(* $Id$ - * ---------------------------------------------------------------------- - * - *) - - -module Filesys = struct - - let join_path path = - if path = [ "" ] then - "/" - else - String.concat "/" path (* TODO *) - - - let split_re = Str.regexp "/" (* TODO *) - - let split_path s = - Str.split split_re s - - - let list path = - let path_name = join_path path in - let d = Unix.opendir path_name in - let l = ref [] in - try - while true do - let e = Unix.readdir d in - if e <> "." && e <> ".." then - l := e :: !l - done; assert false - with - End_of_file -> - Unix.closedir d; - List.sort Pervasives.compare !l - | err -> - Unix.closedir d; - raise err - - let is_directory path = - let path_name = join_path path in - try - (Unix.lstat path_name).Unix.st_kind = Unix.S_DIR - with - _ -> false - - let is_container path = - let path_name = join_path path in - try - (Unix.stat path_name).Unix.st_kind = Unix.S_DIR - with - _ -> false - -end -;; - -module Filetree_dlg = struct - open Lx_tree.Types;; - open Tk;; - open Widget;; - - - type node = - { path : string list; - mutable name : string; - } - - let some = function Some x -> x | None -> assert false - - let selected = ref [] - let name_tv = lazy(Textvariable.create()) - - let listbox = ref None - let dir_label = ref None - let ok_button = ref None - let cb_enable_ok = ref (fun _ -> true) - - let update_ok_button() = - let dir = Filesys.join_path !selected in - let name = Textvariable.get (Lazy.force name_tv) in - prerr_endline ("Name: " ^ name); - let en = !selected <> [] && name <> "" && - !cb_enable_ok (Filename.concat dir name) in - Button.configure - ~state:(if en then `Normal else `Disabled) (some !ok_button) - - let update_listbox d = - (* Fill listbox: *) - let files = Filesys.list [d] in - let reg_files = - List.filter (fun file -> not(Filesys.is_container [d;file])) files in - Listbox.delete (some !listbox) ~first:(`Num 0) ~last:`End; - Listbox.insert (some !listbox) ~index:`End ~texts:reg_files; - (* Set label: *) - Label.configure ~text:(d ^ ":") (some !dir_label) - - let node_action tw tree ev evinfo = - selected := tree.node.path; - Lx_tree.update tw; - let dir = Filesys.join_path tree.node.path in - update_listbox dir; - update_ok_button() - - let display_node tw tree = - let (foreground,background) = - if tree.node.path = !selected then - (Some `White, Some `Blue) - else - (None, None) - in - - Lx_tree.display_text - ?foreground ?background - ~events:[ `ButtonPress ] ~action:node_action tree.node.name - - let rescan_node tw tree = - let files = Filesys.list tree.node.path in - let subnodes = - List.map - (fun name -> - { path = tree.node.path @ [name]; - name = name; - } - ) - files in - let dirs = List.filter - (fun n -> Filesys.is_container n.path) - subnodes in - let subtrees = - List.map - (fun n -> - { node = n; - children = []; - show = false; - scanned = false; - interactive = true; - } - ) - dirs in - tree.children <- subtrees - - let rec make_tree_from_path ?(loc = []) p = - match p with - p1 :: pr -> - { node = { path = loc @ [p1]; - name = p1; - }; - children = (if pr = [] then [] else - [ make_tree_from_path ~loc:(loc@[p1]) pr ]); - show = true; - scanned = true; - interactive = true; - } - | [] -> - assert false - - let open_dialog ?(title = "Browse...") ?(enable_ok = fun _ -> true) parent = - selected := []; - Textvariable.set (Lazy.force name_tv) ""; - - let top = Toplevel.create parent in - Wm.transient_set top ~master:parent; - Wm.title_set top title; - - cb_enable_ok := enable_ok; - - let l1 = Label.create ~text:"Directories:" top in - pack ~anchor:`W [ l1 ]; - - let dir_tree = - make_tree_from_path ("" :: Filesys.split_path (Sys.getcwd())) in - dir_tree.node.name <- ""; - - let tframe = Frame.create top in - - let tw = Lx_tree.create - ~display:display_node ~rescan:rescan_node ~width:300 ~height:300 - dir_tree - tframe in - let sbar = Scrollbar.create ~orient:`Vertical tframe in - let canvas = Lx_tree.canvas tw in - Canvas.configure ~yscrollcommand:(Scrollbar.set sbar) ~relief:`Sunken - ~borderwidth:3 canvas; - Scrollbar.configure ~command:(Canvas.yview canvas) sbar; - - pack ~side:`Left ~fill:`Both ~expand:true [canvas]; - pack ~side:`Left ~fill:`Y [ sbar]; - pack ~anchor:`W ~fill:`X [tframe]; - - (* Listbox *) - let lab = Label.create ~text:(" ") top in - let lbf = Frame.create top in - let lb = Listbox.create ~height:10 ~font:"fixed" ~exportselection:false - lbf in - let lbs = Scrollbar.create lbf in - Listbox.configure ~yscrollcommand:(Scrollbar.set lbs) lb; - Scrollbar.configure ~command:(Listbox.yview lb) lbs; - pack ~anchor:`W [lab]; - pack ~anchor:`W ~fill:`X [lbf]; - pack ~side:`Left ~expand:true ~fill:`X [lb]; - pack ~side:`Left ~fill:`Y [lbs]; - listbox := Some lb; - dir_label := Some lab; - - (* Entry: *) - let lab' = Label.create ~text:"Filename:" top in - let ent = Entry.create ~font:"fixed" - ~textvariable:(Lazy.force name_tv) top in - pack ~anchor:`W [lab']; - pack ~anchor:`W ~fill:`X [ent]; - - (* Link listbox and entry: *) - Tk.bind ~events:[ `ButtonReleaseDetail 1 ] - ~action:(fun _ -> - match Listbox.curselection lb with - [] -> () - | hd :: _ -> - let s = Listbox.get lb ~index:hd in - Textvariable.set (Lazy.force name_tv) s; - update_ok_button() - ) - lb; - Tk.bind ~events:[ `KeyPress ] - ~action:(fun _ -> - Timer.set ~ms:0 ~callback:update_ok_button) - ent; - - let result = ref None in - - let buttons = Frame.create top in - let ok_b = Button.create ~text:"OK" - ~state:`Disabled - ~command:(fun _ -> - let name = Textvariable.get (Lazy.force name_tv) in - if name <> "" then begin - result := Some (Filesys.join_path !selected, - name); - Tk.destroy top - end else Bell.ring() ) - buttons in - let cancel_b = Button.create ~text:"Cancel" - ~command:(fun _ -> Tk.destroy top) - buttons in - - pack ~expand:true ~fill:`X [buttons]; - pack ~side:`Left [ ok_b; cancel_b ]; - ok_button := Some ok_b; - - Grab.set top; - Tkwait.window top; - - !result - (* returns None if canceled, or Some (dir, name) *) - -end -;; - - -module S = struct - type t = string - let compare = compare -end -;; - - -module StringSet = Set.Make(S) -;; - - -open Lx_tree.Types;; -open Tk;; -open Widget;; - - -let some = Filetree_dlg.some;; - -type filetype = - Regular - | Directory - | Absent -;; - - -type node = - { path : string list; - name : string; (* last component of [path] *) - mutable is_dir : bool; (* from file list *) - mutable selected : bool; (* from file list *) - mutable realtype : filetype; (* from file system *) - } -;; - -type file_tree = node tree ;; - -type state = - { mutable current_directory : string; - mutable list_file : string; (* relative to current_directory *) - mutable tree_widget : node tree_widget option; - mutable info_widget : label widget option; - mutable dir_context_menu : menu widget option; - mutable dir_context_suffix_menu : menu widget option; - mutable dir_context_unsuffix_menu : menu widget option; - mutable file_context_menu : menu widget option; - mutable context_menu_tree : node tree; - mutable modified : bool; - topwdg : toplevel widget; - workframe : frame widget; - directory_xpm : image; - selected_xpm : image; - unselected_xpm : image; - mutable display : node tree_widget -> file_tree -> node display_item; - } -;; - - -let dummy_tree = - { node = { path = []; - name = ""; - is_dir = false; - selected = false; - realtype = Regular; - }; - children = []; - show = false; - scanned = false; - interactive = false; - } -;; - - -let rescan_node tw tree = - let files = Filesys.list tree.node.path in - let missing_files = - List.map - (fun child -> child.node.name) - (List.filter - (fun child -> - child.node.selected && not(List.mem child.node.name files) - ) - tree.children - ) - in - let all_files = List.sort compare (files @ missing_files) in - let old_children = tree.children in - let new_children = - List.map - (fun filename -> - try - (* maybe the new child is the old child: *) - List.find - (fun old_child -> old_child.node.name = filename) - old_children - with - Not_found -> - let new_path = tree.node.path @ [filename] in - let is_dir = Filesys.is_directory new_path in - let new_tree = - { node = { path = new_path; - name = filename; - is_dir = is_dir; - selected = false; - realtype = Regular; (* Will be updated below *) - }; - children = []; - scanned = not is_dir; - show = false; - interactive = true; - } in - new_tree - ) - all_files - in - (* Update the [realtype] flag: *) - List.iter - (fun child -> - child.node.realtype <- - if List.mem child.node.name files then - (if Filesys.is_directory child.node.path then Directory else Regular) - else - Absent - ) - new_children; - (* Store the result: *) - tree.children <- new_children -;; - - -let rec selected_files_exist tree = - tree.node.selected || selected_files_exist_in_children tree - -and selected_files_exist_in_children tree = - List.exists selected_files_exist tree.children -;; - - -let rec expand ?(all = false) tw tree = - let show = - tree.node.is_dir && (all || selected_files_exist_in_children tree) in - tree.show <- tree.show || show; - if show then rescan_node tw tree; - List.iter (fun child -> expand ~all tw child) tree.children -;; - - -let rec collapse tw tree = - tree.show <- false; - List.iter (fun child -> collapse tw child) tree.children -;; - - -let suffix_re = Str.regexp "\\.[^.]+$";; - -let rec find_suffixes ?(recursive = false) tw tree = - assert(tree.node.is_dir); - rescan_node tw tree; (* questionable *) - tree.show <- true; - let files = - List.map - (fun ch -> ch.node.name) - tree.children in - let suff = - List.filter - (fun s -> - s <> "" - ) - (List.map - (fun name -> - try - let k = Str.search_forward suffix_re name 0 in - String.sub name k (String.length name - k) - with - Not_found -> "" - ) - files - ) - in - let suff_set = ref (StringSet.empty) in - List.iter - (fun s -> - suff_set := StringSet.add s !suff_set) - suff; - if recursive then begin - List.iter - (fun child -> - if child.node.is_dir then - suff_set := StringSet.union !suff_set (find_suffixes ~recursive tw child) - ) - tree.children - end; - !suff_set -;; - - -let rec select_suffixes ?(recursive = false) ?(unselect=false) suffix tree = - prerr_endline "select_suffixes"; - List.iter - (fun child -> - let child_suff = - try - let name = child.node.name in - let k = Str.search_forward suffix_re name 0 in - String.sub name k (String.length name - k) - with - Not_found -> "" - in - if child_suff = suffix && not (child.node.is_dir) then - child.node.selected <- not unselect; - if recursive && child.node.is_dir then - select_suffixes ~recursive ~unselect suffix child - ) - tree.children -;; - - -let rec select_all ?(recursive = false) ?(unselect=false) tree = - prerr_endline "select_all"; - List.iter - (fun child -> - if not (child.node.is_dir) then - child.node.selected <- not unselect; - if recursive && child.node.is_dir then - select_all ~recursive ~unselect child - ) - tree.children -;; - - -let set_suffix_menu ?unselect tw menu tree = - Menu.delete menu ~first:(`Num 0) ~last:`End; - let suffixes = find_suffixes tw tree in - StringSet.iter - (fun s -> - Menu.add_command - ~label:s - ~command:(fun () -> - select_suffixes ?unselect s tree; - Lx_tree.update tw) - menu - ) - suffixes -;; - - -let node_action st tw tree ev evinfo = - (* prerr_endline "node_action"; *) - match (ev : Lx_spots.supported_event) with - `ButtonPress -> - begin match evinfo.ev_ButtonNumber with - 1 -> - (* prerr_endline ("name=" ^ node.node.name); *) - if not(tree.node.is_dir) then begin - (* prerr_endline "invert!"; *) - tree.node.selected <- not tree.node.selected; - st.modified <- true; - prerr_endline ("update"); - Lx_tree.update tw; - prerr_endline ("/update"); - end - | 3 -> - (* Context menu *) - let menu = - if tree.node.is_dir - then ( - set_suffix_menu - tw (some st.dir_context_suffix_menu) tree; - set_suffix_menu - ~unselect:true - tw (some st.dir_context_unsuffix_menu) tree; - st.dir_context_menu - ) - else st.file_context_menu in - st.context_menu_tree <- tree; - ( match menu with - Some m -> - Menu.popup ~x:(evinfo.ev_RootX) ~y:(evinfo.ev_RootY) m; - | None -> - () - ) - | _ -> - () - end - - | `Enter -> - begin match st.info_widget with - Some label -> - let text = - match tree.node.realtype, tree.node.is_dir with - Regular,false -> - tree.node.name ^ ": File is " ^ - (if tree.node.selected then "selected" else "not selected") - | Regular,true -> - tree.node.name ^ ": Listed as file, but now a directory" - | Directory,true -> - tree.node.name ^ ": Directory" - | Directory,false -> - tree.node.name ^ ": Listed as directory, but now a file" - | Absent, _ -> - tree.node.name ^ ": does not exist" - in - Label.configure ~text label - | None -> () - end - - | `Leave -> - begin match st.info_widget with - Some label -> - Label.configure ~text:" " label - | None -> () - end - - | _ -> - () -;; - - -let display_node st = - let node_action_st = node_action st in - fun tw tree -> - let node = tree.node in - let image = - if node.is_dir then - st.directory_xpm - else - if node.selected then - st.selected_xpm - else - st.unselected_xpm - in - - let foreground = - (* Blue means: A selected regular file - * Black means: A non selected regular file - * Red means a problem: - * - The file does not exist - * - The file has the wrong type - *) - match (node.realtype, node.is_dir) with - (Regular, false) -> - (if node.selected then Some `Blue else None) - | (Directory, true) -> - None (* directories can never be selected *) - | _ -> - Some(`Red) - in - - let events = [ `ButtonPress; `Enter; `Leave ] in - - Lx_tree.display_text - ~image ~events ~action:node_action_st ?foreground node.name -;; - - -let neutral_frame wdg = - Frame.create ~highlightthickness:0 ~borderwidth:0 wdg -;; - - -let save st = - let rec write_file file path tree = - let full_name = - if path = "" then - tree.node.name - else - Filename.concat path tree.node.name - in - if not tree.node.is_dir && tree.node.selected then begin - output_string file full_name; - output_string file "\n"; - end; - List.iter (fun child -> write_file file full_name child) tree.children - in - - match st.tree_widget with - Some tw -> - let tree = Lx_tree.tree tw in - let filename = Filename.concat st.current_directory st.list_file in - let file = open_out filename in - List.iter (fun child -> write_file file "" child) tree.children; - close_out file; - st.modified <- false; - | None -> - () -;; - - -let q_save st = - (* Question: save current file list? Returns [true] if the operation - * can be continued - *) - if st.modified then begin - let choice = - Dialog.create ~parent:st.topwdg ~title:"Save?" ~message:"The current tree is modified. Save it to disk?" - ~buttons:[ "Yes"; "No"; "Cancel" ] () in - match choice with - 0 -> save st; true - | 1 -> true - | 2 -> false - end - else - true -;; - - -let drop st = - st.list_file <- ""; - st.modified <- false; - Frame.configure ~width:400 ~height:600 st.workframe; - List.iter destroy (Winfo.children st.workframe); - st.tree_widget <- None -;; - - -let create_work_tree st top_node = - let tree_frame = neutral_frame st.workframe in - let info_frame = neutral_frame st.workframe in - - let sbar = Scrollbar.create ~orient:`Vertical tree_frame in - let info_label = - Label.create ~highlightthickness:0 ~borderwidth:0 ~justify:`Left - ~text:" " info_frame in - pack ~anchor:`W ~ipady:4 ~ipadx:4 ~side:`Left [info_label]; - - let width = Winfo.reqwidth st.workframe - Winfo.reqwidth sbar in - let height = Winfo.reqheight st.workframe - Winfo.reqwidth info_label - 14 in - (* TODO: why 14? I think that 8 pixels = 2*ipady is the right value. *) - let tw = Lx_tree.create - ~display:st.display ~rescan:rescan_node ~width ~height - ~background:`White - ~font:"9x15" - top_node - tree_frame in - let canvas = Lx_tree.canvas tw in - Canvas.configure ~yscrollcommand:(Scrollbar.set sbar) canvas; - Scrollbar.configure ~command:(Canvas.yview canvas) sbar; - - Canvas.configure ~highlightthickness:0 canvas; - - pack ~side:`Left ~fill:`Both ~expand:true [canvas]; - pack ~side:`Left ~fill:`Y [ sbar]; - - pack ~anchor:`W [tree_frame; info_frame ]; - - st.tree_widget <- Some tw; - st.info_widget <- Some info_label; - - let dcm = Menu.create ~tearoff:false st.workframe in - let dcm_suffix = Menu.create ~tearoff:false dcm in - let dcm_unsuffix = Menu.create ~tearoff:false dcm in - Menu.add_cascade ~label:"Select by suffix" ~menu:dcm_suffix dcm; - Menu.add_cascade ~label:"Unselect by suffix" ~menu:dcm_unsuffix dcm; -(* - Menu.add_command ~label:".ml" dcm_suffix; - Menu.add_command ~label:".mli" dcm_suffix; - Menu.add_command ~label:".mly" dcm_suffix; -*) - - Menu.add_command ~label:"Select all files" - ~command:(fun () -> - select_all st.context_menu_tree; - Lx_tree.update tw) - dcm; - Menu.add_command ~label:"Unselect all files" - ~command:(fun () -> - select_all ~unselect:true st.context_menu_tree; - Lx_tree.update tw) - dcm; - Menu.add_separator dcm; - Menu.add_command ~label:"Rescan directory" - ~command:(fun () -> - rescan_node tw st.context_menu_tree; - Lx_tree.update tw - ) dcm; - Menu.add_separator dcm; - Menu.add_command ~label:"Expand all" - ~command:(fun () -> - expand ~all:true tw st.context_menu_tree; - Lx_tree.update tw - ) dcm; - Menu.add_command ~label:"Expand as needed" - ~command:(fun () -> - expand tw st.context_menu_tree; - Lx_tree.update tw - ) dcm; - Menu.add_command ~label:"Collapse" - ~command:(fun () -> - collapse tw st.context_menu_tree; - Lx_tree.update tw - ) dcm; - st.dir_context_menu <- Some dcm; - st.dir_context_suffix_menu <- Some dcm_suffix; - st.dir_context_unsuffix_menu <- Some dcm_unsuffix; -;; - - -let file_new st () = - let enable_ok filename = - not(Sys.file_exists filename) - in - - if q_save st then begin - match Filetree_dlg.open_dialog ~title:"New tree" ~enable_ok st.topwdg with - Some (dir, name) -> - drop st; - st.current_directory <- dir; - st.list_file <- name; - let basename = Filename.basename dir in - let initial_node = - { node = { name = basename; - path = [ dir ]; - is_dir = true; - realtype = Directory; - selected = false; - }; - children = []; - show = false; - scanned = false; - interactive = true; - } in - let filename = Filename.concat dir name in - Unix.close(Unix.openfile filename [Unix.O_RDWR; Unix.O_CREAT] 0o666); - create_work_tree st initial_node - | None -> - () - end -;; - - -let strip_ws_re = Str.regexp "^[ \r\n\t]*\\(.*\\)[ \r\n\t]*$";; - -let strip_ws s = - if Str.string_match strip_ws_re s 0 then - Str.matched_group 1 s - else - assert false -;; - - -let file_open st () = - let rec enter_path path node = - match path with - n :: path' -> - begin try - let child = List.find (fun ch -> ch.node.name = n) node.children in - (* or Not_found *) - if path' <> [] then begin - child.node.is_dir <- true; - end; - enter_path path' child - with - Not_found -> - let child = - { node = { name = n; - path = node.node.path @ [n]; - is_dir = (path' <> []); - realtype = Regular; (* Will be updated later *) - selected = true; - }; - children = []; - show = false; - scanned = path' = []; - interactive = true; - } in - node.children <- child :: node.children; - enter_path path' child - end - | [] -> - () - in - - let rec read_file file initial_node = - let line = strip_ws (input_line file) in - if line = "" then read_file file initial_node else begin - let path = Filesys.split_path line in - enter_path path initial_node; - read_file file initial_node - end - in - - let enable_ok filename = - Sys.file_exists filename - in - - if q_save st then begin - match Filetree_dlg.open_dialog ~title:"Open tree" ~enable_ok st.topwdg with - Some (dir, name) -> - drop st; - st.current_directory <- dir; - st.list_file <- name; - let basename = Filename.basename dir in - let initial_node = - { node = { name = basename; - path = [ dir ]; - is_dir = true; - realtype = Directory; - selected = false; - }; - children = []; - show = false; - scanned = false; - interactive = true; - } in - let filename = Filename.concat dir name in - let file = open_in filename in - (try read_file file initial_node with End_of_file -> ()); - close_in file; - create_work_tree st initial_node - | None -> - () - end -;; - - -let file_save st () = - save st; - ignore(Dialog.create ~parent:st.topwdg ~title:"Saved" ~message:"Tree saved." - ~buttons:[ "OK" ] ()); -;; - - -let file_quit st () = - if q_save st then destroy st.topwdg -;; - - -let view_expand ?all st () = - match st.tree_widget with - Some tw -> - expand ?all tw (Lx_tree.tree tw); - Lx_tree.update tw - | None -> - () -;; - - -let view_collapse st () = - match st.tree_widget with - Some tw -> - collapse tw (Lx_tree.tree tw); - Lx_tree.update tw - | None -> - () -;; - - -let init_application top = - let directory_xpm = - Imagebitmap.create ~file:"directory.xpm" ~background:`White () in - let selected_xpm = - Imagebitmap.create ~file:"selected.xpm" ~background:`White () in - let unselected_xpm = - Imagebitmap.create ~file:"unselected.xpm" ~background:`White () in - - (* Create the work frame, 400 x 600 pixels *) - - let workframe = Frame.create ~width:400 ~height:600 top in - - (* Create the state record: *) - - let st = - { current_directory = Sys.getcwd(); - list_file = ""; - tree_widget = None; - info_widget = None; - dir_context_menu = None; - dir_context_suffix_menu = None; - dir_context_unsuffix_menu = None; - file_context_menu = None; - context_menu_tree = dummy_tree; - modified = false; - workframe = workframe; - topwdg = top; - directory_xpm = directory_xpm; - selected_xpm = selected_xpm; - unselected_xpm = unselected_xpm; - display = (fun _ _ -> Lx_tree.display_text ""); - } in - st.display <- display_node st; - - (* Because there are currently no toplevel menubars in labltk (they appeared - * first in Tk 8.0), we simulate them using a frame. - *) - - let menuframe = - Frame.create ~relief:`Groove ~borderwidth:2 top in - - let file_mb = - Menubutton.create ~text:"File" menuframe in - - let file_m = - Menu.create file_mb in - Menu.add_command ~label:"New Tree" ~command:(file_new st) file_m; - Menu.add_command ~label:"Open" ~command:(file_open st) file_m; - Menu.add_command ~label:"Check" file_m; - Menu.add_command ~label:"Save" ~command:(file_save st) file_m; - Menu.add_command ~label:"Quit" ~command:(file_quit st) file_m; - Menubutton.configure ~menu:file_m file_mb; - Wm.protocol_set top ~name:"WM_DELETE_WINDOW" ~command:(file_quit st); - -(* - let edit_mb = - Menubutton.create ~text:"Edit" menuframe in - - let edit_m = - Menu.create edit_mb in - (* Undo? *) - Menu.add_command ~label:"Select by suffix" edit_m; - Menu.add_command ~label:"Select by regexp" edit_m; - Menu.add_command ~label:"Select all" edit_m; - Menubutton.configure ~menu:edit_m edit_mb; -*) - - let view_mb = - Menubutton.create ~text:"View" menuframe in - - let view_m = - Menu.create view_mb in - Menu.add_command ~label:"Expand all" ~command:(view_expand ~all:true st) view_m; - Menu.add_command ~label:"Expand as needed" ~command:(view_expand st) view_m; - Menu.add_command ~label:"Collapse all" ~command:(view_collapse st) view_m; - Menubutton.configure ~menu:view_m view_mb; - - pack ~side:`Left [file_mb; (* edit_mb; *) view_mb]; - - pack ~anchor:`W ~fill:`X [menuframe]; - pack ~anchor:`W [workframe] -;; - - -let top_window = openTk() in -init_application top_window; -Sys.catch_break true; -try - mainLoop() -with - Sys.Break -> - prerr_endline "EXIT"; - () -;; - -(* ====================================================================== - * History: - * - * $Log: tree_editor.ml,v $ - * Revision 1.1 2002/06/08 19:39:53 gerd - * Initial revision. - * - * - *) diff --git a/src/findlib-toolbox/unselected.xpm b/src/findlib-toolbox/unselected.xpm deleted file mode 100644 index f46f9df..0000000 --- a/src/findlib-toolbox/unselected.xpm +++ /dev/null @@ -1,6 +0,0 @@ -#define unselected_width 16 -#define unselected_height 16 -static unsigned char unselected_bits[] = { - 0x55, 0x55, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, - 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, - 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0xaa, 0xaa}; diff --git a/src/findlib/frontend.ml b/src/findlib/frontend.ml index ed39fff..9daa890 100644 --- a/src/findlib/frontend.ml +++ b/src/findlib/frontend.ml @@ -2069,6 +2069,8 @@ let install_package () = let add_files = ref false in let optional = ref false in let patches = ref [] in + let lean = ref false in + let lean_gen_meta = ref false in let keywords = [ "-destdir", (Arg.String (fun s -> destdir := s)), @@ -2095,6 +2097,13 @@ let install_package () = " Remove the subpackage "; "-patch-archives", Arg.Unit (fun () -> patches := !patches @ [`Archives]), " Remove non-existing archives"; + "-lean", Arg.Set lean, + " Install lean (new-style) package"; + "-lean-gen-meta", Arg.Set lean_gen_meta, + " For -lean: generate a META file for backward compat"; + "-legacy", Arg.Clear lean, + " Install legacy package (this is the default)"; + ] in let errmsg = "usage: ocamlfind install [options] ..." in @@ -2112,6 +2121,7 @@ let install_package () = ) errmsg; if !pkgname = "" then (Arg.usage keywords errmsg; exit 1); + (* TODO: allow installation of subpackages! *) if not (Fl_split.is_valid_package_name !pkgname) then failwith "Package names must not contain the character '.'!"; From 202b1f043aa743ae0f0b2f2a67284f7dafc42361 Mon Sep 17 00:00:00 2001 From: Gerd Stolpmann Date: Fri, 1 May 2020 15:54:24 +0000 Subject: [PATCH 07/17] remove "findlib mini" --- mini/README | 104 ------ mini/ocamlfind-mini | 851 -------------------------------------------- 2 files changed, 955 deletions(-) delete mode 100644 mini/README delete mode 100755 mini/ocamlfind-mini diff --git a/mini/README b/mini/README deleted file mode 100644 index 66a2169..0000000 --- a/mini/README +++ /dev/null @@ -1,104 +0,0 @@ ----------------------------------------------------------------------- -ocamlfind-mini ----------------------------------------------------------------------- - -ocamlfind-mini is an O'Caml script that implements a subset of the -full functionality of ocamlfind. It consists only of one file, so it -is easy to distribute it with any software. - -The subset is normally sufficient to compile a library and to -install the library; but it is insufficient to link the library -into an executable. - ----------------------------------------------------------------------- -SUPPORTED OPERATING SYSTEMS: ----------------------------------------------------------------------- - -For Unixes, the script runs out of the box. It uses the ocaml system -found in the command path. - -I think the script also runs in Windows, but I have not yet checked that. -Anyway, you cannot call it directly, but by doing -ocaml ocamlfind-mini ... - -Macintosh is not supported; I don't have enough knowledge for a Mac port. - ----------------------------------------------------------------------- -FUNCTIONALITY: ----------------------------------------------------------------------- - -Overall: The configuration file ocamlfind.conf is ignored. However, -some environment variables are respected (see below). - -A package directory is recognized by checking whether there is a META -file in it. However, the contents of that file are ignored. - -The following subset has been implemented: - -- ocamlfind-mini [ocamlc|ocamlopt|ocamlcp|ocamlmktop] ... - - The -package option works, but you must set the environment variable - OCAMLPATH (see below). - - The options -linkpkg, -predicates, -dontlink, -syntax, -ppopt are - rejected. - - This normally means that you can compile modules as in: - - ocamlfind-mini ocamlc -c -package p1,p2,p3 my_module.ml - - However, you cannot create executables because -linkpkg is not - supported. - - Note that ocamlfind-mini is unable to figure out the prerequisite - packages, so the -package option must enumerate _all_ needed packages. - - Note that ocamlfind-mini does not support the alternate directory - layout where all META files are collected in one directory. - -- ocamlfind-mini install ... - - Installs the files in the package directory for . You must help - ocamlfind-mini by specifying the destination directory: - - * Setting the -destdir option: - - ocamlfind-mini install -destdir

    ... - - This command installs the new package into /. - - * Setting the OCAMLFIND_DESTDIR variable: - - export OCAMLFIND_DESTDIR= - ocamlfind-mini install ... - - This command installs the new package into /, too. - -- ocamlfind-mini remove - - Removes the package . Again, you must specify the destination - directory by either setting the -destdir option or by setting the - OCAMLFIND_DESTDIR variable. - ----------------------------------------------------------------------- -ENVIRONMENT: ----------------------------------------------------------------------- - -The following variables are supported: - -- OCAMLPATH - - A colon (Win: semicolon)-separated list of directories: - OCAMLPATH=::... - - When ocamlfind-mini searches a package , it checks whether - //META exists for K=1, 2, ... - -- OCAMLFIND_DESTDIR - - The destination directory for "install" and "remove". - -- OCAMLFIND_METADIR - - The destination directory for META files. It is not recommended to set - this variable. diff --git a/mini/ocamlfind-mini b/mini/ocamlfind-mini deleted file mode 100755 index 4e37221..0000000 --- a/mini/ocamlfind-mini +++ /dev/null @@ -1,851 +0,0 @@ -#! /bin/sh -# (* -exec ocaml "$0" "$@" -*) directory ".";; - -(* $Id$ - * ---------------------------------------------------------------------- - * - *) - -(**********************************************************************) - -(* Module split, rev. 1.2 *) - -module Split = struct -let in_words s = - (* splits s in words separated by commas and/or whitespace *) - let l = String.length s in - let rec split i j = - if j < l then - match s.[j] with - (' '|'\t'|'\n'|'\r'|',') -> - if i - split i (j+1) - else - if i - if i - split i (j+1) - else - if i ':' - | "Cygwin" -> ';' (* You might want to change this *) - | "Win32" -> ';' - | "MacOS" -> failwith "Findlib: I do not know what is the correct path separator for MacOS. If you can help me, write a mail to gerd@gerd-stolpmann.de" - | _ -> failwith "Findlib: unknown operating system" -;; - - -let path str = - (* split "str" into parts separated by "path_separator" *) - let l = String.length str in - let rec split_up j k = - if k < l then begin - let c = str.[k] in - if c = path_separator then begin - if k - j > 0 then - String.sub str j (k-j) :: split_up (k+1) (k+1) - else - split_up (k+1) (k+1) - end - else - split_up j (k+1) - end - else - if k - j > 0 then - [ String.sub str j (k-j) ] - else - [] - in - split_up 0 0 -;; -end;; - -(**********************************************************************) - - - -exception Usage;; - -type mode = - M_use | M_query | M_install | M_remove | M_compiler of string - | M_printconf | M_guess | M_list -;; - - -let rec remove_dups l = - match l with - x :: l' -> - if List.mem x l' then remove_dups l' else x::remove_dups l' - | [] -> [] -;; - - -let arg n = - if n < Array.length Sys.argv then Sys.argv.(n) else raise Not_found -;; - - -(**********************************************************************) - -let ocaml_stdlib_default = "/usr/local/lib/ocaml";; - -let ocaml_stdlib = - begin - (* Execute "ocamlc -v" and read the stdlib directory *) - let filename = Filename.temp_file "ocamlfind." ".dat" in - let command = "ocamlc -v >" ^ filename in (* SYS *) - let n = Sys.command command in - if n <> 0 then begin - prerr_endline ("ocamlfind-mini: [WARNING] Cannot determine directory of stdlib; using " ^ ocaml_stdlib_default ^ " by default"); - ocaml_stdlib_default - end - else begin - (* Search the line "Standard library directory: " *) - let tag = "Standard library directory: " in - let taglen = String.length tag in - let f = open_in filename in - let dir = ref ocaml_stdlib_default in - try - while true do - let s = input_line f in - if String.length s >= taglen && String.sub s 0 taglen = tag then begin - dir := String.sub s taglen (String.length s - taglen); - raise Exit; - end - done; - assert false - with - Exit -> - close_in f; - (try Sys.remove filename with _ -> ()); - !dir - | End_of_file -> - close_in f; - prerr_endline ("ocamlfind-mini: [WARNING] Cannot determine directory of stdlib; using " ^ ocaml_stdlib_default ^ " by default"); - ocaml_stdlib_default - end - end -;; - - -let ocamlpath = - try - Split.path (Sys.getenv "OCAMLPATH") - with - Not_found -> - (* Use stdlib as default: *) - [ ocaml_stdlib ] -;; - - -let env_destdir = - try Sys.getenv "OCAMLFIND_DESTDIR" with Not_found -> "";; - - -let env_metadir = - try Sys.getenv "OCAMLFIND_METADIR" with Not_found -> "";; - - -let core_packages = - [ "bigarray", ocaml_stdlib; - "dbm", ocaml_stdlib; - "dynlink", ocaml_stdlib; - "graphics", ocaml_stdlib; - "labltk", (Filename.concat ocaml_stdlib "labltk"); - "num", ocaml_stdlib; - "stdlib", ocaml_stdlib; - "str", ocaml_stdlib; - "threads", (Filename.concat ocaml_stdlib "threads"); - "unix", ocaml_stdlib; - ] -;; - - -(**********************************************************************) - -let package_directory pkg = - let rec lookup path = - match path with - | [] -> raise Not_found - | dir :: path' -> - let pkgdir = Filename.concat dir pkg in - let meta = Filename.concat pkgdir "META" in - if Sys.file_exists meta then - pkgdir - else - lookup path' - in - - try - List.assoc pkg core_packages - with - Not_found -> - lookup ocamlpath -;; - - -(**********************************************************************) - -let use_package prefix pkgnames = - let pdirs = - List.map - (fun pname -> - try - "-I " ^ package_directory pname - with - Not_found -> failwith ("Cannot find package " ^ pname ^ " (check environment variable OCAMLPATH)")) - pkgnames - in - - print_endline (prefix ^ String.concat " " pdirs) -;; - - -(**************** OCAMLC/OCAMLMKTOP/OCAMLOPT subcommands ****************) - -type pass_file_t = - Pass of string - | Impl of string - | Intf of string -;; - - -let ocamlc which () = - Arg.current := 1; - - let switches = ref [] in - let pass_options = ref [] in - let pass_files = ref [] in - let incpath = ref [] in - - let packages = ref [] in - - let add_switch name = - Arg.Unit (fun () -> - switches := name :: !switches; - pass_options := !pass_options @ [name]) in - let add_spec_fn name s = - pass_options := !pass_options @ [name; s] in - let add_spec name = Arg.String (add_spec_fn name) in - let add_pkg = - Arg.String (fun s -> packages := !packages @ (Split.in_words s)) in - - - Arg.parse - (List.flatten - [ [ - "-package", add_pkg, - " Refer to package when compiling"; - "-linkpkg", Arg.Unit(fun _ -> raise (Arg.Bad "Not supported: -linkpkg")), - " Link the packages in (NOT SUPPORTED)"; - "-predicates", Arg.String(fun _ -> raise (Arg.Bad "Not supported: -predicates")), - "

    Add predicate

    when resolving package properties (NOT SUPPORTED)"; - "-dontlink", Arg.String(fun _ -> raise (Arg.Bad "Not supported: -dontlink")), - " Do not link in package and its ancestors (NOT SUPPORTED)"; - "-syntax", Arg.String(fun _ -> raise (Arg.Bad "Not supported: -syntax")), - "

    Use preprocessor with predicate

    (NOT SUPPORTED)"; - "-ppopt", Arg.String(fun _ -> raise (Arg.Bad "Not supported: -ppopt")), - " Append option to preprocessor invocation (NOT SUPPORTED)"; - "-passopt", Arg.String (fun s -> pass_options := !pass_options @ [s]), - " Pass option directly to ocamlc/opt/mktop\nSTANDARD OPTIONS:"; - - "-a", add_switch "-a", - " Build a library"; - "-c", add_switch "-c", - " Compile only (do not link)"; - "-cc", add_spec "-cc", - " Use as the C compiler and linker"; - "-cclib", add_spec "-cclib", - " Pass option to the C linker"; - "-ccopt", add_spec "-ccopt", - " Pass option to the C compiler and linker"; - ]; - if which = "ocamlopt" then [ - "-compact", add_switch "-compact", - " Optimize code size rather than speed" - ] - else []; - if which <> "ocamlopt" then [ - "-custom", add_switch "-custom", - " Link in custom mode"; - "-g", add_switch "-g", - " Save debugging information"; - ] else []; - [ - "-i", add_switch "-i", - " Print the types"; - "-I", (Arg.String - (fun s -> - incpath := s :: !incpath; - add_spec_fn "-I" s)), - "

    Add to the list of include directories"; - "-impl", Arg.String (fun s -> pass_files := !pass_files @ [ Impl s ]), - " Compile as a .ml file"; - ] ; - if which = "ocamlopt" then [ - "-inline", add_spec "-inline", - " Set aggressiveness of inlining to "; - ] else []; - [ - "-intf", Arg.String (fun s -> pass_files := !pass_files @ [ Intf s ]), - " Compile as a .mli file"; - "-intf-suffix", add_spec "-intf-suffix", - " Suffix for interface file (default: .mli)"; - "-intf_suffix", add_spec "-intf_suffix", - " same as -intf-suffix"; - "-labels", add_switch "-labels", - " Use commuting label mode"; - "-linkall", add_switch "-linkall", - " Link all modules, even unused ones"; - ] ; - if which <> "ocamlopt" then [ - "-make-runtime", add_switch "-make-runtime", - " Build a runtime system"; - "-make_runtime", add_switch "-make_runtime", - " same as -make-runtime"; - ] else []; - [ - "-noautolink", add_switch "-noautolink", - " Don't automatically link C libraries specif'd in .cma files"; - "-noassert", add_switch "-noassert", - " Do not compile assertion checks"; - "-o", add_spec "-o", - " Set output file name to "; - "-output-obj", add_switch "-output-obj", - " Output a C object file instead of an executable"; - ]; - if which = "ocamlopt" then [ - "-p", add_switch "-p", - " Compile/link with profiling support for \"gprof\" - (implies -predicates gprof)"; - ] else if which = "ocamlcp" then [ - "-p", add_spec "-p", - " [afilmt] Profile constructs specified by argument: - a Everything - f Function calls - i if ... then ... else - l while, for - m match ... with - t try ... with"; - ] else []; - [ - "-pp", Arg.String (fun s -> add_spec_fn "-pp" s), - " Pipe sources through preprocessor "; - "-rectypes", add_switch "-rectypes", - " Allow arbitrary recursive types"; - ] ; - if which = "ocamlopt" then [ - "-S", add_switch "-S", - " Keep intermediate assembly file"; - ] else []; - [ - "-thread", add_switch "-thread", - " Use thread-safe standard library (implies -predicate mt)"; - "-unsafe", add_switch "-unsafe", - " No bounds checking on array and string access"; - ] ; - if which <> "ocamlopt" then [ - "-use-runtime", add_spec "-use-runtime", - " Generate bytecode for the given runtime system"; - "-use_runtime", add_spec "-use_runtime", - " same as -use-runtime"; - ] else []; - [ - "-v", add_switch "-v", - " Print compiler version number"; - "-verbose", add_switch "-verbose", - " Print calls to external commands"; - "-w", add_spec "-w", - " Enable or disable warnings according to : - A/a enable/disable all warnings - C/c enable/disable suspicious comment - F/f enable/disable partially applied function - M/m enable/disable overriden methods - P/p enable/disable partial match - S/s enable/disable non-unit statement - U/u enable/disable unused match case - V/v enable/disable hidden instance variables - X/x enable/disable all other warnings - default setting is A (all warnings enabled)"; - "-warn-error", add_spec "-warn-error", - " Turn these warnings into errors"; - "-where", add_switch "-where", - " Print standard library directory"; - "-", Arg.String (fun s -> pass_files := !pass_files @ [ Pass s ]), - " Treat as a file name (even if it starts with `-')"; - ] - ]) - (fun s -> pass_files := !pass_files @ [ Pass s]) - ("usage: ocamlfind-mini " ^ which ^ " [options] file ..."); - - begin match which with - "ocamlc" - | "ocamlcp" - | "ocamlmktop" - | "ocamlopt" -> () - | _ -> failwith "unsupported backend" - end; - - let verbose = List.mem "-verbose" !switches in - - (* check packages: *) - List.iter - (fun pkg -> - try - let _ = package_directory pkg in - () - with - Not_found -> - failwith ("package '" ^ pkg ^ "' not found (check environment variable OCAMLPATH)")) - !packages; - - let eff_packages = !packages in - - let eff_packages_dl = - remove_dups (List.map package_directory eff_packages) in - - let stdlibdir = - (* normalized form of the stdlib directory *) - let d = ocaml_stdlib in - if d <> "" & d.[String.length d - 1] = '/' then - String.sub d 0 (String.length d - 1) - else - d - in - let stdlibdirslash = stdlibdir ^ "/" in - - let i_options = - List.flatten - (List.map - (fun pkgdir -> - if pkgdir = stdlibdir or pkgdir = stdlibdirslash then - [] - else - [ "-I"; pkgdir; - "-ccopt"; "-I" ^ pkgdir; ]) - eff_packages_dl) in - - let pass_files' = - List.flatten - (List.map - (function - Pass s -> - if s.[0] = '-' - then [ "-"; String.sub s 1 (String.length s - 1) ] - else [ s ] - | Impl s -> - [ "-impl"; s ] - | Intf s -> - [ "-intf"; s ] - ) - !pass_files) - in - - let arguments = - !pass_options @ - i_options @ - pass_files' - in - - let actual_command = which in - - if verbose then - print_string ("+ " ^ actual_command ^ " " ^ - String.concat " " arguments ^ "\n"); - - flush stdout; - - let argstring = - String.concat " " - (List.map Filename.quote arguments) - in - - let status = Sys.command (actual_command ^ " " ^ argstring) in - - begin - match status with - 0 -> () - | n -> - if verbose then - print_string (actual_command ^ " returned with exit code " ^ string_of_int n ^ "\n"); - exit n - end; -;; - - -(************************************************************************) - -let make_directory dirname = - (* Invoke the mkdir command *) - let cmd = - match Sys.os_type with - "Unix" -> "mkdir" - | "Cygwin" -> "mkdir" (* don't really know *) - | "Win32" -> "md" - | "MacOS" -> failwith "make_directory not implemented for MacOS" - | _ -> failwith "Findlib: unknown operating system" - in - let c = Sys.command (cmd ^ " " ^ Filename.quote dirname) in - if c <> 0 then - failwith ("Cannot make directory " ^ dirname) -;; - - -let remove_directory dirname = - (* Invoke the rmdir command *) - let cmd = - match Sys.os_type with - "Unix" -> "rmdir" - | "Cygwin" -> "rmdir" (* don't really know *) - | "Win32" -> "rd" - | "MacOS" -> failwith "remove_directory not implemented for MacOS" - | _ -> failwith "Findlib: unknown operating system" - in - let c = Sys.command (cmd ^ " " ^ Filename.quote dirname) in - if c <> 0 then - failwith ("Cannot remove directory " ^ dirname) -;; - - -let list_dir dirname = - let rec rd_dir f = - try - let s = input_line f in - if s = "" then rd_dir f else s::rd_dir f - with - End_of_file -> - close_in f; - [] - in - - (* Invoke the ls command *) - let cmd = - match Sys.os_type with - "Unix" -> "ls -1" - | "Cygwin" -> "ls -1" (* don't really know *) - | "Win32" -> "dir /b" - | "MacOS" -> failwith "list_dir not implemented for MacOS" - | _ -> failwith "Findlib: unknown operating system" - in - let filename = Filename.temp_file "ocamlfind." ".dat" in - let fullcmd = cmd ^ " " ^ Filename.quote dirname ^ " >" ^ filename in - let n = Sys.command fullcmd in - if n <> 0 then - failwith ("Cannot execute: " ^ fullcmd); - let f = open_in filename in - let l = rd_dir f in - close_in f; - (try Sys.remove filename with _ -> ()); - l -;; - - -let copy_file ?(rename = (fun name -> name)) ?(append = "") src dstdir = - (* A system-independent function to copy the file src to dstdir *) - let outname = rename (Filename.basename src) in - let ch_in = open_in_bin src in - try - let outpath = Filename.concat dstdir outname in - if Sys.file_exists outpath then - prerr_endline ("ocamlfind-mini: [WARNING] Overwriting file " ^ outpath); - let ch_out = open_out_bin outpath in - try - let buflen = 4096 in - let buf = String.create buflen in - let pos = ref 0 in - let len = ref (input ch_in buf 0 buflen) in - while !len > 0 do - output ch_out buf !pos !len; - len := input ch_in buf !pos buflen; - done; - output_string ch_out append; - close_out ch_out; - close_in ch_in; - prerr_endline("Installed " ^ outpath); - with - exc -> close_out ch_out; raise exc - with - exc -> close_in ch_in; raise exc -;; - - -let install_create_directory pkgname dstdir = - if Sys.file_exists dstdir then - failwith ("Package " ^ pkgname ^ " is already installed; please remove it first"); - make_directory dstdir -;; - - -exception Skip_file;; - -let install_package () = - let destdir = ref (env_destdir) in - let metadir = ref (env_metadir) in - let don't_add_directory_directive = ref false in - let pkgname = ref "" in - let files = ref [] in - - let keywords = - [ "-destdir", (Arg.String (fun s -> destdir := s)), - " Set the destination directory"; - "-metadir", (Arg.String (fun s -> metadir := s)), - " Install the META file into this directory"; - "-dont-add-directory-directive", (Arg.Set don't_add_directory_directive), - " never append directory='...' to META"; - ] in - let errmsg = "usage: ocamlfind-mini install [options] ..." in - - Arg.current := 1; - Arg.parse - keywords - (fun s -> - if !pkgname = "" - then pkgname := s - else files := s :: !files - ) - errmsg; - if !pkgname = "" then (Arg.usage keywords errmsg; exit 1); - - (* Check destdir: *) - if !destdir = "" then - failwith ("No destination directory. Either specify the -destdir option, or set the environment variable OCAMLFIND_DESTDIR"); - if not (Sys.file_exists !destdir) then - failwith ("The destination directory " ^ !destdir ^ " does not exist"); - - (* Check whether META exists: *) - let meta_dot_pkg = "META." ^ !pkgname in - let has_meta = - List.exists - (fun p -> - let b = Filename.basename p in - b = "META" || b = meta_dot_pkg) - !files - in - if not has_meta then - failwith "The META file is missing"; - - (* Check that there is no meta_dot_pkg: *) - if Sys.file_exists (Filename.concat !metadir meta_dot_pkg) then - failwith ("Package " ^ !pkgname ^ " is already installed; please remove it first"); - - (* Create the package directory: *) - let pkgdir = Filename.concat !destdir !pkgname in - install_create_directory !pkgname pkgdir; - - (* Now copy the files into the package directory: *) - let has_metadir = !metadir <> "" in - List.iter - (fun p -> - try - copy_file - ~rename: (fun f -> - if has_metadir then begin - if f = "META" || f = meta_dot_pkg - then raise Skip_file - else f - end - else - if f = meta_dot_pkg then "META" else f) - p - pkgdir - with - Skip_file -> () - ) - !files; - - (* Finally copy META into metadir, if this has been requested *) - if has_metadir then begin - List.iter - (fun p -> - let b = Filename.basename p in - if b = "META" || b = meta_dot_pkg then - copy_file - ~rename: (fun f -> - if f = "META" then meta_dot_pkg else f) - ~append: ("\ndirectory=\"" ^ pkgdir ^ "\" # auto-added by ocamlfind-mini\n") - p - !metadir - ) - !files - end -;; - - -let remove_package () = - let destdir = ref (env_destdir) in - let metadir = ref (env_metadir) in - let pkgname = ref "" in - - let keywords = - [ "-destdir", (Arg.String (fun s -> destdir := s)), - " Set the destination directory"; - "-metadir", (Arg.String (fun s -> metadir := s)), - " Remove the META file from this directory"; - ] in - let errmsg = "usage: ocamlfind-mini remove [options] " in - - Arg.current := 1; - Arg.parse - keywords - (fun s -> - if !pkgname = "" - then pkgname := s - else raise (Arg.Bad "too many arguments") - ) - errmsg; - if !pkgname = "" then (Arg.usage keywords errmsg; exit 1); - - (* Check destdir: *) - if !destdir = "" then - failwith ("No destination directory. Either specify the -destdir option, or set the environment variable OCAMLFIND_DESTDIR"); - if not (Sys.file_exists !destdir) then - failwith ("The destination directory " ^ !destdir ^ " does not exist"); - - let meta_dot_pkg = "META." ^ !pkgname in - let has_metadir = !metadir <> "" in - - (* If there is a metadir, remove the META file from it: *) - if has_metadir then begin - let f = Filename.concat !metadir meta_dot_pkg in - if Sys.file_exists f then begin - Sys.remove f; - prerr_endline ("Removed " ^ f); - end - else - prerr_endline ("ocamlfind-mini: [WARNING] No such file: " ^ f) - end; - - (* Remove the files from the package directory: *) - let pkgdir = Filename.concat !destdir !pkgname in - - if Sys.file_exists pkgdir then begin - let files = list_dir pkgdir in - List.iter (fun f -> Sys.remove (Filename.concat pkgdir f)) files; - remove_directory pkgdir; - prerr_endline ("Removed " ^ pkgdir) - end - else - prerr_endline("ocamlfind-mini: [WARNING] No such directory: " ^ pkgdir); -;; - - -let select_mode() = - let m_string = try arg 1 with Not_found -> raise Usage in - let m = - match m_string with - ("use"|"-use") -> M_use - | ("query"|"-query") -> M_query - | ("install"|"-install") -> M_install - | ("remove"|"-remove") -> M_remove - | ("ocamlc"|"-ocamlc") -> M_compiler "ocamlc" - | ("ocamlcp"|"-ocamlcp") -> M_compiler "ocamlcp" - | ("ocamlmktop"|"-ocamlmktop") -> M_compiler "ocamlmktop" - | ("ocamlopt"|"-ocamlopt") -> M_compiler "ocamlopt" - | ("printconf"|"-printconf") -> M_printconf - | ("guess"|"-guess") -> M_guess - | ("list"|"-list") -> M_list - | _ -> raise Usage - in - - m -;; - - -let sorry() = - prerr_endline "ocamlfind-mini: sorry, this function is not implemented in the reduced version of ocamlfind"; - exit 1 -;; - - -let main() = - try - let m = select_mode() in - let l = Array.length Sys.argv in - let rest = Array.sub Sys.argv 2 (l-2) in - match m with - M_use -> if rest = [| |] then raise Usage; - if rest.(0) = "-p" then begin - if l<4 then raise Usage; - use_package rest.(1) - (List.tl(List.tl(Array.to_list rest))) - end - else - use_package "" (Array.to_list rest) - | M_query -> sorry() - | M_install -> install_package() - | M_remove -> remove_package () - | M_printconf -> sorry() - | M_guess -> sorry() - | M_list -> sorry() - | M_compiler which -> ocamlc which () - with - Usage -> - prerr_endline "usage: ocamlfind-mini ocamlc [-help | other options] ..."; - prerr_endline " or: ocamlfind-mini ocamlcp [-help | other options] ..."; - prerr_endline " or: ocamlfind-mini ocamlmktop [-help | other options] ..."; - prerr_endline " or: ocamlfind-mini ocamlopt [-help | other options] ..."; - prerr_endline " or: ocamlfind-mini install [-help | other options] ..."; - prerr_endline " or: ocamlfind-mini remove [-help | other options] "; - exit 2 - | Failure f -> - prerr_endline ("ocamlfind-mini: " ^ f); - exit 2 -;; - - -try - Sys.catch_break true; - main() -with - any -> - prerr_endline ("Uncaught exception: " ^ Printexc.to_string any); - let raise_again = - try ignore(Sys.getenv "OCAMLFIND_DEBUG"); true - with Not_found -> false - in - if raise_again then raise any; - exit 3 -;; - - -(* ====================================================================== - * History: - * - * $Log: ocamlfind-mini,v $ - * Revision 1.4 2001/03/10 08:15:24 gerd - * -warn-error - * - * Revision 1.3 2001/03/06 20:18:03 gerd - * Option -where. - * - * Revision 1.2 2001/03/04 19:03:56 gerd - * list_dir: deletes the temp file after use - * - * Revision 1.1 2001/03/04 19:01:21 gerd - * Initial revision. - * - *) From 727b5b7c98a8011fe4b48b54635b306dfe206b62 Mon Sep 17 00:00:00 2001 From: Gerd Stolpmann Date: Fri, 1 May 2020 16:05:36 +0000 Subject: [PATCH 08/17] remove support for separate directory with META files --- src/findlib/findlib.ml | 11 +--- src/findlib/findlib.mli | 6 -- src/findlib/fl_package_base.ml | 12 +--- src/findlib/frontend.ml | 108 +++++++-------------------------- 4 files changed, 26 insertions(+), 111 deletions(-) diff --git a/src/findlib/findlib.ml b/src/findlib/findlib.ml index 94052fd..8f62a6c 100644 --- a/src/findlib/findlib.ml +++ b/src/findlib/findlib.ml @@ -21,7 +21,6 @@ let init_called = ref false ;; let conf_config_file = ref "";; let conf_default_location = ref "";; -let conf_meta_directory = ref "";; let conf_search_path = ref [];; let conf_command = ref [];; let conf_stdlib = ref "";; @@ -55,7 +54,6 @@ let init_manually ?(ldconf = Findlib_config.ocaml_ldconf) ?(config = Findlib_config.config_file) ~install_dir - ~meta_dir ~search_path () = conf_command := [ `ocamlc, ocamlc_command; `ocamlopt, ocamlopt_command; @@ -70,7 +68,6 @@ let init_manually conf_config_file := config; conf_search_path := search_path; conf_default_location := install_dir; - conf_meta_directory := meta_dir; conf_stdlib := stdlib; conf_ldconf := ldconf; conf_ignore_dups_in := @@ -308,7 +305,6 @@ let init ~ldconf: ldconf ~config: config_file ~install_dir: destdir - ~meta_dir: metadir ~search_path: search_path () ;; @@ -327,12 +323,7 @@ let default_location() = !conf_default_location;; -let meta_directory() = - lazy_init(); - if !conf_meta_directory = "none" then "" else !conf_meta_directory;; - - -let search_path() = +let search_path() = lazy_init(); !conf_search_path;; diff --git a/src/findlib/findlib.mli b/src/findlib/findlib.mli index efc8ad5..249ebfc 100644 --- a/src/findlib/findlib.mli +++ b/src/findlib/findlib.mli @@ -105,7 +105,6 @@ val init_manually : ?ldconf: string -> ?config: string -> install_dir: string -> - meta_dir: string -> search_path: string list -> unit -> unit @@ -122,11 +121,6 @@ val config_file : unit -> string val default_location : unit -> string (** Get the default installation directory for packages *) -val meta_directory : unit -> string - (** Get the META installation directory for packages. - * Returns [""] if no such directory is configured. - *) - val search_path : unit -> string list (** Get the search path for packages *) diff --git a/src/findlib/fl_package_base.ml b/src/findlib/fl_package_base.ml index 3919123..f4c781d 100644 --- a/src/findlib/fl_package_base.ml +++ b/src/findlib/fl_package_base.ml @@ -643,16 +643,8 @@ let load_base ?prefix () = if Sys.file_exists meta_file_1 then process_meta_file f package_dir meta_file_1 else - (* If f is META.pkgname: Add package pkgname *) - (* We skip over filenames ending in '~' *) - if String.length f >= 6 && String.sub f 0 5 = "META." && - String.sub f (String.length f - 1) 1 <> "~" then begin - let name = String.sub f 5 (String.length f - 5) in - let meta_file_2 = Filename.concat dir f in - process_meta_file ~directory_required:true name dir meta_file_2 - end else - if Fl_barescanner.is_bare_pkg package_dir then - process_bare_dir f package_dir + if Fl_barescanner.is_bare_pkg package_dir then + process_bare_dir f package_dir ) files; run_ocamlpath path' diff --git a/src/findlib/frontend.ml b/src/findlib/frontend.ml index 9daa890..02a2d02 100644 --- a/src/findlib/frontend.ml +++ b/src/findlib/frontend.ml @@ -2058,7 +2058,6 @@ let string_lowercase_ascii = let install_package () = let destdir = ref (default_location()) in - let metadir = ref (meta_directory()) in let ldconf = ref (ocaml_ldconf()) in let don't_add_directory_directive = ref false in let pkgname = ref "" in @@ -2069,16 +2068,11 @@ let install_package () = let add_files = ref false in let optional = ref false in let patches = ref [] in - let lean = ref false in - let lean_gen_meta = ref false in let keywords = [ "-destdir", (Arg.String (fun s -> destdir := s)), (" Set the destination directory (default: " ^ !destdir ^ ")"); - "-metadir", (Arg.String (fun s -> metadir := s)), - (" Install the META file into this directory (default: "^ - (if !metadir = "" then "none" else !metadir) ^ ")"); "-ldconf", (Arg.String (fun s -> ldconf := s)), (" Update this ld.conf file (default: " ^ !ldconf ^ ")"); "-dont-add-directory-directive", (Arg.Set don't_add_directory_directive), @@ -2097,13 +2091,6 @@ let install_package () = " Remove the subpackage "; "-patch-archives", Arg.Unit (fun () -> patches := !patches @ [`Archives]), " Remove non-existing archives"; - "-lean", Arg.Set lean, - " Install lean (new-style) package"; - "-lean-gen-meta", Arg.Set lean_gen_meta, - " For -lean: generate a META file for backward compat"; - "-legacy", Arg.Clear lean, - " Install legacy package (this is the default)"; - ] in let errmsg = "usage: ocamlfind install [options] ..." in @@ -2121,14 +2108,11 @@ let install_package () = ) errmsg; if !pkgname = "" then (Arg.usage keywords errmsg; exit 1); - (* TODO: allow installation of subpackages! *) if not (Fl_split.is_valid_package_name !pkgname) then failwith "Package names must not contain the character '.'!"; let pkgdir = Filename.concat !destdir !pkgname in let dlldir = Filename.concat !destdir Findlib_config.libexec_name in - let has_metadir = !metadir <> "" in - let meta_dot_pkg = "META." ^ !pkgname in (* The list of all files to install: *) let full_list = !auto_files @ !dll_files @ !nodll_files in @@ -2138,37 +2122,23 @@ let install_package () = let nodll_list = l2 @ !nodll_files in let have_libexec = Sys.file_exists dlldir in let pkgdir_list = if have_libexec then nodll_list else full_list in - let pkgdir_eff_list = - (* The files that will be placed into pkgdir: *) - List.map - (fun f -> - if f = meta_dot_pkg then "META" else f) - (List.filter - (fun f -> - not has_metadir || - (f <> "META" && f <> meta_dot_pkg)) - pkgdir_list) in - + (* Check whether META exists: (And check syntax) *) let meta_name = try List.find (fun p -> let b = Filename.basename p in - b = "META" || b = meta_dot_pkg) + b = "META") nodll_list with | Not_found -> if !add_files then ( - let m1 = Filename.concat !metadir meta_dot_pkg in - let m2 = Filename.concat pkgdir "META" in - if Sys.file_exists m1 then - m1 - else - if Sys.file_exists m2 then - m2 - else - failwith "Cannot find META in package dir" + let m = Filename.concat pkgdir "META" in + if Sys.file_exists m then + m + else + failwith "Cannot find META in package dir" ) else failwith "The META file is missing" in @@ -2177,9 +2147,6 @@ let install_package () = if not !add_files then ( (* Check for frequent reasons why installation can go wrong *) - if Sys.file_exists (Filename.concat !metadir meta_dot_pkg) then - failwith ("Package " ^ !pkgname ^ " is already installed\n - (file " ^ Filename.concat !metadir meta_dot_pkg ^ " already exists)"); - if Sys.file_exists (Filename.concat pkgdir "META") then failwith ("Package " ^ !pkgname ^ " is already installed\n - (file " ^ pkgdir ^ "/META already exists)"); ); @@ -2188,7 +2155,7 @@ let install_package () = let f' = Filename.concat pkgdir f in if Sys.file_exists f' then failwith ("Conflict with file: " ^ f')) - pkgdir_eff_list; + pkgdir_list; if have_libexec then begin List.iter @@ -2210,7 +2177,7 @@ let install_package () = try copy_file ~rename: (fun f -> - if f = "META" || f = meta_dot_pkg then + if f = "META" then raise Skip_file else f) @@ -2287,10 +2254,7 @@ let install_package () = ) in if not !add_files then ( - if has_metadir then - write_meta true !metadir meta_dot_pkg - else - write_meta false pkgdir "META"; + write_meta false pkgdir "META"; ); (* Check if there is a postinstall script: *) @@ -2305,7 +2269,6 @@ let reserved_names = [ Findlib_config.libexec_name; "postinstall"; "postremove" let remove_package () = let destdir = ref (default_location()) in let destdir_set = ref false in - let metadir = ref (meta_directory()) in let ldconf = ref (ocaml_ldconf()) in let pkgname = ref "" in @@ -2313,9 +2276,6 @@ let remove_package () = [ "-destdir", (Arg.String (fun s -> destdir := s; destdir_set := true)), (" Set the destination directory (default: " ^ !destdir ^ ")"); - "-metadir", (Arg.String (fun s -> metadir := s)), - (" Remove the META file from this directory (default: " ^ - (if !metadir = "" then "none" else !metadir) ^ ")"); "-ldconf", (Arg.String (fun s -> ldconf := s)), (" Update this ld.conf file (default: " ^ !ldconf ^ ")"); ] in @@ -2335,8 +2295,6 @@ let remove_package () = if not (Fl_split.is_valid_package_name !pkgname) then failwith "Package names must not contain the character '.'!"; - let meta_dot_pkg = "META." ^ !pkgname in - let has_metadir = !metadir <> "" in let pkgdir = Filename.concat !destdir !pkgname in let dlldir = Filename.concat !destdir Findlib_config.libexec_name in let have_libexec = Sys.file_exists dlldir in @@ -2367,30 +2325,17 @@ let remove_package () = (* If there is a metadir, remove the META file from it: *) let meta_removal_ok = - if has_metadir then ( - let f = Filename.concat !metadir meta_dot_pkg in - try - Unix.unlink f; - prerr_endline ("Removed " ^ f); - true - with - | Unix.Unix_error(Unix.ENOENT,_,_) -> - prerr_endline ("ocamlfind: [WARNING] No such file: " ^ f); - false - | Unix.Unix_error(code, _, arg) -> - raise(sys_error code arg) - ) else - let f = Filename.concat pkgdir "META" in - try - Unix.unlink f; - prerr_endline ("Removed " ^ f); - true - with - | Unix.Unix_error(Unix.ENOENT,_,_) -> - prerr_endline ("ocamlfind: [WARNING] No such file: " ^ f); - false - | Unix.Unix_error(code, _, arg) -> - raise(sys_error code arg) in + let f = Filename.concat pkgdir "META" in + try + Unix.unlink f; + prerr_endline ("Removed " ^ f); + true + with + | Unix.Unix_error(Unix.ENOENT,_,_) -> + prerr_endline ("ocamlfind: [WARNING] No such file: " ^ f); + false + | Unix.Unix_error(code, _, arg) -> + raise(sys_error code arg) in if meta_removal_ok then ( @@ -2492,11 +2437,7 @@ let print_configuration() = (Findlib.search_path()); Printf.printf "Packages will be installed in/removed from:\n %s\n" (dir (Findlib.default_location())); - Printf.printf "META files will be installed in/removed from:\n %s\n" - (let md = Findlib.meta_directory() in - if md = "" then "the corresponding package directories" else dir md - ); - Printf.printf "The standard library is assumed to reside in:\n %s\n" + Printf.printf "The standard library is assumed to reside in:\n %s\n" (Findlib.ocaml_stdlib()); Printf.printf "The ld.conf file can be found here:\n %s\n" (Findlib.ocaml_ldconf()); @@ -2507,13 +2448,10 @@ let print_configuration() = List.iter print_endline (Findlib.search_path()) | Some "destdir" -> print_endline (Findlib.default_location()) - | Some "metadir" -> - print_endline (Findlib.meta_directory()) | Some "metapath" -> - let mdir = Findlib.meta_directory() in let ddir = Findlib.default_location() in print_endline - (if mdir <> "" then mdir ^ "/META.%s" else ddir ^ "/%s/META") + (ddir ^ "/%s/META") | Some "stdlib" -> print_endline (Findlib.ocaml_stdlib()) | Some "ldconf" -> From 91864762ec8e7fa5b67ab59e7a7954632955d55c Mon Sep 17 00:00:00 2001 From: Gerd Stolpmann Date: Fri, 1 May 2020 17:27:37 +0000 Subject: [PATCH 09/17] ocamlfind install: support lean packages --- src/findlib/fl_barescanner.ml | 31 +++++- src/findlib/fl_barescanner.mli | 3 + src/findlib/frontend.ml | 178 ++++++++++++++++++++++++--------- 3 files changed, 161 insertions(+), 51 deletions(-) diff --git a/src/findlib/fl_barescanner.ml b/src/findlib/fl_barescanner.ml index d011302..3f88705 100644 --- a/src/findlib/fl_barescanner.ml +++ b/src/findlib/fl_barescanner.ml @@ -98,6 +98,33 @@ let scan_bare_pkg mainname dir = } in scan "" mainname dir +let check_bare_pkg bare = + let reqs = + [ if bare.bare_byte_archive <> None then + [ "lib.cma", bare.bare_byte_requires ] + else + []; + if bare.bare_native_archive <> None then + [ "lib.cmxa", bare.bare_native_requires ] + else + []; + if bare.bare_shared_archive <> None then + [ "lib.cmxs", bare.bare_shared_requires ] + else + []; + ] |> List.flatten in + if reqs = [] then + failwith "no archive to install (lib.cma, lib.cmxa, or lib.cmxs)" + else ( + let ref_lib, ref_req = List.hd reqs in + List.iter + (fun (lib, req) -> + if req <> ref_req then + failwith ("The archives " ^ ref_lib ^ " and " ^ lib ^ " have different requirements") + ) + reqs + ) + let to_pkg_definition bare = let pkg_defs_byte = match bare.bare_byte_archive with @@ -151,10 +178,10 @@ let to_pkg_definition bare = def_preds = []; def_value = bare.bare_name }; - { def_var = "directory"; + { def_var = "lean"; def_flav = `BaseDef; def_preds = []; - def_value = bare.bare_directory + def_value = "true"; }; { def_var = "requires"; def_flav = `BaseDef; diff --git a/src/findlib/fl_barescanner.mli b/src/findlib/fl_barescanner.mli index 49c6639..3e34d7c 100644 --- a/src/findlib/fl_barescanner.mli +++ b/src/findlib/fl_barescanner.mli @@ -38,6 +38,9 @@ val scan_bare_pkg : string -> string -> bare_definition scanned, too (unless ignore_chdilren). *) +val check_bare_pkg : bare_definition -> unit + (** Peforms some checks, and fails if the check are not succeeding. *) + val to_pkg_expr : bare_definition -> Fl_metascanner.pkg_expr (** Converts the bare definition into an expression, as if a META file with the same information was present. diff --git a/src/findlib/frontend.ml b/src/findlib/frontend.ml index 02a2d02..9da2814 100644 --- a/src/findlib/frontend.ml +++ b/src/findlib/frontend.ml @@ -2055,6 +2055,17 @@ let char_lowercase_ascii c = let string_lowercase_ascii = String.map char_lowercase_ascii +let dir_contains_pkg dir = + if Sys.file_exists(Filename.concat dir "META") then + Some "META" + else if Sys.file_exists(Filename.concat dir "lib.cma") then + Some "lib.cma" + else if Sys.file_exists(Filename.concat dir "lib.cmxa") then + Some "lib.cmxa" + else if Sys.file_exists(Filename.concat dir "lib.cmxs") then + Some "lib.cmxs" + else + None let install_package () = let destdir = ref (default_location()) in @@ -2068,6 +2079,8 @@ let install_package () = let add_files = ref false in let optional = ref false in let patches = ref [] in + let lean = ref false in + let lean_gen_meta = ref false in let keywords = [ "-destdir", (Arg.String (fun s -> destdir := s)), @@ -2091,6 +2104,12 @@ let install_package () = " Remove the subpackage "; "-patch-archives", Arg.Unit (fun () -> patches := !patches @ [`Archives]), " Remove non-existing archives"; + "-lean", Arg.Set lean, + " Install lean (new-style) package"; + "-lean-gen-meta", Arg.Set lean_gen_meta, + " For -lean: generate a META file for backward compat"; + "-legacy", Arg.Clear lean, + " Install legacy package (this is the default)"; ] in let errmsg = "usage: ocamlfind install [options] ..." in @@ -2108,10 +2127,20 @@ let install_package () = ) errmsg; if !pkgname = "" then (Arg.usage keywords errmsg; exit 1); - if not (Fl_split.is_valid_package_name !pkgname) then - failwith "Package names must not contain the character '.'!"; - let pkgdir = Filename.concat !destdir !pkgname in + if !lean then ( + let n = Fl_split.package_name !pkgname in + if n = [] || List.mem "" n || List.mem "." n then + failwith("Bad package name"); + ) else + if not (Fl_split.is_valid_package_name !pkgname) then + failwith "Legacy package names must not contain the character '.'!"; + if !lean_gen_meta && not !lean then + failwith "For -lean-gen-meta you also have to request -lean!"; + + let subpath = + Fl_split.package_name !pkgname |> String.concat "/" in + let pkgdir = Filename.concat !destdir subpath in let dlldir = Filename.concat !destdir Findlib_config.libexec_name in (* The list of all files to install: *) @@ -2123,38 +2152,70 @@ let install_package () = let have_libexec = Sys.file_exists dlldir in let pkgdir_list = if have_libexec then nodll_list else full_list in + let pkgdir_map = Hashtbl.create 7 in + List.iter + (fun f -> + Hashtbl.add pkgdir_map (Filename.basename f) f + ) + pkgdir_list; + let pkgdir_open file = + try + let path = Hashtbl.find pkgdir_map file in + Some(open_in_bin path) + with + | Not_found -> None in + + if !lean_gen_meta && Hashtbl.mem pkgdir_map "META" then + failwith "Cannot generate META when a META file is already given"; + + (* For lean packages: archives must be called "lib" *) + if !lean then ( + List.iter + (fun p -> + let f = Filename.basename p in + if Filename.check_suffix f ".cma" && f <> "lib.cma" then + failwith "For lean packages, bytecode archives must be called lib.cma"; + if Filename.check_suffix f ".cmxa" && f <> "lib.cmxa" then + failwith "For lean packages, native archives must be called lib.cmxa"; + if Filename.check_suffix f ".cmxs" && f <> "lib.cmxs" then + failwith "For lean packages, shared archives must be called lib.cmxs"; + ) + pkgdir_list + ); + (* Check whether META exists: (And check syntax) *) - let meta_name = + let meta_in_path_opt = try - List.find - (fun p -> - let b = Filename.basename p in - b = "META") - nodll_list + Some(Hashtbl.find pkgdir_map "META") with | Not_found -> - if !add_files then ( - let m = Filename.concat pkgdir "META" in - if Sys.file_exists m then - m + if !lean then + None + else + if !add_files then + None else - failwith "Cannot find META in package dir" - ) - else - failwith "The META file is missing" in - - let meta_pkg = meta_pkg meta_name in + failwith "The META file is missing" in + let meta_in_expr_opt = + match meta_in_path_opt with + | None -> None + | Some m -> Some(meta_pkg m) in if not !add_files then ( (* Check for frequent reasons why installation can go wrong *) - if Sys.file_exists (Filename.concat pkgdir "META") then - failwith ("Package " ^ !pkgname ^ " is already installed\n - (file " ^ pkgdir ^ "/META already exists)"); + match dir_contains_pkg pkgdir with + | None -> () + | Some f -> + failwith ("Package " ^ !pkgname ^ " is already installed\n - (file " ^ pkgdir ^ "/" ^ f ^ " already exists)"); ); List.iter - (fun f -> - let f' = Filename.concat pkgdir f in - if Sys.file_exists f' then - failwith ("Conflict with file: " ^ f')) + (fun path -> + let file = Filename.basename path in + if !add_files && file = "META" then + failwith "Cannot add META to existing package"; + let file' = Filename.concat pkgdir file in + if Sys.file_exists file' then + failwith ("Conflict with file: " ^ file')) pkgdir_list; if have_libexec then begin @@ -2168,6 +2229,31 @@ let install_package () = dll_list end; + (* For lean packages: check META or generate META *) + let meta_expr_opt = + if !lean then ( + let bare = + Fl_barescanner.scan_bare_files !pkgname pkgdir pkgdir_open in + Fl_barescanner.check_bare_pkg bare; + if !lean_gen_meta then + Some (Fl_barescanner.to_pkg_expr bare) + else ( + match meta_in_expr_opt with + | Some m -> + let toks = + Fl_metachecker.check_incompat_with_lean_meta + !pkgname pkgdir_open m in + if toks <> [] then ( + prerr_endline (Fl_metachecker.incompat_to_text toks); + failwith "Bad META file." + ); + Some m + | None -> + None + ) + ) else + meta_in_expr_opt in + (* Create the package directory: *) install_create_directory !pkgname pkgdir; @@ -2229,32 +2315,26 @@ let install_package () = end; (* Finally, write the META file: *) - let write_meta append_directory dir name = + if not !add_files then ( (* If there are patches, write the patched META, else copy the file: *) - if !patches = [] then - copy_file - ~rename:(fun _ -> name) - ?append:(if append_directory then - Some("\ndirectory=\"" ^ pkgdir ^ - "\" # auto-added by ocamlfind\n") - else - None) - meta_name - dir - else ( - let p = Filename.concat dir name in - let patched_pkg = patch_pkg pkgdir meta_pkg !patches in - let out = open_out p in - Fl_metascanner.print out patched_pkg; - if append_directory then - output_string out ("\ndirectory=\"" ^ pkgdir ^ - "\" # auto-added by ocamlfind\n"); - close_out out; - prerr_endline ("Installed " ^ p); + if !patches = [] && not !lean_gen_meta then ( + match meta_in_path_opt with + | None -> + () + | Some meta -> + copy_file meta pkgdir + ) else ( + match meta_expr_opt with + | None -> + () + | Some pkg -> + let p = Filename.concat pkgdir "META" in + let patched_pkg = patch_pkg pkgdir pkg !patches in + let out = open_out p in + Fl_metascanner.print out patched_pkg; + close_out out; + prerr_endline ("Installed " ^ p); ) - in - if not !add_files then ( - write_meta false pkgdir "META"; ); (* Check if there is a postinstall script: *) From 0608d4359756e2426994a6696cc25b31e3fc9a43 Mon Sep 17 00:00:00 2001 From: Gerd Stolpmann Date: Fri, 1 May 2020 19:49:03 +0000 Subject: [PATCH 10/17] improved META checking for bare libs --- src/findlib/fl_metachecker.ml | 43 ++++++++++++++++++++++++---------- src/findlib/fl_metachecker.mli | 1 + 2 files changed, 31 insertions(+), 13 deletions(-) diff --git a/src/findlib/fl_metachecker.ml b/src/findlib/fl_metachecker.ml index 849053e..ee3ac10 100644 --- a/src/findlib/fl_metachecker.ml +++ b/src/findlib/fl_metachecker.ml @@ -9,6 +9,7 @@ type incompat_reasons = | Incompat_uses_directory | Incompat_uses_linkopts | Incompat_bad_archive of string * string + | Incompat_bad_plugin of string * string | Incompat_bad_requires of string | Incompat_inline_subpackage @@ -52,7 +53,7 @@ let check_incompat_with_lean_meta name open_archive meta = let archive_byte_ok = archive_byte = None || archive_byte = Some "lib.cma" in let archive_byte_plugin = - try Some(lookup "archive" ["byte"; "plugin"] meta.pkg_defs) + try Some(lookup "plugin" ["byte"] meta.pkg_defs) with Not_found -> None in let archive_byte_plugin_ok = archive_byte_plugin = None || archive_byte = Some "lib.cma" in @@ -62,7 +63,7 @@ let check_incompat_with_lean_meta name open_archive meta = let archive_native_ok = archive_native = None || archive_native = Some "lib.cmxa" in let archive_native_plugin = - try Some(lookup "archive" ["native"; "plugin"] meta.pkg_defs) + try Some(lookup "plugin" ["native"] meta.pkg_defs) with Not_found -> None in let archive_native_plugin_ok = archive_native_plugin = None || archive_native_plugin = Some "lib.cmxs" in @@ -93,24 +94,36 @@ let check_incompat_with_lean_meta name open_archive meta = token_if (archive_byte = None && bare.bare_byte_archive <> None) (Incompat_bad_archive("byte","missing entry: lib.cma")); + token_if + (archive_byte <> bare.bare_byte_archive) + (Incompat_bad_archive("byte","not named lib.cma")); token_if (archive_byte_plugin <> None && bare.bare_byte_archive = None) - (Incompat_bad_archive("byte,plugin","missing file lib.cma")); + (Incompat_bad_plugin("byte","missing file lib.cma")); token_if (archive_byte_plugin = None && bare.bare_byte_archive <> None) - (Incompat_bad_archive("byte,plugin","missing entry: lib.cma")); + (Incompat_bad_plugin("byte","missing entry: lib.cma")); + token_if + (archive_byte_plugin <> bare.bare_byte_archive) + (Incompat_bad_plugin("byte","not named lib.cma")); token_if (archive_native <> None && bare.bare_native_archive = None) (Incompat_bad_archive("native","missing file lib.cmxa")); token_if (archive_native = None && bare.bare_native_archive <> None) (Incompat_bad_archive("native","missing entry: lib.cmxa")); + token_if + (archive_native <> bare.bare_native_archive) + (Incompat_bad_archive("native","not named lib.cmxa")); token_if (archive_native_plugin <> None && bare.bare_shared_archive = None) - (Incompat_bad_archive("native,plugin","missing file lib.cmxs")); + (Incompat_bad_plugin("native","missing file lib.cmxs")); token_if (archive_native_plugin = None && bare.bare_shared_archive <> None) - (Incompat_bad_archive("native,plugin","missing entry: lib.cmxs")); + (Incompat_bad_plugin("native","missing entry: lib.cmxs")); + token_if + (archive_native_plugin <> bare.bare_shared_archive) + (Incompat_bad_archive("native","not named lib.cmxs")); token_if (bare.bare_byte_archive <> None && not(reqs_ok bare.bare_byte_requires)) (Incompat_bad_requires "lib.cma"); @@ -130,19 +143,21 @@ let check_incompat_with_lean_meta name open_archive meta = let token_to_text token = match token with | Incompat_not_declared_lean -> - " - The META file misses a 'lean = true' setting.\n" + " - The META file misses a 'lean = true' setting." | Incompat_bad_lean_decl -> - " - The META file has a bad setting for the 'lean' variable.\n" + " - The META file has a bad setting for the 'lean' variable." | Incompat_uses_directory -> - " - The META file defines the 'directory' variable which is not permitted for lean libraries.\n" + " - The META file defines the 'directory' variable which is not permitted for lean libraries." | Incompat_uses_linkopts -> - " - The META file defines the 'linkopts' variable which is not permitted for lean libraries.\n" + " - The META file defines the 'linkopts' variable which is not permitted for lean libraries." | Incompat_bad_archive(which,what) -> - sprintf " - bad variable 'archive(%s)': %s\n" which what + sprintf " - bad variable 'archive(%s)': %s" which what + | Incompat_bad_plugin(which,what) -> + sprintf " - bad variable 'plugin(%s)': %s" which what | Incompat_bad_requires file -> - sprintf " - bad setting for the 'requires' variable which differs from what the file %s specifies.\n" file + sprintf " - bad setting for the 'requires' variable which differs from what the file %s specifies." file | Incompat_inline_subpackage -> - " - The META file contains inline subpackages, which is not supported for lean libraries. Subpackages need to go into subdirectories.\n" + " - The META file contains inline subpackages, which is not supported for lean libraries. Subpackages need to go into subdirectories." let incompat_to_text tokens = if tokens = [] then @@ -150,3 +165,5 @@ let incompat_to_text tokens = else "This library is not lean. The following incompatibilities have been detected:\n" ^ (String.concat "\n" (List.map token_to_text tokens)) + ^ "\n" + diff --git a/src/findlib/fl_metachecker.mli b/src/findlib/fl_metachecker.mli index 9840875..f5164db 100644 --- a/src/findlib/fl_metachecker.mli +++ b/src/findlib/fl_metachecker.mli @@ -4,6 +4,7 @@ type incompat_reasons = | Incompat_uses_directory | Incompat_uses_linkopts | Incompat_bad_archive of string * string + | Incompat_bad_plugin of string * string | Incompat_bad_requires of string | Incompat_inline_subpackage From 098efb61bd261874ebe37d62f2bf966b7e4827e8 Mon Sep 17 00:00:00 2001 From: Gerd Stolpmann Date: Fri, 1 May 2020 19:49:29 +0000 Subject: [PATCH 11/17] relaxing install requirement for lean packages: there must be at least one archive lib.cma/lib.cmxa/lib.cmxs. --- src/findlib/frontend.ml | 20 ++++++++------------ 1 file changed, 8 insertions(+), 12 deletions(-) diff --git a/src/findlib/frontend.ml b/src/findlib/frontend.ml index 9da2814..e3e8232 100644 --- a/src/findlib/frontend.ml +++ b/src/findlib/frontend.ml @@ -2168,19 +2168,15 @@ let install_package () = if !lean_gen_meta && Hashtbl.mem pkgdir_map "META" then failwith "Cannot generate META when a META file is already given"; - (* For lean packages: archives must be called "lib" *) + (* For lean packages: at least one archive must be called "lib" *) if !lean then ( - List.iter - (fun p -> - let f = Filename.basename p in - if Filename.check_suffix f ".cma" && f <> "lib.cma" then - failwith "For lean packages, bytecode archives must be called lib.cma"; - if Filename.check_suffix f ".cmxa" && f <> "lib.cmxa" then - failwith "For lean packages, native archives must be called lib.cmxa"; - if Filename.check_suffix f ".cmxs" && f <> "lib.cmxs" then - failwith "For lean packages, shared archives must be called lib.cmxs"; - ) - pkgdir_list + if not (List.exists + (fun p -> + let f = Filename.basename p in + f = "lib.cma" || f = "lib.cmxa" || f = "lib.cmxs" + ) + pkgdir_list) then + failwith "For lean packages, archives must be named lib.(cma,cmxa,cmxs), and there must be at least one such archive to install" ); (* Check whether META exists: (And check syntax) *) From 1e9c3840b885fda3f13d2bfb3a6c65900593ee99 Mon Sep 17 00:00:00 2001 From: Gerd Stolpmann Date: Fri, 1 May 2020 19:57:59 +0000 Subject: [PATCH 12/17] add "ocamlfind install -patch-description" --- src/findlib/frontend.ml | 36 +++++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 15 deletions(-) diff --git a/src/findlib/frontend.ml b/src/findlib/frontend.ml index e3e8232..95b3a91 100644 --- a/src/findlib/frontend.ml +++ b/src/findlib/frontend.ml @@ -1991,24 +1991,28 @@ let rec patch_archives pkgdir pkg = let rec patch_pkg pkgdir pkg patches = + let patch_var name value = + let def = + { Fl_metascanner.def_var = name; + def_flav = `BaseDef; + def_preds = []; + def_value = value + } in + let defs = + List.filter + (fun d -> d.Fl_metascanner.def_var <> name) + pkg.Fl_metascanner.pkg_defs in + { pkg with + Fl_metascanner.pkg_defs = def :: defs + } in match patches with | [] -> pkg | (`Version v) :: patches' -> - let def = - { Fl_metascanner.def_var = "version"; - def_flav = `BaseDef; - def_preds = []; - def_value = v - } in - let defs = - List.filter - (fun d -> d.Fl_metascanner.def_var <> "version") - pkg.Fl_metascanner.pkg_defs in - let pkg' = - { pkg with - Fl_metascanner.pkg_defs = def :: defs - } in - patch_pkg pkgdir pkg' patches' + let pkg' = patch_var "version" v in + patch_pkg pkgdir pkg' patches' + | (`Description v) :: patches' -> + let pkg' = patch_var "description" v in + patch_pkg pkgdir pkg' patches' | (`Rmpkg n) :: patches' -> let children = List.filter @@ -2100,6 +2104,8 @@ let install_package () = " The following files are optional"; "-patch-version", Arg.String (fun s -> patches := !patches @ [`Version s]), " Set the package version to "; + "-patch-description", Arg.String (fun s -> patches := !patches @ [`Description s]), + " Set the package description to "; "-patch-rmpkg", Arg.String (fun s -> patches := !patches @ [`Rmpkg s]), " Remove the subpackage "; "-patch-archives", Arg.Unit (fun () -> patches := !patches @ [`Archives]), From d8c118ab39cc28c39754aecf1cb3ddbf72b9cb4a Mon Sep 17 00:00:00 2001 From: Gerd Stolpmann Date: Fri, 1 May 2020 20:42:26 +0000 Subject: [PATCH 13/17] reporting the package type (lean/legacy) --- src/findlib/findlib.ml | 15 +++++++++++ src/findlib/findlib.mli | 12 +++++++++ src/findlib/fl_package_base.ml | 45 +++++++++++++++------------------ src/findlib/fl_package_base.mli | 7 ++--- src/findlib/frontend.ml | 23 ++++++++++++----- 5 files changed, 65 insertions(+), 37 deletions(-) diff --git a/src/findlib/findlib.ml b/src/findlib/findlib.ml index 8f62a6c..c7e58f9 100644 --- a/src/findlib/findlib.ml +++ b/src/findlib/findlib.ml @@ -387,6 +387,21 @@ let package_deep_ancestors predlist pkglist = Fl_package_base.requires_deeply predlist pkglist ;; +type package_type = + | Lean + | Lean_with_META + | Legacy + +let package_type pkg = + let open Fl_package_base in + lazy_init(); + let l = query pkg in + if l.package_lean then + match l.package_path with + | Pkg_with_META _ -> Lean_with_META + | Pkg_bare _ -> Lean + else + Legacy let resolve_path ?base ?(explicit=false) p = lazy_init(); diff --git a/src/findlib/findlib.mli b/src/findlib/findlib.mli index 249ebfc..22f05d5 100644 --- a/src/findlib/findlib.mli +++ b/src/findlib/findlib.mli @@ -204,6 +204,18 @@ val package_deep_ancestors : string list -> string list -> string list * cyclic dependency. *) +type package_type = + | Lean + | Lean_with_META + | Legacy + +val package_type : string -> package_type + (** Returns the package type: + - [Lean]: a new-style package without META file + - [Lean_with_META]: a lean package with META for compatibility + - [Legacy]: old-style package + *) + val resolve_path : ?base:string -> ?explicit:bool -> string -> string (** Resolves findlib notation in filename paths. The notation * [ +name/path ] can be used to refer to the subdirectory [name] diff --git a/src/findlib/fl_package_base.ml b/src/findlib/fl_package_base.ml index f4c781d..ea45f39 100644 --- a/src/findlib/fl_package_base.ml +++ b/src/findlib/fl_package_base.ml @@ -16,6 +16,7 @@ type package = { package_name : string; package_dir : string; package_path : package_path; + package_lean : bool; package_defs : Fl_metascanner.pkg_definition list; package_priv : package_priv } @@ -76,8 +77,7 @@ let dir_of_type = | Pkg_bare dir -> dir -let packages_in_meta_file ?(directory_required = false) - ~name:package_name ~dir:package_dir ~meta_file () = +let packages_in_meta_file ~name:package_name ~dir:package_dir ~meta_file () = (* Parses the META file whose name is [meta_file]. In [package_name], the * name of the main package must be passed. [package_dir] is the * directory associated with the package by default (i.e. before @@ -101,10 +101,7 @@ let packages_in_meta_file ?(directory_required = false) lookup "directory" [] pkg_expr.pkg_defs with Not_found -> - if pkg_name_prefix="" && directory_required then - failwith ("The `directory' directive is required in this META definition"); - - "" + "" in let d' = if d = "" then @@ -128,11 +125,15 @@ let packages_in_meta_file ?(directory_required = false) if pkg_name_prefix = "" then pkg_name_component else - pkg_name_prefix ^ "." ^ pkg_name_component in + pkg_name_prefix ^ "." ^ pkg_name_component in + let package_lean = + try lookup "lean" [] pkg_expr.pkg_defs = "true" + with Not_found -> false in let p = { package_name = p_name; package_dir = d'; package_path = Pkg_with_META meta_file; + package_lean; package_defs = pkg_expr.pkg_defs; package_priv = { missing_reqs = [] } } in @@ -180,6 +181,7 @@ let packages_in_bare_dir ~name:package_name ~dir:package_dir () = { package_name = Fl_barescanner.(p.bare_name); package_dir = Fl_barescanner.(p.bare_directory); package_path = Pkg_bare Fl_barescanner.(p.bare_directory); + package_lean = true; package_defs = Fl_barescanner.to_pkg_definition p; package_priv = { missing_reqs = [] } } in @@ -202,10 +204,10 @@ let query package_name = Not_found -> raise (No_such_package (package_name, "")) in - let process_meta_file_and_lookup ?directory_required package_dir meta_file = + let process_meta_file_and_lookup package_dir meta_file = let packages = packages_in_meta_file - ?directory_required ~name:main_name ~dir:package_dir ~meta_file () in + ~name:main_name ~dir:package_dir ~meta_file () in let p = lookup packages in List.iter (Fl_metastore.add store) packages; p @@ -224,21 +226,14 @@ let query package_name = [] -> raise(No_such_package(package_name, "")) | dir :: path' -> let package_dir = Filename.concat dir main_name in - let meta_file_1 = Filename.concat package_dir "META" in - let meta_file_2 = Filename.concat dir ("META." ^ main_name) in - if Sys.file_exists meta_file_1 then - process_meta_file_and_lookup package_dir meta_file_1 - else - if Sys.file_exists meta_file_2 then - process_meta_file_and_lookup ~directory_required:true dir meta_file_2 - (* Note: It is allowed to have relative "directory" directives. - * The base directory is [dir] in this case. - *) + let meta_file = Filename.concat package_dir "META" in + if Sys.file_exists meta_file then + process_meta_file_and_lookup package_dir meta_file + else + if Fl_barescanner.is_bare_pkg package_dir then + process_bare_dir_and_lookup main_name package_dir else - if Fl_barescanner.is_bare_pkg package_dir then - process_bare_dir_and_lookup main_name package_dir - else - run_ocamlpath path' + run_ocamlpath path' in try @@ -592,7 +587,7 @@ let load_base ?prefix () = [] in - let process_meta_file ?directory_required main_name package_dir meta_file = + let process_meta_file main_name package_dir meta_file = try let _ = Fl_metastore.find store main_name in (* Note: If the main package is already loaded into the graph, we @@ -604,7 +599,7 @@ let load_base ?prefix () = let packages = try packages_in_meta_file - ?directory_required ~name:main_name ~dir:package_dir ~meta_file () + ~name:main_name ~dir:package_dir ~meta_file () with Failure s -> prerr_endline ("findlib: [WARNING] " ^ s); [] diff --git a/src/findlib/fl_package_base.mli b/src/findlib/fl_package_base.mli index 965b2b2..f75afb7 100644 --- a/src/findlib/fl_package_base.mli +++ b/src/findlib/fl_package_base.mli @@ -19,6 +19,8 @@ type package = (** The directory where to lookup package files *) package_path : package_path; (** The path to the META file *) + package_lean : bool; + (** Whether this is a lean (new-style) package *) package_defs : Fl_metascanner.pkg_definition list; (** The definitions in the META file *) package_priv : package_priv; @@ -160,7 +162,6 @@ val package_users : preds:string list -> string list -> string list *) val packages_in_meta_file : - ?directory_required:bool -> name:string -> dir:string -> meta_file:string -> unit -> package list (** Parses the META file whose name is [meta_file]. In [name], the * name of the main package must be passed. [dir] is the @@ -169,10 +170,6 @@ val packages_in_meta_file : * * Returns the package records found in this file. The "directory" * directive is already applied. - * - * @param directory_required If true, it is checked whether there is a - * "directory" directive in the main package. If this directive is missing, - * the function will fail. *) val packages_in_bare_dir : diff --git a/src/findlib/frontend.ml b/src/findlib/frontend.ml index 95b3a91..7cbb2e6 100644 --- a/src/findlib/frontend.ml +++ b/src/findlib/frontend.ml @@ -687,6 +687,7 @@ let expand predicates eff_packages format = * %p package name * %d package directory * %m META file (or dir of bare package) + * %T package type (lean/legacy) * %D description * %v version * %a archive file(s) @@ -704,6 +705,11 @@ let expand predicates eff_packages format = [ "%p", [pkg]; "%d", [out_path dir]; "%m", [out_ppath (package_path pkg)]; + "%T", [match package_type pkg with + | Lean -> "lean" + | Lean_with_META -> "lean_with_META" + | Legacy -> "legacy" + ]; "%D", [try package_property predicates pkg "description" with Not_found -> "[n/a]"]; "%v", [try package_property predicates pkg "version" @@ -739,6 +745,7 @@ let help_format() = %m META file %D description %v version + %T package type (lean, lean_with_META, legacy) %a archive file(s) %+a archive file(s), converted to absolute paths %A archive files as single string @@ -757,7 +764,7 @@ let help_format() = let query_package () = let long_format = - "package: %p\ndescription: %D\nversion: %v\narchive(s): %A\nlinkopts: %O\nlocation: %d\n" in + "package: %p\ndescription: %D\nversion: %v\ntype: %T\narchive(s): %A\nlinkopts: %O\nlocation: %d\n" in let i_format = "-I %d" in let l_format = @@ -2723,16 +2730,18 @@ let main() = ;; +let print_bt = + try ignore(Sys.getenv "OCAMLFIND_DEBUG"); true + with Not_found -> false;; + try Sys.catch_break true; + if print_bt then Printexc.record_backtrace true; main() with - any -> + any -> + let bt = Printexc.get_backtrace() in prerr_endline ("Uncaught exception: " ^ Printexc.to_string any); - let raise_again = - try ignore(Sys.getenv "OCAMLFIND_DEBUG"); true - with Not_found -> false - in - if raise_again then raise any; + if print_bt then prerr_endline bt; exit 3 ;; From 52042a534cb07e56626e9ae863bd1364d03baf55 Mon Sep 17 00:00:00 2001 From: Gerd Stolpmann Date: Fri, 1 May 2020 21:28:06 +0000 Subject: [PATCH 14/17] check at pkg install time whether lean packages use legacy packages. React with warning or error. --- src/findlib/findlib.ml | 37 ++++++++++++++++++++++++--- src/findlib/findlib.mli | 7 ++++++ src/findlib/frontend.ml | 56 ++++++++++++++++++++++++++++++++++++++++- 3 files changed, 95 insertions(+), 5 deletions(-) diff --git a/src/findlib/findlib.ml b/src/findlib/findlib.ml index c7e58f9..2d62840 100644 --- a/src/findlib/findlib.ml +++ b/src/findlib/findlib.ml @@ -17,6 +17,8 @@ type formal_pred = | `NegPred of string ] +type level = Ignore | Warn | Err + let init_called = ref false ;; let conf_config_file = ref "";; @@ -26,6 +28,7 @@ let conf_command = ref [];; let conf_stdlib = ref "";; let conf_ldconf = ref "";; let conf_ignore_dups_in = ref ([] : string list);; +let conf_inconsistent_lean_libs = ref Warn;; let ocamlc_default = "ocamlc";; let ocamlopt_default = "ocamlopt";; @@ -50,6 +53,7 @@ let init_manually ?(ocamldoc_command = ocamldoc_default) ?ignore_dups_in ?(ignore_dups_in_list = []) + ?(inconsistent_lean_libs = Warn) ?(stdlib = Findlib_config.ocaml_stdlib) ?(ldconf = Findlib_config.ocaml_ldconf) ?(config = Findlib_config.config_file) @@ -75,10 +79,18 @@ let init_manually | None -> [] | Some d -> [d] ) @ ignore_dups_in_list; + conf_inconsistent_lean_libs := inconsistent_lean_libs; Fl_package_base.init !conf_search_path stdlib !conf_ignore_dups_in; init_called := true ;; +let parse_level = + function + | "warn" | "warning" -> Warn + | "err" | "error" -> Err + | "ignore" -> Ignore + | s -> failwith ("bad value for inconsistent_lean_libs: " ^ s) + let command_names cmd_spec = try @@ -112,7 +124,9 @@ let auto_config_file() = let init ?env_ocamlpath ?env_ocamlfind_destdir ?env_ocamlfind_metadir ?env_ocamlfind_commands ?env_ocamlfind_ignore_dups_in - ?env_ocamlfind_ignore_dups_in_list ?env_camllib ?env_ldconf + ?env_ocamlfind_ignore_dups_in_list + ?env_ocamlfind_inconsistent_lean_libs + ?env_camllib ?env_ldconf ?config ?toolchain () = let config_file = @@ -154,7 +168,8 @@ let init let sys_ocamlc, sys_ocamlopt, sys_ocamlcp, sys_ocamloptp, sys_ocamlmklib, sys_ocamlmktop, sys_ocamldep, sys_ocamlbrowser, sys_ocamldoc, - sys_search_path, sys_destdir, sys_metadir, sys_stdlib, sys_ldconf = + sys_search_path, sys_destdir, sys_metadir, sys_stdlib, sys_ldconf, + sys_inconsistent_lean_libs = ( let config_vars = if config_file <> "" && @@ -199,7 +214,8 @@ let init (lookup "destdir" ""), (lookup "metadir" "none"), (lookup "stdlib" Findlib_config.ocaml_stdlib), - (lookup "ldconf" Findlib_config.ocaml_ldconf) + (lookup "ldconf" Findlib_config.ocaml_ldconf), + (lookup "inconsistent_lean_libs" "warn" |> parse_level); ) in if not !found && config_preds <> [] then prerr_endline("ocamlfind: [WARNING] Undefined toolchain: " ^ @@ -215,7 +231,8 @@ let init "", "none", Findlib_config.ocaml_stdlib, - Findlib_config.ocaml_ldconf + Findlib_config.ocaml_ldconf, + Warn ) ) in @@ -271,6 +288,13 @@ let init try Fl_split.path (Sys.getenv "OCAMLFIND_IGNORE_DUPS_IN") with Not_found -> [] in + let inconsistent_lean_libs = + match env_ocamlfind_inconsistent_lean_libs with + | Some x -> x + | None -> + try Sys.getenv "OCAMLFIND_INCONSISTENT_LEAN_LIBS" |> parse_level + with Not_found -> sys_inconsistent_lean_libs in + let ocamlc, ocamlopt, ocamlcp, ocamloptp, ocamlmklib, ocamlmktop, ocamldep, ocamlbrowser, ocamldoc, search_path, destdir, metadir, stdlib, ldconf = @@ -306,6 +330,7 @@ let init ~config: config_file ~install_dir: destdir ~search_path: search_path + ~inconsistent_lean_libs () ;; @@ -350,6 +375,10 @@ let ignore_dups_in() = lazy_init(); !conf_ignore_dups_in;; +let inconsistent_lean_libs() = + lazy_init(); + !conf_inconsistent_lean_libs;; + let package_directory pkg = lazy_init(); (Fl_package_base.query pkg).Fl_package_base.package_dir diff --git a/src/findlib/findlib.mli b/src/findlib/findlib.mli index 22f05d5..74b97e7 100644 --- a/src/findlib/findlib.mli +++ b/src/findlib/findlib.mli @@ -30,6 +30,8 @@ type formal_pred = ] (** A formal predicate as it occurs in a package definition *) +type level = Ignore | Warn | Err + val init : ?env_ocamlpath: string -> ?env_ocamlfind_destdir: string -> @@ -37,6 +39,7 @@ val init : ?env_ocamlfind_commands: string -> ?env_ocamlfind_ignore_dups_in: string -> ?env_ocamlfind_ignore_dups_in_list: string list -> + ?env_ocamlfind_inconsistent_lean_libs: level -> ?env_camllib: string -> ?env_ldconf: string -> ?config: string -> @@ -101,6 +104,7 @@ val init_manually : ?ocamldoc_command: string -> (* default: "ocamldoc" *) ?ignore_dups_in:string -> (* default: None *) ?ignore_dups_in_list:string list -> (* default: [] *) + ?inconsistent_lean_libs:level -> (* default: Warn *) ?stdlib: string -> (* default: taken from Findlib_config *) ?ldconf: string -> ?config: string -> @@ -136,6 +140,9 @@ val ocaml_stdlib : unit -> string val ocaml_ldconf : unit -> string (** Get the file name of [ld.conf] *) +val inconsistent_lean_libs : unit -> level + (** How to deal with inconsistent lean libraries *) + val package_directory : string -> string (** Get the absolute path of the directory where the given package is * stored. diff --git a/src/findlib/frontend.ml b/src/findlib/frontend.ml index 7cbb2e6..264c34e 100644 --- a/src/findlib/frontend.ml +++ b/src/findlib/frontend.ml @@ -4,6 +4,7 @@ *) open Findlib;; +open Printf exception Usage;; exception Silent_error;; @@ -2258,11 +2259,64 @@ let install_package () = ); Some m | None -> - None + Some (Fl_barescanner.to_pkg_expr bare) ) ) else meta_in_expr_opt in + (* For lean packages: check list of requirements *) + let inconsistent_lean_libs = + Findlib.inconsistent_lean_libs() in + if !lean && inconsistent_lean_libs <> Findlib.Ignore then ( + match meta_expr_opt with + | None -> + assert false + | Some m -> + let problem = ref false in + let reqs = + try Fl_metascanner.lookup "requires" [] m.Fl_metascanner.pkg_defs |> Fl_split.in_words + with Not_found -> [] in + List.iter + (fun pkg -> + try + match Findlib.package_type pkg with + | Lean | Lean_with_META -> () + | Legacy -> + problem := true; + let msg = + sprintf "Required package '%s' is a legacy package" pkg in + ( match inconsistent_lean_libs with + | Findlib.Ignore -> + () + | Findlib.Warn -> + eprintf "[WARNING] %s\n" msg + | Findlib.Err -> + eprintf "[ERROR] %s\n" msg + ) + with + | Findlib.No_such_package _ -> + (* ignore this for now *) + () + ) + reqs; + if !problem then ( + eprintf "**********************************************************************\n"; + eprintf "* This lean package uses installed packages that are not lean. *\n"; + eprintf "* Because of this you will not be able to use this package *\n"; + eprintf "* with only the basic lookup feature built into the compiler. *\n"; + ( match inconsistent_lean_libs with + | Ignore -> () + | Warn -> + eprintf "* This situation is tolerated, but the packages should be fixed. *\n" + | Err -> + eprintf "* This is no longer accepted. Go and fix the packages. *\n" + ); + eprintf "**********************************************************************\n"; + if inconsistent_lean_libs = Err then + failwith "Bad package" + ) + ); + (* Create the package directory: *) install_create_directory !pkgname pkgdir; From 113d3245ddb6fda801025f34b6c7a5979d8c571a Mon Sep 17 00:00:00 2001 From: Gerd Stolpmann Date: Fri, 1 May 2020 21:38:32 +0000 Subject: [PATCH 15/17] update TODO --- TODO | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/TODO b/TODO index 3d3e568..09d7850 100644 --- a/TODO +++ b/TODO @@ -1,6 +1,14 @@ -Document archive(plugin) + - ocamlfind remove + - lean packages: support sub packages properly (also when there is a META file). + descend into subdirs also for lean_with_META + install: create subdirs as needed + - support that ocamlopt is not present + - support old compilers without cmo/cmx parsing helpers + - support "unparsed bare package" mode + These packages are just forwarded to the compiler. + Also use this for dynlink. + - fix generation of META for built-in libs like unix + No longer m4 + Turn them into lean packages + - Support ppx -Suggestion (gasche): -show-command only outputs the constructed -command, but does not run it. - -Get ready for -ppx From 24e857dc5477ba216ef7c9b9b1d9a525c56fd13c Mon Sep 17 00:00:00 2001 From: Gerd Stolpmann Date: Fri, 1 May 2020 21:41:17 +0000 Subject: [PATCH 16/17] udpates --- TODO | 2 ++ 1 file changed, 2 insertions(+) diff --git a/TODO b/TODO index 09d7850..45eb32d 100644 --- a/TODO +++ b/TODO @@ -11,4 +11,6 @@ No longer m4 Turn them into lean packages - Support ppx + - support Dune's virtual packages + - clean up the version of OCAMLPATH passed to the compiler From 252dd88f9fa1299e0f08755f115be6639388897d Mon Sep 17 00:00:00 2001 From: Gerd Stolpmann Date: Mon, 4 May 2020 12:11:36 +0000 Subject: [PATCH 17/17] docs --- TODO | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/TODO b/TODO index 45eb32d..3168c34 100644 --- a/TODO +++ b/TODO @@ -13,4 +13,6 @@ - Support ppx - support Dune's virtual packages - clean up the version of OCAMLPATH passed to the compiler - + - enforce DLL naming convention for lean pkgs + - Support dynload + - Documentation