File: | Dpkg/Path.pm |
Coverage: | 74.6% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
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 | 47 47 47 | 136 3 525 | use strict; | ||||
20 | 47 47 47 | 91 1 1432 | use warnings; | ||||
21 | |||||||
22 | our $VERSION = '1.05'; | ||||||
23 | our @EXPORT_OK = qw( | ||||||
24 | canonpath | ||||||
25 | resolve_symlink | ||||||
26 | check_files_are_the_same | ||||||
27 | check_directory_traversal | ||||||
28 | find_command | ||||||
29 | find_build_file | ||||||
30 | get_control_path | ||||||
31 | get_pkg_root_dir | ||||||
32 | guess_pkg_root_dir | ||||||
33 | relative_to_pkg_root | ||||||
34 | ); | ||||||
35 | |||||||
36 | 47 47 47 | 98 16 523 | use Exporter qw(import); | ||||
37 | 47 47 47 | 4681 20423 1995 | use Errno qw(ENOENT); | ||||
38 | 47 47 47 | 98 1 633 | use File::Spec; | ||||
39 | 47 47 47 | 89 5 897 | use File::Find; | ||||
40 | 47 47 47 | 55 47 619 | use Cwd qw(realpath); | ||||
41 | |||||||
42 | 47 47 47 | 94 41 1174 | use Dpkg::ErrorHandling; | ||||
43 | 47 47 47 | 50 44 1057 | use Dpkg::Gettext; | ||||
44 | 47 47 47 | 7075 44 1370 | use Dpkg::Arch qw(get_host_arch debarch_to_debtuple); | ||||
45 | 47 47 47 | 6827 47 25692 | use Dpkg::IPC; | ||||
46 | |||||||
47 | =encoding utf8 | ||||||
48 | |||||||
49 - 69 | =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 | ||||||
70 | |||||||
71 | sub get_pkg_root_dir($) { | ||||||
72 | 6 | 1 | 3 | my $file = shift; | |||
73 | 6 | 11 | $file =~ s{/+$}{}; | ||||
74 | 6 | 19 | $file =~ s{/+[^/]+$}{} if not -d $file; | ||||
75 | 6 | 6 | while ($file) { | ||||
76 | 21 | 51 | return $file if -d "$file/DEBIAN"; | ||||
77 | 18 | 14 | last if $file !~ m{/}; | ||||
78 | 15 | 23 | $file =~ s{/+[^/]+$}{}; | ||||
79 | } | ||||||
80 | 3 | 2 | return; | ||||
81 | } | ||||||
82 | |||||||
83 - 87 | =item relative_to_pkg_root($file) Returns the filename relative to get_pkg_root_dir($file). =cut | ||||||
88 | |||||||
89 | sub relative_to_pkg_root($) { | ||||||
90 | 2 | 1 | 2 | my $file = shift; | |||
91 | 2 | 1 | my $pkg_root = get_pkg_root_dir($file); | ||||
92 | 2 | 3 | if (defined $pkg_root) { | ||||
93 | 1 | 0 | $pkg_root .= '/'; | ||||
94 | 1 | 10 | return $file if ($file =~ s/^\Q$pkg_root\E//); | ||||
95 | } | ||||||
96 | 1 | 1 | return; | ||||
97 | } | ||||||
98 | |||||||
99 - 109 | =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 | ||||||
110 | |||||||
111 | sub guess_pkg_root_dir($) { | ||||||
112 | 2 | 1 | 2 | my $file = shift; | |||
113 | 2 | 2 | my $root = get_pkg_root_dir($file); | ||||
114 | 2 | 3 | return $root if defined $root; | ||||
115 | |||||||
116 | 1 | 2 | $file =~ s{/+$}{}; | ||||
117 | 1 | 2 | $file =~ s{/+[^/]+$}{} if not -d $file; | ||||
118 | 1 | 1 | my $parent = $file; | ||||
119 | 1 | 3 | while ($file) { | ||||
120 | 3 | 5 | $parent =~ s{/+[^/]+$}{}; | ||||
121 | 3 | 6 | last if not -d $parent; | ||||
122 | 3 | 1 | return $file if check_files_are_the_same('debian', $parent); | ||||
123 | 2 | 2 | $file = $parent; | ||||
124 | 2 | 2 | last if $file !~ m{/}; | ||||
125 | } | ||||||
126 | 0 | 0 | return; | ||||
127 | } | ||||||
128 | |||||||
129 - 135 | =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 | ||||||
136 | |||||||
137 | sub check_files_are_the_same($$;$) { | ||||||
138 | 5 | 1 | 6 | my ($file1, $file2, $resolve_symlink) = @_; | |||
139 | |||||||
140 | 5 | 4 | return 1 if $file1 eq $file2; | ||||
141 | 4 | 22 | return 0 if ((! -e $file1) || (! -e $file2)); | ||||
142 | 4 | 1 | my (@stat1, @stat2); | ||||
143 | 4 | 18 | if ($resolve_symlink) { | ||||
144 | 0 | 0 | @stat1 = stat($file1); | ||||
145 | 0 | 0 | @stat2 = stat($file2); | ||||
146 | } else { | ||||||
147 | 4 | 10 | @stat1 = lstat($file1); | ||||
148 | 4 | 7 | @stat2 = lstat($file2); | ||||
149 | } | ||||||
150 | 4 | 8 | my $result = ($stat1[0] == $stat2[0]) && ($stat1[1] == $stat2[1]); | ||||
151 | 4 | 5 | return $result; | ||||
152 | } | ||||||
153 | |||||||
154 | |||||||
155 - 162 | =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 | ||||||
163 | |||||||
164 | sub canonpath($) { | ||||||
165 | 7 | 1 | 5 | my $path = shift; | |||
166 | 7 | 10 | $path = File::Spec->canonpath($path); | ||||
167 | 7 | 29 | my ($v, $dirs, $file) = File::Spec->splitpath($path); | ||||
168 | 7 | 15 | my @dirs = File::Spec->splitdir($dirs); | ||||
169 | 7 | 5 | my @new; | ||||
170 | 7 | 3 | foreach my $d (@dirs) { | ||||
171 | 38 | 18 | if ($d eq '..') { | ||||
172 | 5 | 11 | if (scalar(@new) > 0 and $new[-1] ne '..') { | ||||
173 | 5 | 5 | next if $new[-1] eq ''; # Root directory has no parent | ||||
174 | 5 | 14 | my $parent = File::Spec->catpath($v, | ||||
175 | File::Spec->catdir(@new), ''); | ||||||
176 | 5 | 15 | if (not -l $parent) { | ||||
177 | 4 | 4 | pop @new; | ||||
178 | } else { | ||||||
179 | 1 | 1 | push @new, $d; | ||||
180 | } | ||||||
181 | } else { | ||||||
182 | 0 | 0 | push @new, $d; | ||||
183 | } | ||||||
184 | } else { | ||||||
185 | 33 | 25 | push @new, $d; | ||||
186 | } | ||||||
187 | } | ||||||
188 | 7 | 38 | return File::Spec->catpath($v, File::Spec->catdir(@new), $file); | ||||
189 | } | ||||||
190 | |||||||
191 - 196 | =item $newpath = resolve_symlink($symlink) Return the filename of the file pointed by the symlink. The new name is canonicalized by canonpath(). =cut | ||||||
197 | |||||||
198 | sub resolve_symlink($) { | ||||||
199 | 3 | 1 | 3 | my $symlink = shift; | |||
200 | 3 | 10 | my $content = readlink($symlink); | ||||
201 | 3 | 3 | return unless defined $content; | ||||
202 | 3 | 8 | if (File::Spec->file_name_is_absolute($content)) { | ||||
203 | 1 | 1 | return canonpath($content); | ||||
204 | } else { | ||||||
205 | 2 | 8 | my ($link_v, $link_d, $link_f) = File::Spec->splitpath($symlink); | ||||
206 | 2 | 5 | my ($cont_v, $cont_d, $cont_f) = File::Spec->splitpath($content); | ||||
207 | 2 | 6 | my $new = File::Spec->catpath($link_v, $link_d . '/' . $cont_d, $cont_f); | ||||
208 | 2 | 2 | return canonpath($new); | ||||
209 | } | ||||||
210 | } | ||||||
211 | |||||||
212 - 217 | =item check_directory_traversal($basedir, $dir) This function verifies that the directory $dir does not contain any symlink that goes beyond $basedir (which should be either equal or a parent of $dir). =cut | ||||||
218 | |||||||
219 | sub check_directory_traversal { | ||||||
220 | 18 | 1 | 16 | my ($basedir, $dir) = @_; | |||
221 | |||||||
222 | 18 | 128 | my $canon_basedir = realpath($basedir); | ||||
223 | # On Solaris /dev/null points to /devices/pseudo/mm@0:null. | ||||||
224 | 18 | 58 | my $canon_devnull = realpath('/dev/null'); | ||||
225 | my $check_symlinks = sub { | ||||||
226 | 77 | 942 | my $canon_pathname = realpath($_); | ||||
227 | 77 | 65 | if (not defined $canon_pathname) { | ||||
228 | 1 | 3 | return if $! == ENOENT; | ||||
229 | |||||||
230 | 1 | 1 | syserr(g_("pathname '%s' cannot be canonicalized"), $_); | ||||
231 | } | ||||||
232 | 76 | 56 | return if $canon_pathname eq $canon_devnull; | ||||
233 | 75 | 46 | return if $canon_pathname eq $canon_basedir; | ||||
234 | 75 | 1107 | return if $canon_pathname =~ m{^\Q$canon_basedir/\E}; | ||||
235 | |||||||
236 | 10 | 9 | error(g_("pathname '%s' points outside source root (to '%s')"), | ||||
237 | $_, $canon_pathname); | ||||||
238 | 18 | 44 | }; | ||||
239 | |||||||
240 | 18 | 591 | find({ | ||||
241 | wanted => $check_symlinks, | ||||||
242 | no_chdir => 1, | ||||||
243 | follow => 1, | ||||||
244 | follow_skip => 2, | ||||||
245 | }, $dir); | ||||||
246 | |||||||
247 | 7 | 26 | return; | ||||
248 | } | ||||||
249 | |||||||
250 - 255 | =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 | ||||||
256 | |||||||
257 | sub find_command($) { | ||||||
258 | 292 | 1 | 496 | my $cmd = shift; | |||
259 | |||||||
260 | 292 | 918 | return if not $cmd; | ||||
261 | 292 | 797 | if ($cmd =~ m{/}) { | ||||
262 | 0 | 0 | return "$cmd" if -x "$cmd"; | ||||
263 | } else { | ||||||
264 | 292 | 1344 | foreach my $dir (split(/:/, $ENV{PATH})) { | ||||
265 | 2044 | 17708 | return "$dir/$cmd" if -x "$dir/$cmd"; | ||||
266 | } | ||||||
267 | } | ||||||
268 | 0 | return; | |||||
269 | } | ||||||
270 | |||||||
271 - 280 | =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 | ||||||
281 | |||||||
282 | sub get_control_path($;$) { | ||||||
283 | 0 | 1 | my ($pkg, $filetype) = @_; | ||||
284 | 0 | my $control_file; | |||||
285 | 0 | my @exec = ('dpkg-query', '--control-path', $pkg); | |||||
286 | 0 | push @exec, $filetype if defined $filetype; | |||||
287 | 0 | spawn(exec => \@exec, wait_child => 1, to_string => \$control_file); | |||||
288 | 0 | chomp($control_file); | |||||
289 | 0 | if (defined $filetype) { | |||||
290 | 0 | return if $control_file eq ''; | |||||
291 | 0 | return $control_file; | |||||
292 | } | ||||||
293 | 0 | return () if $control_file eq ''; | |||||
294 | 0 | return split(/\n/, $control_file); | |||||
295 | } | ||||||
296 | |||||||
297 - 309 | =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 | ||||||
310 | |||||||
311 | sub find_build_file($) { | ||||||
312 | 0 | 1 | my $base = shift; | ||||
313 | 0 | my $host_arch = get_host_arch(); | |||||
314 | 0 | my ($abi, $libc, $host_os, $cpu) = debarch_to_debtuple($host_arch); | |||||
315 | 0 | my @files; | |||||
316 | 0 | foreach my $f ("$base.$host_arch", "$base.$host_os", "$base") { | |||||
317 | 0 | push @files, $f if -f $f; | |||||
318 | } | ||||||
319 | 0 | return @files if wantarray; | |||||
320 | 0 | return $files[0] if scalar @files; | |||||
321 | 0 | return; | |||||
322 | } | ||||||
323 | |||||||
324 | =back | ||||||
325 | |||||||
326 - 352 | =head1 CHANGES =head2 Version 1.05 (dpkg 1.20.4) New function: check_directory_traversal(). =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 | ||||||
353 | |||||||
354 | 1; |