Commit | Line | Data |
---|---|---|
1479465f GJ |
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; |