not-ocamlfind-0.15/0002755000175000017500000000000015237132260013224 5ustar stephstephnot-ocamlfind-0.15/.github/0002755000175000017500000000000015237132260014564 5ustar stephstephnot-ocamlfind-0.15/.github/workflows/0002755000175000017500000000000015237132260016621 5ustar stephstephnot-ocamlfind-0.15/.github/workflows/ci.yml0000644000175000017500000000211715237132260017736 0ustar stephstephname: CI # on: [push, pull_request] on: [workflow_dispatch] jobs: build: strategy: fail-fast: false # Test Linux, macOS and Windows with the oldest and newest supported OCaml # and trunk. matrix: os: - macos-latest - ubuntu-latest - windows-latest ocaml-version: - "4.14" - "5.3" include: - os: ubuntu-latest ocaml-version: "4.10" - os: macos-13 ocaml-version: "4.10" - os: macos-latest ocaml-version: "4.10" runs-on: ${{ matrix.os }} steps: - name: Checkout code uses: actions/checkout@v4 - name: Set-up OCaml ${{ matrix.ocaml-version }} uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: ${{ matrix.ocaml-version }} - name: Setup Dependencies run: | opam install . --deps-only --with-doc --with-test opam pin add not-ocamlfind . --no-action - name: Install it with opam run: | opam install --strict not-ocamlfind not-ocamlfind-0.15/.gitignore0000644000175000017500000000003215237132260015205 0ustar stephsteph*.cm* not-ocamlfind *.exe not-ocamlfind-0.15/CHANGES0000644000175000017500000000312115237132260014212 0ustar stephstephnot-ocamlfind 0.15 ------------------ * [12 Aug 2026] release 0.15 * [03 Aug 2026] remove local copy of findlib, since findlib upgrade obviates it. -- ALSO, it seems there's some bug with this cached copy of findlib that appeared recently, and removing it fixes that bug. not-ocamlfind 0.14 ------------------ * [19 Mar 2025] update cached copy of ocamlfind to 1.9.8; update toplevel Makefile to hopefully work well on Windows. not-ocamlfind 0.13 ------------------ * [3 May 2024] add "-impl", "-intf" to the "preprocess" command (pass thru to camlp5). Also fix Freebsd build process. not-ocamlfind 0.12 ------------------ * [22 Sep 2023] change bootstrap in Makefile to avoid freebsd build bug not-ocamlfind 0.11 ------------------ * [30 Aug 2023] swap "bash" to "sh" not-ocamlfind 0.10 ------------------ * [30 Mar 2023] in "preprocess", ignore "-for-pack", "-linkall" arguments so we can just replace "ocamlc" with "preprocess" not-ocamlfind 0.08 ------------------ * [04 Aug 2021] add better support for syntax predicates. formerly, a syntax predicate gets added to "syntax_preds". with this patch, "syntax_" prepended to that predicate also gets added to "predicates". not-ocamlfind 0.07.02 --------------------- * [26 Oct 2020] remove dependencies on sexp (too many deps) since they were for debug only not-ocamlfind 0.07.01 --------------------- * [13 Oct 2020] added a changelog minor fix for ocamlgraph 2.0.0 compatibility. Since ocamlgraph 1.8.8->2.0.0 is a breaking change, this version of not-ocamlfind will only work with the newer version of ocamlgraph. not-ocamlfind-0.15/LICENSE0000644000175000017500000000241315237132260014227 0ustar stephstephThis package is a slight modification of sources originally authored by Gerd Stolpmann, and hence governed by the license on his code. ================================================================ Copyright 1999 by Gerd Stolpmann The package "findlib" is copyright by Gerd Stolpmann. Permission is hereby granted, free of charge, to any person obtaining a copy of this document and the "findlib" software (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. The Software is provided ``as is'', without warranty of any kind, express or implied, including but not limited to the warranties of merchantability, fitness for a particular purpose and noninfringement. In no event shall Gerd Stolpmann be liable for any claim, damages or other liability, whether in an action of contract, tort or otherwise, arising from, out of or in connection with the Software or the use or other dealings in the software. not-ocamlfind-0.15/META0000644000175000017500000000021215237132260013666 0ustar stephsteph# stub META file for "not-ocamlfind" frontend to "ocamlfind" requires = "" version = "0.15" description = "add-on commands for ocamlfind" not-ocamlfind-0.15/Makefile0000644000175000017500000000221315237132260014660 0ustar stephsteph #include local-packages/ocamlfind/Makefile.config INSTALLFILE = install -c OCAMLFIND_BIN= $(shell dirname `which ocamlfind`) DEBUG= PACKAGES = str,unix,fmt,rresult,ocamlgraph,camlp-streams,findlib EXEC_SUFFIX := $(shell ocamlc -config-var ext_exe) all: not-ocamlfind$(EXEC_SUFFIX) papr_official.exe not-ocamlfind$(EXEC_SUFFIX): fsmod.ml frontend.ml main.ml ocamlfind ocamlc $(DEBUG) $(INC) -package $(PACKAGES) -linkall -linkpkg fsmod.ml frontend.ml main.ml -o not-ocamlfind$(EXEC_SUFFIX) bootstrap: fsmod.ORIG.ml not-ocamlfind preprocess -package camlp5,pa_ppx.deriving_plugins.show,camlp5.pr_o \ -syntax camlp5o $< > fsmod.ml.NEW mv fsmod.ml.NEW fsmod.ml papr_official.exe: papr_official.ml ocamlfind ocamlc $(DEBUG) $(INC) -package str,unix,compiler-libs.common \ -linkall -linkpkg $< -o $@ install: not-ocamlfind$(EXEC_SUFFIX) $(INSTALLFILE) not-ocamlfind$(EXEC_SUFFIX) $(OCAMLFIND_BIN) ocamlfind remove not-ocamlfind || true ocamlfind install not-ocamlfind META papr_official.exe uninstall: rm -f $(OCAMLFIND_BIN)/not-ocamlfind$(EXEC_SUFFIX) ocamlfind remove not-ocamlfind || true clean: rm -f *.cm* not-ocamlfind$(EXEC_SUFFIX) *.exe not-ocamlfind-0.15/README.md0000644000175000017500000000662715237132260014514 0ustar stephsteph# not-ocamlfind Front-end to ocamlfind to add a few new commands # Features The command `not-ocamlfind` is a pass-thru to `ocamlfind`, but adds three new commands: `preprocess`, `reinstall-if-diff` and `package-graph`. ### `reinstall-if-diff` 1. `reinstall-if-diff` does what it says on the label: only reinstalls (remove then install) if the file-content of the package has changed. A regular `ocamlfind install` command like ``` ocamlfind install pa_ppx_base -destdir $(DESTDIR)/lib META $(TARGET) pa_ppx_base.cmx pa_ppx_base.cmi ``` installs a package `pa_ppx_base`, failing if the package is already installed. Rewrite that to ``` ocamlfind reinstall-if-diff pa_ppx_base -destdir $(DESTDIR)/lib META $(TARGET) pa_ppx_base.cmx pa_ppx_base.cmi ``` and it checks (a) that the package is already-installed, (b) that the files-to-be-installed are identical in names and checksums to the files already-installed, (c) if not does ``` ocamlfind remove pa_ppx_base ocamlfind install pa_ppx_base -destdir $(DESTDIR)/lib META $(TARGET) pa_ppx_base.cmx pa_ppx_base.cmi ``` and (d) if they are identical in names and checksums, does *nothing*. In projects will multiple directories, if each directory locally installs a `findlib` package, then other directories can use those packages; they can also put those packages into their `make depend` dependencies, viz. ``` EXTERNAL := $(shell $(OCAMLFIND) query -predicates byte $(PACKAGES)) $(CMO) $(CMI) $(CMX): $(EXTERNAL) ``` hence causing rebuilds to occur when other directories have changed. ### `preprocess` A compile command using PPX rewriters ``` ocamlfind ocamlc -package ounit2,ppx_deriving.show -c test_deriving_show.ml ``` can be coaxed to produce its preprocessed output by adding "-dsource". But this is messy and ugly, esp. when we might want to use that source for further compilation. It also isn't very helpful when dealing with a multi-stage PPX rewriter sequence. `preprocess` produces the source and does not attempt to compile it; as an added benefit, it prints (to stderr) the commands it executed to produce that source. So you can use this for debugging multi-stage PPX rewriter sequences: ``` ocamlfind preprocess -package ounit2,ppx_deriving.show test_deriving_show.ml ``` Note well that all the options destined only for the compiler, linker, etc, are removed (and henced rejected) for `preprocess`. Only options required for preprocessing are accepted (`-package`, `-syntax`, `-predicates`, `-ppopt`, `-ppxopt`, `-intf`, `-impl`). This can work for camlp5 also, but that little bit of documentation is TBD. ### `package-graph` This command outputs a graph in the format accepted by the ``dot`` command of graphviz. By default you get the package-dependency graph, with sizes of the archives for each packages as part of the node-label. If you add ``-dominator-from ``, it will compute the dominator-tree from that node. and if you add ``-xdot``, it will automatically invoke ``xdot`` on the graph. Example: ``` not-ocamlfind package-graph -xdot -package camlp5,ounit2,pa_ppx.here.link -dominator-from pa_ppx.here.link -xdot ``` # Installation To install `not-ocamlfind` you need a slightly-patched version of ocamlfind (branch `export-more-cmis`). Until (and unless) this patch gets integrated into the ocamlfind distribution, we build a local copy with that patch. So you merely need to: ``` ./configure make make install ``` not-ocamlfind-0.15/frontend.ml0000644000175000017500000014050315237132260015376 0ustar stephsteph(* $Id$ * ---------------------------------------------------------------------- * *) open Findlib;; exception Usage;; exception Silent_error;; type mode = M_reinstall_if_diff | M_preprocess | M_package_graph | M_passthru ;; type psubst = Const of string | Percent of string * modifier | Lookup of string * modifier and modifier = | Plain | Plus ;; let except e = let rec except_e = function [] -> [] | elem::l -> if e = elem then except_e l else elem::except_e l in except_e ;; let sys_error code arg = if arg = "" then Sys_error (Unix.error_message code) else Sys_error (arg ^ ": " ^ Unix.error_message code) let slashify s = match Findlib_config.system with | "mingw" | "mingw64" | "cygwin" -> let b = Buffer.create 80 in String.iter (function | '\\' -> Buffer.add_char b '/' | c -> Buffer.add_char b c ) s; Buffer.contents b | _ -> s let out_path ?(prefix="") s = match Findlib_config.system with | "mingw" | "mingw64" | "cygwin" -> let u = slashify s in prefix ^ (if String.contains u ' ' then (* Desperate attempt to fix the space problem in paths. Note that we invoke commands via Unix.open_process, and this function already quotes the arguments on win32. However, for -ccopt arguments, one quoting level seems to be lost, and we have to add another level to compensate. E.g. for the list of args [ -ccopt; -L/my programs/include -L/somewhere ] we get after out_path [ -ccopt; "-I/my programs/include -L/somewhere" ] which actually translates to -ccopt "\"-I/my programs/include\" \"-L/somewhere\"" on the command line, i.e. a double-quoted argument. *) "\"" ^ u ^ "\"" else u ) | _ -> prefix ^ slashify s let percent_subst ?base spec lookup s = (* spec = [ "%c", [ "ctext1"; "ctext2"; ... ]; * "%d", [ "dtext1"; "dtext2"; ... ] ] * All occurrences of %c in the string s are replaced as specified in spec. * spec is an association list with the %-notation as keys * and lists of strings as values. The result is a list of strings containing * every combination of substituted values. * * Support for the %(name) syntax: In this case, the name is taken as * key for the [lookup] function, which either returns the string value * or raises Not_found. * * "+" modifier: A "+" after "%" causes that Findlib.resolve_path is * called for the substitution string (e.g. %+c, %+(name)). * * Example: * spec = [ "%a", [ "file1" ] ] * lookup = function "archive" -> "file2" | _ -> raise Not_found * Here, %a is substituted by file1, and %(archive) is substituted by * file2. * * ?base: The base parameter for Findlib.resolve_path. *) let l = String.length s in let fail() = failwith "bad format string" in let parenthesized_name j = try if j+1>=l then raise Not_found; let k = String.index_from s (j+1) ')' in let name = String.sub s (j+1) (k-j-1) in (name, k+1) with Not_found -> fail() in let rec preprocess i j = if j if j+1 prev :: Const "%" :: preprocess (j+2) (j+2) | '(' -> let name, j_next = parenthesized_name (j+1) in prev :: Lookup(name,Plain) :: preprocess j_next j_next | '+' -> if j+2 fail() | '(' -> let name, j_next = parenthesized_name (j+2) in prev :: Lookup(name,Plus) :: preprocess j_next j_next | _ -> let name = "%" ^ String.make 1 c in prev :: Percent(name,Plus) :: preprocess (j+3) (j+3) end else fail() | _ -> let name = "%" ^ String.make 1 c in prev :: Percent(name,Plain) :: preprocess (j+2) (j+2) end else fail() | _ -> preprocess i (j+1) end else if i u | Plus -> plus_subst u in let rec subst prefix l = match l with [] -> [prefix] | Const s :: l' -> subst (prefix ^ s) l' | Percent(name,modi) :: l' -> let replacements0 = try List.assoc name spec with Not_found -> failwith "bad format string" in let replacements = List.map (any_subst modi) replacements0 in List.flatten (List.map (fun replacement -> subst (prefix ^ replacement) l') replacements) | Lookup(name,modi) :: l' -> let replacement0 = try lookup name with Not_found -> "" in let replacement = any_subst modi replacement0 in subst (prefix ^ replacement) l' in subst "" (preprocess 0 0) ;; 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 current = ref 0 let argv = ref [||] let arg n = if n < Array.length !argv then (!argv).(n) else raise Not_found ;; let rec nth0 = function (0,l) -> l | (n, h::t) -> nth0 (n-1,t) | _ -> assert false ;; let remaining_args () = nth0 (!current, Array.to_list !argv) ;; let escape_if_needed s = if String.contains s ' ' then "\"" ^ String.escaped s ^ "\"" else s ;; let use_package prefix pkgnames = (* may raise No_such_package *) let pdirs = List.map (fun pname -> "-I " ^ out_path(package_directory pname) ) pkgnames in print_endline (prefix ^ String.concat " " pdirs) ;; let file_contents filename = let ic = open_in filename in let inlen = in_channel_length ic in let s = really_input_string ic inlen in close_in ic ; s ;; let parse_ldconf contents = Str.(split (regexp "\n+") contents) ;; let read_ldconf filename = let contents = file_contents filename in let lines = parse_ldconf contents in lines ;; let format_ldconf lines new_lines = let b = Buffer.create 23 in List.iter (fun line -> Buffer.add_string b (line ^ "\n")) (lines @ new_lines) ; Buffer.contents b ;; let is_dll p = let sfx = Findlib_config.dll_suffix in sfx <> "" && Filename.check_suffix p sfx ;; let identify_dir d = match Sys.os_type with | "Win32" -> failwith "identify_dir" (* not available *) | _ -> let s = Unix.stat d in (s.Unix.st_dev, s.Unix.st_ino) ;; let conflict_report incpath pkglist = (* Check whether there are several definitions for packages * in the current path. We remove duplicate directories first. * Note that all other checks are not sensitive to duplicate directories. *) Fl_package_base.package_conflict_report ~identify_dir (); (* Second check whether there are module conflicts *) let pkgpath = List.map Findlib.package_directory pkglist in Fl_package_base.module_conflict_report ~identify_dir (pkgpath @ incpath); (* Finally check whether there are multiple DLLs: *) (* Note: Only the directories mentioned in ld.conf are checked, but not the * directories in [incpath], and not the directories in CAML_LD_LIBRARY_PATH. * The idea of this check is to ensure a proper installation, and not to * complain about the user's special configuration. *) let ldconf = ocaml_ldconf() in if ldconf <> "ignore" then begin let dll_dirs = remove_dups (read_ldconf ldconf) in let dll_pairs = List.flatten (List.map (fun dll_dir -> let files = try Array.to_list (Sys.readdir dll_dir) with _ -> prerr_endline ("ocamlfind: [WARNING] Cannot read directory " ^ dll_dir ^ " which is mentioned in ld.conf"); [] in List.map (fun file -> (file, dll_dir)) (List.filter is_dll files) ) dll_dirs ) in let dll_hash = Hashtbl.create 50 in List.iter (fun (file, dll_dir) -> Hashtbl.add dll_hash file dll_dir) dll_pairs; Hashtbl.iter (fun file dll_dir -> let locations = Hashtbl.find_all dll_hash file in if List.length locations > 1 then begin prerr_endline ("ocamlfind: [WARNING] The DLL " ^ file ^ " occurs in multiple directories: " ^ dll_dir) end ) dll_hash end ;; let check_package_list l = (* may raise No_such_package *) List.iter (fun pkg -> let _ = package_directory pkg in () ) l ;; type verbosity = | Normal | Verbose | Only_show let run_command ?filter verbose cmd args = let printable_cmd = cmd ^ " " ^ String.concat " " (List.map escape_if_needed args) in ( match verbose with | Normal -> () | Verbose -> print_endline ("+ " ^ printable_cmd); if filter <> None then print_string (" (output of this command is filtered by ocamlfind)\n") | Only_show -> print_endline printable_cmd ); flush stdout; if verbose <> Only_show then ( let filter_input, cmd_output = match filter with None -> Unix.stdin (* dummy *), Unix.stdout | Some f -> Unix.pipe() in (* Signals: On SIGINT, we wait until the subprocess finishes, and * die then. This allows us to call interactive commands as subprocesses. *) let old_sigint = Sys.signal Sys.sigint Sys.Signal_ignore in let need_exe = List.mem Findlib_config.system [ "win32"; "win64"; "mingw"; "mingw64" ] in let fixed_cmd = if need_exe then ( if Filename.check_suffix cmd ".exe" then cmd else cmd ^ ".exe" ) else cmd in let pid = Unix.create_process fixed_cmd (Array.of_list (cmd :: args)) Unix.stdin cmd_output Unix.stderr in begin match filter with Some filter_fun -> begin Unix.close cmd_output; let ch = Unix.in_channel_of_descr filter_input in try while true do let line = input_line ch in match filter_fun line with None -> () (* Suppress line *) | Some line' -> print_endline line' done; assert false with End_of_file -> close_in ch; flush stdout end | None -> () end; let (_,status) = Unix.waitpid [] pid in Sys.set_signal Sys.sigint old_sigint; begin match status with Unix.WEXITED 0 -> () | Unix.WEXITED n -> if verbose = Verbose then print_string (cmd ^ " returned with exit code " ^ string_of_int n ^ "\n"); exit n | Unix.WSIGNALED _ -> print_string (cmd ^ " got signal and exited\n"); exit 2 | Unix.WSTOPPED _ -> failwith "Your operating system does not work correctly" end ) ;; (**************** preprocessor ******************************************) let select_pp_packages syntax_preds packages = if syntax_preds = [] then (* No syntax predicates, no preprocessor! *) [] else List.filter (fun pkg -> let al = try package_property syntax_preds pkg "archive" with Not_found -> "" in let w = Fl_split.in_words al in w <> [] ) packages let process_pp_spec syntax_preds packages pp_opts = (* Returns: pp_command *) (* may raise No_such_package *) (* [packages]: all packages given on the command line. May include * packages for compilation and for preprocessing. * * The difficulty is now that the preprocessor packages may have * requirements that are non-preprocessor packages. To get exactly * the preprocessor packages and its requirements, we do: * * 1. Determine the subset of [packages] that are preprocessor * packages by checking whether they have an "archive" for * [syntax_preds], i.e. the preprocessor packages mentioned * on the command line = [cl_pp_packages]. * * 2. Add their requirements = [pp_packages] * * Because the packages are now mixed, we must evaluate for * [syntax_preds] + "byte". *) (* One packages must now have the variable "preprocessor", usually camlp4 *) let cl_pp_packages = select_pp_packages syntax_preds packages in let pp_packages = package_deep_ancestors syntax_preds cl_pp_packages in let preprocessor_cmds = List.flatten (List.map (fun pname -> try [ pname, package_property syntax_preds pname "preprocessor" ] with Not_found -> [] ) pp_packages ) in let preprocessor_cmd = if syntax_preds <> [] then match preprocessor_cmds with [] -> failwith("Using -syntax, but no package is selected specifying \ a preprocessor as required for -syntax") | [_, cmd] -> Some cmd | _ -> failwith("Several packages are selected that specify \ preprocessors: " ^ String.concat ", " (List.map (fun (n,v) -> "package " ^ n ^ " defines `" ^ v ^ "'") preprocessor_cmds ) ) else None in let pp_i_options = List.flatten (List.map (fun pkg -> let pkgdir = package_directory pkg in [ "-I"; slashify pkgdir ] ) pp_packages) in let pp_archives = if preprocessor_cmd = None then [] else List.flatten (List.map (fun pkg -> let al = try package_property ("byte" :: syntax_preds) pkg "archive" with Not_found -> "" in Fl_split.in_words al ) pp_packages) in match preprocessor_cmd with None -> [] | Some cmd -> let cmd = Str.(split (regexp "[ \t]+") cmd) in cmd@ pp_i_options@ pp_archives@ pp_opts ;; (**************** ppx extensions ****************************************) let process_ppx_spec predicates packages ppx_opts = (* Returns: ppx_commands *) (* may raise No_such_package *) let ppx_packages = package_deep_ancestors predicates packages in let ppx_opts = List.map (fun opt -> match Fl_split.in_words opt with | pkg :: ((_ :: _) as opts) -> let exists = try ignore(package_directory pkg); true with No_such_package _ -> false in if not exists then failwith ("The package named in -ppxopt does not exist: " ^ pkg); pkg, opts | _ -> failwith "-ppxopt must include package name, e.g. -ppxopt \"foo,-name bar\"" ) ppx_opts in let meta_ppx_opts = List.concat (List.map (fun pname -> try let opts = package_property predicates pname "ppxopt" in (* Split by whitespace to get (package,options) combinations. Then, split by commas to get individual options. *) List.map (fun opts -> match Fl_split.in_words opts with | pkg :: ((_ :: _) as opts) -> let exists = try ignore(package_directory pkg); true with No_such_package _ -> false in if not exists then failwith ("The package named in ppxopt variable does not exist: " ^ pkg ^ " (from " ^ pname ^ ")"); let base = package_directory pname in pkg, List.map (resolve_path ~base ~explicit:true) opts | _ -> failwith ("ppxopt variable must include package name, e.g. " ^ "ppxopt=\"foo,-name bar\" (from " ^ pname ^ ")") ) (Fl_split.in_words_ws opts) with Not_found -> [] ) ppx_packages ) in List.flatten (List.map (fun pname -> let base = package_directory pname in let options = try List.concat (List.map (fun (_, opts) -> opts) (List.filter (fun (pname', _) -> pname' = pname) (meta_ppx_opts @ ppx_opts))) with Not_found -> [] in try let preprocessor = resolve_path ~base ~explicit:true (package_property predicates pname "ppx") in ["-ppx"; String.concat " " (preprocessor :: options)] with Not_found -> [] ) ppx_packages) let parse_args ?(current = current) ?(args = !argv) ?(align = true) spec anon usage = try Arg.parse_argv ~current args (if align then Arg.align spec else spec) anon usage with | Arg.Help text -> print_string text; exit 0 | Arg.Bad text -> prerr_string text; exit 2 (**************** OCAMLC/OCAMLMKTOP/OCAMLOPT subcommands ****************) let ppx_invoke1 cmd ~root f = let open Filename in let outf = temp_file root "" in (Printf.sprintf "%s %s %s" cmd f outf, outf) ;; let ppx_invoke cmds f = let open Filename in let base = basename f in if not (check_suffix base ".mli" || check_suffix base ".ml") then failwith "File must end with either .ml or .mli" ; let (root, suff) = if check_suffix base ".mli" then (chop_suffix base ".mli", ".mli") else (chop_suffix base ".ml", ".ml") in let extra_arg = if suff = ".mli" then "-intf" else "-impl" in let outf0 = temp_file root "" in let cmd0 = Printf.sprintf "ocamlfind not-ocamlfind/papr_official.exe -binary-output %s %s %s" extra_arg f outf0 in let (outf, cmdsacc, tmpfiles) = List.fold_left (fun (inf, cmdsacc, tmpfiles) cmd -> let (cmd, outf) = ppx_invoke1 ~root cmd inf in (outf, ((cmd,outf)::cmdsacc), outf::tmpfiles)) (outf0, [(cmd0, outf0)], [outf0]) cmds in let cmds = List.rev cmdsacc in (suff, cmds, outf, tmpfiles) ;; let check_rc msg cmd = Printf.fprintf stderr "%s: %s\n%!" msg cmd ; match Unix.system cmd with Unix.WEXITED 0 -> () | Unix.WEXITED n -> Printf.fprintf stderr "%s: process exited with status %d\n%!" msg n ; failwith (Printf.sprintf "%s: failed" msg) | _ -> failwith (Printf.sprintf "%s: failed with unexpected status" msg) ;; let ppx_execute (suff, cmds, outf, tmpfiles) = cmds |> List.iter (fun (cmd, outf) -> check_rc "ppx_execute" cmd ; ) ; let extra_arg = if suff = ".mli" then "-intf" else "-impl" in check_rc "format output file" (Printf.sprintf "ocamlfind not-ocamlfind/papr_official.exe -binary-input %s %s" extra_arg outf) (* check_rc "unlink tmpfiles" (Printf.sprintf "rm -f %s" (String.concat " " tmpfiles)) *) ;; type pass_file_t = Pass of string | Impl of string (* Forces module implementation: -impl *) | Intf of string (* Forces module interface: -intf *) | Cclib of string (* Option for the C linker: -cclib *) ;; let contracted_ocamlmklib_options = [ "-l"; "-L"; "-R"; "-F"; "-Wl,-rpath,"; "-Wl,-R" ] (* The ocamlmklib options where the argument is directly attached to the switch (e.g. -L instead of -L ) *) (************************************************************************) let preprocess () = (* let destdir = ref (default_location()) in *) let pass_files = ref [] in let packages = ref [] in let predicates = ref [] in let syntax_preds = ref [] in let pp_opts = ref [] in let ppx_opts = ref [] in let verbose = ref Normal in let add_pkg = Arg.String (fun s -> packages := !packages @ (Fl_split.in_words s)) in let ignore_for_pack = Arg.String (fun s -> Fmt.(pf stderr "not-ocamlfind preprocess: ignore -for-pack %s\n%!" s)) in let ignore_linkall = Arg.Unit (fun _ -> Fmt.(pf stderr "not-ocamlfind preprocess: ignore -linkall\n%!")) in let add_pred = Arg.String (fun s -> predicates := !predicates @ (Fl_split.in_words s)) in let add_syntax_pred = Arg.String (fun s -> begin syntax_preds := !syntax_preds @ (Fl_split.in_words s) ; predicates := !predicates @ (List.map (Printf.sprintf "syntax_%s") (Fl_split.in_words s)) ; end) in let do_add_pp_opt s = pp_opts := !pp_opts @ [s] in let add_pp_opt = Arg.String do_add_pp_opt in let do_add_pass_file s = pass_files := !pass_files @ [s] in let ignore_error = ref false in let arg_spec = [ "-package", add_pkg, " Refer to package when compiling"; "-for-pack", ignore_for_pack, " Ignored -for-pack option from ocamlc"; "-linkall", ignore_linkall, " Ignored -linkall option from ocamlc"; "-predicates", add_pred, "

