chiark - git - mdw - dpkg/blob - 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 package Dpkg::Path;
  18
  19 use strict;
  20 use warnings;
  21
  22 our $VERSION = '1.04';
  23 our @EXPORT_OK = qw(
  24     canonpath
  25     resolve_symlink
  26     check_files_are_the_same
  27     find_command
  28     find_build_file
  29     get_control_path
  30     get_pkg_root_dir
  31     guess_pkg_root_dir
  32     relative_to_pkg_root
  33 );
  34
  35 use Exporter qw(import);
  36 use File::Spec;
  37 use Cwd qw(realpath);
  38
  39 use Dpkg::Arch qw(get_host_arch debarch_to_debtuple);
  40 use Dpkg::IPC;
  41
  42 =encoding utf8
  43
  44 =head1 NAME
  45
  46 Dpkg::Path - some common path handling functions
  47
  48 =head1 DESCRIPTION
  49
  50 It provides some functions to handle various path.
  51
  52 =head1 FUNCTIONS
  53
  54 =over 8
  55
  56 =item get_pkg_root_dir($file)
  57
  58 This function will scan upwards the hierarchy of directory to find out
  59 the directory which contains the "DEBIAN" sub-directory and it will return
  60 its path. This directory is the root directory of a package being built.
  61
  62 If no DEBIAN subdirectory is found, it will return undef.
  63
  64 =cut
  65
  66 sub get_pkg_root_dir($) {
  67     my $file = shift;
  68     $file =~ s{/+$}{};
  69     $file =~ s{/+[^/]+$}{} if not -d $file;
  70     while ($file) {
  71         return $file if -d "$file/DEBIAN";
  72         last if $file !~ m{/};
  73         $file =~ s{/+[^/]+$}{};
  74     }
  75     return;
  76 }
  77
  78 =item relative_to_pkg_root($file)
  79
  80 Returns the filename relative to get_pkg_root_dir($file).
  81
  82 =cut
  83
  84 sub relative_to_pkg_root($) {
  85     my $file = shift;
  86     my $pkg_root = get_pkg_root_dir($file);
  87     if (defined $pkg_root) {
  88         $pkg_root .= '/';
  89         return $file if ($file =~ s/^\Q$pkg_root\E//);
  90     }
  91     return;
  92 }
  93
  94 =item guess_pkg_root_dir($file)
  95
  96 This function tries to guess the root directory of the package build tree.
  97 It will first use get_pkg_root_dir(), but it will fallback to a more
  98 imprecise check: namely it will use the parent directory that is a
  99 sub-directory of the debian directory.
 100
 101 It can still return undef if a file outside of the debian sub-directory is
 102 provided.
 103
 104 =cut
 105
 106 sub guess_pkg_root_dir($) {
 107     my $file = shift;
 108     my $root = get_pkg_root_dir($file);
 109     return $root if defined $root;
 110
 111     $file =~ s{/+$}{};
 112     $file =~ s{/+[^/]+$}{} if not -d $file;
 113     my $parent = $file;
 114     while ($file) {
 115         $parent =~ s{/+[^/]+$}{};
 116         last if not -d $parent;
 117         return $file if check_files_are_the_same('debian', $parent);
 118         $file = $parent;
 119         last if $file !~ m{/};
 120     }
 121     return;
 122 }
 123
 124 =item check_files_are_the_same($file1, $file2, $resolve_symlink)
 125
 126 This function verifies that both files are the same by checking that the device
 127 numbers and the inode numbers returned by stat()/lstat() are the same. If
 128 $resolve_symlink is true then stat() is used, otherwise lstat() is used.
 129
 130 =cut
 131
 132 sub check_files_are_the_same($$;$) {
 133     my ($file1, $file2, $resolve_symlink) = @_;
 134     return 0 if ((! -e $file1) || (! -e $file2));
 135     my (@stat1, @stat2);
 136     if ($resolve_symlink) {
 137         @stat1 = stat($file1);
 138         @stat2 = stat($file2);
 139     } else {
 140         @stat1 = lstat($file1);
 141         @stat2 = lstat($file2);
 142     }
 143     my $result = ($stat1[0] == $stat2[0]) && ($stat1[1] == $stat2[1]);
 144     return $result;
 145 }
 146
 147
 148 =item canonpath($file)
 149
 150 This function returns a cleaned path. It simplifies double //, and remove
 151 /./ and /../ intelligently. For /../ it simplifies the path only if the
 152 previous element is not a symlink. Thus it should only be used on real
 153 filenames.
 154
 155 =cut
 156
 157 sub canonpath($) {
 158     my $path = shift;
 159     $path = File::Spec->canonpath($path);
 160     my ($v, $dirs, $file) = File::Spec->splitpath($path);
 161     my @dirs = File::Spec->splitdir($dirs);
 162     my @new;
 163     foreach my $d (@dirs) {
 164         if ($d eq '..') {
 165             if (scalar(@new) > 0 and $new[-1] ne '..') {
 166                 next if $new[-1] eq ''; # Root directory has no parent
 167                 my $parent = File::Spec->catpath($v,
 168                         File::Spec->catdir(@new), '');
 169                 if (not -l $parent) {
 170                     pop @new;
 171                 } else {
 172                     push @new, $d;
 173                 }
 174             } else {
 175                 push @new, $d;
 176             }
 177         } else {
 178             push @new, $d;
 179         }
 180     }
 181     return File::Spec->catpath($v, File::Spec->catdir(@new), $file);
 182 }
 183
 184 =item $newpath = resolve_symlink($symlink)
 185
 186 Return the filename of the file pointed by the symlink. The new name is
 187 canonicalized by canonpath().
 188
 189 =cut
 190
 191 sub resolve_symlink($) {
 192     my $symlink = shift;
 193     my $content = readlink($symlink);
 194     return unless defined $content;
 195     if (File::Spec->file_name_is_absolute($content)) {
 196         return canonpath($content);
 197     } else {
 198         my ($link_v, $link_d, $link_f) = File::Spec->splitpath($symlink);
 199         my ($cont_v, $cont_d, $cont_f) = File::Spec->splitpath($content);
 200         my $new = File::Spec->catpath($link_v, $link_d . '/' . $cont_d, $cont_f);
 201         return canonpath($new);
 202     }
 203 }
 204
 205
 206 =item $cmdpath = find_command($command)
 207
 208 Return the path of the command if defined and available on an absolute or
 209 relative path or on the $PATH, undef otherwise.
 210
 211 =cut
 212
 213 sub find_command($) {
 214     my $cmd = shift;
 215
 216     return if not $cmd;
 217     if ($cmd =~ m{/}) {
 218         return "$cmd" if -x "$cmd";
 219     } else {
 220         foreach my $dir (split(/:/, $ENV{PATH})) {
 221             return "$dir/$cmd" if -x "$dir/$cmd";
 222         }
 223     }
 224     return;
 225 }
 226
 227 =item $control_file = get_control_path($pkg, $filetype)
 228
 229 Return the path of the control file of type $filetype for the given
 230 package.
 231
 232 =item @control_files = get_control_path($pkg)
 233
 234 Return the path of all available control files for the given package.
 235
 236 =cut
 237
 238 sub get_control_path($;$) {
 239     my ($pkg, $filetype) = @_;
 240     my $control_file;
 241     my @exec = ('dpkg-query', '--control-path', $pkg);
 242     push @exec, $filetype if defined $filetype;
 243     spawn(exec => \@exec, wait_child => 1, to_string => \$control_file);
 244     chomp($control_file);
 245     if (defined $filetype) {
 246         return if $control_file eq '';
 247         return $control_file;
 248     }
 249     return () if $control_file eq '';
 250     return split(/\n/, $control_file);
 251 }
 252
 253 =item $file = find_build_file($basename)
 254
 255 Selects the right variant of the given file: the arch-specific variant
 256 ("$basename.$arch") has priority over the OS-specific variant
 257 ("$basename.$os") which has priority over the default variant
 258 ("$basename"). If none of the files exists, then it returns undef.
 259
 260 =item @files = find_build_file($basename)
 261
 262 Return the available variants of the given file. Returns an empty
 263 list if none of the files exists.
 264
 265 =cut
 266
 267 sub find_build_file($) {
 268     my $base = shift;
 269     my $host_arch = get_host_arch();
 270     my ($abi, $libc, $host_os, $cpu) = debarch_to_debtuple($host_arch);
 271     my @files;
 272     foreach my $f ("$base.$host_arch", "$base.$host_os", "$base") {
 273         push @files, $f if -f $f;
 274     }
 275     return @files if wantarray;
 276     return $files[0] if scalar @files;
 277     return;
 278 }
 279
 280 =back
 281
 282 =head1 CHANGES
 283
 284 =head2 Version 1.04 (dpkg 1.17.11)
 285
 286 Update semantics: find_command() now handles an empty or undef argument.
 287
 288 =head2 Version 1.03 (dpkg 1.16.1)
 289
 290 New function: find_build_file()
 291
 292 =head2 Version 1.02 (dpkg 1.16.0)
 293
 294 New function: get_control_path()
 295
 296 =head2 Version 1.01 (dpkg 1.15.8)
 297
 298 New function: find_command()
 299
 300 =head2 Version 1.00 (dpkg 1.15.6)
 301
 302 Mark the module as public.
 303
 304 =cut
 305
 306 1;