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