summaryrefslogtreecommitdiffstats
path: root/scripts/Dpkg/Path.pm
diff options
context:
space:
mode:
Diffstat (limited to 'scripts/Dpkg/Path.pm')
-rw-r--r--scripts/Dpkg/Path.pm306
1 files changed, 306 insertions, 0 deletions
diff --git a/scripts/Dpkg/Path.pm b/scripts/Dpkg/Path.pm
new file mode 100644
index 0000000..f352cac
--- /dev/null
+++ b/scripts/Dpkg/Path.pm
@@ -0,0 +1,306 @@
+# 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.04';
+our @EXPORT_OK = qw(
+ canonpath
+ resolve_symlink
+ check_files_are_the_same
+ find_command
+ find_build_file
+ get_control_path
+ get_pkg_root_dir
+ guess_pkg_root_dir
+ relative_to_pkg_root
+);
+
+use Exporter qw(import);
+use File::Spec;
+use Cwd qw(realpath);
+
+use Dpkg::Arch qw(get_host_arch debarch_to_debtuple);
+use Dpkg::IPC;
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::Path - some common path handling functions
+
+=head1 DESCRIPTION
+
+It provides some functions to handle various path.
+
+=head1 FUNCTIONS
+
+=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 $cmdpath = find_command($command)
+
+Return the path of the command if defined and available on an absolute or
+relative path or on the $PATH, undef otherwise.
+
+=cut
+
+sub find_command($) {
+ my $cmd = shift;
+
+ return if not $cmd;
+ if ($cmd =~ m{/}) {
+ return "$cmd" if -x "$cmd";
+ } else {
+ foreach my $dir (split(/:/, $ENV{PATH})) {
+ return "$dir/$cmd" if -x "$dir/$cmd";
+ }
+ }
+ return;
+}
+
+=item $control_file = get_control_path($pkg, $filetype)
+
+Return the path of the control file of type $filetype for the given
+package.
+
+=item @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 $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 @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, $libc, $host_os, $cpu) = debarch_to_debtuple($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.04 (dpkg 1.17.11)
+
+Update semantics: find_command() now handles an empty or undef argument.
+
+=head2 Version 1.03 (dpkg 1.16.1)
+
+New function: find_build_file()
+
+=head2 Version 1.02 (dpkg 1.16.0)
+
+New function: get_control_path()
+
+=head2 Version 1.01 (dpkg 1.15.8)
+
+New function: find_command()
+
+=head2 Version 1.00 (dpkg 1.15.6)
+
+Mark the module as public.
+
+=cut
+
+1;