diff --git a/configure b/configure index bfc1e8ba1ad..8a4ba9b2368 100755 --- a/configure +++ b/configure @@ -6104,7 +6104,7 @@ esac if test "${enable_static}" = yes then : - echo "(-noautolink -cclib -lunix -cclib -lmccs_stubs -cclib -lmccs_glpk_stubs -cclib -lsha_stubs ${platform_dependant_stuff})" > src/client/linking.sexp + echo "(-noautolink -cclib -lunixnat -cclib -lmccs_stubs -cclib -lmccs_glpk_stubs -cclib -lsha_stubs ${platform_dependant_stuff})" > src/client/linking.sexp { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: static" >&5 printf "%s\n" "static" >&6; } diff --git a/configure.ac b/configure.ac index 2ae3218f623..61aa0d5dbc8 100644 --- a/configure.ac +++ b/configure.ac @@ -356,7 +356,7 @@ AS_CASE([${support_static},${enable_static}], [no,yes],[AC_MSG_ERROR([--enable-static is not available on this platform (${TARGET}).])], [*,auto],[enable_static=${default_static}]) AS_IF([test "${enable_static}" = yes],[ - echo "(-noautolink -cclib -lunix -cclib -lmccs_stubs -cclib -lmccs_glpk_stubs -cclib -lsha_stubs ${platform_dependant_stuff})" > src/client/linking.sexp + echo "(-noautolink -cclib -lunixnat -cclib -lmccs_stubs -cclib -lmccs_glpk_stubs -cclib -lsha_stubs ${platform_dependant_stuff})" > src/client/linking.sexp AC_MSG_RESULT([static]) ],[ AC_MSG_RESULT([shared]) diff --git a/src/client/opamAction.ml b/src/client/opamAction.ml index 7b309d29cf4..2bcce4896bf 100644 --- a/src/client/opamAction.ml +++ b/src/client/opamAction.ml @@ -58,8 +58,9 @@ let preprocess_dot_install_t st nv build_dir = let check ~src ~dst base = let src_file = OpamFilename.create src base.c in if base.optional && not (OpamFilename.exists src_file) then - log "Not installing %a is not present and optional." - (slog OpamFilename.to_string) src_file; + log (fun fmt -> + fmt "Not installing %a is not present and optional." + (slog OpamFilename.to_string) src_file); let exists = OpamFilename.exists src_file in let warn = if not base.optional && not exists then @@ -76,7 +77,7 @@ let preprocess_dot_install_t st nv build_dir = if OpamFilename.exists_dir dst_dir || files = [] then [] else let dir = OpamFilename.remove_prefix_dir switch_prefix dst_dir in let inst _ = - log "creating %a" (slog OpamFilename.Dir.to_string) dst_dir; + log (fun fmt -> fmt "creating %a" (slog OpamFilename.Dir.to_string) dst_dir); OpamFilename.mkdir dst_dir; None in @@ -211,8 +212,7 @@ let preprocess_dot_install st nv build_dir = else (OpamSystem.default_install_warning, (fun () -> false)) in - OpamFilename.in_dir build_dir @@ fun () -> - log "Installing %s.\n" (OpamPackage.to_string nv); + log (fun fmt -> fmt "Installing %s.\n" (OpamPackage.to_string nv)); let warnings = OpamStd.List.filter_map (fun install -> install warning) installs in @@ -239,11 +239,12 @@ let preprocess_dot_install st nv build_dir = let download_shared_source st url nvs = let labelise pkg_str = OpamStd.List.concat_map ", " pkg_str nvs in - log "download_package: %a%a" - (slog (fun _ -> labelise OpamPackage.to_string)) () - (slog (fun url -> match url, nvs with - | None, _ | _, [_] -> "" - | Some url, _ -> " " ^ OpamUrl.to_string (OpamFile.URL.url url))) url; + log (fun fmt -> + fmt "download_package: %a%a" + (slog (fun _ -> labelise OpamPackage.to_string)) () + (slog (fun url -> match url, nvs with + | None, _ | _, [_] -> "" + | Some url, _ -> " " ^ OpamUrl.to_string (OpamFile.URL.url url))) url); if OpamStateConfig.(!r.dryrun) || OpamClientConfig.(!r.fake) then Done None else let nvs = @@ -345,8 +346,9 @@ let prepare_package_build env opam nv dir = let patches = OpamFile.OPAM.patches opam in let print_apply basename = - log "%s: applying %s.\n" (OpamPackage.name_to_string nv) - (OpamFilename.Base.to_string basename); + log (fun fmt -> + fmt "%s: applying %s.\n" (OpamPackage.name_to_string nv) + (OpamFilename.Base.to_string basename)); if OpamConsole.verbose () then OpamConsole.msg "[%s: patch] applying %s\n" (OpamConsole.colorise `green (OpamPackage.name_to_string nv)) @@ -355,9 +357,10 @@ let prepare_package_build env opam nv dir = let print_subst basename = let file = OpamFilename.Base.to_string basename in let file_in = file ^ ".in" in - log "%s: expanding opam variables in %s, generating %s.\n" - (OpamPackage.name_to_string nv) - file_in file; + log (fun fmt -> + fmt "%s: expanding opam variables in %s, generating %s.\n" + (OpamPackage.name_to_string nv) + file_in file); if OpamConsole.verbose () then OpamConsole.msg "[%s: subst] expanding opam variables in %s, generating %s\n" @@ -393,7 +396,6 @@ let prepare_package_build env opam nv dir = apply_patches ~dryrun:true ()) @@| fun _ -> None else let subst_errs = - OpamFilename.in_dir dir @@ fun () -> List.fold_left (fun errs f -> try print_subst f; @@ -415,7 +417,6 @@ let prepare_package_build env opam nv dir = substitution files (see [OpamFilter.expand_interpolations_in_file] and [OpamFilename.of_basename]. *) let subst_errs = - OpamFilename.in_dir dir @@ fun () -> List.fold_left (fun errs f -> try print_subst f; @@ -449,9 +450,10 @@ let prepare_package_build env opam nv dir = Done None let prepare_package_source st nv dir = - log "prepare_package_source: %a at %a" - (slog OpamPackage.to_string) nv - (slog OpamFilename.Dir.to_string) dir; + log (fun fmt -> + fmt "prepare_package_source: %a at %a" + (slog OpamPackage.to_string) nv + (slog OpamFilename.Dir.to_string) dir); if OpamStateConfig.(!r.dryrun) then Done None else let opam = OpamSwitchState.opam st nv in let get_extra_sources_job = @@ -695,8 +697,9 @@ let make_command st opam ?dir ?text_command (cmd, args) = let remove_commands t nv = match installed_opam_opt t nv with | None -> - log "No opam file was found for removing %a\n" - (slog OpamPackage.to_string) nv; + log (fun fmt -> + fmt "No opam file was found for removing %a\n" + (slog OpamPackage.to_string) nv); [] | Some opam -> OpamFilter.commands (OpamPackageVar.resolve ~opam t) @@ -725,7 +728,7 @@ let noop_remove_package t nv = (* Remove a given package *) let remove_package_aux t ?(silent=false) ?changes ?force ?build_dir nv = - log "Removing %a" (slog OpamPackage.to_string) nv; + log (fun fmt -> fmt "Removing %a" (slog OpamPackage.to_string) nv); let name = nv.name in let root = t.switch_global.root in @@ -786,7 +789,7 @@ let remove_package_aux if OpamFilename.rec_files dir = [] then OpamFilename.rmdir dir in - log "Removing files from .install"; + log (fun fmt -> fmt "Removing files from .install"); remove_files OpamPath.Switch.sbin OpamFile.Dot_install.sbin; remove_files OpamPath.Switch.bin OpamFile.Dot_install.bin; remove_files_and_dir @@ -800,7 +803,7 @@ let remove_package_aux remove_files_and_dir OpamPath.Switch.doc OpamFile.Dot_install.doc; (* Remove the misc files *) - log "Removing the misc files"; + log (fun fmt -> fmt "Removing the misc files"); List.iter (fun (_,dst) -> if OpamFilename.exists dst then begin OpamConsole.msg "Removing %s." (OpamFilename.to_string dst); @@ -886,7 +889,7 @@ let remove_package_aux (* Removes build dir and source cache of package if unneeded *) let cleanup_package_artefacts t nv = - log "Cleaning up artefacts of %a" (slog OpamPackage.to_string) nv; + log (fun fmt -> fmt "Cleaning up artefacts of %a" (slog OpamPackage.to_string) nv); let build_dir = OpamPath.Switch.build t.switch_global.root t.switch nv in if not OpamClientConfig.(!r.keep_build_dir) then OpamFilename.rmdir build_dir; @@ -897,7 +900,7 @@ let cleanup_package_artefacts t nv = (if not (OpamSwitchState.is_dev_package t nv) then OpamFilename.rmdir dev_dir) else - (log "Removing the local metadata"; + (log (fun fmt -> fmt "Removing the local metadata"); OpamSwitchAction.remove_metadata t (OpamPackage.Set.singleton nv); if not (OpamPackage.Set.mem nv t.pinned) then OpamFilename.rmdir dev_dir) @@ -1117,9 +1120,10 @@ let install_package t ?(test=false) ?(doc=false) ?(dev_setup=false) ?build_dir | Left config, changes -> let changes_f = OpamPath.Switch.changes root t.switch nv.name in if OpamStateConfig.(not !r.dryrun) then - (log "changes recorded for %s: %a" - (OpamPackage.to_string nv) - (slog OpamDirTrack.to_summary_string) changes; + (log (fun fmt -> + fmt "changes recorded for %s: %a" + (OpamPackage.to_string nv) + (slog OpamDirTrack.to_summary_string) changes); OpamFile.Changes.write changes_f changes); OpamConsole.msg "%s installed %s.%s\n" (if not (OpamConsole.utf8 ()) then "->" diff --git a/src/client/opamAdminCommand.ml b/src/client/opamAdminCommand.ml index baebc3778e3..cd8d32c6e7f 100644 --- a/src/client/opamAdminCommand.ml +++ b/src/client/opamAdminCommand.ml @@ -488,10 +488,10 @@ let add_hashes_command cli = tbl [] |> fun lines -> try OpamFile.Lines.write file lines with e -> OpamStd.Exn.fatal e; - OpamConsole.log "ADMIN" - "Could not write hash cache to %s, skipping (%s)" - (OpamFile.to_string file) - (Printexc.to_string e)) + OpamConsole.log "ADMIN" (fun fmt -> + fmt "Could not write hash cache to %s, skipping (%s)" + (OpamFile.to_string file) + (Printexc.to_string e))) hash_tables in let additions_count = ref 0 in diff --git a/src/client/opamAdminRepoUpgrade.ml b/src/client/opamAdminRepoUpgrade.ml index 84a12fae7f2..1ec1e951ea5 100644 --- a/src/client/opamAdminRepoUpgrade.ml +++ b/src/client/opamAdminRepoUpgrade.ml @@ -206,10 +206,10 @@ let do_upgrade repo_root = url_md5 [] |> fun lines -> try OpamFile.Lines.write cache_file lines with e -> OpamStd.Exn.fatal e; - OpamConsole.log "REPO_UPGRADE" - "Could not write archive hash cache to %s, skipping (%s)" - (OpamFile.to_string cache_file) - (Printexc.to_string e)) + OpamConsole.log "REPO_UPGRADE" (fun fmt -> + fmt "Could not write archive hash cache to %s, skipping (%s)" + (OpamFile.to_string cache_file) + (Printexc.to_string e))) in let ocaml_versions = OpamStd.String.Map.fold (fun c comp_file ocaml_versions -> @@ -411,9 +411,9 @@ let do_upgrade repo_root = let packages = OpamRepository.packages_with_prefixes repo_root in - OpamConsole.log "REPO_UPGRADE" - "Will not update base packages: %s\n" - (OpamPackage.Name.Set.to_string all_base_packages); + OpamConsole.log "REPO_UPGRADE" (fun fmt -> + fmt "Will not update base packages: %s\n" + (OpamPackage.Name.Set.to_string all_base_packages)); OpamPackage.Map.iter (fun package prefix -> let opam_file = OpamRepositoryPath.opam repo_root prefix package in diff --git a/src/client/opamAuxCommands.ml b/src/client/opamAuxCommands.ml index cbcc6851b5d..016291f419e 100644 --- a/src/client/opamAuxCommands.ml +++ b/src/client/opamAuxCommands.ml @@ -264,13 +264,14 @@ let autopin_aux st ?quiet ?(for_view=false) ?recurse ?subpath ?locked | _ -> None) atom_or_local_list in - log "autopin: %a" - (slog @@ OpamStd.List.to_string (fun pin -> - Printf.sprintf "%s%s => %s" - (OpamPackage.Name.to_string pin.pin_name) - (if pin.pin.pin_locked = None then "" else "[locked]") - (OpamUrl.to_string_w_subpath pin.pin.pin_subpath pin.pin.pin_url))) - to_pin; + log (fun fmt -> + fmt "autopin: %a" + (slog @@ OpamStd.List.to_string (fun pin -> + Printf.sprintf "%s%s => %s" + (OpamPackage.Name.to_string pin.pin_name) + (if pin.pin.pin_locked = None then "" else "[locked]") + (OpamUrl.to_string_w_subpath pin.pin.pin_subpath pin.pin.pin_url))) + to_pin); let obsolete_pins = (* Packages not current but pinned to the same dirs *) OpamPackage.Set.filter (fun nv -> @@ -534,8 +535,8 @@ let check_and_revert_sandboxing root config = in try (* Don't assume that we can mount the CWD *) - OpamSystem.in_tmp_dir @@ fun () -> - OpamSystem.read_command_output ~env ~allow_stdin:false (cmd @ test_cmd) + OpamSystem.with_tmp_dir @@ fun dir -> + OpamSystem.read_command_output ~env ~dir ~allow_stdin:false (cmd @ test_cmd) = ["SUCCESS"] with e -> (OpamConsole.error "Sandboxing is not working on your platform%s:\n%s" diff --git a/src/client/opamClient.ml b/src/client/opamClient.ml index 57e47d33fea..9d0b9e722fa 100644 --- a/src/client/opamClient.ml +++ b/src/client/opamClient.ml @@ -145,15 +145,16 @@ let upgrade_t ?strict_upgrade ?auto_install ?ask ?(check=false) ?(terse=false) ?only_installed ~all atoms ?(formula=OpamFormula.Empty) t = - log "UPGRADE %a" - (slog @@ function [] -> "" | a -> OpamFormula.string_of_atoms a) - atoms; + log (fun fmt -> + fmt "UPGRADE %a" + (slog @@ function [] -> "" | a -> OpamFormula.string_of_atoms a) + atoms); match compute_upgrade_t ?strict_upgrade ?auto_install ?only_installed ~all ~formula atoms t with | requested, Conflicts cs -> - log "conflict!"; + log (fun fmt -> fmt "conflict!"); if not (OpamPackage.Name.Set.is_empty requested) then (OpamConsole.error "Package conflict!"; OpamConsole.errmsg "%s" @@ -347,7 +348,7 @@ let upgrade t ?formula ?check ?only_installed ~all names = let fixup ?(formula=OpamFormula.Empty) t = (* @LG reimplement as an alias for 'opam upgrade --criteria=fixup --best-effort --update-invariant *) - log "FIXUP"; + log (fun fmt -> fmt "FIXUP"); let resolve pkgs = pkgs, OpamSolution.resolve t Upgrade @@ -362,21 +363,22 @@ let fixup ?(formula=OpamFormula.Empty) t = let is_success = function | _, Success _ -> true | _, Conflicts cs -> - log "conflict: %a" - (slog (OpamCudf.string_of_conflicts t.packages @@ - OpamSwitchState.unavailable_reason t)) - cs; + log (fun fmt -> + fmt "conflict: %a" + (slog (OpamCudf.string_of_conflicts t.packages @@ + OpamSwitchState.unavailable_reason t)) + cs); false in let requested, solution = let s = - log "fixup-1/ keep installed packages with orphaned versions and roots"; + log (fun fmt -> fmt "fixup-1/ keep installed packages with orphaned versions and roots"); resolve (t.installed_roots %% t.installed %% Lazy.force t.available_packages) in if is_success s then s else let s = - log "fixup-2/ last resort: no constraints. This should never fail"; + log (fun fmt -> fmt "fixup-2/ last resort: no constraints. This should never fail"); resolve OpamPackage.Set.empty in s @@ -409,7 +411,7 @@ let fixup ?(formula=OpamFormula.Empty) t = let update gt ~repos_only ~dev_only ?(all=false) names = - log "UPDATE %a" (slog @@ String.concat ", ") names; + log (fun fmt -> fmt "UPDATE %a" (slog @@ String.concat ", ") names); let rt = OpamRepositoryState.load `Lock_none gt in let st, repos_only = match OpamStateConfig.get_switch_opt () with @@ -478,7 +480,7 @@ let update OpamProcess.Job.run @@ OpamRepository.is_dirty { cache_url with OpamUrl.backend = vc } with OpamSystem.Process_error _ -> - log "Skipping %s, not a git repo" (OpamPackage.to_string nv); + log (fun fmt -> fmt "Skipping %s, not a git repo" (OpamPackage.to_string nv)); false) | _ -> false) dev_packages @@ -1141,8 +1143,9 @@ let init ?(check_sandbox=true) ?cygwin_setup ?git_location shell = - log "INIT %a" - (slog @@ OpamStd.Option.to_string OpamRepositoryBackend.to_string) repo; + log (fun fmt -> + fmt "INIT %a" + (slog @@ OpamStd.Option.to_string OpamRepositoryBackend.to_string) repo); let root = OpamStateConfig.(!r.root_dir) in let config_f = OpamPath.config root in let root_empty = @@ -1212,7 +1215,7 @@ let init OpamFile.Repos_config.write (OpamPath.repos_config root) repos_config; - log "updating repository state"; + log (fun fmt -> fmt "updating repository state"); let gt = OpamGlobalState.load `Lock_write in let rt = OpamRepositoryState.load `Lock_write gt in OpamConsole.header_msg "Fetching repository information"; @@ -1247,9 +1250,10 @@ let init alternatives |> OpamStd.Option.default [] in - log "Selected default compiler %s in %0.3fs" - (OpamFormula.string_of_atoms default_compiler) - (chrono ()); + log (fun fmt -> + fmt "Selected default compiler %s in %0.3fs" + (OpamFormula.string_of_atoms default_compiler) + (chrono ())); default_compiler in gt, OpamRepositoryState.unlock ~cleanup:false rt, default_compiler @@ -1394,7 +1398,7 @@ let filter_unpinned_locally t atoms f = let install_t t ?ask ?(ignore_conflicts=false) ?(depext_only=false) ?(download_only=false) atoms ?(formula=OpamFormula.Empty) add_to_roots ~deps_only ~assume_built = - log "INSTALL %a" (slog OpamFormula.string_of_atoms) atoms; + log (fun fmt -> fmt "INSTALL %a" (slog OpamFormula.string_of_atoms) atoms); let available_packages = Lazy.force t.available_packages in let atoms = @@ -1576,7 +1580,7 @@ let install_t t ?ask ?(ignore_conflicts=false) ?(depext_only=false) let t = {t with installed = t.installed -- deps_of_packages} in let t, solution = match solution with | Conflicts cs -> - log "conflict!"; + log (fun fmt -> fmt "conflict!"); OpamConsole.error "Package conflict!"; let (conflicts, _cycles) as explanations = OpamCudf.conflict_explanations_raw t.packages cs @@ -1653,8 +1657,9 @@ let install t ?formula ?autoupdate ?add_to_roots ~ignore_conflicts ~depext_only ~deps_only ~download_only ~assume_built let remove_t ?ask ~autoremove ~force ?(formula=OpamFormula.Empty) atoms t = - log "REMOVE autoremove:%b %a" autoremove - (slog OpamFormula.string_of_atoms) atoms; + log (fun fmt -> + fmt "REMOVE autoremove:%b %a" autoremove + (slog OpamFormula.string_of_atoms) atoms); let nothing_to_do = ref true in let packages, not_installed = @@ -1741,7 +1746,7 @@ let remove t ~autoremove ~force ?formula names = remove_t ~autoremove ~force ?formula atoms t let reinstall_t t ?ask ?(force=false) ~assume_built atoms = - log "reinstall %a" (slog OpamFormula.string_of_atoms) atoms; + log (fun fmt -> fmt "reinstall %a" (slog OpamFormula.string_of_atoms) atoms); let packages = OpamFormula.packages_of_atoms t.packages atoms in diff --git a/src/client/opamCommands.ml b/src/client/opamCommands.ml index ad1acdd3903..d91a51a5976 100644 --- a/src/client/opamCommands.ml +++ b/src/client/opamCommands.ml @@ -107,8 +107,9 @@ let global_options cli = let apply_global_options cli (options,self_upgrade) = apply_global_options cli options; - OpamConsole.log "CLI" "Parsing CLI version %s" - (OpamCLIVersion.to_string options.cli); + OpamConsole.log "CLI" (fun fmt -> + fmt "Parsing CLI version %s" + (OpamCLIVersion.to_string options.cli)); try let argv0 = OpamFilename.of_string Sys.executable_name in if self_upgrade <> `Running && diff --git a/src/client/opamConfigCommand.ml b/src/client/opamConfigCommand.ml index ad32393c934..01c4276cdc6 100644 --- a/src/client/opamConfigCommand.ml +++ b/src/client/opamConfigCommand.ml @@ -18,7 +18,7 @@ open OpamStateTypes (* List all the available variables *) let list t ns = - log "config-list"; + log (fun fmt -> fmt "config-list"); if ns = [] then () else let list_vars name = try @@ -249,9 +249,10 @@ let load_and_verify_env ~set_opamroot ~set_opamswitch ~force_path OpamFilename.Dir.to_string (OpamPath.Switch.root gt.root switch) in if environment_opam_switch_prefix <> actual_opam_switch_prefix then - (log "Switch has moved from %s to %s" - environment_opam_switch_prefix actual_opam_switch_prefix; - log "Regenerating environment file"; + (log (fun fmt -> + fmt "Switch has moved from %s to %s" + environment_opam_switch_prefix actual_opam_switch_prefix); + log (fun fmt -> fmt "Regenerating environment file"); regenerate_env ~set_opamroot ~set_opamswitch ~force_path gt switch env_file) else upd @@ -298,7 +299,7 @@ let ensure_env_aux ?(base=[]) ?(set_opamroot=false) ?(set_opamswitch=false) load_and_verify_env ~set_opamroot ~set_opamswitch ~force_path gt switch env_file else begin - log "Missing environment file, regenerate it"; + log (fun fmt -> fmt "Missing environment file, regenerate it"); regenerate_env ~set_opamroot ~set_opamswitch ~force_path gt switch env_file end @@ -332,7 +333,7 @@ let ensure_env gt switch = let env gt switch ?(set_opamroot=false) ?(set_opamswitch=false) ~csh ~sexp ~fish ~pwsh ~cmd ~inplace_path = - log "config-env"; + log (fun fmt -> fmt "config-env"); let opamroot_not_current = let current = gt.root in let default = OpamStateConfig.(default.root_dir) in @@ -375,21 +376,21 @@ let env gt switch ?(set_opamroot=false) ?(set_opamswitch=false) [@@ocaml.warning "-16"] let subst gt fs = - log "config-substitute"; + log (fun fmt -> fmt "config-substitute"); OpamSwitchState.with_ `Lock_none gt @@ fun st -> List.iter (OpamFilter.expand_interpolations_in_file (OpamPackageVar.resolve st)) fs let expand gt str = - log "config-expand"; + log (fun fmt -> fmt "config-expand"); OpamSwitchState.with_ `Lock_none gt @@ fun st -> OpamConsole.msg "%s\n" (OpamFilter.expand_string ~default:(fun _ -> "") (OpamPackageVar.resolve st) str) let exec gt ~set_opamroot ~set_opamswitch ~inplace_path ~no_switch command = - log "config-exec command=%a" (slog (String.concat " ")) command; + log (fun fmt -> fmt "config-exec command=%a" (slog (String.concat " ")) command); let switch = OpamStateConfig.get_switch () in let st_lazy = lazy ( let rt = OpamRepositoryState.load `Lock_none gt in diff --git a/src/client/opamListCommand.ml b/src/client/opamListCommand.ml index 327e8c1569d..21cf05e5161 100644 --- a/src/client/opamListCommand.ml +++ b/src/client/opamListCommand.ml @@ -363,8 +363,9 @@ let apply_selector ~base st = function with Not_found -> acc) OpamPackage.Set.empty matching_change_files with Not_found -> - log "%a doesn't belong to a known opam switch" - (slog OpamFilename.to_string) file; + log (fun fmt -> + fmt "%a doesn't belong to a known opam switch" + (slog OpamFilename.to_string) file); OpamPackage.Set.empty) diff --git a/src/client/opamPinCommand.ml b/src/client/opamPinCommand.ml index 3ec2b4731e6..1da83539172 100644 --- a/src/client/opamPinCommand.ml +++ b/src/client/opamPinCommand.ml @@ -229,7 +229,7 @@ let edit_raw name temp_file = Some new_opam let edit st ?version name = - log "pin-edit %a" (slog OpamPackage.Name.to_string) name; + log (fun fmt -> fmt "pin-edit %a" (slog OpamPackage.Name.to_string) name); let nv = try OpamPinned.package st name with Not_found -> @@ -455,11 +455,12 @@ and source_pin ?subpath ?locked target_url = - log "pin %a to %a %a" - (slog OpamPackage.Name.to_string) name - (slog (OpamStd.Option.to_string OpamPackage.Version.to_string)) version - (slog (OpamStd.Option.to_string ~none:"none" - (OpamUrl.to_string_w_subpath subpath))) target_url; + log (fun fmt -> + fmt "pin %a to %a %a" + (slog OpamPackage.Name.to_string) name + (slog (OpamStd.Option.to_string OpamPackage.Version.to_string)) version + (slog (OpamStd.Option.to_string ~none:"none" + (OpamUrl.to_string_w_subpath subpath))) target_url); (* let installed_version = try Some (OpamPackage.version @@ -705,8 +706,9 @@ let unpin_one st nv = { st with available_packages } let unpin st names = - log "unpin %a" - (slog @@ OpamStd.List.concat_map " " OpamPackage.Name.to_string) names; + log (fun fmt -> + fmt "unpin %a" + (slog @@ OpamStd.List.concat_map " " OpamPackage.Name.to_string) names); List.fold_left (fun st name -> OpamFilename.rmdir (OpamPath.Switch.pinned_package st.switch_global.root st.switch name); @@ -735,7 +737,7 @@ let unpin st names = st names let list st ~short = - log "pin_list"; + log (fun fmt -> fmt "pin_list"); if short then OpamPackage.Set.iter (fun nv -> OpamConsole.msg "%s\n" (OpamPackage.name_to_string nv)) diff --git a/src/client/opamRepositoryCommand.ml b/src/client/opamRepositoryCommand.ml index 583b23e42eb..cb871fcfa07 100644 --- a/src/client/opamRepositoryCommand.ml +++ b/src/client/opamRepositoryCommand.ml @@ -52,7 +52,7 @@ let update_repos_config rt repositories = rt let add rt name url trust_anchors = - log "repository-add"; + log (fun fmt -> fmt "repository-add"); let root = rt.repos_global.root in let repo_exists = OpamStd.Option.of_Not_found @@ -101,7 +101,7 @@ let add rt name url trust_anchors = (OpamRepositoryName.Map.add name repo rt.repositories) let remove rt name = - log "repository-remove"; + log (fun fmt -> fmt "repository-remove"); let rt = update_repos_config rt (OpamRepositoryName.Map.remove name rt.repositories) in @@ -111,7 +111,7 @@ let remove rt name = rt let set_url rt name url trust_anchors = - log "repository-set-url"; + log (fun fmt -> fmt "repository-set-url"); let repo = try OpamRepositoryName.Map.find name rt.repositories with Not_found -> @@ -167,7 +167,7 @@ let list rt ~global ~switches ~short = switches let list_all rt ~short = - log "repository-list"; + log (fun fmt -> fmt "repository-list"); if short then OpamRepositoryName.Map.iter (fun r _ -> diff --git a/src/client/opamSolution.ml b/src/client/opamSolution.ml index 4b7576483af..00bcb0f30d6 100644 --- a/src/client/opamSolution.ml +++ b/src/client/opamSolution.ml @@ -312,7 +312,7 @@ end let parallel_apply t ~requested ?add_roots ~assume_built ~download_only ?(force_remove=false) action_graph = - log "parallel_apply"; + log (fun fmt -> fmt "parallel_apply"); let remove_action_packages = PackageActionGraph.fold_vertex @@ -506,8 +506,9 @@ let parallel_apply t |> OpamUrl.Map.values |> List.filter (fun s -> not @@ OpamPackage.Set.is_singleton s) in - log "Regroup shared source packages: %s" - (OpamStd.List.to_string OpamPackage.Set.to_string shared_source); + log (fun fmt -> + fmt "Regroup shared source packages: %s" + (OpamStd.List.to_string OpamPackage.Set.to_string shared_source)); fun p -> try List.find (OpamPackage.Set.mem p) shared_source @@ -614,8 +615,9 @@ let parallel_apply t else match action with | `Fetch nvs -> - log "Fetching sources for %s" - (OpamStd.Format.pretty_list (List.map OpamPackage.to_string nvs)); + log (fun fmt -> + fmt "Fetching sources for %s" + (OpamStd.Format.pretty_list (List.map OpamPackage.to_string nvs))); ((match nvs with | [nv] -> OpamAction.download_package t nv @@ -639,11 +641,12 @@ let parallel_apply t | `Build nv -> if assume_built && OpamPackage.Set.mem nv requested then - (log "Skipping build for %s, just install%s" - (OpamPackage.to_string nv) - (OpamStd.Option.map_default - (fun p -> " from " ^ OpamFilename.Dir.to_string p) - "" (OpamPackage.Map.find_opt nv inplace)); + (log (fun fmt -> + fmt "Skipping build for %s, just install%s" + (OpamPackage.to_string nv) + (OpamStd.Option.map_default + (fun p -> " from " ^ OpamFilename.Dir.to_string p) + "" (OpamPackage.Map.find_opt nv inplace))); Done (`Successful (installed, removed))) else let is_inplace, build_dir = @@ -1304,7 +1307,7 @@ let apply ?ask t ~requested ?print_requested ?add_roots ?(download_only=false) ?force_remove solution0 = let names = OpamPackage.names_of_packages requested in let print_requested = OpamStd.Option.default names print_requested in - log "apply"; + log (fun fmt -> fmt "apply"); let solution = OpamSolver.filter_solution ~recursive:false (fun nv -> not (OpamPackage.Map.mem nv skip)) @@ -1469,7 +1472,7 @@ let resolve_and_apply ?ask t action ?reinstall ~requested ?print_requested ?add_roots ?(assume_built=false) ?download_only ?force_remove request = match resolve t action ?reinstall ~requested request with | Conflicts cs -> - log "conflict!"; + log (fun fmt -> fmt "conflict!"); OpamConsole.msg "%s" (OpamCudf.string_of_conflicts t.packages (OpamSwitchState.unavailable_reason t) cs); diff --git a/src/client/opamSwitchCommand.ml b/src/client/opamSwitchCommand.ml index 32fe93fc6e3..5b9ec52f95a 100644 --- a/src/client/opamSwitchCommand.ml +++ b/src/client/opamSwitchCommand.ml @@ -20,7 +20,7 @@ let log fmt = OpamConsole.log "SWITCH" fmt let slog = OpamConsole.slog let list gt ~print_short = - log "list"; + log (fun fmt -> fmt "list"); let gt = OpamGlobalState.fix_switch_list gt in if print_short then List.iter (OpamConsole.msg "%s\n" @* OpamSwitch.to_string) @@ -170,7 +170,7 @@ let clear_switch ?(keep_debug=false) (gt: rw global_state) switch = with OpamSystem.Internal_error _ -> gt let remove gt ?(confirm = true) switch = - log "remove switch=%a" (slog OpamSwitch.to_string) switch; + log (fun fmt -> fmt "remove switch=%a" (slog OpamSwitch.to_string) switch); if not (OpamGlobalState.switch_exists gt switch) then ( OpamConsole.msg "The compiler switch %s does not exist.\n" (OpamSwitch.to_string switch); @@ -359,7 +359,7 @@ let create OpamGlobalState.drop gt let switch lock gt switch = - log "switch switch=%a" (slog OpamSwitch.to_string) switch; + log (fun fmt -> fmt "switch switch=%a" (slog OpamSwitch.to_string) switch); if OpamGlobalState.switch_exists gt switch then OpamRepositoryState.with_ `Lock_none gt @@ fun rt -> let st = OpamSwitchState.load lock gt rt switch in @@ -391,7 +391,7 @@ let switch_previous lock gt = "No previously used switch could be found" let import_t ?ask importfile t = - log "import switch"; + log (fun fmt -> fmt "import switch"); let extra_files = importfile.OpamFile.SwitchExport.extra_files in let xfiles_dir = @@ -655,7 +655,7 @@ let show () = let reinstall init_st = let switch = init_st.switch in - log "reinstall switch=%a" (slog OpamSwitch.to_string) switch; + log (fun fmt -> fmt "reinstall switch=%a" (slog OpamSwitch.to_string) switch); let gt = init_st.switch_global in let switch_root = OpamPath.Switch.root gt.root switch in @@ -687,7 +687,7 @@ let import st filename = let importfile = try OpamFile.SwitchExport.read_from_string ?filename import_str with OpamPp.Bad_format _ as e -> - log "Error loading export file, trying the old file format"; + log (fun fmt -> fmt "Error loading export file, trying the old file format"); try let selections = OpamFile.LegacyState.read_from_string import_str in { OpamFile.SwitchExport.selections; diff --git a/src/core/opamCached.ml b/src/core/opamCached.ml index 7b0b9c28f96..d4dbcde148a 100644 --- a/src/core/opamCached.ml +++ b/src/core/opamCached.ml @@ -44,14 +44,15 @@ end = struct Bytes.to_string b in if not OpamCoreConfig.developer && file_magic <> this_magic then ( - log "Bad %s cache: incompatible magic string %S (expected %S)." - X.name file_magic this_magic; + log (fun fmt -> + fmt "Bad %s cache: incompatible magic string %S (expected %S)." + X.name file_magic this_magic); None ) else Some ic with e -> OpamStd.Exn.fatal e; - log "Bad %s cache: %s" X.name (Printexc.to_string e); + log (fun fmt -> fmt "Bad %s cache: %s" X.name (Printexc.to_string e)); None let marshal_from_file file fd = @@ -59,10 +60,10 @@ end = struct let f ic = try let (cache: t) = Marshal.from_channel ic in - log "Loaded %a in %.3fs" (slog OpamFilename.to_string) file (chrono ()); + log (fun fmt -> fmt "Loaded %a in %.3fs" (slog OpamFilename.to_string) file (chrono ())); Some cache with End_of_file | Failure _ -> - log "Bad %s cache: likely a truncated file, ignoring." X.name; + log (fun fmt -> fmt "Bad %s cache: likely a truncated file, ignoring." X.name); None in OpamStd.Option.Op.(check_marshaled_file fd >>= f) @@ -75,7 +76,7 @@ end = struct marshal_from_file file fd in if r = None then begin - log "Invalid %s cache, removing" X.name; + log (fun fmt -> fmt "Invalid %s cache, removing" X.name); OpamFilename.remove file end; r @@ -83,21 +84,23 @@ end = struct let save cache_file t = if OpamCoreConfig.(!r.safe_mode) then - log "Running in safe mode, not upgrading the %s cache" X.name + log (fun fmt -> fmt "Running in safe mode, not upgrading the %s cache" X.name) else try let chrono = OpamConsole.timer () in OpamFilename.with_flock `Lock_write cache_file @@ fun fd -> - log "Writing the %s cache to %s ..." - X.name (OpamFilename.prettify cache_file); + log (fun fmt -> + fmt "Writing the %s cache to %s ..." + X.name (OpamFilename.prettify cache_file)); let oc = Unix.out_channel_of_descr fd in output_string oc (OpamVersion.magic ()); Marshal.to_channel oc t []; flush oc; - log "%a written in %.3fs" (slog OpamFilename.prettify) cache_file (chrono ()) + log (fun fmt -> fmt "%a written in %.3fs" (slog OpamFilename.prettify) cache_file (chrono ())) with Unix.Unix_error _ -> - log "Could not acquire lock for writing %s, skipping %s cache update" - (OpamFilename.prettify cache_file) X.name + log (fun fmt -> + fmt "Could not acquire lock for writing %s, skipping %s cache update" + (OpamFilename.prettify cache_file) X.name) let remove cache_file = OpamFilename.remove cache_file diff --git a/src/core/opamConsole.ml b/src/core/opamConsole.ml index 2e993f3d8c6..6bdae068810 100644 --- a/src/core/opamConsole.ml +++ b/src/core/opamConsole.ml @@ -560,7 +560,10 @@ let clear_pending debug_level = Queue.iter f pending; Queue.clear pending -let log section ?(level=1) fmt = +let log_mutex = Mutex.create () +let log section ?(level=1) k = + Mutex.protect log_mutex @@ fun () -> + k @@ fun fmt -> let debug_level = let debug_level = OpamCoreConfig.(!r.debug_level) in let sections = OpamCoreConfig.(!r.debug_sections) in diff --git a/src/core/opamConsole.mli b/src/core/opamConsole.mli index c82fae1bbf4..9f5955a7582 100644 --- a/src/core/opamConsole.mli +++ b/src/core/opamConsole.mli @@ -79,7 +79,7 @@ val timer : unit -> unit -> float (** [log section ~level fmt args]. Used for debug messages, default level is 1 *) -val log : string -> ?level:int -> ('a, Format.formatter, unit) format -> 'a +val log : string -> ?level:int -> ((('a, Format.formatter, unit) format -> 'a) -> unit) -> unit (** Helper to pass stringifiers to log (use [log "%a" (slog to_string) x] rather than [log "%s" (to_string x)] to avoid costly unneeded diff --git a/src/core/opamDirTrack.ml b/src/core/opamDirTrack.ml index 74f5c7fcb07..64e5143af85 100644 --- a/src/core/opamDirTrack.ml +++ b/src/core/opamDirTrack.ml @@ -124,8 +124,9 @@ let track_t to_track ?(except=OpamFilename.Base.Set.empty) job_f = let files = try Sys.readdir (Filename.concat prefix dir) with Sys_error _ as e -> - log "Error at dir %s: %a" (Filename.concat prefix dir) - (slog Printexc.to_string) e; + log (fun fmt -> + fmt "Error at dir %s: %a" (Filename.concat prefix dir) + (slog Printexc.to_string) e); [||] in Array.fold_left @@ -140,7 +141,7 @@ let track_t to_track ?(except=OpamFilename.Base.Set.empty) job_f = | _, Dir -> make_index_topdir acc prefix rel | _ -> acc with Unix.Unix_error _ as e -> - log "Error at %s: %a" f (slog Printexc.to_string) e; + log (fun fmt -> fmt "Error at %s: %a" f (slog Printexc.to_string) e); acc) acc files in @@ -175,8 +176,9 @@ let track_t to_track ?(except=OpamFilename.Base.Set.empty) job_f = in let scan_timer = OpamConsole.timer () in let before = make_index () in - log ~level:2 "before install: %a elements scanned in %.3fs" - (slog @@ string_of_int @* SM.cardinal) before (scan_timer ()); + log ~level:2 (fun fmt -> + fmt "before install: %a elements scanned in %.3fs" + (slog @@ string_of_int @* SM.cardinal) before (scan_timer ())); job_f () @@| fun result -> let scan_timer = OpamConsole.timer () in let after = make_index () in @@ -198,11 +200,12 @@ let track_t to_track ?(except=OpamFilename.Base.Set.empty) job_f = | _ -> Some (Kind_changed (item_digest item))) before after in - log "after install: %a elements, %a added, scanned in %.3fs" - (slog @@ string_of_int @* SM.cardinal) after - (slog @@ string_of_int @* SM.cardinal @* - SM.filter (fun _ -> function Added _ -> true | _ -> false)) - diff (scan_timer ()); + log (fun fmt -> + fmt "after install: %a elements, %a added, scanned in %.3fs" + (slog @@ string_of_int @* SM.cardinal) after + (slog @@ string_of_int @* SM.cardinal @* + SM.filter (fun _ -> function Added _ -> true | _ -> false)) + diff (scan_timer ())); result, diff let track_files ~prefix files ?except job_f = @@ -280,8 +283,9 @@ let revert ?title ?(verbose=OpamConsole.verbose()) ?(force=false) ([], [], [], []) changes in if already <> [] then - log ~level:2 "%sfiles %s were already removed" title - (String.concat ", " (List.rev already)); + log ~level:2 (fun fmt -> + fmt "%sfiles %s were already removed" title + (String.concat ", " (List.rev already))); if modified <> [] then if OpamConsole.confirm ~default:false "%sthese files have been modified since installation:\n%s\ diff --git a/src/core/opamFilename.ml b/src/core/opamFilename.ml index d925d439179..33ab541014c 100644 --- a/src/core/opamFilename.ml +++ b/src/core/opamFilename.ml @@ -81,10 +81,11 @@ let exists_dir dirname = with Unix.Unix_error _ -> false let cleandir dirname = - if exists_dir dirname then - (log "cleandir %a" (slog Dir.to_string) dirname; - OpamSystem.remove (Dir.to_string dirname); - mkdir dirname) + if exists_dir dirname then begin + log (fun fmt -> fmt "cleandir %a" (slog Dir.to_string) dirname); + OpamSystem.remove (Dir.to_string dirname); + mkdir dirname + end let rec_dirs d = let fs = OpamSystem.rec_dirs (Dir.to_string d) in @@ -97,16 +98,13 @@ let dirs d = let dir_is_empty d = OpamSystem.dir_is_empty (Dir.to_string d) -let in_dir dirname fn = OpamSystem.in_dir dirname fn - let env_of_list l = Array.of_list (List.rev_map (fun (k,v) -> k^"="^v) l) -let exec dirname ?env ?name ?metadata ?keep_going cmds = +let exec dir ?env ?name ?metadata ?keep_going cmds = let env = match env with | None -> None | Some l -> Some (env_of_list l) in - in_dir dirname - (fun () -> OpamSystem.commands ?env ?name ?metadata ?keep_going cmds) + OpamSystem.commands ?env ?name ?metadata ~dir ?keep_going cmds let move_dir ~src ~dst = OpamSystem.mv (Dir.to_string src) (Dir.to_string dst) @@ -379,15 +377,17 @@ type generic_file = let extract_generic_file filename dirname = match filename with | F f -> - log "extracting %a to %a" - (slog to_string) f - (slog Dir.to_string) dirname; + log (fun fmt -> + fmt "extracting %a to %a" + (slog to_string) f + (slog Dir.to_string) dirname); extract f dirname | D d -> if d <> dirname then ( - log "copying %a to %a" - (slog Dir.to_string) d - (slog Dir.to_string) dirname; + log (fun fmt -> + fmt "copying %a to %a" + (slog Dir.to_string) d + (slog Dir.to_string) dirname); copy_dir ~src:d ~dst:dirname ) diff --git a/src/core/opamFilename.mli b/src/core/opamFilename.mli index 6a67d5b1695..cfa3357c43c 100644 --- a/src/core/opamFilename.mli +++ b/src/core/opamFilename.mli @@ -52,9 +52,6 @@ val dir_is_empty: Dir.t -> bool (** List the sub-directory (do not recurse) *) val dirs: Dir.t -> Dir.t list -(** Evaluate a function in a given directory *) -val in_dir: Dir.t -> (unit -> 'a) -> 'a - (** Turns an assoc list into an array suitable to be provided as environment *) val env_of_list: (string * string) list -> string array diff --git a/src/core/opamParallel.ml b/src/core/opamParallel.ml index 49abe705d71..9fb0b27fe67 100644 --- a/src/core/opamParallel.ml +++ b/src/core/opamParallel.ml @@ -73,8 +73,9 @@ module Make (G : G) = struct (* Returns a map (node -> return value) *) let aux_map ~jobs ~command ?(dry_run=false) ?(pools=[]) g = - log "Iterate over %a task(s) with %d process(es)" - (slog @@ G.nb_vertex @> string_of_int) g jobs; + log (fun fmt -> + fmt "Iterate over %a task(s) with %d process(es)" + (slog @@ G.nb_vertex @> string_of_int) g jobs); let njobs = G.nb_vertex g in @@ -153,7 +154,7 @@ module Make (G : G) = struct in let run_seq_command nslots ready n = function | Done r -> - log "Job %a finished" (slog (string_of_int @* V.hash)) n; + log (fun fmt -> fmt "Job %a finished" (slog (string_of_int @* V.hash)) n); let results = M.add n r results in let running = M.remove n running in if not (M.is_empty running) then @@ -174,8 +175,9 @@ module Make (G : G) = struct in loop nslots results running (ready ++ new_ready) | Run (cmd, cont) -> - log "Next task in job %a: %a" (slog (string_of_int @* V.hash)) n - (slog OpamProcess.string_of_command) cmd; + log (fun fmt -> + fmt "Next task in job %a: %a" (slog (string_of_int @* V.hash)) n + (slog OpamProcess.string_of_command) cmd); let p = if dry_run then OpamProcess.dry_run_background cmd else OpamProcess.run_background cmd @@ -188,9 +190,10 @@ module Make (G : G) = struct in let fail node error = - log "Exception while computing job %a: %a" - (slog (string_of_int @* V.hash)) node - (slog V.to_string) node; + log (fun fmt -> + fmt "Exception while computing job %a: %a" + (slog (string_of_int @* V.hash)) node + (slog V.to_string) node); if error = Sys.Break then OpamConsole.error "User interruption"; let running = M.remove node running in (* Cleanup *) @@ -215,7 +218,7 @@ module Make (G : G) = struct running ([node,error],[]) in (try List.iter (fun _ -> ignore (OpamProcess.wait_one pend)) pend - with e -> log "%a in sub-process cleanup" (slog Printexc.to_string) e); + with e -> log (fun fmt -> fmt "%a in sub-process cleanup" (slog Printexc.to_string) e)); (* Generate the remaining nodes in topological order *) let remaining = G.Topological.fold (fun n remaining -> @@ -235,23 +238,24 @@ module Make (G : G) = struct then (* Start a new process *) let n = S.choose ready in - log "Starting job %a (worker %a): %a" - (slog (string_of_int @* V.hash)) n - (slog - (fun pools -> - let slots = get_slots nslots n in - OpamStd.List.concat_map " " (fun (pool, jobs) -> - let nslots = - OpamStd.List.assoc_opt S.equal pool slots - in - Printf.sprintf "%s/%d" - (match nslots with - | None -> "-" - | Some n -> string_of_int (jobs - n + 1)) - jobs) - pools)) - pools - (slog V.to_string) n; + log (fun fmt -> + fmt "Starting job %a (worker %a): %a" + (slog (string_of_int @* V.hash)) n + (slog + (fun pools -> + let slots = get_slots nslots n in + OpamStd.List.concat_map " " (fun (pool, jobs) -> + let nslots = + OpamStd.List.assoc_opt S.equal pool slots + in + Printf.sprintf "%s/%d" + (match nslots with + | None -> "-" + | Some n -> string_of_int (jobs - n + 1)) + jobs) + pools)) + pools + (slog V.to_string) n); let pred = G.pred g n in let pred = List.map (fun n -> n, M.find n results) pred in let cmd = try command ~pred n with e -> fail n e in @@ -278,8 +282,9 @@ module Make (G : G) = struct with e -> fail (fst (snd (List.hd processes))) e in let n,cont = OpamStd.(List.assoc Compare.equal process processes) in - log "Collected task for job %a (ret:%d)" - (slog (string_of_int @* V.hash)) n result.OpamProcess.r_code; + log (fun fmt -> + fmt "Collected task for job %a (ret:%d)" + (slog (string_of_int @* V.hash)) n result.OpamProcess.r_code); let next = try cont result with e -> OpamProcess.cleanup result; diff --git a/src/core/opamProcess.ml b/src/core/opamProcess.ml index 5da63c8d995..d8d2b378305 100644 --- a/src/core/opamProcess.ml +++ b/src/core/opamProcess.ml @@ -69,7 +69,7 @@ let cygwin_create_process_env prog args env fd1 fd2 fd3 = let make_args argv = let b = Buffer.create 128 in let gen_quote ~quote ~pre ?(post = pre) s = - log ~level:3 "gen_quote: %S" s; + log ~level:3 (fun fmt -> fmt "gen_quote: %S" s); Buffer.clear b; let l = String.length s in let rec f i = @@ -101,7 +101,7 @@ let cygwin_create_process_env prog args env fd1 fd2 fd3 = else f 0 in - log ~level:3 "result: %S" r; r in + log ~level:3 (fun fmt -> fmt "result: %S" r); r in (* Setting noglob is causing some problems for ocamlbuild invoking Cygwin's find. The reason for using it is to try to keep command line lengths below the maximum, but for now disable the use of noglob. *) @@ -110,7 +110,7 @@ let cygwin_create_process_env prog args env fd1 fd2 fd3 = else (String.concat " " (List.map (gen_quote ~quote:"\b\r\n " ~pre:"\"") argv), true) in let (command_line, no_glob) = make_args (Array.to_list args) in - log "cygvoke(%sglob): %s" (if no_glob then "no" else "") command_line; + log (fun fmt -> fmt "cygvoke(%sglob): %s" (if no_glob then "no" else "") command_line); let env = Array.to_list env in let cygwin_set = ref false in let f item = @@ -135,26 +135,26 @@ let cygwin_create_process_env prog args env fd1 fd2 fd3 = match setting with | "glob" -> if no_glob then begin - log ~level:2 "Removing glob from %s" key; + log ~level:2 (fun fmt -> fmt "Removing glob from %s" key); false end else begin - log ~level:2 "Leaving glob in %s" key; + log ~level:2 (fun fmt -> fmt "Leaving glob in %s" key); noglob_set := true; true end | "noglob" -> if no_glob then begin - log ~level:2 "Leaving noglob in %s" key; + log ~level:2 (fun fmt -> fmt "Leaving noglob in %s" key); noglob_set := true; true end else begin - log ~level:2 "Removing noglob from %s" key; + log ~level:2 (fun fmt -> fmt "Removing noglob from %s" key); false end | "winsymlinks" -> begin match value with | Some ("nativestrict" as value) | Some ("native" as value) -> - log ~level:2 "Leaving %s:%s in %s" setting value key; + log ~level:2 (fun fmt -> fmt "Leaving %s:%s in %s" setting value key); winsymlinks_set := true; true | Some _ | None -> false @@ -164,18 +164,18 @@ let cygwin_create_process_env prog args env fd1 fd2 fd3 = let settings = List.filter f settings in let settings = if not !noglob_set && no_glob then begin - log ~level:2 "Setting noglob in %s" key; + log ~level:2 (fun fmt -> fmt "Setting noglob in %s" key); "noglob"::settings end else settings in let settings = if not !winsymlinks_set then begin - log ~level:2 "Setting winsymlinks:native in %s" key; + log ~level:2 (fun fmt -> fmt "Setting winsymlinks:native in %s" key); settings @ ["winsymlinks:native"] end else settings in if settings = [] then begin - log ~level:2 "Removing %s completely" key; + log ~level:2 (fun fmt -> fmt "Removing %s completely" key); None end else Some (key ^ "=" ^ String.concat " " settings) @@ -187,10 +187,10 @@ let cygwin_create_process_env prog args env fd1 fd2 fd3 = env else if no_glob then begin - log ~level:2 "Adding CYGWIN=winsymlinks:native noglob"; + log ~level:2 (fun fmt -> fmt "Adding CYGWIN=winsymlinks:native noglob"); "CYGWIN=winsymlinks:native noglob"::env end else begin - log ~level:2 "Adding CYGWIN=winsymlinks:native"; + log ~level:2 (fun fmt -> fmt "Adding CYGWIN=winsymlinks:native"); "CYGWIN=winsymlinks:native"::env end in OpamStubs.win_create_process prog command_line @@ -683,7 +683,7 @@ let safe_wait fallback_pid f x = try f x with | Unix.Unix_error (Unix.EINTR,_,_) -> aux () (* handled signal *) | Unix.Unix_error (Unix.ECHILD,_,_) -> - log "Warn: no child to wait for %d" fallback_pid; + log (fun fmt -> fmt "Warn: no child to wait for %d" fallback_pid); fallback_pid, Unix.WEXITED 256 with | _, Unix.WSTOPPED _ -> @@ -765,10 +765,10 @@ let is_success r = not (is_failure r) let safe_unlink f = try - log ~level:2 "safe_unlink: %s" f; + log ~level:2 (fun fmt -> fmt "safe_unlink: %s" f); Unix.unlink f with Unix.Unix_error _ -> - log ~level:2 "safe_unlink: %s (FAILED)" f + log ~level:2 (fun fmt -> fmt "safe_unlink: %s (FAILED)" f) let cleanup ?(force=false) r = if force || (not (OpamConsole.debug ()) && is_success r) then diff --git a/src/core/opamStubs.win32.ml b/src/core/opamStubs.win32.ml index 22792c62461..74f6c9c8c13 100644 --- a/src/core/opamStubs.win32.ml +++ b/src/core/opamStubs.win32.ml @@ -14,4 +14,4 @@ let getpid () = Int32.to_int (getCurrentProcessID ()) external win_create_process : string -> string -> string option -> Unix.file_descr -> Unix.file_descr -> Unix.file_descr -> int - = "win_create_process" "win_create_process_native" + = "caml_unix_create_process" "caml_unix_create_process_native" diff --git a/src/core/opamSystem.ml b/src/core/opamSystem.ml index 1282e307094..2095aa30ab9 100644 --- a/src/core/opamSystem.ml +++ b/src/core/opamSystem.ml @@ -25,7 +25,7 @@ let slog = OpamConsole.slog let internal_error fmt = Printf.ksprintf (fun str -> - log "error: %s" str; + log (fun fmt -> fmt "error: %s" str); raise (Internal_error str) ) fmt @@ -90,7 +90,7 @@ let rec mk_temp_dir ?(prefix="opam") () = let safe_mkdir dir = try - log "mkdir %s" dir; + log (fun fmt -> fmt "mkdir %s" dir); Unix.mkdir dir 0o755 with Unix.Unix_error(Unix.EEXIST,_,_) -> () @@ -131,7 +131,7 @@ let win32_unlink fn = let remove_file_t ?(with_log=true) file = try if with_log || log_for_file_management () then - log "rm %s" file; + log (fun fmt -> fmt "rm %s" file); if Sys.win32 then win32_unlink file else @@ -156,7 +156,7 @@ let rec remove_dir_t dir = Unix.rmdir dir let remove_dir dir = - log "rmdir %s" dir; + log (fun fmt -> fmt "rmdir %s" dir); if Sys.file_exists dir then begin if Sys.is_directory dir then remove_dir_t dir @@ -173,7 +173,7 @@ let logs_cleaner = try Unix.unlink f; (* Only log the item if unlink succeeded *) - log "logs_cleaner: rm: %s" f + log (fun fmt -> fmt "logs_cleaner: rm: %s" f) with Unix.Unix_error _ -> ()) !to_clean; if OpamCoreConfig.(!r.log_dir = default.log_dir) then @@ -203,7 +203,7 @@ let remove_file file = if try ignore (Unix.lstat file); true with Unix.Unix_error _ -> false then ( - log "rm %s" file; + log (fun fmt -> fmt "rm %s" file); try try Unix.unlink file with Unix.Unix_error(EACCES, _, _) when Sys.win32 -> @@ -303,35 +303,15 @@ let copy_file_aux ?chmod ~src ~dst () = (try Unix.unlink dst with Unix.Unix_error _ -> ()); internal_error "Cannot copy %s to %s (%s)." src dst (Printexc.to_string e) -let chdir dir = - try Unix.chdir dir - with Unix.Unix_error _ -> raise (File_not_found dir) - -let in_dir dir fn = - let reset_cwd = - let cwd = - try Some (Sys.getcwd ()) - with Sys_error _ -> None in - fun () -> - match cwd with - | None -> () - | Some cwd -> try chdir cwd with File_not_found _ -> () in - chdir dir; - try - let r = fn () in - reset_cwd (); - r - with e -> - OpamStd.Exn.finalise e reset_cwd - let list kind dir = try - in_dir dir (fun () -> - let d = Sys.readdir (Sys.getcwd ()) in - let d = Array.to_list d in - let l = List.filter kind d in - List.map (Filename.concat dir) (List.sort compare l) - ) + let d = Sys.readdir dir in + let l = Array.fold_left (fun acc d -> + let d = dir / d in + if kind d then d :: acc else acc + ) [] d + in + List.sort String.compare l with File_not_found _ -> [] let ls dir = list (fun _ -> true) dir @@ -368,7 +348,7 @@ let dirs dir = directories_with_links dir let dir_is_empty dir = - try in_dir dir (fun () -> Sys.readdir (Sys.getcwd ()) = [||]) + try Sys.readdir dir = [||] with File_not_found _ -> false let with_tmp_dir fn = @@ -382,10 +362,6 @@ let with_tmp_dir fn = OpamStd.Exn.finalise e @@ fun () -> remove_dir dir -let in_tmp_dir fn = - with_tmp_dir @@ fun dir -> - in_dir dir fn - let with_tmp_dir_job fjob = let dir = mk_temp_dir () in mkdir dir; @@ -608,7 +584,7 @@ let make_command | `Denied -> permission_denied cmd let run_process - ?verbose ?env ~name ?metadata ?stdout ?allow_stdin command = + ?verbose ?env ~name ?metadata ?dir ?stdout ?allow_stdin command = let env = match env with None -> OpamProcess.default_env () | Some e -> e in let chrono = OpamConsole.timer () in runs := command :: !runs; @@ -624,26 +600,27 @@ let run_process let r = OpamProcess.run (OpamProcess.command - ~env ~name ~verbose ?metadata ?allow_stdin ?stdout + ~env ~name ~verbose ?metadata ?dir ?allow_stdin ?stdout full_cmd args) in let str = String.concat " " (cmd :: args) in - log ~level:2 "[%a] (in %.3fs) %s" - (OpamConsole.slog Filename.basename) name - (chrono ()) str; + log ~level:2 (fun fmt -> + fmt "[%a] (in %.3fs) %s" + (OpamConsole.slog Filename.basename) name + (chrono ()) str); r | `Not_found -> command_not_found cmd | `Denied -> permission_denied cmd -let command ?verbose ?env ?name ?metadata ?allow_stdin cmd = +let command ?verbose ?env ?name ?metadata ?dir ?allow_stdin cmd = let name = log_file name in - let r = run_process ?verbose ?env ~name ?metadata ?allow_stdin cmd in + let r = run_process ?verbose ?env ~name ?metadata ?dir ?allow_stdin cmd in OpamProcess.cleanup r; raise_on_process_error r -let commands ?verbose ?env ?name ?metadata ?(keep_going=false) commands = +let commands ?verbose ?env ?name ?metadata ?dir ?(keep_going=false) commands = let name = log_file name in - let run = run_process ?verbose ?env ~name ?metadata in + let run = run_process ?verbose ?env ~name ?metadata ?dir in let command r0 c = match r0, keep_going with | (`Error _ | `Exception _), false -> r0 @@ -661,12 +638,12 @@ let commands ?verbose ?env ?name ?metadata ?(keep_going=false) commands = | `Error e -> process_error e | `Exception e -> raise e -let read_command_output ?verbose ?env ?metadata ?allow_stdin +let read_command_output ?verbose ?env ?metadata ?dir ?allow_stdin ?(ignore_stderr=false) cmd = let name = log_file None in let stdout = name ^ (if ignore_stderr then ".stdout" else ".out") in let r = - run_process ?verbose ?env ~name ?metadata ?allow_stdin + run_process ?verbose ?env ~name ?metadata ?dir ?allow_stdin ~stdout cmd in @@ -687,7 +664,7 @@ let copy_file_t ?(with_log=true) src dst = then remove_file dst; mkdir (Filename.dirname dst); if with_log || log_for_file_management () then - log "copy %s -> %s" src dst; + log (fun fmt -> fmt "copy %s -> %s" src dst); copy_file_aux ~src ~dst () let rec link_t ?(with_log=true) src dst = @@ -696,7 +673,7 @@ let rec link_t ?(with_log=true) src dst = remove_file dst; try if with_log || log_for_file_management () then - log "ln -s %s %s" src dst; + log (fun fmt -> fmt "ln -s %s %s" src dst); Unix.symlink src dst with Unix.Unix_error (Unix.EXDEV, _, _) -> (* Fall back to copy if symlinks are not supported *) @@ -711,7 +688,7 @@ let rec link_t ?(with_log=true) src dst = and copy_dir_t ?(with_log=true) src dst_dir = if with_log || log_for_file_management () then - log "copydir %s -> %s" src dst_dir; + log (fun fmt -> fmt "copydir %s -> %s" src dst_dir); let files = get_files src in mkdir dst_dir; let with_log = false in @@ -746,7 +723,7 @@ let copy_file = copy_file_t ~with_log:true let mv src dst = if file_or_symlink_exists dst then remove_file dst; mkdir (Filename.dirname dst); - log "mv %s -> %s" src dst; + log (fun fmt -> fmt "mv %s -> %s" src dst); try Unix.rename src dst with @@ -868,7 +845,7 @@ let install ?(warning=default_install_warning) ?exec src dst = | Some e -> e | None -> is_exec src in let perm = if exec then 0o755 else 0o644 in - log "install %s -> %s (%o)" src dst perm; + log (fun fmt -> fmt "install %s -> %s (%o)" src dst perm); if Sys.win32 then if exec then begin let (dst, cygcheck) = @@ -1148,12 +1125,12 @@ let link src dst = ); if Unix.has_symlink () then try - log "ln -s %s %s" src dst; + log (fun fmt -> fmt "ln -s %s %s" src dst); Unix.symlink src dst with Unix.Unix_error (Unix.EXDEV, _, _) -> fallback () else ( - log "copy %s -> %s" src dst; + log (fun fmt -> fmt "copy %s -> %s" src dst); fallback () ) @@ -1190,9 +1167,10 @@ let release_all_locks () = let rec flock_update : 'a. ([< lock_flag ] as 'a) -> ?dontblock:bool -> lock -> unit = fun flag ?(dontblock=OpamCoreConfig.(!r.safe_mode)) lock -> - log "LOCK %s (%a => %a)" ~level:2 lock.file - (slog string_of_lock_kind) (lock.kind) - (slog string_of_lock_kind) flag; + log ~level:2 (fun fmt -> + fmt "LOCK %s (%a => %a)" lock.file + (slog string_of_lock_kind) (lock.kind) + (slog string_of_lock_kind) flag); if lock.kind = (flag :> lock_flag) then () else match flag, lock with @@ -1399,17 +1377,17 @@ let translate_patch ~dir orig corrected = match (crlf, patch_crlf) with | (None, _) | (_, None) -> - log ~level:3 "CRLF adaptation skipped for %s" target; + log ~level:3 (fun fmt -> fmt "CRLF adaptation skipped for %s" target); None | (Some crlf, Some patch_crlf) -> if crlf = patch_crlf then begin - log ~level:3 "No CRLF adaptation necessary for %s" target; + log ~level:3 (fun fmt -> fmt "No CRLF adaptation necessary for %s" target); None end else if crlf then begin - log ~level:3 "Adding \\r to patch chunks for %s" target; + log ~level:3 (fun fmt -> fmt "Adding \\r to patch chunks for %s" target); Some true end else begin - log ~level:3 "Stripping \\r to patch chunks for %s" target; + log ~level:3 (fun fmt -> fmt "Stripping \\r to patch chunks for %s" target); Some false end in @@ -1552,8 +1530,9 @@ let translate_patch ~dir orig corrected = | None -> Some (Some has_cr) | Some (Some think_cr) when think_cr <> has_cr -> - log ~level:2 "Patch adaptation disabled for %s: \ - mixed endings or binary file" target; + log ~level:2 (fun fmt -> + fmt "Patch adaptation disabled for %s: \ + mixed endings or binary file" target); Some None | _ -> patch_crlf @@ -1597,7 +1576,7 @@ let translate_patch ~dir orig corrected = if OpamConsole.debug () then let log_transform (first_line, last_line, add_cr) = let indicator = if add_cr then '+' else '-' in - log ~level:3 "Transform %d-%d %c\\r" first_line last_line indicator + log ~level:3 (fun fmt -> fmt "Transform %d-%d %c\\r" first_line last_line indicator) in List.iter log_transform transforms; let rec fold_lines n transforms = diff --git a/src/core/opamSystem.mli b/src/core/opamSystem.mli index de977c51c0d..5fa1f117376 100644 --- a/src/core/opamSystem.mli +++ b/src/core/opamSystem.mli @@ -35,9 +35,6 @@ val internal_error: ('a, unit, string, 'b) format4 -> 'a passes its name to [fn]. The directory is alwasy removed on completion. *) val with_tmp_dir: (string -> 'a) -> 'a -(** [in_tmp_dir fn] executes [fn] in a temporary directory. *) -val in_tmp_dir: (unit -> 'a) -> 'a - (** Runs a job with a temp dir that is cleaned up afterwards *) val with_tmp_dir_job: (string -> 'a OpamProcess.job) -> 'a OpamProcess.job @@ -124,12 +121,6 @@ val remove_file: string -> unit directory (not for symlinks or other files). *) val remove_dir: string -> unit -(** Change the current working directory *) -val chdir: string -> unit - -(** [in_dir dir fn] evaluates [fn] in the directory [dir] *) -val in_dir: string -> (unit -> 'a) -> 'a - (** Returns the list of files and directories in the given directory (full names) *) val ls: string -> string list @@ -208,14 +199,14 @@ val apply_cygpath: string -> string (** [command cmd] executes the command [cmd] in the correct OPAM environment. *) val command: ?verbose:bool -> ?env:string array -> ?name:string -> - ?metadata:(string * string) list -> ?allow_stdin:bool -> + ?metadata:(string * string) list -> ?dir:string -> ?allow_stdin:bool -> command -> unit (** [commands cmds] executes the commands [cmds] in the correct OPAM environment. It stops whenever one command fails unless [keep_going] is set to [true]. In this case, the first error is re-raised at the end. *) val commands: ?verbose:bool -> ?env:string array -> ?name:string -> - ?metadata:(string * string) list -> ?keep_going:bool -> command list -> unit + ?metadata:(string * string) list -> ?dir:string -> ?keep_going:bool -> command list -> unit (** [read_command_output cmd] executes the command [cmd] in the correct OPAM environment and return the lines from output if the command @@ -224,7 +215,7 @@ val commands: ?verbose:bool -> ?env:string array -> ?name:string -> It returns stdout and stder combiend, unless [ignore_stderr] is st to true. *) val read_command_output: ?verbose:bool -> ?env:string array -> - ?metadata:(string * string) list -> ?allow_stdin:bool -> + ?metadata:(string * string) list -> ?dir:string -> ?allow_stdin:bool -> ?ignore_stderr:bool -> command -> string list (** END *) diff --git a/src/core/opamUrl.ml b/src/core/opamUrl.ml index 16baf4c752b..51a58806ff5 100644 --- a/src/core/opamUrl.ml +++ b/src/core/opamUrl.ml @@ -43,7 +43,7 @@ let equal u v = compare u v = 0 exception Parse_error of string let parse_error s = raise (Parse_error s) -let split_url = +let split_url u = let re = Re.(compile @@ whole_string @@ seq [ (* Parse the scheme, which is either backend+protocol or just a protocol *) @@ -66,7 +66,6 @@ let split_url = opt @@ seq [ char '#'; group @@ rep any ]; ]) in - fun u -> match Re.Group.all (Re.exec re u) with | [| _; vc; transport; path; suffix; hash |] -> let opt = function "" -> None | s -> Some s in @@ -103,7 +102,7 @@ let backend_of_string = function (OpamConsole.colorise `underline p)) -let looks_like_ssh_path = +let looks_like_ssh_path path = (* ':' before any '/' : assume ssh, like git does. Exception for 'x:' with single char, because Windows *) let re = @@ -121,7 +120,6 @@ let looks_like_ssh_path = eos; ]) in - fun path -> try let sub = Re.exec re path in Some (Re.Group.get sub 1 ^ diff --git a/src/format/opamFile.ml b/src/format/opamFile.ml index 75085db5fa5..c139501878b 100644 --- a/src/format/opamFile.ml +++ b/src/format/opamFile.ml @@ -118,7 +118,7 @@ module MakeIO (F : IO_Arg) = struct in write f (fun oc -> F.to_channel f oc v); Stats.write_files := filename :: !Stats.write_files; - log "Wrote %s%s in %.3fs" filename (if F.atomic then " atomically" else "") (chrono ()) + log (fun fmt -> fmt "Wrote %s%s in %.3fs" filename (if F.atomic then " atomically" else "") (chrono ())) let read_opt f = let filename = OpamFilename.prettify f in @@ -127,10 +127,10 @@ module MakeIO (F : IO_Arg) = struct let ic = OpamFilename.open_in f in try Unix.lockf (Unix.descr_of_in_channel ic) Unix.F_RLOCK 0; - Stats.read_files := filename :: !Stats.read_files; + (*Stats.read_files := filename :: !Stats.read_files;*) let r = F.of_channel f ic in close_in ic; - log ~level:3 "Read %s in %.3fs" filename (chrono ()); + log ~level:3 (fun fmt -> fmt "Read %s in %.3fs" filename (chrono ())); Some r with e -> OpamStd.Exn.finalise e (fun () -> close_in ic) with @@ -156,7 +156,7 @@ module MakeIO (F : IO_Arg) = struct match read_opt f with | Some f -> f | None -> - log ~level:2 "Cannot find %a" (slog OpamFilename.to_string) f; + log ~level:2 (fun fmt -> fmt "Cannot find %a" (slog OpamFilename.to_string) f); F.empty with | (Pp.Bad_version _ | Pp.Bad_format _) as e-> @@ -3501,9 +3501,9 @@ module OPAMSyntax = struct | Some _, None, None -> t | None, Some _, Some _ -> t | None, _, _ -> - OpamConsole.log "FILE(opam)" - "Outputting opam file %s with unspecified name or version" - (OpamFilename.to_string filename); + OpamConsole.log "FILE(opam)" (fun fmt -> + fmt "Outputting opam file %s with unspecified name or version" + (OpamFilename.to_string filename)); t | Some nv, _, _ -> if t.name <> None && t.name <> Some (nv.OpamPackage.name) || diff --git a/src/format/opamFilter.ml b/src/format/opamFilter.ml index 09d0ad5ff0a..61318a46ac8 100644 --- a/src/format/opamFilter.ml +++ b/src/format/opamFilter.ml @@ -251,7 +251,7 @@ let expand_string_aux ?(partial=false) ?(escape_value=fun x -> x) ?default env t let str = Re.Group.get g 0 in if str = "%%" then (if partial then "%%" else "%") else if not (OpamStd.String.ends_with ~suffix:"}%" str) then - (log "ERR: Unclosed variable replacement in %S\n" str; + (log (fun fmt -> fmt "ERR: Unclosed variable replacement in %S\n" str); str) else let fident = String.sub str 2 (String.length str - 4) in @@ -341,7 +341,7 @@ let logop1 cstr op = function | FUndef f -> FUndef (cstr f) | e -> try FBool (op (value_bool e)) - with Invalid_argument s -> log "ERR: %s" s; FUndef (cstr e) + with Invalid_argument s -> log (fun fmt -> fmt "ERR: %s" s); FUndef (cstr e) let logop2 cstr op absorb e f = match e, f with | _, FBool x when x = absorb -> FBool x @@ -349,7 +349,7 @@ let logop2 cstr op absorb e f = match e, f with | FUndef x, FUndef y | FUndef x, y | x, FUndef y -> FUndef (cstr x y) | f, g -> try FBool (op (value_bool f) (value_bool g)) - with Invalid_argument s -> log "ERR: %s" s; FUndef (cstr f g) + with Invalid_argument s -> log (fun fmt -> fmt "ERR: %s" s); FUndef (cstr f g) (* Reduce expressions to values *) @@ -472,7 +472,7 @@ let arguments env (a,f) = | Some (S s) -> [s] | Some (B b) -> [string_of_bool b] | Some (L sl) -> sl - | None -> log "ERR in replacement: undefined ident %S" i; [""] + | None -> log (fun fmt -> fmt "ERR in replacement: undefined ident %S" i); [""] else [] @@ -523,8 +523,9 @@ let filter_constraints ?default_version ?default env filtered_constraint = `Formula (Atom (relop, OpamPackage.Version.of_string v)) with Failure msg -> match default_version with | None -> - log "Warn: ignoring version constraint %a: %s" - (slog to_string) v msg; + log (fun fmt -> + fmt "Warn: ignoring version constraint %a: %s" + (slog to_string) v msg); `Formula (Empty) | Some v -> `Formula (Atom (relop, v))) filtered_constraint diff --git a/src/format/opamFormat.ml b/src/format/opamFormat.ml index 08d2b618f8b..d714994318c 100644 --- a/src/format/opamFormat.ml +++ b/src/format/opamFormat.ml @@ -844,11 +844,12 @@ module I = struct (fun e -> OpamPp.string_of_bad_format (Bad_format e)) (List.rev_map snd errs)) else - OpamConsole.log "FORMAT" "File errors in %s, ignored fields: %s" - file - (OpamStd.List.concat_map "; " - (fun e -> OpamPp.string_of_bad_format (Bad_format e)) - (List.rev_map snd errs)); + OpamConsole.log "FORMAT" (fun fmt -> + fmt "File errors in %s, ignored fields: %s" + file + (OpamStd.List.concat_map "; " + (fun e -> OpamPp.string_of_bad_format (Bad_format e)) + (List.rev_map snd errs))); t) in let print t = t, [] in diff --git a/src/format/opamPackage.ml b/src/format/opamPackage.ml index f9b3d93c852..f2c7bb70fbc 100644 --- a/src/format/opamPackage.ml +++ b/src/format/opamPackage.ml @@ -224,7 +224,7 @@ let of_archive f = | Some (s,_) -> of_string_opt s let list dir = - log "list %a" (slog OpamFilename.Dir.to_string) dir; + log (fun fmt -> fmt "list %a" (slog OpamFilename.Dir.to_string) dir); if OpamFilename.exists_dir dir then ( let files = OpamFilename.rec_files dir in List.fold_left (fun set f -> @@ -244,7 +244,7 @@ let list dir = Set.empty let prefixes repodir = - log "prefixes %a" (slog OpamFilename.Dir.to_string) repodir; + log (fun fmt -> fmt "prefixes %a" (slog OpamFilename.Dir.to_string) repodir); if OpamFilename.exists_dir repodir then ( let files = OpamFilename.rec_files repodir in List.fold_left (fun map f -> diff --git a/src/repository/opamDownload.ml b/src/repository/opamDownload.ml index 567a7018753..fb84523309a 100644 --- a/src/repository/opamDownload.ml +++ b/src/repository/opamDownload.ml @@ -149,7 +149,7 @@ let really_download | e -> OpamSystem.remove tmp_dst; OpamStd.Exn.fatal e; - log "Could not download file at %s." (OpamUrl.to_string url); + log (fun fmt -> fmt "Could not download file at %s." (OpamUrl.to_string url)); raise e) @@ fun () -> download_command ~compress ?checksum ~url ~dst:tmp_dst () @@ -328,8 +328,9 @@ module SWHID = struct It may take few minutes." (OpamConsole.colorise `underline (OpamUrl.to_string (OpamFile.URL.url urlf))) then - (log "SWH fallback for %s" - (OpamUrl.to_string (OpamFile.URL.url urlf)); + (log (fun fmt -> + fmt "SWH fallback for %s" + (OpamUrl.to_string (OpamFile.URL.url urlf))); get_url ?max_tries swhid @@+ function | Not_available _ as error -> Done error | Up_to_date _ -> assert false diff --git a/src/repository/opamHTTP.ml b/src/repository/opamHTTP.ml index 9c62d0ea231..5d679b0471b 100644 --- a/src/repository/opamHTTP.ml +++ b/src/repository/opamHTTP.ml @@ -40,7 +40,7 @@ module B = struct let name = `http let fetch_repo_update repo_name ?cache_dir:_ repo_root url = - log "pull-repo-update"; + log (fun fmt -> fmt "pull-repo-update"); let quarantine = OpamFilename.Dir.(of_string (to_string repo_root ^ ".new")) in @@ -69,9 +69,10 @@ module B = struct let repo_update_complete _ _ = Done () let pull_url ?full_fetch:_ ?cache_dir:_ ?subpath:_ dirname checksum remote_url = - log "pull-file into %a: %a" - (slog OpamFilename.Dir.to_string) dirname - (slog OpamUrl.to_string) remote_url; + log (fun fmt -> + fmt "pull-file into %a: %a" + (slog OpamFilename.Dir.to_string) dirname + (slog OpamUrl.to_string) remote_url); OpamProcess.Job.catch (fun e -> OpamStd.Exn.fatal e; @@ -100,9 +101,9 @@ end (* Helper functions used by opam-admin *) let make_index_tar_gz repo_root = - OpamFilename.in_dir repo_root (fun () -> - let to_include = [ "version"; "packages"; "repo" ] in - match List.filter Sys.file_exists to_include with - | [] -> () - | d -> OpamSystem.command ("tar" :: "czhf" :: "index.tar.gz" :: "--exclude=.git*" :: d) - ) + let repo_root = OpamFilename.Dir.to_string repo_root in + let ( / ) = Filename.concat in + let to_include = [ repo_root / "version"; repo_root / "packages"; repo_root / "repo" ] in + match List.filter Sys.file_exists to_include with + | [] -> () + | d -> OpamSystem.command ~dir:repo_root ("tar" :: "czhf" :: "index.tar.gz" :: "--exclude=.git*" :: d) diff --git a/src/repository/opamLocal.ml b/src/repository/opamLocal.ml index 77205c0940c..0377b9d0f20 100644 --- a/src/repository/opamLocal.ml +++ b/src/repository/opamLocal.ml @@ -56,7 +56,7 @@ let call_rsync check args = | _ -> OpamSystem.process_error r let rsync ?(args=[]) ?(exclude_vcdirs=true) src dst = - log "rsync: src=%s dst=%s" src dst; + log (fun fmt -> fmt "rsync: src=%s dst=%s" src dst); let remote = String.contains src ':' in let overlap src dst = let norm d = Filename.concat d "" in @@ -116,7 +116,7 @@ let rsync_dirs ?args ?exclude_vcdirs url dst = let rsync_file ?(args=[]) url dst = let src_s = url.OpamUrl.path in let dst_s = OpamFilename.to_string dst in - log "rsync_file src=%s dst=%s" src_s dst_s; + log (fun fmt -> fmt "rsync_file src=%s dst=%s" src_s dst_s); if not (is_remote url || OpamFilename.(exists (of_string src_s))) then Done (Not_available (None, src_s)) else if src_s = dst_s then @@ -145,7 +145,7 @@ module B = struct rsync_dirs url local_dirname let fetch_repo_update repo_name ?cache_dir:_ repo_root url = - log "pull-repo-update"; + log (fun fmt -> fmt "pull-repo-update"); let quarantine = OpamFilename.Dir.(of_string (to_string repo_root ^ ".new")) in diff --git a/src/repository/opamRepository.ml b/src/repository/opamRepository.ml index 39531ace163..e907dcf2a66 100644 --- a/src/repository/opamRepository.ml +++ b/src/repository/opamRepository.ml @@ -179,8 +179,9 @@ let pull_from_upstream let url, pull = if OpamUrl.(match url.backend with | #version_control -> false | _ -> true) && OpamFilename.exists_dir pin_cache_dir then - (log "Pin cache existing for %s : %s\n" - (OpamUrl.to_string url) @@ OpamFilename.Dir.to_string pin_cache_dir; + (log (fun fmt -> + fmt "Pin cache existing for %s : %s\n" + (OpamUrl.to_string url) @@ OpamFilename.Dir.to_string pin_cache_dir); let rsync = OpamUrl.parse ~backend:`rsync ~from_file:false @@ OpamFilename.Dir.to_string pin_cache_dir @@ -193,8 +194,9 @@ let pull_from_upstream ) else if OpamUrl.(match url.backend with | `git -> true | _ -> false) && OpamFilename.exists_dir pin_cache_dir then - (log "Pin cache (git) existing for %s : %s\n" - (OpamUrl.to_string url) @@ OpamFilename.Dir.to_string pin_cache_dir; + (log (fun fmt -> + fmt "Pin cache (git) existing for %s : %s\n" + (OpamUrl.to_string url) @@ OpamFilename.Dir.to_string pin_cache_dir); let git_cached = OpamUrl.parse ~backend:`git @@ OpamFilename.Dir.to_string pin_cache_dir @@ -478,16 +480,17 @@ let validate_repo_update repo repo_root update = | [] -> failwith "Empty validation hook" in cmd @@> fun r -> - log "validation: %s" (OpamProcess.result_summary r); + log (fun fmt -> fmt "validation: %s" (OpamProcess.result_summary r)); Done (OpamProcess.check_success_and_cleanup r) open OpamRepositoryBackend let apply_repo_update repo repo_root = function | Update_full d -> - log "%a: applying update from scratch at %a" - (slog OpamRepositoryName.to_string) repo.repo_name - (slog OpamFilename.Dir.to_string) d; + log (fun fmt -> + fmt "%a: applying update from scratch at %a" + (slog OpamRepositoryName.to_string) repo.repo_name + (slog OpamFilename.Dir.to_string) d); OpamFilename.rmdir repo_root; if OpamFilename.is_symlink_dir d then (OpamFilename.copy_dir ~src:d ~dst:repo_root; @@ -503,9 +506,10 @@ let apply_repo_update repo repo_root = function (OpamConsole.colorise `green (OpamRepositoryName.to_string repo.repo_name)) (OpamUrl.to_string repo.repo_url); - log "%a: applying patch update at %a" - (slog OpamRepositoryName.to_string) repo.repo_name - (slog OpamFilename.to_string) f; + log (fun fmt -> + fmt "%a: applying patch update at %a" + (slog OpamRepositoryName.to_string) repo.repo_name + (slog OpamFilename.to_string) f); let preprocess = match repo.repo_url.OpamUrl.backend with | `http | `rsync -> false @@ -521,8 +525,9 @@ let apply_repo_update repo repo_root = function (OpamConsole.colorise `green (OpamRepositoryName.to_string repo.repo_name)) (OpamUrl.to_string repo.repo_url); - log "%a: applying empty update" - (slog OpamRepositoryName.to_string) repo.repo_name; + log (fun fmt -> + fmt "%a: applying empty update" + (slog OpamRepositoryName.to_string) repo.repo_name); Done () | Update_err _ -> assert false @@ -534,12 +539,12 @@ let cleanup_repo_update upd = | _ -> () let update repo repo_root = - log "update %a" (slog OpamRepositoryBackend.to_string) repo; + log (fun fmt -> fmt "update %a" (slog OpamRepositoryBackend.to_string) repo); let module B = (val find_backend repo: OpamRepositoryBackend.S) in B.fetch_repo_update repo.repo_name repo_root repo.repo_url @@+ function | Update_err e -> raise e | Update_empty -> - log "update empty, no validation performed"; + log (fun fmt -> fmt "update empty, no validation performed"); apply_repo_update repo repo_root Update_empty @@+ fun () -> B.repo_update_complete repo_root repo.repo_url @@+ fun () -> Done `No_changes diff --git a/src/repository/opamRepositoryBackend.ml b/src/repository/opamRepositoryBackend.ml index 202c702c083..3f40474233f 100644 --- a/src/repository/opamRepositoryBackend.ml +++ b/src/repository/opamRepositoryBackend.ml @@ -74,10 +74,11 @@ let job_text name label = label) let get_diff parent_dir dir1 dir2 = - log "diff: %a/{%a,%a}" - (slog OpamFilename.Dir.to_string) parent_dir - (slog OpamFilename.Base.to_string) dir1 - (slog OpamFilename.Base.to_string) dir2; + log (fun fmt -> + fmt "diff: %a/{%a,%a}" + (slog OpamFilename.Dir.to_string) parent_dir + (slog OpamFilename.Base.to_string) dir1 + (slog OpamFilename.Base.to_string) dir2); let patch = OpamSystem.temp_file ~auto_clean: false "patch" in let patch_file = OpamFilename.of_string patch in let finalise () = OpamFilename.remove patch_file in diff --git a/src/solver/opamBuiltin0install.ml b/src/solver/opamBuiltin0install.ml index bc5c9c3fa37..3ab51ce4c3f 100644 --- a/src/solver/opamBuiltin0install.ml +++ b/src/solver/opamBuiltin0install.ml @@ -112,9 +112,9 @@ let call ~criteria ?timeout:_ (preamble, universe, request) = match Opam_0install_cudf.solve context pkgs with | Ok selections -> let universe = reconstruct_universe universe selections in - log "Solution found. Solve took %.2f s" (timer ()); + log (fun fmt -> fmt "Solution found. Solve took %.2f s" (timer ())); (Some preamble, universe) | Error problem -> - log "No solution. Solve took %.2f s" (timer ()); - log ~level:3 "%a" (OpamConsole.slog Opam_0install_cudf.diagnostics) problem; + log (fun fmt -> fmt "No solution. Solve took %.2f s" (timer ())); + log ~level:3 (fun fmt -> fmt "%a" (OpamConsole.slog Opam_0install_cudf.diagnostics) problem); raise Dose_common.CudfSolver.Unsat diff --git a/src/solver/opamCudf.ml b/src/solver/opamCudf.ml index 9f6f8390ef8..cb46d59529f 100644 --- a/src/solver/opamCudf.ml +++ b/src/solver/opamCudf.ml @@ -581,7 +581,7 @@ module Graph = struct PG.add_vertex g p; iter_deps (PG.add_edge g p) p.Cudf.depends) u; - log ~level:3 "Graph generation: %.3f" (t ()); + log ~level:3 (fun fmt -> fmt "Graph generation: %.3f" (t ())); g let output g filename = @@ -830,11 +830,11 @@ module Pp_explanation = struct end let extract_explanations packages cudfnv2opam reasons : explanation list = - log "Conflict reporting"; + log (fun fmt -> fmt "Conflict reporting"); let open Dose_algo.Diagnostic in let module CS = ChainSet in (* Definitions and printers *) - log ~level:3 "Reasons: %a" (Pp_explanation.pp_reasonlist cudfnv2opam) reasons; + log ~level:3 (fun fmt -> fmt "Reasons: %a" (Pp_explanation.pp_reasonlist cudfnv2opam) reasons); let all_opam = let add p set = if is_artefact p then set @@ -1057,7 +1057,7 @@ let extract_explanations packages cudfnv2opam reasons : explanation list = | `Missing (_, sdeps', fdeps') -> sdeps = sdeps' && fdeps = fdeps' | _ -> false) in - log ~level:3 "Explanations: %a" Pp_explanation.pp_explanationlist explanations; + log ~level:3 (fun fmt -> fmt "Explanations: %a" Pp_explanation.pp_explanationlist explanations); match explanations with | [] -> OpamConsole.error_and_exit `Internal_error @@ -1424,17 +1424,19 @@ let preprocess_cudf_request (props, univ, creq) criteria = interesting_set in let conflicts = compute_conflicts univ to_install in - log "Conflicts: %a (%a) pkgs to remove" - (slog OpamStd.Op.(string_of_int @* Set.cardinal)) conflicts - (slog OpamStd.Op.(string_of_int @* Set.cardinal)) (conflicts %% packages); + log (fun fmt -> + fmt "Conflicts: %a (%a) pkgs to remove" + (slog OpamStd.Op.(string_of_int @* Set.cardinal)) conflicts + (slog OpamStd.Op.(string_of_int @* Set.cardinal)) (conflicts %% packages)); Cudf.load_universe (Set.elements (packages -- conflicts)) in - log "Preprocess cudf request (trimming: %s): from %d to %d packages in %.2fs" - (match do_trimming with - None -> "none" | Some false -> "simple" | Some true -> "full") - (Cudf.universe_size univ0) - (Cudf.universe_size univ) - (chrono ()); + log (fun fmt -> + fmt "Preprocess cudf request (trimming: %s): from %d to %d packages in %.2fs" + (match do_trimming with + None -> "none" | Some false -> "simple" | Some true -> "full") + (Cudf.universe_size univ0) + (Cudf.universe_size univ) + (chrono ())); props, univ, creq let trim_universe univ packages = @@ -1445,9 +1447,10 @@ let trim_universe univ packages = Cudf.load_universe (Cudf.get_packages ~filter:(fun p -> not (Set.mem p conflicts)) univ) in - log "Pre-remove conflicts (%s): from %d - %d to %d packages in %.2fs" - (Set.to_string packages) - n (Set.cardinal conflicts) (Cudf.universe_size univ) (chrono ()); + log (fun fmt -> + fmt "Pre-remove conflicts (%s): from %d - %d to %d packages in %.2fs" + (Set.to_string packages) + n (Set.cardinal conflicts) (Cudf.universe_size univ) (chrono ())); univ exception Timeout of Dose_algo.Depsolver.solver_result option @@ -1482,11 +1485,11 @@ let call_external_solver ~version_map univ req = ~call_solver:(OpamSolverConfig.call_solver ~criteria) ~explain:true cudf_request in - log "Solver call done in %.3fs" (chrono ()); + log (fun fmt -> fmt "Solver call done in %.3fs" (chrono ())); r with | Timeout (Some sol) -> - log "Solver call TIMED OUT with solution after %.3fs" (chrono ()); + log (fun fmt -> fmt "Solver call TIMED OUT with solution after %.3fs" (chrono ())); OpamConsole.warning "Resolution of the installation set timed out, so the following \ solution might not be optimal.\n\ @@ -1525,9 +1528,9 @@ let call_external_solver ~version_map univ req = let check_request ?(explain=true) ~version_map univ req = let chrono = OpamConsole.timer () in - log "Checking request..."; + log (fun fmt -> fmt "Checking request..."); let result = Dose_algo.Depsolver.check_request ~explain (to_cudf univ req) in - log "Request checked in %.3fs" (chrono ()); + log (fun fmt -> fmt "Request checked in %.3fs" (chrono ())); match result with | Dose_algo.Depsolver.Unsat (Some ({Dose_algo.Diagnostic.result = Dose_algo.Diagnostic.Failure _; _} as r)) -> @@ -1593,7 +1596,7 @@ let actions_of_diff (install, remove) = actions let resolve ~extern ~version_map universe request = - log "resolve request=%a" (slog string_of_request) request; + log (fun fmt -> fmt "resolve request=%a" (slog string_of_request) request); let resp = let check () = check_request ~version_map universe request in let solve () = get_final_universe ~version_map universe request in @@ -1835,8 +1838,9 @@ let compute_root_causes g requested reinstall available = required reinstallations and computing the graph of dependency of required actions *) let atomic_actions ~simple_universe ~complete_universe root_actions = - log ~level:2 "graph_of_actions root_actions=%a" - (slog string_of_actions) root_actions; + log ~level:2 (fun fmt -> + fmt "graph_of_actions root_actions=%a" + (slog string_of_actions) root_actions); let to_remove, to_install = List.fold_left (fun (rm,inst) a -> match a with @@ -1950,7 +1954,7 @@ let trim_actions univ req g = root_actions in let discard_actions = Action.Set.diff other_actions connex_actions in - log "Removed unrelated actions: %s" (Action.Set.to_string discard_actions); + log (fun fmt -> fmt "Removed unrelated actions: %s" (Action.Set.to_string discard_actions)); Action.Set.iter (ActionGraph.remove_vertex g) discard_actions let packages u = Cudf.get_packages u diff --git a/src/solver/opamCudfSolver.ml b/src/solver/opamCudfSolver.ml index c60a0d012fe..c873057e38b 100644 --- a/src/solver/opamCudfSolver.ml +++ b/src/solver/opamCudfSolver.ml @@ -112,8 +112,8 @@ module Aspcud_def = struct | s::_ -> match OpamStd.String.split s ' ' with | "aspcud"::_::v::_ when OpamVersionCompare.compare v "1.9" >= 0 -> - OpamConsole.log "SOLVER" - "Solver is aspcud >= 1.9: using latest version criteria"; + OpamConsole.log "SOLVER" (fun fmt -> + fmt "Solver is aspcud >= 1.9: using latest version criteria"); true | _ -> false with OpamSystem.Process_error _ -> false diff --git a/src/solver/opamSolver.ml b/src/solver/opamSolver.ml index bd68b18327f..ab792c80980 100644 --- a/src/solver/opamSolver.ml +++ b/src/solver/opamSolver.ml @@ -42,7 +42,7 @@ let solution_of_json json = OpamCudf.ActionGraph.of_json json let cudf_versions_map universe = - log ~level:3 "cudf_versions_map"; + log ~level:3 (fun fmt -> fmt "cudf_versions_map"); let add_packages_from_formula acc formula = List.fold_left (fun acc -> function | n, Some (_, v) -> OpamPackage.Set.add (OpamPackage.create n v) acc @@ -94,8 +94,9 @@ let constraint_to_cudf version_map name (op,v) = (this shouldn't happen for any constraint in the universe, now that we compute a full version map, but may still happen for user-provided constraints) *) - log "Warn: fallback constraint for %s" - (OpamFormula.string_of_atom (name, Some (op,v))); + log (fun fmt -> + fmt "Warn: fallback constraint for %s" + (OpamFormula.string_of_atom (name, Some (op,v)))); let all_versions = OpamPackage.Map.filter (fun nv _ -> nv.name = name) version_map in @@ -335,19 +336,20 @@ let load_cudf_packages opam_universe ?version_map opam_packages = let version_map = match version_map with | Some vm -> vm | None -> cudf_versions_map opam_universe in - log ~level:3 "Load cudf universe: opam2cudf"; + log ~level:3 (fun fmt -> fmt "Load cudf universe: opam2cudf"); let univ_gen = opam2cudf_map opam_universe version_map opam_packages in - log ~level:3 "Preload of cudf universe: done in %.3fs" (chrono ()); + log ~level:3 (fun fmt -> fmt "Preload of cudf universe: done in %.3fs" (chrono ())); fun ?(add_invariant=false) ?(depopts=false) ~build ~post () -> - log "Load cudf universe (depopts:%a, build:%b, post:%b)" - (slog string_of_bool) depopts - build - post; + log (fun fmt -> + fmt "Load cudf universe (depopts:%a, build:%b, post:%b)" + (slog string_of_bool) depopts + build + post); let chrono = OpamConsole.timer () in let cudf_packages_map = univ_gen ~depopts ~build ~post in - log ~level:3 "opam2cudf: done in %.3fs" (chrono ()); + log ~level:3 (fun fmt -> fmt "opam2cudf: done in %.3fs" (chrono ())); if add_invariant then let rec mk_key s = let k = OpamPackage.of_string (s^".~") in @@ -369,14 +371,15 @@ let map_to_cudf_universe cudf_packages_map = let load_cudf_universe opam_universe ?version_map opam_packages = let load_f = load_cudf_packages opam_universe ?version_map opam_packages in fun ?add_invariant ?depopts ~build ~post () -> - log "Load cudf universe (depopts:%a, build:%b, post:%b)" - (slog string_of_bool) OpamStd.Option.Op.(depopts +! false) - build - post; + log (fun fmt -> + fmt "Load cudf universe (depopts:%a, build:%b, post:%b)" + (slog string_of_bool) OpamStd.Option.Op.(depopts +! false) + build + post); let chrono = OpamConsole.timer () in let cudf_packages_map = load_f ?add_invariant ?depopts ~build ~post () in let cudf_universe = map_to_cudf_universe cudf_packages_map in - log ~level:3 "Secondary load of cudf universe: done in %.3fs" (chrono ()); + log ~level:3 (fun fmt -> fmt "Secondary load of cudf universe: done in %.3fs" (chrono ())); cudf_universe let load_cudf_universe_with_packages @@ -436,7 +439,7 @@ let cycle_conflict ~version_map univ cycles = OpamCudf.cycle_conflict ~version_map univ cycles let resolve universe request = - log "resolve request=%a" (slog string_of_request) request; + log (fun fmt -> fmt "resolve request=%a" (slog string_of_request) request); let all_packages = universe.u_available ++ universe.u_installed in let version_map = cudf_versions_map universe in let univ_gen = load_cudf_universe universe ~version_map all_packages in @@ -511,9 +514,10 @@ let dosetrim f = !trimmed_pkgs let coinstallable_subset universe ?(add_invariant=true) set packages = - log "subset of coinstallable with %a within %a" - (slog OpamPackage.Set.to_string) set - (slog OpamPackage.Set.to_string) packages; + log (fun fmt -> + fmt "subset of coinstallable with %a within %a" + (slog OpamPackage.Set.to_string) set + (slog OpamPackage.Set.to_string) packages); let cudf_packages_map = load_cudf_packages ~add_invariant ~build:true ~post:true universe (universe.u_available ++ set ++ packages) () diff --git a/src/solver/opamSolverConfig.ml b/src/solver/opamSolverConfig.ml index 1df6755e121..eba944fa319 100644 --- a/src/solver/opamSolverConfig.ml +++ b/src/solver/opamSolverConfig.ml @@ -250,9 +250,10 @@ let criteria kind = let call_solver ~criteria cudf = let module S = (val Lazy.force (!r.solver)) in - OpamConsole.log "SOLVER" "Calling solver %s with criteria %s" - (OpamCudfSolver.get_name (module S)) criteria; + OpamConsole.log "SOLVER" (fun fmt -> + fmt "Calling solver %s with criteria %s" + (OpamCudfSolver.get_name (module S)) criteria); let chrono = OpamConsole.timer () in let r = S.call ~criteria ?timeout:(!r.solver_timeout) cudf in - OpamConsole.log "SOLVER" "External solver took %.3fs" (chrono ()); + OpamConsole.log "SOLVER" (fun fmt -> fmt "External solver took %.3fs" (chrono ())); r diff --git a/src/state/opamEnv.ml b/src/state/opamEnv.ml index 6922c9df87a..b1ab5687878 100644 --- a/src/state/opamEnv.ml +++ b/src/state/opamEnv.ml @@ -593,7 +593,7 @@ let env_expansion ?opam st upd = let fenv v = try OpamPackageVar.resolve st ?opam v with Not_found -> - log "Undefined variable: %s" (OpamVariable.Full.to_string v); + log (fun fmt -> fmt "Undefined variable: %s" (OpamVariable.Full.to_string v)); None in let s = @@ -769,9 +769,10 @@ let is_up_to_date_raw ?(skip=OpamStateConfig.(!r.no_env_notice)) updates = in let r = not_utd = [] in if not r then - log "Not up-to-date env variables: [%a]" - (slog @@ String.concat " " @* List.map (fun upd -> upd.envu_var)) not_utd - else log "Environment is up-to-date"; + log (fun fmt -> + fmt "Not up-to-date env variables: [%a]" + (slog @@ String.concat " " @* List.map (fun upd -> upd.envu_var)) not_utd) + else log (fun fmt -> fmt "Environment is up-to-date"); r let is_up_to_date_switch root switch = diff --git a/src/state/opamFileTools.ml b/src/state/opamFileTools.ml index c98b9b47792..6f77c5affff 100644 --- a/src/state/opamFileTools.ml +++ b/src/state/opamFileTools.ml @@ -1113,8 +1113,9 @@ let add_aux_files ?dir ~files_subdir_hashes opam = | None, (Some url, None) -> OpamFile.OPAM.with_url url opam | Some opam_url, (Some url, errs) -> if url = opam_url && errs = None then - log "Duplicate definition of url in '%s' and opam file" - (OpamFile.to_string url_file) + log (fun fmt -> + fmt "Duplicate definition of url in '%s' and opam file" + (OpamFile.to_string url_file)) else OpamConsole.warning "File '%s' ignored (conflicting url already specified in the \ @@ -1130,8 +1131,9 @@ let add_aux_files ?dir ~files_subdir_hashes opam = try_read OpamFile.Descr.read_opt descr_file with | None, (Some descr, None) -> OpamFile.OPAM.with_descr descr opam | Some _, (Some _, _) -> - log "Duplicate descr in '%s' and opam file" - (OpamFile.to_string descr_file); + log (fun fmt -> + fmt "Duplicate descr in '%s' and opam file" + (OpamFile.to_string descr_file)); opam | _, (_, Some err) -> OpamFile.OPAM.with_format_errors (err :: opam.format_errors) opam @@ -1149,12 +1151,12 @@ let add_aux_files ?dir ~files_subdir_hashes opam = match OpamFile.OPAM.extra_files opam, extra_files with | None, None -> opam | None, Some ef -> - log ~level:2 - "Missing extra-files field for %a for %a, adding them." - (slog @@ OpamStd.List.concat_map ", " - (fun (_,f) -> OpamFilename.Base.to_string f)) ef - OpamStd.Op.(slog @@ OpamPackage.to_string @* OpamFile.OPAM.package) - opam; + log ~level:2 (fun fmt -> + fmt "Missing extra-files field for %a for %a, adding them." + (slog @@ OpamStd.List.concat_map ", " + (fun (_,f) -> OpamFilename.Base.to_string f)) ef + OpamStd.Op.(slog @@ OpamPackage.to_string @* OpamFile.OPAM.package) + opam); let ef = List.map (fun (file, basename) -> @@ -1164,10 +1166,11 @@ let add_aux_files ?dir ~files_subdir_hashes opam = in OpamFile.OPAM.with_extra_files ef opam | Some ef, None -> - log "Missing expected extra files %s at %s/files" - (OpamStd.List.concat_map ", " - (fun (f,_) -> OpamFilename.Base.to_string f) ef) - (OpamFilename.Dir.to_string dir); + log (fun fmt -> + fmt "Missing expected extra files %s at %s/files" + (OpamStd.List.concat_map ", " + (fun (f,_) -> OpamFilename.Base.to_string f) ef) + (OpamFilename.Dir.to_string dir)); opam | Some oef, Some ef -> let wr_check, nf_opam, rest = @@ -1186,20 +1189,21 @@ let add_aux_files ?dir ~files_subdir_hashes opam = in let nf_file = List.map fst rest in if nf_file <> [] || wr_check <> [] || nf_opam <> [] then - log "Mismatching extra-files at %s: %s" - (OpamFilename.Dir.to_string dir) - ((if nf_file = [] then None else - Some (Printf.sprintf "missing from 'files' directory (%d)" - (List.length nf_file))) - :: (if nf_opam = [] then None else - Some (Printf.sprintf "missing from opam file (%d)" - (List.length nf_opam))) - :: (if wr_check = [] then None else - Some (Printf.sprintf "wrong checksum (%d)" - (List.length wr_check))) - :: [] - |> OpamStd.List.filter_some - |> OpamStd.Format.pretty_list); + log (fun fmt -> + fmt "Mismatching extra-files at %s: %s" + (OpamFilename.Dir.to_string dir) + ((if nf_file = [] then None else + Some (Printf.sprintf "missing from 'files' directory (%d)" + (List.length nf_file))) + :: (if nf_opam = [] then None else + Some (Printf.sprintf "missing from opam file (%d)" + (List.length nf_opam))) + :: (if wr_check = [] then None else + Some (Printf.sprintf "wrong checksum (%d)" + (List.length wr_check))) + :: [] + |> OpamStd.List.filter_some + |> OpamStd.Format.pretty_list)); opam in opam @@ -1231,7 +1235,7 @@ let dep_formula_to_string f = OpamPrinter.FullPos.value (OpamPp.print pp f) let sort_opam opam = - log "sorting %s" (OpamPackage.to_string (package opam)); + log (fun fmt -> fmt "sorting %s" (OpamPackage.to_string (package opam))); let sort_ff = let compare_filters filter filter' = let get_vars = function diff --git a/src/state/opamFormatUpgrade.ml b/src/state/opamFormatUpgrade.ml index 5cab7d60ecd..de55bb4fc97 100644 --- a/src/state/opamFormatUpgrade.ml +++ b/src/state/opamFormatUpgrade.ml @@ -370,7 +370,7 @@ let from_1_0_to_1_1 ~on_the_fly:_ root _config = let v1_2 = OpamVersion.of_string "1.2" let from_1_1_to_1_2 ~on_the_fly:_ root config = - log "Upgrade pinned packages format to 1.2"; + log (fun fmt -> fmt "Upgrade pinned packages format to 1.2"); let aliases = OpamFile.Aliases.safe_read (OpamFile.make (root // "aliases")) in let remove_pinned_suffix d = let s = OpamFilename.Dir.to_string d in @@ -441,7 +441,7 @@ let from_1_1_to_1_2 ~on_the_fly:_ root config = let v1_3_dev2 = OpamVersion.of_string "1.3~dev2" let from_1_2_to_1_3_dev2 ~on_the_fly:_ root config = - log "Upgrade switch state files format to 1.3"; + log (fun fmt -> fmt "Upgrade switch state files format to 1.3"); let aliases = OpamFile.Aliases.safe_read (OpamFile.make (root // "aliases")) in @@ -533,7 +533,7 @@ let from_1_2_to_1_3_dev2 ~on_the_fly:_ root config = let v1_3_dev5 = OpamVersion.of_string "1.3~dev5" let from_1_3_dev2_to_1_3_dev5 ~on_the_fly:_ root conf = - log "Upgrade switch state files format to 1.3 step 2"; + log (fun fmt -> fmt "Upgrade switch state files format to 1.3 step 2"); let aliases_f = OpamFile.make (root // "aliases") in let aliases = OpamFile.Aliases.safe_read aliases_f in OpamSwitch.Map.iter (fun switch comp_name -> @@ -681,7 +681,7 @@ let from_1_3_dev2_to_1_3_dev5 ~on_the_fly:_ root conf = let v1_3_dev6 = OpamVersion.of_string "1.3~dev6" let from_1_3_dev5_to_1_3_dev6 ~on_the_fly:_ root conf = - log "Upgrade switch state files format to 1.3 step 3"; + log (fun fmt -> fmt "Upgrade switch state files format to 1.3 step 3"); (* Move switch internals to [switch/.opam-switch] *) List.iter (fun switch -> let switch_dir = root / OpamSwitch.to_string switch in @@ -704,7 +704,7 @@ let from_1_3_dev5_to_1_3_dev6 ~on_the_fly:_ root conf = let v1_3_dev7 = OpamVersion.of_string "1.3~dev7" let from_1_3_dev6_to_1_3_dev7 ~on_the_fly:_ root conf = - log "Upgrade switch state files format to 1.3 step 4"; + log (fun fmt -> fmt "Upgrade switch state files format to 1.3 step 4"); (* Get mirrors of the metadata of all installed packages into switch_meta_dir/packages *) List.iter (fun switch -> @@ -749,7 +749,7 @@ let from_1_3_dev6_to_1_3_dev7 ~on_the_fly:_ root conf = let v2_0_alpha = OpamVersion.of_string "2.0~alpha" let from_1_3_dev7_to_2_0_alpha ~on_the_fly:_ root conf = - log "Upgrade switch state files format to 2.0~alpha"; + log (fun fmt -> fmt "Upgrade switch state files format to 2.0~alpha"); (* leftovers from previous upgrades *) OpamFilename.rmdir (root / "compilers"); OpamFilename.remove (root / "repo" // "package-index"); @@ -1299,11 +1299,12 @@ let as_necessary ?reinit requested_lock global_lock root config = in if hard_upg = [] && light_upg = [] then config, gtc_none (* no upgrade to do *) else let is_dev = OpamVersion.is_dev_version () in - log "%s config upgrade, from %s to %s" - (if on_the_fly then "On-the-fly" else - if need_hard_upg then "Hard" else "Light") - (OpamVersion.to_string root_version) - (OpamVersion.to_string latest_version); + log (fun fmt -> + fmt "%s config upgrade, from %s to %s" + (if on_the_fly then "On-the-fly" else + if need_hard_upg then "Hard" else "Light") + (OpamVersion.to_string root_version) + (OpamVersion.to_string latest_version)); if not on_the_fly then OpamConsole.errmsg "%s\n" @@ OpamStd.Format.reformat @@ @@ -1339,7 +1340,7 @@ let as_necessary ?reinit requested_lock global_lock root config = OpamStd.Sys.exit_because `Aborted else (let config, changes = light config in - log "Format upgrade done"; + log (fun fmt -> fmt "Format upgrade done"); config, changes) let as_necessary_repo_switch_light_upgrade lock_kind kind gt = @@ -1383,10 +1384,11 @@ let hard_upgrade_from_2_1_intermediates ?reinit ?global_lock root = || OpamVersion.compare v2_1 v <= 0 -> () (* do nothing, need to reraise parsing exception *) | _ -> - log "Intermediate opam root detected%s, launch hard upgrade" - (match opam_root_version with - None -> "" - | Some v -> "("^(OpamVersion.to_string v)^")"); + log (fun fmt -> + fmt "Intermediate opam root detected%s, launch hard upgrade" + (match opam_root_version with + None -> "" + | Some v -> "("^(OpamVersion.to_string v)^")")); let filename = OpamFile.filename config_f in let opamfile = OpamParser.FullPos.file (OpamFilename.to_string filename) in let opamfile' = @@ -1402,7 +1404,7 @@ let hard_upgrade_from_2_1_intermediates ?reinit ?global_lock root = {v with pelem = String "2.0"})} | _ -> item) opamfile.file_contents} in - log "Downgrade config opam-version to fix up"; + log (fun fmt -> fmt "Downgrade config opam-version to fix up"); OpamFilename.write filename (OpamPrinter.FullPos.opamfile opamfile'); let config = OpamFile.Config.read config_f in let global_lock = match global_lock with @@ -1419,10 +1421,11 @@ let opam_file ?(quiet=false) ?filename opam = then ((match filename with | Some f when not quiet -> - log "Internally converting format of %a from %a to %a" - (slog OpamFile.to_string) f - (slog OpamVersion.to_string) v - (slog OpamVersion.to_string) latest_version + log (fun fmt -> + fmt "Internally converting format of %a from %a to %a" + (slog OpamFile.to_string) f + (slog OpamVersion.to_string) v + (slog OpamVersion.to_string) latest_version) | _ -> ()); opam_file_from_1_2_to_2_0 ?filename opam) else opam diff --git a/src/state/opamGlobalState.ml b/src/state/opamGlobalState.ml index 02edf6cd924..8428f323bf4 100644 --- a/src/state/opamGlobalState.ml +++ b/src/state/opamGlobalState.ml @@ -60,7 +60,7 @@ let inferred_from_system = "Inferred from system" let load lock_kind = let root = OpamStateConfig.(!r.root_dir) in - log "LOAD-GLOBAL-STATE %@ %a" (slog OpamFilename.Dir.to_string) root; + log (fun fmt -> fmt "LOAD-GLOBAL-STATE %@ %a" (slog OpamFilename.Dir.to_string) root); (* Always take a global read lock, this is only used to prevent concurrent ~/.opam format changes *) let has_root = OpamFilename.exists_dir root in @@ -83,10 +83,11 @@ let load lock_kind = raise e in if OpamStateConfig.is_newer config && lock_kind <> `Lock_write then - log "root version (%s) is greater than running binary's (%s); \ - load with best-effort (read-only)" - (OpamVersion.to_string (OpamFile.Config.opam_root_version config)) - (OpamVersion.to_string (OpamFile.Config.root_version)); + log (fun fmt -> + fmt "root version (%s) is greater than running binary's (%s); \ + load with best-effort (read-only)" + (OpamVersion.to_string (OpamFile.Config.opam_root_version config)) + (OpamVersion.to_string (OpamFile.Config.root_version))); let switches = List.filter (fun sw -> not (OpamSwitch.is_external sw) || @@ -134,9 +135,10 @@ let load lock_kind = Some (S (OpamStd.String.strip (String.concat "\n" ret))) with e -> OpamStd.Exn.fatal e; - log "Failed to evaluate global variable %a: %a" - (slog OpamVariable.to_string) v - (slog Printexc.to_string) e; + log (fun fmt -> + fmt "Failed to evaluate global variable %a: %a" + (slog OpamVariable.to_string) v + (slog Printexc.to_string) e); Lazy.force (fst previous_value))), doc) (lazy None, "") diff --git a/src/state/opamPinned.ml b/src/state/opamPinned.ml index fac5d8ecd83..02505e77e2b 100644 --- a/src/state/opamPinned.ml +++ b/src/state/opamPinned.ml @@ -45,7 +45,7 @@ let check_locked ?locked default = | None -> default, None | Some (locked, ext) -> if not (OpamFilename.exists locked) then default, None else - (log "Lock file found %s" (OpamFilename.to_string default); + (log (fun fmt -> fmt "Lock file found %s" (OpamFilename.to_string default)); let base_depends = OpamFile.make default |> OpamFile.OPAM.read diff --git a/src/state/opamRepositoryState.ml b/src/state/opamRepositoryState.ml index f3f84343bb5..460f894f011 100644 --- a/src/state/opamRepositoryState.ml +++ b/src/state/opamRepositoryState.ml @@ -77,12 +77,71 @@ module Cache = struct end +module Thread_pool : sig + type t + val create : unit -> t + val async : t -> (unit -> (OpamPackage.t * OpamFile.OPAM.t) option) -> unit + val value : t -> OpamFile.OPAM.t OpamPackage.Map.t +end = struct + type t = { + kill : bool Atomic.t; + threads : unit Domain.t list; + tasks_mutex : Mutex.t; + tasks : (unit -> (OpamPackage.t * OpamFile.OPAM.t) option) Queue.t; + value_mutex : Mutex.t; + value : OpamFile.OPAM.t OpamPackage.Map.t ref; + } + + let create () = + let kill = Atomic.make false in + let tasks_mutex = Mutex.create () in + let tasks = Queue.create () in + let value_mutex = Mutex.create () in + let value = ref OpamPackage.Map.empty in + let aux () = + Domain.spawn (fun () -> + while not (Atomic.get kill && Mutex.protect tasks_mutex (fun () -> Queue.is_empty tasks)) do + Mutex.protect tasks_mutex (fun () -> + Queue.take_opt tasks + ) |> + Option.iter (fun task -> + Option.iter (fun (k, v) -> + Mutex.protect value_mutex (fun () -> + value := OpamPackage.Map.add k v !value; + ) + ) (task ()) + ) + done + ) + in + let max_jobs = Int.max (Domain.recommended_domain_count () - 1) 1 in + log (fun fmt -> fmt "Spawning %d threads" max_jobs); + let threads = List.init max_jobs (fun _ -> aux ()) in + {kill; threads; tasks_mutex; tasks; value_mutex; value} + + let async {tasks_mutex; tasks; _} f = + Mutex.protect tasks_mutex (fun () -> + Queue.add f tasks; + ) + + let value {kill; threads; value_mutex; value; _} = + log (fun fmt -> fmt "Getting all the values..."); + Atomic.set kill true; + List.iter Domain.join threads; + Mutex.protect value_mutex (fun () -> + log (fun fmt -> fmt "Got %d values" (OpamPackage.Map.cardinal !value)); + !value + ) +end + let load_opams_from_dir repo_name repo_root = + let thread_pool = Thread_pool.create () in (* FIXME: why is this different from OpamPackage.list ? *) - let rec aux r dir = + let rec aux dir = if OpamFilename.exists_dir dir then let fnames = Sys.readdir (OpamFilename.Dir.to_string dir) in if Array.exists (fun f -> f = "opam") fnames then + Thread_pool.async thread_pool @@ fun () -> match OpamFileTools.read_repo_opam ~repo_name ~repo_root dir with | Some opam -> (try @@ -90,21 +149,23 @@ let load_opams_from_dir repo_name repo_root = OpamPackage.of_string OpamFilename.(Base.to_string (basename_dir dir)) in - OpamPackage.Map.add nv opam r + Some (nv, opam) with Failure _ -> - log "ERR: directory name not a valid package: ignored %s" - OpamFilename.(to_string Op.(dir // "opam")); - r) + log (fun fmt -> + fmt "ERR: directory name not a valid package: ignored %s" + OpamFilename.(to_string Op.(dir // "opam"))); + None) | None -> - log "ERR: Could not load %s, ignored" - OpamFilename.(to_string Op.(dir // "opam")); - r + log (fun fmt -> + fmt "ERR: Could not load %s, ignored" + OpamFilename.(to_string Op.(dir // "opam"))); + None else - Array.fold_left (fun r name -> aux r OpamFilename.Op.(dir / name)) - r fnames - else r + Array.iter (fun name -> aux OpamFilename.Op.(dir / name)) fnames + else () in - aux OpamPackage.Map.empty (OpamRepositoryPath.packages_dir repo_root) + aux (OpamRepositoryPath.packages_dir repo_root); + Thread_pool.value thread_pool let load_repo repo repo_root = let t = OpamConsole.timer () in @@ -113,9 +174,10 @@ let load_repo repo repo_root = |> OpamFile.Repo.with_root_url repo.repo_url in let opams = load_opams_from_dir repo.repo_name repo_root in - log "loaded opam files from repo %s in %.3fs" - (OpamRepositoryName.to_string repo.repo_name) - (t ()); + log (fun fmt -> + fmt "loaded opam files from repo %s in %.3fs" + (OpamRepositoryName.to_string repo.repo_name) + (t ())); repo_def, opams (* Cleaning directories follows the repo path pattern: @@ -151,14 +213,15 @@ let get_repo_root rt repo = let load lock_kind gt = OpamFormatUpgrade.as_necessary_repo_switch_light_upgrade lock_kind `Repo gt; - log "LOAD-REPOSITORY-STATE %@ %a" (slog OpamFilename.Dir.to_string) gt.root; + log (fun fmt -> fmt "LOAD-REPOSITORY-STATE %@ %a" (slog OpamFilename.Dir.to_string) gt.root); let lock = OpamFilename.flock lock_kind (OpamPath.repos_lock gt.root) in let repos_map = OpamStateConfig.Repos.safe_read ~lock_kind gt in if OpamStateConfig.is_newer_than_self gt then - log "root version (%s) is greater than running binary's (%s); \ - load with best-effort (read-only)" - (OpamVersion.to_string (OpamFile.Config.opam_root_version gt.config)) - (OpamVersion.to_string (OpamFile.Config.root_version)); + log (fun fmt -> + fmt "root version (%s) is greater than running binary's (%s); \ + load with best-effort (read-only)" + (OpamVersion.to_string (OpamFile.Config.opam_root_version gt.config)) + (OpamVersion.to_string (OpamFile.Config.root_version))); let mk_repo name url_opt = { repo_name = name; repo_url = OpamStd.Option.Op.((url_opt >>| fst) +! OpamUrl.empty); @@ -207,10 +270,10 @@ let load lock_kind gt = in match Cache.load gt.root with | Some (repofiles, opams) when OpamRepositoryName.Map.is_empty uncached -> - log "Cache found"; + log (fun fmt -> fmt "Cache found"); make_rt repofiles opams | Some (repofiles, opams) -> - log "Cache found, loading repositories without remote only"; + log (fun fmt -> fmt "Cache found, loading repositories without remote only"); OpamFilename.with_flock_upgrade `Lock_read lock @@ fun _ -> let repofiles, opams = OpamRepositoryName.Map.fold (fun name url (defs, opams) -> @@ -224,7 +287,7 @@ let load lock_kind gt = in make_rt repofiles opams | None -> - log "No cache found"; + log (fun fmt -> fmt "No cache found"); OpamFilename.with_flock_upgrade `Lock_read lock @@ fun _ -> let repofiles, opams = OpamRepositoryName.Map.fold (fun name url (defs, opams) -> @@ -307,4 +370,3 @@ let check_last_update () = OpamConsole.note "It seems you have not updated your repositories \ for a while. Consider updating them with:\n%s\n" (OpamConsole.colorise `bold "opam update"); - diff --git a/src/state/opamSwitchAction.ml b/src/state/opamSwitchAction.ml index be5d5018beb..5017fca72b1 100644 --- a/src/state/opamSwitchAction.ml +++ b/src/state/opamSwitchAction.ml @@ -42,13 +42,13 @@ let gen_switch_config } let install_switch_config root switch config = - log "install_switch_config switch=%a" (slog OpamSwitch.to_string) switch; + log (fun fmt -> fmt "install_switch_config switch=%a" (slog OpamSwitch.to_string) switch); OpamFile.Switch_config.write (OpamPath.Switch.switch_config root switch) config let create_empty_switch gt ?synopsis ?repos ?invariant switch = - log "create_empty_switch at %a" (slog OpamSwitch.to_string) switch; + log (fun fmt -> fmt "create_empty_switch at %a" (slog OpamSwitch.to_string) switch); let root = gt.root in let switch_dir = OpamPath.Switch.root root switch in @@ -98,8 +98,9 @@ let write_selections st = OpamFile.Environment.write env (OpamEnv.compute_updates st) let add_to_reinstall st ~unpinned_only packages = - log "add-to-reinstall unpinned_only:%b packages:%a" unpinned_only - (slog OpamPackage.Set.to_string) packages; + log (fun fmt -> + fmt "add-to-reinstall unpinned_only:%b packages:%a" unpinned_only + (slog OpamPackage.Set.to_string) packages); let root = st.switch_global.root in let packages = if unpinned_only then diff --git a/src/state/opamSwitchState.ml b/src/state/opamSwitchState.ml index 1f1649062b2..88e398d487b 100644 --- a/src/state/opamSwitchState.ml +++ b/src/state/opamSwitchState.ml @@ -69,10 +69,11 @@ let repos_list_raw rt switch_config = repos in List.iter (fun r -> - log "Ignoring %s-selected repository %S, no configured repository by \ - this name found" - (if global then "globally" else "switch") - (OpamRepositoryName.to_string r)) + log (fun fmt -> + fmt "Ignoring %s-selected repository %S, no configured repository by \ + this name found" + (if global then "globally" else "switch") + (OpamRepositoryName.to_string r))) notfound; found @@ -219,7 +220,7 @@ let depexts_status_of_packages_raw msg; OpamPackage.Map.empty in - log "depexts loaded in %.3fs" (chronos()); + log (fun fmt -> fmt "depexts loaded in %.3fs" (chronos())); ret let depexts_unavailable_raw sys_packages nv = @@ -232,11 +233,12 @@ let depexts_unavailable_raw sys_packages nv = let load lock_kind gt rt switch = OpamFormatUpgrade.as_necessary_repo_switch_light_upgrade lock_kind `Switch gt; let chrono = OpamConsole.timer () in - log "LOAD-SWITCH-STATE %@ %a" (slog OpamSwitch.to_string) switch; + log (fun fmt -> fmt "LOAD-SWITCH-STATE %@ %a" (slog OpamSwitch.to_string) switch); if not (OpamGlobalState.switch_exists gt switch) then - (log "The switch %a does not appear to be installed according to %a" - (slog OpamSwitch.to_string) switch - (slog @@ OpamFile.to_string @* OpamPath.config) gt.root; + (log (fun fmt -> + fmt "The switch %a does not appear to be installed according to %a" + (slog OpamSwitch.to_string) switch + (slog @@ OpamFile.to_string @* OpamPath.config) gt.root); OpamConsole.error_and_exit (if OpamStateConfig.(!r.switch_from = `Command_line) then `Bad_arguments @@ -258,10 +260,11 @@ let load lock_kind gt rt switch = in let switch_config = load_switch_config ~lock_kind gt switch in if OpamStateConfig.is_newer_than_self gt then - log "root version (%s) is greater than running binary's (%s); \ - load with best-effort (read-only)" - (OpamVersion.to_string (OpamFile.Config.opam_root_version gt.config)) - (OpamVersion.to_string (OpamFile.Config.root_version)); + log (fun fmt -> + fmt "root version (%s) is greater than running binary's (%s); \ + load with best-effort (read-only)" + (OpamVersion.to_string (OpamFile.Config.opam_root_version gt.config)) + (OpamVersion.to_string (OpamFile.Config.root_version))); if OpamVersion.compare switch_config.opam_version OpamFile.Switch_config.oldest_compatible_format_version @@ -289,12 +292,13 @@ let load lock_kind gt rt switch = let version = match OpamFile.OPAM.version_opt o with | Some v when v <> nv.version -> - log "warn: %s has conflicting pinning versions between \ - switch-state (%s) and overlay (%s). Using %s." - (OpamPackage.Name.to_string nv.name) - (OpamPackage.Version.to_string nv.version) - (OpamPackage.Version.to_string v) - (OpamPackage.Version.to_string v); + log (fun fmt -> + fmt "warn: %s has conflicting pinning versions between \ + switch-state (%s) and overlay (%s). Using %s." + (OpamPackage.Name.to_string nv.name) + (OpamPackage.Version.to_string nv.version) + (OpamPackage.Version.to_string v) + (OpamPackage.Version.to_string v)); v | _ -> nv.version in @@ -353,9 +357,10 @@ let load lock_kind gt rt switch = try let o = OpamPackage.Map.find nv opams in if lock_kind = `Lock_write then (* auto-repair *) - (log "Definition missing for installed package %s, \ - copying from repo" - (OpamPackage.to_string nv); + (log (fun fmt -> + fmt "Definition missing for installed package %s, \ + copying from repo" + (OpamPackage.to_string nv)); OpamFile.OPAM.write (OpamPath.Switch.installed_opam gt.root switch nv) o); nodef @@ -380,8 +385,9 @@ let load lock_kind gt rt switch = opams installed_opams |> OpamPackage.keys in - log "Detected changed packages (marked for reinstall): %a" - (slog OpamPackage.Set.to_string) changed; + log (fun fmt -> + fmt "Detected changed packages (marked for reinstall): %a" + (slog OpamPackage.Set.to_string) changed); changed ) in let switch_config, switch_invariant = @@ -398,11 +404,12 @@ let load lock_kind gt rt switch = gt switch switch_config opams packages compiler_packages installed_roots available_packages in - log "Inferred invariant: from base packages %a, (roots %a) => %a" - (slog OpamPackage.Set.to_string) compiler_packages - (slog @@ fun () -> - OpamPackage.Set.to_string (compiler_packages %% installed_roots)) () - (slog OpamFileTools.dep_formula_to_string) invariant; + log (fun fmt -> + fmt "Inferred invariant: from base packages %a, (roots %a) => %a" + (slog OpamPackage.Set.to_string) compiler_packages + (slog @@ fun () -> + OpamPackage.Set.to_string (compiler_packages %% installed_roots)) () + (slog OpamFileTools.dep_formula_to_string) invariant); let min_opam_version = OpamVersion.of_string "2.0" in let opam_version = if OpamVersion.compare switch_config.opam_version min_opam_version < 0 @@ -588,7 +595,7 @@ let load lock_kind gt rt switch = let available_packages = lazy ( let chrono = OpamConsole.timer () in let r = Lazy.force available_packages in - log ~level:2 "Availability of packages computed in %.3fs." (chrono ()); + log ~level:2 (fun fmt -> fmt "Availability of packages computed in %.3fs." (chrono ())); r ) in let reinstall = lazy ( @@ -613,7 +620,7 @@ let load lock_kind gt rt switch = opams; conf_files; packages; available_packages; sys_packages; reinstall; invalidated; } in - log "Switch state loaded in %.3fs" (chrono ()); + log (fun fmt -> fmt "Switch state loaded in %.3fs" (chrono ())); st let load_virtual ?repos_list ?(avail_default=true) gt rt = @@ -903,10 +910,11 @@ let package_env_t st ~force_dev_deps ~test ~doc ~dev_setup (if OpamFormatConfig.(!r.strict) then OpamConsole.error_and_exit `File_error "Undefined filter variable %s in dependencies of %s" + (OpamVariable.Full.to_string v) (OpamPackage.to_string nv) else - log - "ERR: Undefined filter variable %s in dependencies of %s") - (OpamVariable.Full.to_string v) (OpamPackage.to_string nv); + log (fun fmt -> + fmt "ERR: Undefined filter variable %s in dependencies of %s" + (OpamVariable.Full.to_string v) (OpamPackage.to_string nv))); r let get_dependencies_t st ~force_dev_deps ~test ~doc ~dev_setup @@ -1037,7 +1045,7 @@ let universe st "avoid-version", avoid_versions]; } in - log ~level:2 "Universe load: %.3fs" (chrono ()); + log ~level:2 (fun fmt -> fmt "Universe load: %.3fs" (chrono ())); u let dump_pef_state st oc = @@ -1341,8 +1349,9 @@ let dependencies_t st base_deps_compute deps_compute else if unavailable then st.packages else Lazy.force st.available_packages in - log ~level:3 "dependencies packages=%a" - (slog OpamPackage.Set.to_string) packages; + log ~level:3 (fun fmt -> + fmt "dependencies packages=%a" + (slog OpamPackage.Set.to_string) packages); let timer = OpamConsole.timer () in let base_depends = let filter = base_deps_compute base in @@ -1371,8 +1380,9 @@ let dependencies_t st base_deps_compute deps_compute depends in let result = deps_compute base base_depends packages in - log "dependencies (%.3f) result=%a" (timer ()) - (slog OpamPackage.Set.to_string) result; + log (fun fmt -> + fmt "dependencies (%.3f) result=%a" (timer ()) + (slog OpamPackage.Set.to_string) result); result let dependencies st ~build ~post = diff --git a/src/state/opamSysInteract.ml b/src/state/opamSysInteract.ml index 9d48d0f62d3..8d048deda3b 100644 --- a/src/state/opamSysInteract.ml +++ b/src/state/opamSysInteract.ml @@ -52,12 +52,14 @@ let run_command let str_var (v,c) = Printf.sprintf "%s=%s" v c in if set_vars = [] then ((if kept_vars <> [] then - log "Won't override %s" - (OpamStd.List.to_string str_var (kept_vars :> (string * string) list))); + log (fun fmt -> + fmt "Won't override %s" + (OpamStd.List.to_string str_var (kept_vars :> (string * string) list)))); None) else - (log "Adding to env %s" - (OpamStd.List.to_string str_var (set_vars :> (string * string) list)); + (log (fun fmt -> + fmt "Adding to env %s" + (OpamStd.List.to_string str_var (set_vars :> (string * string) list))); Some ((set_vars @ env :> (string * string) list) |> List.rev_map str_var |> Array.of_list)) @@ -396,12 +398,13 @@ module Cygwin = struct if OpamFilename.exists dst then () else (match setup with | Some setup -> - log "Copying %s into %s" - (OpamFilename.to_string setup) - (OpamFilename.to_string dst); + log (fun fmt -> + fmt "Copying %s into %s" + (OpamFilename.to_string setup) + (OpamFilename.to_string dst)); OpamFilename.copy ~src:setup ~dst | None -> - log "Donwloading setup exe"; + log (fun fmt -> fmt "Donwloading setup exe"); OpamProcess.Job.run @@ download_setupexe dst) end @@ -1058,7 +1061,7 @@ let sudo_run_command ?(env=OpamVariable.Map.empty) ?vars cmd args = let install ?env config packages = if OpamSysPkg.Set.is_empty packages then - log "Nothing to install" + log (fun fmt -> fmt "Nothing to install") else let commands, vars = install_packages_commands_t ?env config packages in let vars = OpamStd.Option.map (List.map (fun x -> `add, x)) vars in diff --git a/src/state/opamUpdate.ml b/src/state/opamUpdate.ml index 515a8d06454..c98462a0dfb 100644 --- a/src/state/opamUpdate.ml +++ b/src/state/opamUpdate.ml @@ -97,10 +97,10 @@ let repository rt repo = (OpamUrl.to_string repo.repo_url); match has_changes with | `No_changes -> - log "Repository did not change: nothing to do."; + log (fun fmt -> fmt "Repository did not change: nothing to do."); Done None | `Changes -> - log "Repository has new changes"; + log (fun fmt -> fmt "Repository has new changes"); let repo_file = OpamFile.Repo.safe_read repo_file_path in let repo_file = OpamFile.Repo.with_root_url repo.repo_url repo_file in let repo_vers = @@ -201,7 +201,7 @@ let fetch_dev_package url srcdir ?(working_dir=false) ?subpath nv = let remote_url = OpamFile.URL.url url in let mirrors = remote_url :: OpamFile.URL.mirrors url in let checksum = OpamFile.URL.checksum url in - log "updating %a" (slog (OpamUrl.to_string_w_subpath subpath)) remote_url; + log (fun fmt -> fmt "updating %a" (slog (OpamUrl.to_string_w_subpath subpath)) remote_url); (* (slog (OpamStd.Option.to_string OpamFilename.SubPath.pretty_string)) subpath; @@ -212,8 +212,9 @@ let fetch_dev_package url srcdir ?(working_dir=false) ?subpath nv = @@| OpamRepository.report_fetch_result nv let pinned_package st ?version ?(autolock=false) ?(working_dir=false) name = - log "update-pinned-package %s%a" (OpamPackage.Name.to_string name) - (slog @@ function true -> " (working dir)" | false -> "") working_dir; + log (fun fmt -> + fmt "update-pinned-package %s%a" (OpamPackage.Name.to_string name) + (slog @@ function true -> " (working dir)" | false -> "") working_dir); let open OpamStd.Option.Op in let root = st.switch_global.root in let overlay_dir = OpamPath.Switch.Overlay.package root st.switch name in @@ -367,8 +368,9 @@ let pinned_package st ?version ?(autolock=false) ?(working_dir=false) name = | Result _, Some new_opam when changed_opam old_source_opam new_source_opam && changed_opam overlay_opam new_source_opam -> - log "Metadata from the package source of %s changed" - (OpamPackage.to_string nv); + log (fun fmt -> + fmt "Metadata from the package source of %s changed" + (OpamPackage.to_string nv)); let interactive_part st = if not (changed_opam old_source_opam overlay_opam) || not (changed_opam repo_opam overlay_opam) @@ -416,7 +418,7 @@ let pinned_package st ?version ?(autolock=false) ?(working_dir=false) name = Done ((fun st -> st), true) let dev_package st ?autolock ?working_dir nv = - log "update-dev-package %a" (slog OpamPackage.to_string) nv; + log (fun fmt -> fmt "update-dev-package %a" (slog OpamPackage.to_string) nv); if OpamSwitchState.is_pinned st nv.name && not (OpamSwitchState.is_version_pinned st nv.name) then pinned_package st ?autolock ~version:nv.version ?working_dir nv.name @@ -433,7 +435,7 @@ let dev_package st ?autolock ?working_dir nv = (fun st -> st), match result with Result () -> true | _ -> false let dev_packages st ?autolock ?(working_dir=OpamPackage.Set.empty) packages = - log "update-dev-packages"; + log (fun fmt -> fmt "update-dev-packages"); let command nv = let working_dir = OpamPackage.Set.mem nv working_dir in OpamProcess.Job.ignore_errors @@ -471,7 +473,7 @@ let dev_packages st ?autolock ?(working_dir=OpamPackage.Set.empty) packages = success, st, updated_set let pinned_packages st ?autolock ?(working_dir=OpamPackage.Name.Set.empty) names = - log "update-pinned-packages"; + log (fun fmt -> fmt "update-pinned-packages"); let command name = let working_dir = OpamPackage.Name.Set.mem name working_dir in OpamProcess.Job.ignore_errors diff --git a/src_ext/Makefile b/src_ext/Makefile index 9149517c4a7..d06ee425170 100644 --- a/src_ext/Makefile +++ b/src_ext/Makefile @@ -11,8 +11,8 @@ endif PATCH ?= patch -URL_ocaml = https://caml.inria.fr/pub/distrib/ocaml-4.14/ocaml-4.14.1.tar.gz -MD5_ocaml = c45b013a233c9a4b80c3930d723d19dd +URL_ocaml = https://caml.inria.fr/pub/distrib/ocaml-5.2/ocaml-5.2.0.tar.gz +MD5_ocaml = 17b0e3d4eec32c8960fd0e1e6a7ec672 URL_flexdll = https://github.com/ocaml/flexdll/archive/0.43.tar.gz MD5_flexdll = 6ce706f6c65b2c5adf5791fac678f090 @@ -32,7 +32,7 @@ URL_PKG_$(1) = $(URL_$(1)) MD5_PKG_$(1) = $(MD5_$(1)) endef -SRC_EXTS = cppo base64 extlib re cmdliner ocamlgraph cudf dose3 opam-file-format seq stdlib-shims spdx_licenses opam-0install-cudf 0install-solver uutf jsonm sha swhid_core +SRC_EXTS = cppo base64 extlib re cmdliner ocamlgraph cudf dose3 opam-file-format seq stdlib-shims spdx_licenses opam-0install-cudf 0install-solver uutf jsonm sha swhid_core menhir PKG_EXTS = $(SRC_EXTS) dune-local findlib ocamlbuild topkg mccs ifeq ($(MCCS_ENABLED),true) diff --git a/src_ext/Makefile.sources b/src_ext/Makefile.sources index 7c343e325ef..1a81c74015b 100644 --- a/src_ext/Makefile.sources +++ b/src_ext/Makefile.sources @@ -53,8 +53,8 @@ MD5_0install-solver = 030edc9b1d3676c06d51397ffb5a737d $(call PKG_SAME,0install-solver) -URL_opam-file-format = https://github.com/ocaml/opam-file-format/archive/refs/tags/2.1.6.tar.gz -MD5_opam-file-format = 706ce5fc3e77db746a4c8b11d79cefef +URL_opam-file-format = https://github.com/kit-ty-kate/opam-file-format/archive/menhir.tar.gz +MD5_opam-file-format = ee0ae73225e3f96d1dd39b18fb1c1730 $(call PKG_SAME,opam-file-format) @@ -105,3 +105,6 @@ URL_swhid_core = https://github.com/OCamlPro/swhid_core/archive/refs/tags/0.1.ta MD5_swhid_core = 77d88d4b1d96261c866f140c64d89af8 $(call PKG_SAME,swhid_core) + +URL_menhir = https://gitlab.inria.fr/fpottier/menhir/-/archive/20231231/archive.tar.gz +MD5_menhir = 799748bc3b7a542798a85956c7863865