Do not use opam-installer to copy files (#941)

Instead of calling opam-installer, manually parse .install files and copy the files.

Signed-off-by: Jeremie Dimino <jeremie@dimino.org>
This commit is contained in:
Jérémie Dimino 2018-07-03 10:10:09 +01:00 committed by GitHub
parent 51c9b207b1
commit e56fba9a57
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
11 changed files with 303 additions and 88 deletions

View File

@ -106,6 +106,8 @@ next
- Add `%{profile}` variable. (#938, @rgrinberg)
- Do not require opam-installer anymore (#941, @diml)
1.0+beta20 (10/04/2018)
-----------------------

View File

@ -1053,16 +1053,6 @@ let rules =
& Arg.info [] ~docv:"TARGET"))
, Term.info "rules" ~doc ~man)
let opam_installer () =
match Bin.which "opam-installer" with
| None ->
die "\
Sorry, you need the opam-installer tool to be able to install or
uninstall packages.
I couldn't find the opam-installer binary :-("
| Some fn -> fn
let get_prefix context ~from_command_line =
match from_command_line with
| Some p -> Fiber.return (Path.of_string p)
@ -1073,6 +1063,16 @@ let get_libdir context ~libdir_from_command_line =
| Some p -> Fiber.return (Some (Path.of_string p))
| None -> Context.install_ocaml_libdir context
let print_unix_error f =
try
f ()
with Unix.Unix_error (e, _, _) ->
Format.eprintf "@{<error>Error@}: %s@."
(Unix.error_message e)
let set_executable_bits x = x lor 0o111
let clear_executable_bits x = x land (lnot 0o111)
let install_uninstall ~what =
let doc =
sprintf "%s packages using opam-installer." (String.capitalize what)
@ -1080,7 +1080,6 @@ let install_uninstall ~what =
let name_ = Arg.info [] ~docv:"PACKAGE" in
let go common prefix_from_command_line libdir_from_command_line pkgs =
set_common common ~targets:[];
let opam_installer = opam_installer () in
let log = Log.create common in
Scheduler.go ~log ~common
(Main.setup ~log common >>= fun setup ->
@ -1095,7 +1094,7 @@ let install_uninstall ~what =
List.map setup.contexts ~f:(fun ctx ->
let fn = Path.append ctx.Context.build_dir fn in
if Path.exists fn then
Left (ctx, fn)
Left (ctx, (pkg, fn))
else
Right fn))
|> List.partition_map ~f:(fun x -> x)
@ -1121,23 +1120,57 @@ let install_uninstall ~what =
in
Fiber.parallel_iter install_files_by_context
~f:(fun (context, install_files) ->
let install_files_set = Path.Set.of_list install_files in
get_prefix context ~from_command_line:prefix_from_command_line
>>= fun prefix ->
get_libdir context ~libdir_from_command_line
>>= fun libdir ->
Fiber.parallel_iter install_files ~f:(fun path ->
let purpose = Process.Build_job install_files_set in
Process.run ~purpose ~env:setup.env Strict opam_installer
([ sprintf "-%c" what.[0]
; Path.to_string path
; "--prefix"
; Path.to_string prefix
] @
match libdir with
| None -> []
| Some p -> [ "--libdir"; Path.to_string p ]
))))
>>| fun libdir ->
List.iter install_files ~f:(fun (package, path) ->
let entries = Install.load_install_file path in
let paths =
Install.Section.Paths.make
~package
~destdir:prefix
?libdir
()
in
let files_deleted_in = ref Path.Set.empty in
List.iter entries ~f:(fun { Install.Entry. src; dst; section } ->
let src = src in
let dst = Option.value dst ~default:(Path.basename src) in
let dst =
Path.relative (Install.Section.Paths.get paths section) dst
in
let dir = Path.parent_exn dst in
if what = "install" then begin
Printf.eprintf "Installing %s\n%!"
(Path.to_string_maybe_quoted dst);
Path.mkdir_p dir;
Io.copy_file () ~src ~dst
~chmod:(
if Install.Section.should_set_executable_bit section then
set_executable_bits
else
clear_executable_bits)
end else begin
if Path.exists dst then begin
Printf.eprintf "Deleting %s\n%!"
(Path.to_string_maybe_quoted dst);
print_unix_error (fun () -> Path.unlink dst)
end;
files_deleted_in := Path.Set.add !files_deleted_in dir;
end;
Path.Set.to_list !files_deleted_in
(* This [List.rev] is to ensure we process children
directories before their parents *)
|> List.rev
|> List.iter ~f:(fun dir ->
if Path.exists dir then
match Path.readdir_unsorted dir with
| [] ->
Printf.eprintf "Deleting empty directory %s\n%!"
(Path.to_string_maybe_quoted dst);
print_unix_error (fun () -> Path.rmdir dir)
| _ -> ())))))
in
( Term.(const go
$ common

View File

@ -637,7 +637,7 @@ module Promotion = struct
Format.eprintf "Promoting %s to %s.@."
(Path.to_string_maybe_quoted src)
(Path.to_string_maybe_quoted dst);
Io.copy_file ~src ~dst
Io.copy_file ~src ~dst ()
end
module P = Utils.Persistent(struct
@ -785,11 +785,11 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to =
Io.copy_channels ic oc);
Fiber.return ()
| Copy (src, dst) ->
Io.copy_file ~src ~dst;
Io.copy_file ~src ~dst ();
Fiber.return ()
| Symlink (src, dst) ->
if Sys.win32 then
Io.copy_file ~src ~dst
Io.copy_file ~src ~dst ()
else begin
let src =
match Path.parent dst with

View File

@ -826,7 +826,7 @@ let rec compile_rule t ?(copy_source=false) pre_rule =
Utils.Cached_digest.file in_source_tree) then begin
if mode = Promote_but_delete_on_clean then
Promoted_to_delete.add in_source_tree;
Io.copy_file ~src:path ~dst:in_source_tree
Io.copy_file ~src:path ~dst:in_source_tree ()
end)
end;
t.hook Rule_completed

