--- src/dpkg.ml | 3 ++- src/package_handler.ml | 1 + src/package_handler.mli | 4 ++++ src/pacman.ml | 2 +- src/rpm.ml | 2 +- 5 files changed, 9 insertions(+), 3 deletions(-) diff --git a/src/dpkg.ml b/src/dpkg.ml index c28354a..5a650b8 100644 --- a/src/dpkg.ml +++ b/src/dpkg.ml @@ -166,7 +166,8 @@ let dpkg_get_all_files pkgs = let config = try string_prefix "/etc/" path && (lstat path).st_kind = S_REG with Unix_error _ -> false in - { ft_path = path; ft_config = config } + let cmd = sprintf "%s --truename %s" Config.dpkg_divert path in + { ft_path = path; ft_source_path = path; ft_config = config } ) lines let dpkg_download_all_packages pkgs dir = diff --git a/src/package_handler.ml b/src/package_handler.ml index 10a9e3d..5aa27ba 100644 --- a/src/package_handler.ml +++ b/src/package_handler.ml @@ -43,6 +43,7 @@ let no_settings = type file = { ft_path : string; + ft_source_path : string; ft_config : bool; } diff --git a/src/package_handler.mli b/src/package_handler.mli index 3dcf97e..fa7b396 100644 --- a/src/package_handler.mli +++ b/src/package_handler.mli @@ -74,6 +74,10 @@ type file = { ft_path : string; (** File path. *) + ft_source_path : string; + (** File's source path. dpkg has a mechanism called "dpkg-divert" + can be used to override a package's version of a file. *) + ft_config : bool; (** Flag to indicate this is a configuration file. In some package managers (RPM) this is stored in package metadata. In others diff --git a/src/pacman.ml b/src/pacman.ml index dbaf4c8..6393cfa 100644 --- a/src/pacman.ml +++ b/src/pacman.ml @@ -155,7 +155,7 @@ let pacman_get_all_files pkgs = let config = try string_prefix "/etc/" path && (lstat path).st_kind = S_REG with Unix_error _ -> false in - { ft_path = path; ft_config = config } + { ft_path = path; ft_source_path = path; ft_config = config } ) lines let pacman_download_all_packages pkgs dir = diff --git a/src/rpm.ml b/src/rpm.ml index e022fa5..6e7afdb 100644 --- a/src/rpm.ml +++ b/src/rpm.ml @@ -174,7 +174,7 @@ let rpm_get_all_files pkgs = function | [ path; flags ] -> let config = String.contains flags 'c' in - { ft_path = path; ft_config = config } + { ft_path = path; ft_source_path = path; ft_config = config } | _ -> assert false ) lines -- 1.9.0

On Mon, Mar 10, 2014 at 11:33:51AM +0100, Hilko Bengen wrote:

and munge files = - let files = List.sort compare files in + let paths = + List.sort compare + (List.map (fun file -> file.ft_path) files) in

let rec stat_is_dir dir = try (stat dir).st_kind = S_DIR with Unix_error _ -> false @@ -336,7 +338,7 @@ and munge files = in

let insert_dir, dir_seen = - let h = Hashtbl.create (List.length files) in + let h = Hashtbl.create (List.length paths) in let insert_dir dir = Hashtbl.replace h dir true in let dir_seen dir = Hashtbl.mem h dir in insert_dir, dir_seen @@ -385,10 +387,17 @@ and munge files = (* Have we seen this parent directory before? *) let dir = Filename.dirname file in if not (dir_seen dir) then - loop (dir :: file :: rest) + loop (dir :: rest)

Why did file get dropped from the list here?

else - file :: loop rest + loop rest

And here?

in - let files = loop files in + let dir_paths = loop paths in + + let dirs = List.map (fun path -> + {ft_path = path; ft_source_path = path; ft_config = false} + ) dir_paths in + let files = List.filter (fun file -> + not (dir_seen file.ft_path) + ) files in

- files + dirs @ files