Add predicate

when resolving package properties"; "-syntax", add_syntax_pred, "

Use preprocessor with predicate

"; "-ppopt", add_pp_opt, " Append option to preprocessor invocation"; "-ppxopt", Arg.String (fun s -> ppx_opts := !ppx_opts @ [s]), ", Append options to ppx invocation for package "; "-impl", Arg.String (fun s -> do_add_pass_file (Impl s)), " Append \"impl \" to preprocessor invocation"; "-intf", Arg.String (fun s -> do_add_pass_file (Intf s)), " Append \"intf \" to preprocessor invocation"; "-ignore-error", Arg.Set ignore_error, " Ignore the 'error' directive in META files"; "-only-show", Arg.Unit (fun () -> verbose := Only_show), " Only show the constructed command, but do not exec it"; "-verbose", Arg.Unit (fun () -> verbose := Verbose), " Show the constructed command and also exec it\nSTANDARD OPTIONS:"; ] in let (current,args) = (current, !argv) in parse_args ~current ~args arg_spec (fun s -> do_add_pass_file (Pass s)) ("usage: not-ocamlfind preprocess [options] file ..."); (* ---- Start requirements analysis ---- *) predicates := "byte" :: !predicates; if !syntax_preds <> [] then begin predicates := "syntax" :: !predicates; syntax_preds := "preprocessor" :: "syntax" :: !syntax_preds; end; (* check packages: *) check_package_list !packages; let eff_packages = package_deep_ancestors !predicates !packages in (* ---- End of requirements analysis ---- *) (* Add the pkg_ predicates: *) predicates := List.map (fun pkg -> "pkg_" ^ pkg) eff_packages @ !predicates; (* Check on [warning] directives: *) List.iter (fun pkg -> try let warning = package_property !predicates pkg "warning" in prerr_endline("ocamlfind: [WARNING] Package `" ^ pkg ^ "': " ^ warning) with Not_found -> () ) eff_packages; (* Check on [error] directives: *) List.iter (fun pkg -> try let error = package_property !predicates pkg "error" in if !ignore_error then prerr_endline("ocamlfind: [WARNING] Package `" ^ pkg ^ "' signals error: " ^ error) else failwith ("Error from package `" ^ pkg ^ "': " ^ error) with Not_found -> () ) eff_packages; if !verbose = Verbose then begin if !syntax_preds <> [] then print_string ("Effective set of preprocessor predicates: " ^ String.concat "," !syntax_preds ^ "\n"); print_string ("Effective set of compiler predicates: " ^ String.concat "," !predicates ^ "\n"); end; (* initl_file_name: the initialization code inserted at the end of * the cma/cmo list (initl = init last) *) let pp_command = process_pp_spec !syntax_preds !packages !pp_opts in let ppx_commands = process_ppx_spec !predicates !packages !ppx_opts in let pass_files' = List.flatten (List.map (function Pass s -> if s <> "" && s.[0] = '-' then [ "-"; String.sub s 1 (String.length s - 1) ] else [ resolve_path s ] | Impl s -> [ "-impl"; resolve_path s ] | Intf s -> [ "-intf"; resolve_path s ] | Cclib s -> [ "-cclib"; s ] ) !pass_files) in if pp_command <> [] && ppx_commands <> [] then prerr_endline("not-ocamlfind: [ERROR] both pp and ppx commands present (cannot preprocess)") ; if pp_command <> [] then let pp_command = pp_command@ pass_files' in run_command !verbose (List.hd pp_command) (List.tl pp_command) else begin let ppx_commands = except "-ppx" ppx_commands in List.iter (fun f -> let (suff, cmds, outf, tmpfiles) = ppx_invoke ppx_commands f in ppx_execute (suff, cmds, outf, tmpfiles) ) pass_files' ; end ;; (************************************************************************) module PackageGraph = struct open Graph module StringVertex = struct type t = string let compare = Stdlib.compare let hash = Hashtbl.hash let equal a b = (a = b) type label = t let create x = x let label x = x end module V = StringVertex module G = Imperative.Digraph.ConcreteBidirectional(V) module DotIn = struct type t = G.t module V = G.V module E = G.E let iter_vertex = G.iter_vertex let iter_edges_e = G.iter_edges_e let graph_attributes _ = [] let default_vertex_attributes _ = [] let vertex_name v = v let vertex_attributes _ = [] let get_subgraph _ = None let default_edge_attributes _ = [] let edge_attributes _ = [] end module GDot = Graph.Graphviz.Dot(DotIn) module DomG = Dominator.Make_graph(struct include G let empty () = create () let add_edge g v1 v2 = G.add_edge g v1 v2 ; g end) let to_dot ~dominator_from oc edges = let g = G.create () in List.iter (fun (s, dl) -> List.iter (fun d -> G.add_edge g s d) dl) edges ; let g = match dominator_from with Some v -> DomG.(compute_dom_graph g (compute_all g v).dom_tree) | None -> g in GDot.output_graph oc g ; flush oc end let size_of_package predicates p = match Findlib.package_directory p, Findlib.package_property predicates p "archive" with (dir, archives) -> let archives = Str.(split (regexp " +") archives) in let archives = List.map (fun a -> Printf.sprintf "%s/%s" dir a) archives in List.fold_left (fun acc f -> acc + Unix.(stat f).st_size) 0 archives | exception Not_found -> 0 let package_graph () = let packages = ref [] in let predicates = ref [] in let verbose = ref Normal in let syntax_preds = ref [] in let add_pkg = Arg.String (fun s -> packages := !packages @ (Fl_split.in_words s)) in let add_pred = Arg.String (fun s -> predicates := !predicates @ (Fl_split.in_words s)) in let add_syntax_pred = Arg.String (fun s -> begin syntax_preds := !syntax_preds @ (Fl_split.in_words s) ; predicates := !predicates @ (List.map (Printf.sprintf "syntax_%s") (Fl_split.in_words s)) ; end) in let ignore_error = ref false in let dominator_from = ref "" in let xdot = ref false in let arg_spec = [ "-package", add_pkg, " Refer to package when compiling"; "-predicates", add_pred, "

