scripts/Dpkg/Path.pm

   1 # Copyright © 2007-2011 Raphaël Hertzog <hertzog@debian.org>
   2 # Copyright © 2011 Linaro Limited
   3 #
   4 # This program is free software; you can redistribute it and/or modify
   5 # it under the terms of the GNU General Public License as published by
   6 # the Free Software Foundation; either version 2 of the License, or
   7 # (at your option) any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  16
  17 =encoding utf8
  18
  19 =head1 NAME
  20
  21 Dpkg::Path - some common path handling functions
  22
  23 =head1 DESCRIPTION
  24
  25 It provides some functions to handle various path.
  26
  27 =cut
  28
  29 package Dpkg::Path 1.05;
  30
  31 use strict;
  32 use warnings;
  33
  34 our @EXPORT_OK = qw(
  35     canonpath
  36     resolve_symlink
  37     check_files_are_the_same
  38     check_directory_traversal
  39     find_command
  40     find_build_file
  41     get_control_path
  42     get_pkg_root_dir
  43     guess_pkg_root_dir
  44     relative_to_pkg_root
  45 );
  46
  47 use Exporter qw(import);
  48 use Errno qw(ENOENT);
  49 use File::Spec;
  50 use File::Find;
  51 use Cwd qw(realpath);
  52
  53 use Dpkg::ErrorHandling;
  54 use Dpkg::Gettext;
  55 use Dpkg::Arch qw(get_host_arch debarch_to_debtuple);
  56 use Dpkg::IPC;
  57
  58 =head1 FUNCTIONS
  59
  60 =over 8
  61
  62 =item get_pkg_root_dir($file)
  63
  64 This function will scan upwards the hierarchy of directory to find out
  65 the directory which contains the "DEBIAN" sub-directory and it will return
  66 its path. This directory is the root directory of a package being built.
  67
  68 If no DEBIAN subdirectory is found, it will return undef.
  69
  70 =cut
  71
  72 sub get_pkg_root_dir($) {
  73     my $file = shift;
  74     $file =~ s{/+$}{};
  75     $file =~ s{/+[^/]+$}{} if not -d $file;
  76     while ($file) {
  77         return $file if -d "$file/DEBIAN";
  78         last if $file !~ m{/};
  79         $file =~ s{/+[^/]+$}{};
  80     }
  81     return;
  82 }
  83
  84 =item relative_to_pkg_root($file)
  85
  86 Returns the filename relative to get_pkg_root_dir($file).
  87
  88 =cut
  89
  90 sub relative_to_pkg_root($) {
  91     my $file = shift;
  92     my $pkg_root = get_pkg_root_dir($file);
  93     if (defined $pkg_root) {
  94         $pkg_root .= '/';
  95         return $file if ($file =~ s/^\Q$pkg_root\E//);
  96     }
  97     return;
  98 }
  99
 100 =item guess_pkg_root_dir($file)
 101
 102 This function tries to guess the root directory of the package build tree.
 103 It will first use get_pkg_root_dir(), but it will fallback to a more
 104 imprecise check: namely it will use the parent directory that is a
 105 sub-directory of the debian directory.
 106
 107 It can still return undef if a file outside of the debian sub-directory is
 108 provided.
 109
 110 =cut
 111
 112 sub guess_pkg_root_dir($) {
 113     my $file = shift;
 114     my $root = get_pkg_root_dir($file);
 115     return $root if defined $root;
 116
 117     $file =~ s{/+$}{};
 118     $file =~ s{/+[^/]+$}{} if not -d $file;
 119     my $parent = $file;
 120     while ($file) {
 121         $parent =~ s{/+[^/]+$}{};
 122         last if not -d $parent;
 123         return $file if check_files_are_the_same('debian', $parent);
 124         $file = $parent;
 125         last if $file !~ m{/};
 126     }
 127     return;
 128 }
 129
 130 =item check_files_are_the_same($file1, $file2, $resolve_symlink)
 131
 132 This function verifies that both files are the same by checking that the device
 133 numbers and the inode numbers returned by stat()/lstat() are the same. If
 134 $resolve_symlink is true then stat() is used, otherwise lstat() is used.
 135
 136 =cut
 137
 138 sub check_files_are_the_same($$;$) {
 139     my ($file1, $file2, $resolve_symlink) = @_;
 140
 141     return 1 if $file1 eq $file2;
 142     return 0 if ((! -e $file1) || (! -e $file2));
 143     my (@stat1, @stat2);
 144     if ($resolve_symlink) {
 145         @stat1 = stat($file1);
 146         @stat2 = stat($file2);
 147     } else {
 148         @stat1 = lstat($file1);
 149         @stat2 = lstat($file2);
 150     }
 151     my $result = ($stat1[0] == $stat2[0]) && ($stat1[1] == $stat2[1]);
 152     return $result;
 153 }
 154
 155
 156 =item canonpath($file)
 157
 158 This function returns a cleaned path. It simplifies double //, and remove
 159 /./ and /../ intelligently. For /../ it simplifies the path only if the
 160 previous element is not a symlink. Thus it should only be used on real
 161 filenames.
 162
 163 =cut
 164
 165 sub canonpath($) {
 166     my $path = shift;
 167     $path = File::Spec->canonpath($path);
 168     my ($v, $dirs, $file) = File::Spec->splitpath($path);
 169     my @dirs = File::Spec->splitdir($dirs);
 170     my @new;
 171     foreach my $d (@dirs) {
 172         if ($d eq '..') {
 173             if (scalar(@new) > 0 and $new[-1] ne '..') {
 174                 next if $new[-1] eq ''; # Root directory has no parent
 175                 my $parent = File::Spec->catpath($v,
 176                         File::Spec->catdir(@new), '');
 177                 if (not -l $parent) {
 178                     pop @new;
 179                 } else {
 180                     push @new, $d;
 181                 }
 182             } else {
 183                 push @new, $d;
 184             }
 185         } else {
 186             push @new, $d;
 187         }
 188     }
 189     return File::Spec->catpath($v, File::Spec->catdir(@new), $file);
 190 }
 191
 192 =item $newpath = resolve_symlink($symlink)
 193
 194 Return the filename of the file pointed by the symlink. The new name is
 195 canonicalized by canonpath().
 196
 197 =cut
 198
 199 sub resolve_symlink($) {
 200     my $symlink = shift;
 201     my $content = readlink($symlink);
 202     return unless defined $content;
 203     if (File::Spec->file_name_is_absolute($content)) {
 204         return canonpath($content);
 205     } else {
 206         my ($link_v, $link_d, $link_f) = File::Spec->splitpath($symlink);
 207         my ($cont_v, $cont_d, $cont_f) = File::Spec->splitpath($content);
 208         my $new = File::Spec->catpath($link_v, $link_d . '/' . $cont_d, $cont_f);
 209         return canonpath($new);
 210     }
 211 }
 212
 213 =item check_directory_traversal($basedir, $dir)
 214
 215 This function verifies that the directory $dir does not contain any symlink
 216 that goes beyond $basedir (which should be either equal or a parent of $dir).
 217
 218 =cut
 219
 220 sub check_directory_traversal {
 221     my ($basedir, $dir) = @_;
 222
 223     my $canon_basedir = realpath($basedir);
 224     # On Solaris /dev/null points to /devices/pseudo/mm@0:null.
 225     my $canon_devnull = realpath('/dev/null');
 226     my $check_symlinks = sub {
 227         my $canon_pathname = realpath($_);
 228         if (not defined $canon_pathname) {
 229             return if $! == ENOENT;
 230
 231             syserr(g_("pathname '%s' cannot be canonicalized"), $_);
 232         }
 233         return if $canon_pathname eq $canon_devnull;
 234         return if $canon_pathname eq $canon_basedir;
 235         return if $canon_pathname =~ m{^\Q$canon_basedir/\E};
 236
 237         error(g_("pathname '%s' points outside source root (to '%s')"),
 238               $_, $canon_pathname);
 239     };
 240
 241     find({
 242         wanted => $check_symlinks,
 243         no_chdir => 1,
 244         follow => 1,
 245         follow_skip => 2,
 246     }, $dir);
 247
 248     return;
 249 }
 250
 251 =item $cmdpath = find_command($command)
 252
 253 Return the path of the command if defined and available on an absolute or
 254 relative path or on the $PATH, undef otherwise.
 255
 256 =cut
 257
 258 sub find_command($) {
 259     my $cmd = shift;
 260
 261     return if not $cmd;
 262     if ($cmd =~ m{/}) {
 263         return "$cmd" if -x "$cmd";
 264     } else {
 265         foreach my $dir (split(/:/, $ENV{PATH})) {
 266             return "$dir/$cmd" if -x "$dir/$cmd";
 267         }
 268     }
 269     return;
 270 }
 271
 272 =item $control_file = get_control_path($pkg, $filetype)
 273
 274 Return the path of the control file of type $filetype for the given
 275 package.
 276
 277 =item @control_files = get_control_path($pkg)
 278
 279 Return the path of all available control files for the given package.
 280
 281 =cut
 282
 283 sub get_control_path($;$) {
 284     my ($pkg, $filetype) = @_;
 285     my $control_file;
 286     my @exec = ('dpkg-query', '--control-path', $pkg);
 287     push @exec, $filetype if defined $filetype;
 288     spawn(exec => \@exec, wait_child => 1, to_string => \$control_file);
 289     chomp($control_file);
 290     if (defined $filetype) {
 291         return if $control_file eq '';
 292         return $control_file;
 293     }
 294     return () if $control_file eq '';
 295     return split(/\n/, $control_file);
 296 }
 297
 298 =item $file = find_build_file($basename)
 299
 300 Selects the right variant of the given file: the arch-specific variant
 301 ("$basename.$arch") has priority over the OS-specific variant
 302 ("$basename.$os") which has priority over the default variant
 303 ("$basename"). If none of the files exists, then it returns undef.
 304
 305 =item @files = find_build_file($basename)
 306
 307 Return the available variants of the given file. Returns an empty
 308 list if none of the files exists.
 309
 310 =cut
 311
 312 sub find_build_file($) {
 313     my $base = shift;
 314     my $host_arch = get_host_arch();
 315     my ($abi, $libc, $host_os, $cpu) = debarch_to_debtuple($host_arch);
 316     my @files;
 317     foreach my $fn ("$base.$host_arch", "$base.$host_os", "$base") {
 318         push @files, $fn if -f $fn;
 319     }
 320     return @files if wantarray;
 321     return $files[0] if scalar @files;
 322     return;
 323 }
 324
 325 =back
 326
 327 =head1 CHANGES
 328
 329 =head2 Version 1.05 (dpkg 1.20.4)
 330
 331 New function: check_directory_traversal().
 332
 333 =head2 Version 1.04 (dpkg 1.17.11)
 334
 335 Update semantics: find_command() now handles an empty or undef argument.
 336
 337 =head2 Version 1.03 (dpkg 1.16.1)
 338
 339 New function: find_build_file()
 340
 341 =head2 Version 1.02 (dpkg 1.16.0)
 342
 343 New function: get_control_path()
 344
 345 =head2 Version 1.01 (dpkg 1.15.8)
 346
 347 New function: find_command()
 348
 349 =head2 Version 1.00 (dpkg 1.15.6)
 350
 351 Mark the module as public.
 352
 353 =cut
 354
 355 1;