This seems to change the result of this (very important and complex) function. Rich. -- Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones Read my programming blog: http://rwmj.wordpress.com Fedora now supports 80 OCaml packages (the OPEN alternative to F#)

* Richard W.M. Jones:

This seems to change the result of this (very important and complex) function.

Since you didn't answer my followup message, I take it that I failed to convince you. I noticed that I can get away with leaving the structure of the function as-is, just changing the type... What do you think about this diff? Cheers, -Hilko diff --git a/src/build.ml b/src/build.ml index 9225184..0e2893d 100644 --- a/src/build.ml +++ b/src/build.ml @@ -345,21 +346,21 @@ and munge files = let rec loop = function | [] -> [] - | "/" :: rest -> + | root :: rest when root.ft_path = "/" -> (* This is just to avoid a corner-case in subsequent rules. *) loop rest - | dir :: rest when stat_is_dir dir && dir_seen dir -> + | dir :: rest when stat_is_dir dir.ft_path && dir_seen dir.ft_path -> dir :: loop rest - | dir :: rest when is_lnk_to_dir dir -> - insert_dir dir; + | dir :: rest when is_lnk_to_dir dir.ft_path -> + insert_dir dir.ft_path; (* Symlink to a directory. Insert the target directory before * if we've not seen it yet. *) - let target = readlink dir in - let parent = Filename.dirname dir in + let target = readlink dir.ft_path in + let parent = Filename.dirname dir.ft_path in (* Make the target an absolute path. *) let target = if String.length target < 1 || target.[0] <> '/' then @@ -367,24 +368,27 @@ and munge files = else target in if not (dir_seen target) then + let target = {ft_path = target; ft_source_path = target; ft_config = false} in loop (target :: dir :: rest) else dir :: loop rest - | dir :: rest when stat_is_dir dir -> - insert_dir dir; + | dir :: rest when stat_is_dir dir.ft_path -> + insert_dir dir.ft_path; (* Have we seen the parent? *) - let parent = Filename.dirname dir in + let parent = Filename.dirname dir.ft_path in if not (dir_seen parent) then + let parent = {ft_path = parent; ft_source_path = parent; ft_config = false} in loop (parent :: dir :: rest) else dir :: loop rest | file :: rest -> (* Have we seen this parent directory before? *) - let dir = Filename.dirname file in + let dir = Filename.dirname file.ft_path in if not (dir_seen dir) then + let dir = {ft_path = dir; ft_source_path = dir; ft_config = false} in loop (dir :: file :: rest) else file :: loop rest

--- configure.ac | 1 + src/config.ml.in | 1 + src/dpkg.ml | 1 + 3 files changed, 3 insertions(+) diff --git a/configure.ac b/configure.ac index 2141540..99ea913 100644 --- a/configure.ac +++ b/configure.ac @@ -92,6 +92,7 @@ AC_PATH_PROG(APT_GET,[apt-get],[no]) AC_PATH_PROG(DPKG,[dpkg],[no]) AC_PATH_PROG(DPKG_DEB,[dpkg-deb],[no]) AC_PATH_PROG(DPKG_QUERY,[dpkg-query],[no]) +AC_PATH_PROG(DPKG_DIVERT,[[dpkg-divert]],[no]) dnl For FrugalWare handler (currently disabled). AC_PATH_PROG(PACMAN_G2,[pacman-g2],[no]) diff --git a/src/config.ml.in b/src/config.ml.in index 5326bb0..acf2912 100644 --- a/src/config.ml.in +++ b/src/config.ml.in @@ -26,6 +26,7 @@ let cpio = "@CPIO@" let dpkg = "@DPKG@" let dpkg_deb = "@DPKG_DEB@" let dpkg_query = "@DPKG_QUERY@" +let dpkg_divert = "@DPKG_DIVERT@" let fakeroot = "@FAKEROOT@" let makepkg = "@MAKEPKG@" let pacman = "@PACMAN@" diff --git a/src/dpkg.ml b/src/dpkg.ml index 71aa12c..c28354a 100644 --- a/src/dpkg.ml +++ b/src/dpkg.ml @@ -26,6 +26,7 @@ let dpkg_detect () = Config.dpkg <> "no" && Config.dpkg_deb <> "no" && Config.dpkg_query <> "no" && + Config.dpkg_divert <> "no" && Config.apt_get <> "no" && file_exists "/etc/debian_version" -- 1.9.0

