opamHg.ml1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161(**************************************************************************) (* *) (* Copyright 2012-2019 OCamlPro *) (* Copyright 2012 INRIA *) (* *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1, with the special *) (* exception on linking described in the file LICENSE. *) (* *) (**************************************************************************) open OpamFilename.Op open OpamProcess.Job.Op module VCS = struct let name = `hg let mark_prefix = "opam-mark" let exists repo_root = OpamFilename.exists_dir (repo_root / ".hg") let hg repo_root = let dir = OpamFilename.Dir.to_string repo_root in fun ?verbose ?env ?stdout args -> OpamSystem.make_command ~dir ?verbose ?env ?stdout "hg" args let init repo_root _repo_url = OpamFilename.mkdir repo_root; hg repo_root [ "init" ] @@> fun r -> OpamSystem.raise_on_process_error r; Done () let mark_from_url url = match url.OpamUrl.hash with | None -> mark_prefix | Some fragment -> mark_prefix ^ "-" ^ fragment let fetch ?cache_dir:_ ?subpath:_ repo_root repo_url = let src = OpamUrl.base_url repo_url in let rev = OpamStd.Option.default "default" repo_url.OpamUrl.hash in let mark = mark_from_url repo_url in hg repo_root [ "pull"; "--rev"; rev; src ] @@> fun r -> OpamSystem.raise_on_process_error r; hg repo_root [ "bookmark"; "--force"; "--rev"; rev; mark ] @@> fun r -> OpamSystem.raise_on_process_error r; Done () let revision repo_root = hg repo_root [ "identify"; "--id" ] @@> fun r -> OpamSystem.raise_on_process_error r; match r.OpamProcess.r_stdout with | [] -> Done None | full::_ -> if String.length full > 8 then Done (Some (String.sub full 0 8)) else Done (Some full) let reset_tree repo_root repo_url = let mark = mark_from_url repo_url in hg repo_root [ "update"; "--clean"; "--rev"; mark ] @@> fun r -> OpamSystem.raise_on_process_error r; Done () let patch_applied = reset_tree let diff repo_root repo_url = let patch_file = OpamSystem.temp_file ~auto_clean:false "hg-diff" in let finalise () = OpamSystem.remove_file patch_file in OpamProcess.Job.catch (fun e -> finalise (); raise e) @@ fun () -> let mark = mark_from_url repo_url in hg repo_root ~stdout:patch_file [ "diff"; "--text"; "--subrepos"; "--reverse"; "--rev"; mark ] @@> fun r -> if OpamProcess.is_failure r then (finalise (); OpamSystem.internal_error "Hg error: '%s' not found." mark) else if OpamSystem.file_is_empty patch_file then (finalise (); Done None) else Done (Some (OpamFilename.of_string patch_file)) let is_up_to_date repo_root repo_url = let mark = mark_from_url repo_url in hg repo_root [ "status"; "--subrepos"; "--rev"; mark ] @@> fun r -> OpamSystem.raise_on_process_error r; Done (r.OpamProcess.r_stdout = []) let versioned_files repo_root = hg repo_root [ "locate" ] @@> fun r -> OpamSystem.raise_on_process_error r; Done r.OpamProcess.r_stdout let vc_dir repo_root = OpamFilename.Op.(repo_root / ".hg") let current_branch repo_root = hg repo_root [ "identify"; "--bookmarks" ] @@> fun r -> OpamSystem.raise_on_process_error r; match r.OpamProcess.r_stdout with | [] -> Done None | marks::_ -> let marks = OpamStd.String.split marks ' ' in let marks = List.filter (OpamStd.String.starts_with ~prefix:mark_prefix) marks in match marks with | mark::_ -> Done (Some mark) | [] -> hg repo_root [ "identify"; "--branch" ] @@> fun r -> OpamSystem.raise_on_process_error r; match r.OpamProcess.r_stdout with | branch::_ when branch <> "default" -> Done (Some branch) | _ -> Done None let is_dirty ?subpath:_ repo_root = hg repo_root [ "status"; "--subrepos" ] @@> fun r -> OpamSystem.raise_on_process_error r; Done (r.OpamProcess.r_stdout = []) let modified_files repo_root = hg repo_root [ "status"; "--subrepos" ] @@> fun r -> OpamSystem.raise_on_process_error r; let files = OpamStd.List.filter_map (fun line -> match OpamStd.String.split line ' ' with | ("A" | "M")::file::[] -> Some file | _ -> None) r.OpamProcess.r_stdout in Done files let get_remote_url ?hash repo_root = hg repo_root [ "paths"; "default" ] @@> function | { OpamProcess.r_code = 0; _ } as r -> (match r.r_stdout with | [url] -> (let url = OpamUrl.parse ~backend:`hg url in if OpamUrl.local_dir url <> None then Done None else let check_remote hash = hg repo_root [ "id"; "-r"; hash; "default" ] @@> fun r -> if OpamProcess.is_success r then Done (Some { url with hash = Some hash }) (* default branch of hg is default *) else Done (Some { url with hash = None}) in match hash with | None -> (hg repo_root ["branch"] @@> function | { OpamProcess.r_code = 0; OpamProcess.r_stdout = [hash]; _ } -> check_remote hash | { OpamProcess.r_code = 0; _ } | { OpamProcess.r_code = 1; _ } -> Done (Some url) | r -> OpamSystem.process_error r) | Some hash -> check_remote hash) | _ -> Done None) | { OpamProcess.r_code = 1; _ } -> Done None | r -> OpamSystem.process_error r end module B = OpamVCS.Make(VCS)