View File

@ -31,6 +31,21 @@ module Section = struct
| Man -> "man"
| Misc -> "misc"
let of_string = function
| "lib" -> Some Lib
| "libexec" -> Some Libexec
| "bin" -> Some Bin
| "sbin" -> Some Sbin
| "toplevel" -> Some Toplevel
| "share" -> Some Share
| "share_root" -> Some Share_root
| "etc" -> Some Etc
| "doc" -> Some Doc
| "stublibs" -> Some Stublibs
| "man" -> Some Man
| "misc" -> Some Misc
| _ -> None
let t =
let open Sexp.Of_sexp in
enum
@ -48,35 +63,65 @@ module Section = struct
; "misc" , Misc
]
module Paths = struct
let lib = Path.in_source "lib"
let libexec = Path.in_source "lib"
let bin = Path.in_source "bin"
let sbin = Path.in_source "sbin"
let toplevel = Path.in_source "lib/toplevel"
let share = Path.in_source "share"
let share_root = Path.in_source "share_root"
let etc = Path.in_source "etc"
let doc = Path.in_source "doc"
let stublibs = Path.in_source "lib/stublibs"
let man = Path.in_source "man"
end
let should_set_executable_bit = function
| Lib -> false
| Libexec -> true
| Bin -> true
| Sbin -> true
| Toplevel -> false
| Share -> false
| Share_root -> false
| Etc -> false
| Doc -> false
| Stublibs -> true
| Man -> false
| Misc -> false
let install_dir t ~(package : Package.Name.t) =
let package = Package.Name.to_string package in
match t with
| Bin -> Paths.bin
| Sbin -> Paths.sbin
| Toplevel -> Paths.toplevel
| Share_root -> Paths.share_root
| Stublibs -> Paths.stublibs
| Man -> Paths.man
| Lib -> Path.relative Paths.lib package
| Libexec -> Path.relative Paths.libexec package
| Share -> Path.relative Paths.share package
| Etc -> Path.relative Paths.etc package
| Doc -> Path.relative Paths.doc package
| Misc -> invalid_arg "Install.Section.install_dir"
module Paths = struct
type t =
{ lib : Path.t
; libexec : Path.t
; bin : Path.t
; sbin : Path.t
; toplevel : Path.t
; share : Path.t
; share_root : Path.t
; etc : Path.t
; doc : Path.t
; stublibs : Path.t
; man : Path.t
}
let make ~package ~destdir ?(libdir=Path.relative destdir "lib") () =
let package = Package.Name.to_string package in
{ bin = Path.relative destdir "bin"
; sbin = Path.relative destdir "sbin"
; toplevel = Path.relative libdir "toplevel"
; share_root = Path.relative libdir "share"
; stublibs = Path.relative libdir "lib/stublibs"
; man = Path.relative destdir "man"
; lib = Path.relative libdir package
; libexec = Path.relative libdir package
; share = Path.relative destdir ("share/" ^ package)
; etc = Path.relative destdir ("etc/" ^ package)
; doc = Path.relative destdir ("doc/" ^ package)
}
let get t section =
match section with
| Lib -> t.lib
| Libexec -> t.libexec
| Bin -> t.bin
| Sbin -> t.sbin
| Toplevel -> t.toplevel
| Share -> t.share
| Share_root -> t.share_root
| Etc -> t.etc
| Doc -> t.doc
| Stublibs -> t.stublibs
| Man -> t.man
| Misc -> invalid_arg "Install.Paths.get"
end
end
module Entry = struct
@ -112,8 +157,8 @@ module Entry = struct
let set_src t src = { t with src }
let relative_installed_path t ~package =
let main_dir = Section.install_dir t.section ~package in
let relative_installed_path t ~paths =
let main_dir = Section.Paths.get paths t.section in
let dst =
match t.dst with
| Some x -> x
@ -129,15 +174,14 @@ module Entry = struct
in
Path.relative main_dir dst
let add_install_prefix t ~package ~prefix =
let opam_will_install_in_this_dir =
Section.install_dir t.section ~package
in
let add_install_prefix t ~paths ~prefix =
let opam_will_install_in_this_dir = Section.Paths.get paths t.section in
let i_want_to_install_the_file_as =
Path.append prefix (relative_installed_path t ~package)
Path.append prefix (relative_installed_path t ~paths)
in
let dst =
Path.reach i_want_to_install_the_file_as ~from:opam_will_install_in_this_dir
Path.reach i_want_to_install_the_file_as
~from:opam_will_install_in_this_dir
in
{ t with dst = Some dst }
end
@ -165,3 +209,62 @@ let gen_install_file entries =
| Some dst -> pr " %S {%S}" src dst);
pr "]");
Buffer.contents buf
let pos_of_opam_value : OpamParserTypes.value -> OpamParserTypes.pos = function
| Bool (pos, _) -> pos
| Int (pos, _) -> pos
| String (pos, _) -> pos
| Relop (pos, _, _, _) -> pos
| Prefix_relop (pos, _, _) -> pos
| Logop (pos, _, _, _) -> pos
| Pfxop (pos, _, _) -> pos
| Ident (pos, _) -> pos
| List (pos, _) -> pos
| Group (pos, _) -> pos
| Option (pos, _, _) -> pos
| Env_binding (pos, _, _, _) -> pos
let load_install_file path =
let open OpamParserTypes in
let file = Opam_file.load path in
let fail (fname, line, col) fmt =
let pos : Lexing.position =
{ pos_fname = fname
; pos_lnum = line
; pos_bol = 0
; pos_cnum = col
}
in
Loc.fail { start = pos; stop = pos } fmt
in
List.concat_map file.file_contents ~f:(function
| Variable (pos, section, files) -> begin
match Section.of_string section with
| None -> fail pos "Unknown install section"
| Some section -> begin
match files with
| List (_, l) ->
List.map l ~f:(function
| String (_, src) ->
{ Entry.
src = Path.of_string src
; dst = None
; section
}
| Option (_, String (_, src),
[String (_, dst)]) ->
{ Entry.
src = Path.of_string src
; dst = Some dst
; section
}
| v ->
fail (pos_of_opam_value v)
"Invalid value in .install file")
| v ->
fail (pos_of_opam_value v)
"Invalid value for install section"
end
end
| Section (pos, _) ->
fail pos "Sections are not allowed in .install file")

