Index: third_party/dpkg-dev/scripts/Dpkg/Path.pm |
diff --git a/third_party/dpkg-dev/scripts/Dpkg/Path.pm b/third_party/dpkg-dev/scripts/Dpkg/Path.pm |
new file mode 100644 |
index 0000000000000000000000000000000000000000..969b1d6cc288741ff4748e642ab6bf4d943d7990 |
--- /dev/null |
+++ b/third_party/dpkg-dev/scripts/Dpkg/Path.pm |
@@ -0,0 +1,295 @@ |
+# Copyright © 2007-2011 Raphaël Hertzog <hertzog@debian.org> |
+# Copyright © 2011 Linaro Limited |
+# |
+# This program is free software; you can redistribute it and/or modify |
+# it under the terms of the GNU General Public License as published by |
+# the Free Software Foundation; either version 2 of the License, or |
+# (at your option) any later version. |
+# |
+# This program is distributed in the hope that it will be useful, |
+# but WITHOUT ANY WARRANTY; without even the implied warranty of |
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
+# GNU General Public License for more details. |
+# |
+# You should have received a copy of the GNU General Public License |
+# along with this program. If not, see <https://www.gnu.org/licenses/>. |
+ |
+package Dpkg::Path; |
+ |
+use strict; |
+use warnings; |
+ |
+our $VERSION = '1.02'; |
+ |
+use Exporter qw(import); |
+use File::Spec; |
+use Cwd qw(realpath); |
+ |
+use Dpkg::Arch qw(get_host_arch debarch_to_debtriplet); |
+use Dpkg::IPC; |
+ |
+our @EXPORT_OK = qw(get_pkg_root_dir relative_to_pkg_root |
+ guess_pkg_root_dir check_files_are_the_same |
+ resolve_symlink canonpath find_command |
+ get_control_path find_build_file); |
+ |
+=encoding utf8 |
+ |
+=head1 NAME |
+ |
+Dpkg::Path - some common path handling functions |
+ |
+=head1 DESCRIPTION |
+ |
+It provides some functions to handle various path. |
+ |
+=head1 METHODS |
+ |
+=over 8 |
+ |
+=item get_pkg_root_dir($file) |
+ |
+This function will scan upwards the hierarchy of directory to find out |
+the directory which contains the "DEBIAN" sub-directory and it will return |
+its path. This directory is the root directory of a package being built. |
+ |
+If no DEBIAN subdirectory is found, it will return undef. |
+ |
+=cut |
+ |
+sub get_pkg_root_dir($) { |
+ my $file = shift; |
+ $file =~ s{/+$}{}; |
+ $file =~ s{/+[^/]+$}{} if not -d $file; |
+ while ($file) { |
+ return $file if -d "$file/DEBIAN"; |
+ last if $file !~ m{/}; |
+ $file =~ s{/+[^/]+$}{}; |
+ } |
+ return; |
+} |
+ |
+=item relative_to_pkg_root($file) |
+ |
+Returns the filename relative to get_pkg_root_dir($file). |
+ |
+=cut |
+ |
+sub relative_to_pkg_root($) { |
+ my $file = shift; |
+ my $pkg_root = get_pkg_root_dir($file); |
+ if (defined $pkg_root) { |
+ $pkg_root .= '/'; |
+ return $file if ($file =~ s/^\Q$pkg_root\E//); |
+ } |
+ return; |
+} |
+ |
+=item guess_pkg_root_dir($file) |
+ |
+This function tries to guess the root directory of the package build tree. |
+It will first use get_pkg_root_dir(), but it will fallback to a more |
+imprecise check: namely it will use the parent directory that is a |
+sub-directory of the debian directory. |
+ |
+It can still return undef if a file outside of the debian sub-directory is |
+provided. |
+ |
+=cut |
+ |
+sub guess_pkg_root_dir($) { |
+ my $file = shift; |
+ my $root = get_pkg_root_dir($file); |
+ return $root if defined $root; |
+ |
+ $file =~ s{/+$}{}; |
+ $file =~ s{/+[^/]+$}{} if not -d $file; |
+ my $parent = $file; |
+ while ($file) { |
+ $parent =~ s{/+[^/]+$}{}; |
+ last if not -d $parent; |
+ return $file if check_files_are_the_same('debian', $parent); |
+ $file = $parent; |
+ last if $file !~ m{/}; |
+ } |
+ return; |
+} |
+ |
+=item check_files_are_the_same($file1, $file2, $resolve_symlink) |
+ |
+This function verifies that both files are the same by checking that the device |
+numbers and the inode numbers returned by stat()/lstat() are the same. If |
+$resolve_symlink is true then stat() is used, otherwise lstat() is used. |
+ |
+=cut |
+ |
+sub check_files_are_the_same($$;$) { |
+ my ($file1, $file2, $resolve_symlink) = @_; |
+ return 0 if ((! -e $file1) || (! -e $file2)); |
+ my (@stat1, @stat2); |
+ if ($resolve_symlink) { |
+ @stat1 = stat($file1); |
+ @stat2 = stat($file2); |
+ } else { |
+ @stat1 = lstat($file1); |
+ @stat2 = lstat($file2); |
+ } |
+ my $result = ($stat1[0] == $stat2[0]) && ($stat1[1] == $stat2[1]); |
+ return $result; |
+} |
+ |
+ |
+=item canonpath($file) |
+ |
+This function returns a cleaned path. It simplifies double //, and remove |
+/./ and /../ intelligently. For /../ it simplifies the path only if the |
+previous element is not a symlink. Thus it should only be used on real |
+filenames. |
+ |
+=cut |
+ |
+sub canonpath($) { |
+ my $path = shift; |
+ $path = File::Spec->canonpath($path); |
+ my ($v, $dirs, $file) = File::Spec->splitpath($path); |
+ my @dirs = File::Spec->splitdir($dirs); |
+ my @new; |
+ foreach my $d (@dirs) { |
+ if ($d eq '..') { |
+ if (scalar(@new) > 0 and $new[-1] ne '..') { |
+ next if $new[-1] eq ''; # Root directory has no parent |
+ my $parent = File::Spec->catpath($v, |
+ File::Spec->catdir(@new), ''); |
+ if (not -l $parent) { |
+ pop @new; |
+ } else { |
+ push @new, $d; |
+ } |
+ } else { |
+ push @new, $d; |
+ } |
+ } else { |
+ push @new, $d; |
+ } |
+ } |
+ return File::Spec->catpath($v, File::Spec->catdir(@new), $file); |
+} |
+ |
+=item $newpath = resolve_symlink($symlink) |
+ |
+Return the filename of the file pointed by the symlink. The new name is |
+canonicalized by canonpath(). |
+ |
+=cut |
+ |
+sub resolve_symlink($) { |
+ my $symlink = shift; |
+ my $content = readlink($symlink); |
+ return unless defined $content; |
+ if (File::Spec->file_name_is_absolute($content)) { |
+ return canonpath($content); |
+ } else { |
+ my ($link_v, $link_d, $link_f) = File::Spec->splitpath($symlink); |
+ my ($cont_v, $cont_d, $cont_f) = File::Spec->splitpath($content); |
+ my $new = File::Spec->catpath($link_v, $link_d . '/' . $cont_d, $cont_f); |
+ return canonpath($new); |
+ } |
+} |
+ |
+ |
+=item my $cmdpath = find_command($command) |
+ |
+Return the path of the command if available on an absolute or relative |
+path or on the $PATH, undef otherwise. |
+ |
+=cut |
+ |
+sub find_command($) { |
+ my $cmd = shift; |
+ |
+ if ($cmd =~ m{/}) { |
+ return "$cmd" if -x "$cmd"; |
+ } else { |
+ foreach my $dir (split(/:/, $ENV{PATH})) { |
+ return "$dir/$cmd" if -x "$dir/$cmd"; |
+ } |
+ } |
+ return; |
+} |
+ |
+=item my $control_file = get_control_path($pkg, $filetype) |
+ |
+Return the path of the control file of type $filetype for the given |
+package. |
+ |
+=item my @control_files = get_control_path($pkg) |
+ |
+Return the path of all available control files for the given package. |
+ |
+=cut |
+ |
+sub get_control_path($;$) { |
+ my ($pkg, $filetype) = @_; |
+ my $control_file; |
+ my @exec = ('dpkg-query', '--control-path', $pkg); |
+ push @exec, $filetype if defined $filetype; |
+ spawn(exec => \@exec, wait_child => 1, to_string => \$control_file); |
+ chomp($control_file); |
+ if (defined $filetype) { |
+ return if $control_file eq ''; |
+ return $control_file; |
+ } |
+ return () if $control_file eq ''; |
+ return split(/\n/, $control_file); |
+} |
+ |
+=item my $file = find_build_file($basename) |
+ |
+Selects the right variant of the given file: the arch-specific variant |
+("$basename.$arch") has priority over the OS-specific variant |
+("$basename.$os") which has priority over the default variant |
+("$basename"). If none of the files exists, then it returns undef. |
+ |
+=item my @files = find_build_file($basename) |
+ |
+Return the available variants of the given file. Returns an empty |
+list if none of the files exists. |
+ |
+=cut |
+ |
+sub find_build_file($) { |
+ my $base = shift; |
+ my $host_arch = get_host_arch(); |
+ my ($abi, $host_os, $cpu) = debarch_to_debtriplet($host_arch); |
+ my @files; |
+ foreach my $f ("$base.$host_arch", "$base.$host_os", "$base") { |
+ push @files, $f if -f $f; |
+ } |
+ return @files if wantarray; |
+ return $files[0] if scalar @files; |
+ return; |
+} |
+ |
+=back |
+ |
+=head1 CHANGES |
+ |
+=head2 Version 1.03 |
+ |
+New function: find_build_file() |
+ |
+=head2 Version 1.02 |
+ |
+New function: get_control_path() |
+ |
+=head2 Version 1.01 |
+ |
+New function: find_command() |
+ |
+=head1 AUTHOR |
+ |
+Raphaël Hertzog <hertzog@debian.org>. |
+ |
+=cut |
+ |
+1; |