Add predicate

when resolving package properties"; "-syntax", add_syntax_pred, "

Use preprocessor with predicate

"; "-dominator-from", Set_string dominator_from, "

compute dominator graph from this package

"; "-ignore-error", Arg.Set ignore_error, " Ignore the 'error' directive in META files"; "-xdot", Arg.Set xdot, " invoke ``xdot'' on .dot file"; "-verbose", Arg.Unit (fun () -> verbose := Verbose), " Only show the constructed command, but do not exec it\nSTANDARD OPTIONS:"; ] in let (current,args) = (current, !argv) in parse_args ~current ~args arg_spec (fun s -> failwith (Printf.sprintf "Should not provide any files to the package-graph subcommand (only packages): %s" s)) ("usage: not-ocamlfind package-graph [options] -package "); (* ---- Start requirements analysis ---- *) if not (List.mem "native" !predicates) && not (List.mem "byte" !predicates) then predicates := "byte" :: !predicates; if !syntax_preds <> [] then begin predicates := "syntax" :: !predicates; syntax_preds := "preprocessor" :: "syntax" :: !syntax_preds; end; (* check packages: *) check_package_list !packages; let eff_packages = package_deep_ancestors !predicates !packages in (* ---- End of requirements analysis ---- *) (* Check on [warning] directives: *) List.iter (fun pkg -> try let warning = package_property !predicates pkg "warning" in prerr_endline("ocamlfind: [WARNING] Package `" ^ pkg ^ "': " ^ warning) with Not_found -> () ) eff_packages; (* Check on [error] directives: *) List.iter (fun pkg -> try let error = package_property !predicates pkg "error" in if !ignore_error then prerr_endline("ocamlfind: [WARNING] Package `" ^ pkg ^ "' signals error: " ^ error) else failwith ("Error from package `" ^ pkg ^ "': " ^ error) with Not_found -> () ) eff_packages; if !verbose = Verbose then begin if !syntax_preds <> [] then print_string ("Effective set of preprocessor predicates: " ^ String.concat "," !syntax_preds ^ "\n"); print_string ("Effective set of compiler predicates: " ^ String.concat "," !predicates ^ "\n"); end; (* initl_file_name: the initialization code inserted at the end of * the cma/cmo list (initl = init last) *) let package_graph = List.map (fun p -> (p, package_ancestors !predicates p)) eff_packages in let name2vertex = List.map (fun (p,_) -> let size = size_of_package !predicates p in let rhs = if size = 0 then Fmt.(str "\"%s\"" p) else Fmt.(str "\"%s: %a\"" p bi_byte_size size) in (p, rhs)) package_graph in (* let name2vertex = List.map (fun (p, _) -> (p, Printf.sprintf "\"%s\"" p)) package_graph in *) let n2v n = match List.assoc n name2vertex with v -> v | exception Not_found -> failwith (Printf.sprintf "package %s not in name2vertex map" n) in let g2 = List.map (fun (s,dl) -> (n2v s, List.map n2v dl)) package_graph in let dominator_from = match !dominator_from with "" -> None | s -> Some (n2v s) in if !xdot then begin let tmpfile = Filename.temp_file "graph" ".dot" in let oc = open_out tmpfile in PackageGraph.to_dot ~dominator_from:dominator_from oc g2 ; close_out oc ; ignore (Unix.system (Printf.sprintf "xdot %s" tmpfile)) ; ignore (Unix.unlink tmpfile) end else PackageGraph.to_dot ~dominator_from:dominator_from stdout g2 ;; (************************************************************************) let format_owner_file pkg file = let outpath = file ^ ".owner" in let contents = (pkg ^ "\n") in (outpath, contents) ;; let trim_cr s = let len = String.length s in if len > 0 && String.get s (len-1) = '\r' then String.sub s 0 (len-1) else s let find_owned_files pkg dir = let files = Array.to_list(Sys.readdir dir) in List.filter (fun file -> let owner_file = if Filename.check_suffix file ".owner" then file else file ^ ".owner" in (List.mem owner_file files) && ( try let fd = Unix.openfile (Filename.concat dir owner_file) [Unix.O_RDONLY] 0 in let f = Unix.in_channel_of_descr fd in try let line = trim_cr (input_line f) in let is_my_file = (line = pkg) in close_in f; is_my_file with | End_of_file -> close_in f; false | exc -> close_in f; raise exc with | Unix.Unix_error(Unix.ENOENT,_,_) -> (* the owner file might have been removed by a package removal that is being done in parallel *) false | Unix.Unix_error(code, _, arg) -> raise(sys_error code arg) ) ) files ;; exception Missing_archives of Fl_metascanner.pkg_expr let rec patch_archives pkgdir pkg = (* First remove all missing files from archive variables: *) let defs' = List.map (fun def -> if def.Fl_metascanner.def_var = "archive" then ( let files = Fl_split.in_words def.Fl_metascanner.def_value in let files' = List.filter (fun file -> let p = Findlib.resolve_path ~base:pkgdir file in Sys.file_exists p) files in { def with Fl_metascanner.def_value = String.concat " " files' } ) else def ) pkg.Fl_metascanner.pkg_defs in (* Remove empty archive variables: *) let defs'' = List.filter (fun def -> def.Fl_metascanner.def_var <> "archive" || Fl_split.in_words def.Fl_metascanner.def_value <> [] ) defs' in (* Return the package or raise Not_found if all archives vanished: *) let children = (* Recursive patch, remove all Not_found packages: *) List.flatten (List.map (fun (name, child) -> try [ name, patch_archives pkgdir child ] with Missing_archives _ -> [] ) pkg.Fl_metascanner.pkg_children) in let pkg' = { Fl_metascanner.pkg_defs = defs''; pkg_children = children } in if List.exists (fun def -> def.Fl_metascanner.def_var = "archive") defs'' then pkg' else raise (Missing_archives pkg') ;; let rec patch_pkg pkgdir pkg patches = 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' | (`Rmpkg n) :: patches' -> let children = List.filter (fun (name,_) -> name <> n) pkg.Fl_metascanner.pkg_children in let pkg' = { pkg with Fl_metascanner.pkg_children = children } in patch_pkg pkgdir pkg' patches' | `Archives :: patches' -> let pkg' = try patch_archives pkgdir pkg with Missing_archives p -> p in patch_pkg pkgdir pkg' patches' ;; exception Skip_file;; type which = Auto | Dll | No_dll;; let meta_pkg meta_name = let f = open_in meta_name in try let pkg = Fl_metascanner.parse f in close_in f; pkg with | Failure s | Stream.Error s -> close_in f; failwith ("Cannot parse '" ^ meta_name ^ "': " ^ s) let char_lowercase_ascii c = (* Char.lowercase_ascii and String.lowercase_ascii first available in OCaml-4.03, but we want to support earlier versions too *) if (c >= 'A' && c <= 'Z') then Char.unsafe_chr(Char.code c + 32) else c let string_lowercase_ascii = String.map char_lowercase_ascii open Fsmod let prepare_remove_package ~destdir ~metadir ~ldconf ~pkgname = 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 (* First remove the META file. If it is already gone, assume that a parallel running removal removed it already. *) let mods = ref [] in let push_rm f = if Sys.file_exists f then let digest = Digest.(f |> file |> to_hex) in mods := (f, FM_delete { name = f; checksum = digest }) :: !mods in let push_update f bytes = if Sys.file_exists f then let digest = Digest.(f |> file |> to_hex) in mods := (f, FM_update ({ name = f; checksum = digest}, bytes)) :: !mods in if has_metadir then push_rm (Filename.concat metadir meta_dot_pkg) else push_rm (Filename.concat pkgdir "META") ; (* Remove files from libexec directory: *) if have_libexec then begin let dll_files = find_owned_files pkgname dlldir in List.iter (fun file -> let absfile = Filename.concat dlldir file in push_rm absfile ) dll_files end; (* Remove the files from the package directory: *) if Sys.file_exists pkgdir then begin let files = Sys.readdir pkgdir in Array.iter (fun f -> if f <> "META" then push_rm (Filename.concat pkgdir f)) files; end else prerr_endline("ocamlfind: [WARNING] No such directory: " ^ pkgdir); (* Modify ld.conf *) if ldconf <> "ignore" && Sys.file_exists ldconf then begin let lines = read_ldconf ldconf in let d = Fl_split.norm_dir pkgdir in let exists = List.exists (fun p -> Fl_split.norm_dir p = d) lines in if exists then begin let lines' = List.filter (fun p -> Fl_split.norm_dir p <> d) lines in push_update ldconf (format_ldconf lines' []) end end; (* Check if there is a postremove script: *) let postremove = Filename.concat destdir "postremove" in if Sys.file_exists postremove then failwith "cannot reinstall-if-diff a package with a postremove script" ; List.rev !mods ;; let prepare_reinstall_if_diff_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 let auto_files = ref [] in let dll_files = ref [] in let nodll_files = ref [] in let which = ref Auto in let debug = 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), " never append directory='...' to META"; "-dll", Arg.Unit (fun () -> which := Dll), " The following files are DLLs"; "-nodll", Arg.Unit (fun () -> which := No_dll), " The following files are not DLLs"; "-debug", Arg.Set debug, " Enable massive debug-logging"; ] in let errmsg = "usage: ocamlfind reinstall-if-diff [options] ..." in let install_args = except "-debug" (List.tl (remaining_args ())) in parse_args keywords (fun s -> if !pkgname = "" then pkgname := s else if Sys.file_exists s then match !which with Auto -> auto_files := s :: !auto_files | Dll -> dll_files := s :: !dll_files | No_dll -> nodll_files := s :: !nodll_files else failwith Fmt.(str "reinstall-if-diff: file (to be installed) %s does not exist" s) ) 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 '.'!"; if !debug then Fmt.(pf stderr "removal_mods: START\n%!"); let removal_mods = prepare_remove_package ~destdir:!destdir ~metadir:!metadir ~ldconf:!ldconf ~pkgname:!pkgname in if !debug then Fmt.(pf stderr "removal_mods:\n%a\n%!" pp_t_pair_list removal_mods ) ; (* if this file is listed in the removal-mods, then we pretend it doesn't exist; otherwise we pass it along to Sys.file_exists *) let file_exists f = if List.mem_assoc f removal_mods then false else Sys.file_exists f in let read_file f = match List.assoc f removal_mods with FM_update (_, contents) -> contents | _ -> failwith "Internal error: can only read_file on a file that we're going to update" | exception Not_found -> failwith "Internal error: can only read_file on a file that we're going to update" in let install_mods = ref [] in let push_install ~srcf ~dstf = let digest = Digest.(srcf |> file |> to_hex) in install_mods := (dstf, FM_install { name = srcf; checksum = digest }) :: !install_mods in let push_create ~dstf ~contents = let digest = Digest.(contents |> string |> to_hex) in install_mods := (dstf, FM_create ({ name = dstf; checksum = digest }, contents)) :: !install_mods in let push_update f b = let digest = Digest.(f |> file |> to_hex) in install_mods := (f, FM_update ({ name = f; checksum = digest}, b)) :: !install_mods in 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 (* Check whether there are DLLs: *) let (l1,l2) = List.partition is_dll !auto_files in let dll_list = l1 @ !dll_files in 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) nodll_list with | Not_found -> failwith "The META file is missing" in (* Check for frequent reasons why installation can go wrong *) if 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 file_exists (Filename.concat pkgdir "META") then failwith ("Package " ^ !pkgname ^ " is already installed\n - (file " ^ pkgdir ^ "/META already exists)"); List.iter (fun f -> let f' = Filename.concat pkgdir f in if file_exists f' then failwith ("Conflict with file: " ^ f')) pkgdir_eff_list; if have_libexec then begin List.iter (fun dll -> let b = Filename.basename dll in if file_exists (Filename.concat dlldir b) then failwith ("Conflict with another package: Library " ^ b ^ " is already installed"); ) dll_list end; (* Now copy the files into the package directory (except META): *) List.iter (fun srcf -> try let dstf = Filename.concat pkgdir srcf in if srcf = "META" || srcf = meta_dot_pkg then raise Skip_file ; if srcf = "postremove" then failwith "cannot reinstall-if-diff a package with a postremove script" ; if srcf = "postinstall" then failwith "cannot reinstall-if-diff a package with a postinstall script" ; push_install ~srcf ~dstf with Skip_file -> () ) pkgdir_list; (* Copy the DLLs into the libexec directory if necessary *) if have_libexec then begin List.iter (fun srcf -> let dstf = Filename.concat pkgdir srcf in push_install ~srcf ~dstf ; let (owner_file, contents) = format_owner_file !pkgname (Filename.concat dlldir (Filename.basename srcf)) in push_create ~dstf:owner_file ~contents ) dll_list end; (* Extend ld.conf if necessary: *) if dll_list <> [] && !ldconf <> "ignore" && not have_libexec then begin if Sys.file_exists !ldconf then begin let contents = read_file !ldconf in let lines = parse_ldconf contents in push_update !ldconf (format_ldconf lines [ pkgdir ]) end else prerr_endline("ocamlfind: [WARNING] You have installed DLLs but there is no ld.conf") end; if dll_list <> [] && have_libexec && !ldconf <> "ignore" then begin (* Check whether libexec is mentioned in ldconf *) (* FIXME: We have to be careful with case-insensitive filesystems. Currently, we only check for Win32, but also OS X may have ci filesystems. So some better check would be nice. *) let lines = read_ldconf !ldconf in let dlldir_norm = Fl_split.norm_dir dlldir in let dlldir_norm_lc = string_lowercase_ascii dlldir_norm in let ci_filesys = (Sys.os_type = "Win32") in let check_dir d = let d' = Fl_split.norm_dir d in (d' = dlldir_norm) || (ci_filesys && string_lowercase_ascii d' = dlldir_norm_lc) in if not (List.exists check_dir lines) then prerr_endline("ocamlfind: [WARNING] You have installed DLLs but the directory " ^ dlldir_norm ^ " is not mentioned in ld.conf"); end; (* Finally, write the META file: *) let write_meta append_directory dir name = let contents = file_contents meta_name in let contents = if append_directory then contents ^ "\ndirectory=\"" ^ pkgdir ^ "\" # auto-added by ocamlfind\n" else contents in push_create ~dstf:(Filename.concat dir name) ~contents in if has_metadir then write_meta true !metadir meta_dot_pkg else write_meta false pkgdir "META"; let remove_args = ["-destdir"; !destdir; !pkgname] in (!debug, List.rev !install_mods, install_args, removal_mods, remove_args) ;; let same_action (ifname, iact) (rfname, ract) = if ifname <> rfname then ( Fmt.(pf stderr "Files %s, %s at same position in sorted list of actions\n%!" ifname rfname) ; false ) else match iact, ract with FM_install {name=s2; checksum=sum2}, FM_delete { name=s1; checksum=sum1} when sum1=sum2 -> true | FM_create ({name=s2; checksum=sum2}, _), FM_delete { name=s1; checksum=sum1} when s1=s2 && sum1=sum2 -> true | _ -> Fmt.(pf stderr "File %s has incompatible {install, remove} actions: (%a,%, %a)\n%!" ifname pp iact pp ract) ; false ;; let is_same (install_mods, removal_mods) = let imap = List.sort Stdlib.compare install_mods in let rmap = List.sort Stdlib.compare removal_mods in let rec rerec = function ((ifname, iact)::it, (rfname, ract)::rt) -> if not (same_action (ifname, iact) (rfname, ract)) then false else rerec (it, rt) | ([], []) -> true | _ -> Fmt.(pf stderr "reinstall-if-diff: remove and install lists have differing lengths\n%!") ; false in rerec (imap, rmap) ;; let reinstall_if_diff () = let (debug, install_mods, install_args, removal_mods, remove_args) = prepare_reinstall_if_diff_package() in if debug then Fmt.(pf stderr "reinstall_if_diff\ninstall_mods:\n%a\ninstall_args: [%a]\nremoval_mods:\n%a\nremove_args: [%a]\n%!" pp_t_pair_list install_mods (list ~sep:(const string " ") string) install_args pp_t_pair_list removal_mods (list ~sep:(const string " ") string) remove_args ) ; if not (is_same (install_mods, removal_mods)) then begin run_command Verbose "ocamlfind" ("remove" :: remove_args) ; run_command Verbose "ocamlfind" ("install" :: install_args) end ;; let passthru () = run_command Normal "ocamlfind" (List.tl (Array.to_list !argv)) ;; let rec select_mode () = let k = !current in let m_string = try arg (k+1) with Not_found -> raise Usage in let m = match m_string with ("reinstall-if-diff") -> incr current; M_reinstall_if_diff | ("preprocess") -> incr current; M_preprocess | ("package-graph") -> incr current; M_package_graph | _ -> M_passthru in m ;; let _main av curr () = argv := av ; current := curr ; try let m = select_mode() in match m with M_reinstall_if_diff -> reinstall_if_diff() | M_preprocess -> preprocess () | M_package_graph -> package_graph () | M_passthru -> passthru() with Failure f -> prerr_endline ("ocamlfind: " ^ f); exit 2 | Sys_error f -> prerr_endline ("ocamlfind: " ^ f); exit 2 | Findlib.No_such_package(pkg,info) -> prerr_endline ("ocamlfind: Package `" ^ pkg ^ "' not found" ^ (if info <> "" then " - " ^ info else "")); exit 2 | Findlib.Package_loop pkg -> prerr_endline ("ocamlfind: Package `" ^ pkg ^ "' requires itself"); exit 2 | Silent_error -> exit 2 ;; let main ?(argv = Sys.argv) ?(current = !Arg.current) () = _main argv current () ;; not-ocamlfind-0.15/fsmod.ORIG.ml0000644000175000017500000000060715237132260015426 0ustar stephsteph module Pa_ppx_runtime = struct module Runtime = struct module Fmt = Fmt end end type file_t = { name : string ; checksum : string }[@@deriving show] type t = FM_delete of file_t | FM_install of file_t | FM_update of file_t * string | FM_create of file_t * string[@@deriving show] type t_pair = string * t[@@deriving show] type t_pair_list = t_pair list[@@deriving show] not-ocamlfind-0.15/fsmod.ml0000644000175000017500000000624315237132260014671 0ustar stephsteph module Pa_ppx_runtime = struct module Runtime = struct module Fmt = Fmt end end type file_t = { name : string; checksum : string }[@@deriving_inline show] let rec (pp_file_t : file_t Fmt.t) = fun (ofmt : Format.formatter) arg -> (fun ofmt ({name = v_name; checksum = v_checksum} : file_t) -> let open Pa_ppx_runtime.Runtime.Fmt in pf ofmt "@[<2>{ @[Fsmod.name =@ %a@];@ @[checksum =@ %a@] }@]" (fun ofmt arg -> let open Pa_ppx_runtime.Runtime.Fmt in pf ofmt "%S" arg) v_name (fun ofmt arg -> let open Pa_ppx_runtime.Runtime.Fmt in pf ofmt "%S" arg) v_checksum) ofmt arg[@@ocaml.warning "-39"] [@@ocaml.warning "-33"] and (show_file_t : file_t -> Stdlib.String.t) = fun arg -> Format.asprintf "%a" pp_file_t arg[@@ocaml.warning "-39"] [@@ocaml.warning "-33"] [@@@end] type t = FM_delete of file_t | FM_install of file_t | FM_update of file_t * string | FM_create of file_t * string[@@deriving_inline show] let rec (pp : t Fmt.t) = fun (ofmt : Format.formatter) arg -> (fun ofmt -> function FM_delete v0 -> let open Pa_ppx_runtime.Runtime.Fmt in pf ofmt "(@[<2>Fsmod.FM_delete@ %a)@]" pp_file_t v0 | FM_install v0 -> let open Pa_ppx_runtime.Runtime.Fmt in pf ofmt "(@[<2>Fsmod.FM_install@ %a)@]" pp_file_t v0 | FM_update (v0, v1) -> let open Pa_ppx_runtime.Runtime.Fmt in pf ofmt "(@[<2>Fsmod.FM_update@ (@,%a,@ %a@,))@]" pp_file_t v0 (fun ofmt arg -> let open Pa_ppx_runtime.Runtime.Fmt in pf ofmt "%S" arg) v1 | FM_create (v0, v1) -> let open Pa_ppx_runtime.Runtime.Fmt in pf ofmt "(@[<2>Fsmod.FM_create@ (@,%a,@ %a@,))@]" pp_file_t v0 (fun ofmt arg -> let open Pa_ppx_runtime.Runtime.Fmt in pf ofmt "%S" arg) v1) ofmt arg[@@ocaml.warning "-39"] [@@ocaml.warning "-33"] and (show : t -> Stdlib.String.t) = fun arg -> Format.asprintf "%a" pp arg[@@ocaml.warning "-39"] [@@ocaml.warning "-33"] [@@@end] type t_pair = string * t[@@deriving_inline show] let rec (pp_t_pair : t_pair Fmt.t) = fun (ofmt : Format.formatter) arg -> (fun (ofmt : Format.formatter) (v0, v1) -> let open Pa_ppx_runtime.Runtime.Fmt in pf ofmt "(@[%a,@ %a@])" (fun ofmt arg -> let open Pa_ppx_runtime.Runtime.Fmt in pf ofmt "%S" arg) v0 pp v1) ofmt arg[@@ocaml.warning "-39"] [@@ocaml.warning "-33"] and (show_t_pair : t_pair -> Stdlib.String.t) = fun arg -> Format.asprintf "%a" pp_t_pair arg[@@ocaml.warning "-39"] [@@ocaml.warning "-33"] [@@@end] type t_pair_list = t_pair list[@@deriving_inline show] let rec (pp_t_pair_list : t_pair_list Fmt.t) = fun (ofmt : Format.formatter) arg -> (fun (ofmt : Format.formatter) arg -> let open Pa_ppx_runtime.Runtime.Fmt in pf ofmt "@[<2>[%a@,]@]" (list ~sep:semi pp_t_pair) arg) ofmt arg[@@ocaml.warning "-39"] [@@ocaml.warning "-33"] and (show_t_pair_list : t_pair_list -> Stdlib.String.t) = fun arg -> Format.asprintf "%a" pp_t_pair_list arg[@@ocaml.warning "-39"] [@@ocaml.warning "-33"] [@@@end] not-ocamlfind-0.15/main.ml0000644000175000017500000000044315237132260014501 0ustar stephsteph try Sys.catch_break true; Frontend.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 ;; not-ocamlfind-0.15/opam0000644000175000017500000000152415237132260014103 0ustar stephstephversion: "0.15" opam-version: "2.0" synopsis: "A small frontend for ocamlfind that adds a few useful commands" license: "MIT" x-maintenance-intent: [ "(latest)" ] maintainer: "Chet Murthy " (* Gerd wrote most of this code; I just modified it (and probably introduced bugs. This is to silence opam *) authors: "Chet Murthy " homepage: "https://github.com/chetmurthy/not-ocamlfind" bug-reports: "Chet Murthy " depends: [ "ocamlfind" {>= "1.9.6"} "camlp-streams" "conf-m4" {build} "fmt" {>= "0.8.8"} "rresult" {>= "0.6.0"} "ocamlgraph" {>= "2.0.0"} "conf-which" ] depexts: [ [ "xdot" ] {os-family = "debian"} ] build: [ [make "all"] ] install: [make "install"] dev-repo: "git+https://github.com/chetmurthy/not-ocamlfind" url { src: "" checksum: [ "sha512=" ] } not-ocamlfind-0.15/papr_official.ml0000644000175000017500000000670015237132260016355 0ustar stephsteph let rec sep_last = function [] -> failwith "sep_last" | [hd] -> hd, [] | hd :: tl -> let (l, tl) = sep_last tl in l, hd :: tl let input_magic ic magic = let maglen = String.length magic in let b = Bytes.create maglen in really_input ic b 0 maglen; Bytes.to_string b let input_implem ic = if Config.ast_impl_magic_number <> input_magic ic Config.ast_impl_magic_number then failwith "input_implem: bad magic number" else let _ = input_value ic in (input_value ic : Parsetree.structure) let input_interf ic = if Config.ast_intf_magic_number <> input_magic ic Config.ast_intf_magic_number then failwith "input_interf: bad magic number" else let _ = input_value ic in (input_value ic : Parsetree.signature) let output_magic oc magic = output_string oc magic let output_interf fname oc (pt : Parsetree.signature) = output_string oc Config.ast_intf_magic_number; output_value oc fname; output_value oc pt; flush oc let output_implem fname oc (pt : Parsetree.structure) = output_string oc Config.ast_impl_magic_number; output_value oc fname; output_value oc pt; flush oc let parse_interf fname ic = let lb = Lexing.from_channel ic in Location.init lb fname; Parse.interface lb let parse_implem fname ic = let lb = Lexing.from_channel ic in Location.init lb fname; Parse.implementation lb let print_interf oc v = let ofmt = Format.formatter_of_out_channel oc in Pprintast.signature ofmt v; Format.pp_print_flush ofmt () let print_implem oc v = let ofmt = Format.formatter_of_out_channel oc in Pprintast.structure ofmt v; Format.pp_print_flush ofmt () let binary_input = ref false let binary_output = ref false let files = ref [] let filetype = ref None let set_impl s = filetype := Some "-impl" let set_intf s = filetype := Some "-intf" let passthru paf prf ic oc = (ic |> paf) |> prf oc let papr_official () = Arg. (parse ["-binary-input", Set binary_input, " binary input"; "-binary-output", Set binary_output, " binary output"; "-impl", Unit set_impl, " implementation"; "-intf", Unit set_intf, " interface"] (fun s -> files := s :: !files) "papr_official: usage"); let open_or opener ifminus = function "-" -> ifminus, "" | f -> opener f, f in let ((ic, ifile), (oc, _)) = match List.rev !files with [] -> (stdin, ""), (stdout, "") | [ifile] -> open_or open_in stdin ifile, (stdout, "") | [ifile; ofile] -> open_or open_in stdin ifile, open_or open_out stdout ofile | _ -> failwith "too many filenames provided" in begin match !filetype, !binary_input, !binary_output with Some "-impl", true, true -> failwith "cannot have both binary input and output" | Some "-impl", true, false -> passthru input_implem print_implem ic oc | Some "-impl", false, true -> passthru (parse_implem ifile) (output_implem ifile) ic oc | Some "-impl", false, false -> passthru (parse_implem ifile) print_implem ic oc | Some "-intf", true, true -> failwith "cannot have both binary input and output" | Some "-intf", true, false -> passthru input_interf print_interf ic oc | Some "-intf", false, true -> passthru (parse_interf ifile) (output_interf ifile) ic oc | Some "-intf", false, false -> passthru (parse_interf ifile) print_interf ic oc | _ -> failwith "unrecognized filetype" end; close_out oc; close_in ic let _ = papr_official () (* ;;; Local Variables: *** ;;; mode:tuareg *** ;;; End: *** *)