View File

@ -18,6 +18,37 @@ module Section : sig
| Misc
val t : t Sexp.Of_sexp.t
(** [true] iff the executable bit should be set for files installed
in this location. *)
val should_set_executable_bit : t -> bool
module Paths : sig
type section = t
type t =
{ lib : Path.t
; libexec : Path.t
; bin : Path.t
; sbin : Path.t
; toplevel : Path.t
; share : Path.t
; share_root : Path.t
; etc : Path.t
; doc : Path.t
; stublibs : Path.t
; man : Path.t
}
val make
: package:Package.Name.t
-> destdir:Path.t
-> ?libdir:Path.t
-> unit
-> t
val get : t -> section -> Path.t
end with type section := t
end
module Entry : sig
@ -30,9 +61,11 @@ module Entry : sig
val make : Section.t -> ?dst:string -> Path.t -> t
val set_src : t -> Path.t -> t
val relative_installed_path : t -> package:Package.Name.t -> Path.t
val add_install_prefix : t -> package:Package.Name.t -> prefix:Path.t -> t
val relative_installed_path : t -> paths:Section.Paths.t -> Path.t
val add_install_prefix : t -> paths:Section.Paths.t -> prefix:Path.t -> t
end
val files : Entry.t list -> Path.Set.t
val gen_install_file : Entry.t list -> string
val load_install_file : Path.t -> Entry.t list