--- src/build.ml | 48 ++++++++++++++++++++++++++---------------------- src/chroot.ml | 12 +++++++----- src/dpkg.ml | 16 +++++++++++++++- src/ext2.ml | 8 +++++++- 4 files changed, 55 insertions(+), 29 deletions(-) diff --git a/src/build.ml b/src/build.ml index 9225184..0e2893d 100644 --- a/src/build.ml +++ b/src/build.ml @@ -106,11 +106,7 @@ let rec build debug *) let files = get_all_files packages in let files = - filter_map ( - function - | { ft_config = false; ft_path = path } -> Some path - | { ft_config = true } -> None - ) files in + List.filter (fun file -> not file.ft_config) files in if debug >= 1 then printf "supermin: build: %d files\n%!" (List.length files); @@ -120,9 +116,11 @@ let rec build debug *) let files = List.filter ( - fun path -> - try ignore (lstat path); true - with Unix_error (err, fn, _) -> false + fun file -> + try ignore (lstat file.ft_source_path); true + with Unix_error (err, fn, _) -> + try ignore (lstat file.ft_path); true + with Unix_error (err, fn, _) -> false ) files in if debug >= 1 then @@ -139,9 +137,9 @@ let rec build debug else ( let fn_flags = [FNM_NOESCAPE] in List.filter ( - fun path -> + fun file -> List.for_all ( - fun pattern -> not (fnmatch pattern path fn_flags) + fun pattern -> not (fnmatch pattern file.ft_path fn_flags) ) appliance.excludefiles ) files ) in @@ -159,7 +157,9 @@ let rec build debug ) appliance.hostfiles in let hostfiles = List.map Array.to_list hostfiles in let hostfiles = List.flatten hostfiles in - files @ hostfiles + files @ (List.map + (fun path -> {ft_path = path; ft_source_path = path; ft_config = false}) + hostfiles) ) in if debug >= 1 then @@ -326,7 +326,8 @@ and isalnum = function * symlink. *) and munge files = - let files = List.sort compare files in + let files = + List.sort (fun f1 f2 -> compare f1.ft_path f2.ft_path) files in let rec stat_is_dir dir = try (stat dir).st_kind = S_DIR with Unix_error _ -> false @@ -345,21 +346,21 @@ and munge files = let rec loop = function | [] -> [] - | "/" :: rest -> + | root :: rest when root.ft_path = "/" -> (* This is just to avoid a corner-case in subsequent rules. *) loop rest - | dir :: rest when stat_is_dir dir && dir_seen dir -> + | dir :: rest when stat_is_dir dir.ft_path && dir_seen dir.ft_path -> dir :: loop rest - | dir :: rest when is_lnk_to_dir dir -> - insert_dir dir; + | dir :: rest when is_lnk_to_dir dir.ft_path -> + insert_dir dir.ft_path; (* Symlink to a directory. Insert the target directory before * if we've not seen it yet. *) - let target = readlink dir in - let parent = Filename.dirname dir in + let target = readlink dir.ft_path in + let parent = Filename.dirname dir.ft_path in (* Make the target an absolute path. *) let target = if String.length target < 1 || target.[0] <> '/' then @@ -367,24 +368,27 @@ and munge files = else target in if not (dir_seen target) then + let target = {ft_path = target; ft_source_path = target; ft_config = false} in loop (target :: dir :: rest) else dir :: loop rest - | dir :: rest when stat_is_dir dir -> - insert_dir dir; + | dir :: rest when stat_is_dir dir.ft_path -> + insert_dir dir.ft_path; (* Have we seen the parent? *) - let parent = Filename.dirname dir in + let parent = Filename.dirname dir.ft_path in if not (dir_seen parent) then + let parent = {ft_path = parent; ft_source_path = parent; ft_config = false} in loop (parent :: dir :: rest) else dir :: loop rest | file :: rest -> (* Have we seen this parent directory before? *) - let dir = Filename.dirname file in + let dir = Filename.dirname file.ft_path in if not (dir_seen dir) then + let dir = {ft_path = dir; ft_source_path = dir; ft_config = false} in loop (dir :: file :: rest) else file :: loop rest diff --git a/src/chroot.ml b/src/chroot.ml index 1e1ddb2..b5c1e53 100644 --- a/src/chroot.ml +++ b/src/chroot.ml @@ -20,13 +20,15 @@ open Unix open Printf open Utils +open Package_handler let build_chroot debug files outputdir = List.iter ( - fun path -> + fun file -> try + let path = file.ft_source_path in let st = lstat path in - let opath = outputdir // path in + let opath = outputdir // file.ft_path in match st.st_kind with | S_DIR -> (* Note we fix up the permissions of directories in a second @@ -65,9 +67,9 @@ let build_chroot debug files outputdir = (* Second pass: fix up directory permissions in reverse. *) let dirs = filter_map ( - fun path -> - let st = lstat path in - if st.st_kind = S_DIR then Some (path, st) else None + fun file -> + let st = lstat file.ft_source_path in + if st.st_kind = S_DIR then Some (file.ft_path, st) else None ) files in List.iter ( fun (path, st) -> diff --git a/src/dpkg.ml b/src/dpkg.ml index 234bb63..efc8123 100644 --- a/src/dpkg.ml +++ b/src/dpkg.ml @@ -155,6 +155,17 @@ let dpkg_get_all_requires pkgs = loop pkgs let dpkg_get_all_files pkgs = + let cmd = sprintf "%s --list" Config.dpkg_divert in + let lines = run_command_get_lines cmd in + let diversions = Hashtbl.create (List.length lines) in + List.iter ( + fun line -> + let items = string_split " " line in + match items with + | ["diversion"; "of"; path; "to"; real_path; "by"; pkg] -> + Hashtbl.add diversions path real_path + | _ -> () + ) lines; let cmd = sprintf "%s --listfiles %s | grep '^/' | grep -v '^/.$' | sort -u" Config.dpkg_query @@ -166,7 +177,10 @@ let dpkg_get_all_files pkgs = let config = try string_prefix "/etc/" path && (lstat path).st_kind = S_REG with Unix_error _ -> false in - { ft_path = path; ft_source_path = path; ft_config = config } + let source_path = + try Hashtbl.find diversions path + with Not_found -> path in + { ft_path = path; ft_source_path = source_path; ft_config = config } ) lines let dpkg_download_all_packages pkgs dir = diff --git a/src/ext2.ml b/src/ext2.ml index 701f52e..ccaa81f 100644 --- a/src/ext2.ml +++ b/src/ext2.ml @@ -21,6 +21,7 @@ open Printf open Utils open Ext2fs +open Package_handler (* The ext2 image that we build always has a fixed size, and we 'hope' * that the files fit in (otherwise we'll get an error). Note that @@ -66,7 +67,12 @@ let build_ext2 debug basedir files modpath kernel_version appliance = printf "supermin: ext2: copying files from host filesystem\n%!"; (* Copy files from host filesystem. *) - List.iter (fun path -> ext2fs_copy_file_from_host fs path path) files; + List.iter (fun file -> + if file_exists file.ft_source_path then + ext2fs_copy_file_from_host fs file.ft_source_path file.ft_path + else + ext2fs_copy_file_from_host fs file.ft_path file.ft_path + ) files; if debug >= 1 then printf "supermin: ext2: copying kernel modules\n%!"; -- 1.9.0