View File

@ -216,12 +216,13 @@ module Gen(P : Install_params) = struct
List.exists [ "README"; "LICENSE"; "CHANGE"; "HISTORY"]
~f:(fun prefix -> String.is_prefix fn ~prefix)
let local_install_rules (entries : Install.Entry.t list) ~package =
let local_install_rules (entries : Install.Entry.t list)
~install_paths ~package =
let install_dir = Config.local_install_dir ~context:ctx.name in
List.map entries ~f:(fun entry ->
let dst =
Path.append install_dir
(Install.Entry.relative_installed_path entry ~package)
(Install.Entry.relative_installed_path entry ~paths:install_paths)
in
Build_system.set_package (SC.build_system sctx) entry.src package;
SC.add_rule sctx (Build.symlink ~src:entry.src ~dst);
@ -255,7 +256,10 @@ module Gen(P : Install_params) = struct
Path.relative (Path.append ctx.build_dir package_path)
(Utils.install_file ~package ~findlib_toolchain:ctx.findlib_toolchain)
in
let entries = local_install_rules entries ~package in
let install_paths =
Install.Section.Paths.make ~package ~destdir:Path.root ()
in
let entries = local_install_rules entries ~package ~install_paths in
let files = Install.files entries in
SC.add_alias_deps sctx
(Alias.package_install ~context:ctx ~pkg:package)
@ -284,7 +288,8 @@ module Gen(P : Install_params) = struct
| Some toolchain ->
let prefix = Path.of_string (toolchain ^ "-sysroot") in
List.map entries
~f:(Install.Entry.add_install_prefix ~prefix ~package)
~f:(Install.Entry.add_install_prefix
~paths:install_paths ~prefix)
in
Install.gen_install_file entries)
>>>

View File

@ -66,9 +66,9 @@ let copy_channels =
in
loop
let copy_file ~src ~dst =
let copy_file ?(chmod=fun x -> x) ~src ~dst () =
with_file_in src ~f:(fun ic ->
let perm = (Unix.fstat (Unix.descr_of_in_channel ic)).st_perm in
let perm = (Unix.fstat (Unix.descr_of_in_channel ic)).st_perm |> chmod in
Exn.protectx (P.open_out_gen
[Open_wronly; Open_creat; Open_trunc; Open_binary]
perm

View File

@ -23,7 +23,7 @@ val write_lines : Path.t -> string list -> unit
val copy_channels : in_channel -> out_channel -> unit
val copy_file : src:Path.t -> dst:Path.t -> unit
val copy_file : ?chmod:(int -> int) -> src:Path.t -> dst:Path.t -> unit -> unit
val read_all : in_channel -> string

View File

@ -874,9 +874,7 @@ let rm_rf =
| _ -> loop fn
let mkdir_p = function
| External s ->
Exn.code_error "Path.mkdir_p cannot create external path"
["s", External.sexp_of_t s]
| External s -> External.mkdir_p s
| In_source_tree s ->
Exn.code_error "Path.mkdir_p cannot dir in source"
["s", Local.sexp_of_t s]

View File

@ -1,13 +1,54 @@
(**************************************************************************)
(* *)
(* Copyright 2012-2015 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. *)
(* *)
(**************************************************************************)
type relop = [ `Eq | `Neq | `Geq | `Gt | `Leq | `Lt ]
type logop = [ `And | `Or ]
type pfxop = [ `Not ]
type file_name = string
(** Source file positions: filename, line, column *)
type pos = file_name * int * int
type env_update_op = Eq | PlusEq | EqPlus | ColonEq | EqColon | EqPlusEq
(** Base values *)
type value =
| String of unit * string
| List of unit * value list
| Other
| Bool of pos * bool
| Int of pos * int
| String of pos * string
| Relop of pos * relop * value * value
| Prefix_relop of pos * relop * value
| Logop of pos * logop * value * value
| Pfxop of pos * pfxop * value
| Ident of pos * string
| List of pos * value list
| Group of pos * value list
| Option of pos * value * value list
| Env_binding of pos * value * env_update_op * value
type opamfile_item =
| Variable of unit * string * value
| Other
(** An opamfile section *)
type opamfile_section = {
section_kind : string;
section_name : string option;
section_items : opamfile_item list;
}
type opamfile =
{ file_contents : opamfile_item list
; file_name : string
}
(** An opamfile is composed of sections and variable definitions *)
and opamfile_item =
| Section of pos * opamfile_section
| Variable of pos * string * value
(** A file is a list of items and the filename *)
type opamfile = {
file_contents: opamfile_item list;
file_name : file_name;
}