1 | package File::Find;
|
---|
2 | use 5.006;
|
---|
3 | use strict;
|
---|
4 | use warnings;
|
---|
5 | use warnings::register;
|
---|
6 | our $VERSION = '1.10';
|
---|
7 | require Exporter;
|
---|
8 | require Cwd;
|
---|
9 |
|
---|
10 | #
|
---|
11 | # Modified to ensure sub-directory traversal order is not inverded by stack
|
---|
12 | # push and pops. That is remains in the same order as in the directory file,
|
---|
13 | # or user pre-processing (EG:sorted).
|
---|
14 | #
|
---|
15 |
|
---|
16 | =head1 NAME
|
---|
17 |
|
---|
18 | File::Find - Traverse a directory tree.
|
---|
19 |
|
---|
20 | =head1 SYNOPSIS
|
---|
21 |
|
---|
22 | use File::Find;
|
---|
23 | find(\&wanted, @directories_to_search);
|
---|
24 | sub wanted { ... }
|
---|
25 |
|
---|
26 | use File::Find;
|
---|
27 | finddepth(\&wanted, @directories_to_search);
|
---|
28 | sub wanted { ... }
|
---|
29 |
|
---|
30 | use File::Find;
|
---|
31 | find({ wanted => \&process, follow => 1 }, '.');
|
---|
32 |
|
---|
33 | =head1 DESCRIPTION
|
---|
34 |
|
---|
35 | These are functions for searching through directory trees doing work
|
---|
36 | on each file found similar to the Unix I<find> command. File::Find
|
---|
37 | exports two functions, C<find> and C<finddepth>. They work similarly
|
---|
38 | but have subtle differences.
|
---|
39 |
|
---|
40 | =over 4
|
---|
41 |
|
---|
42 | =item B<find>
|
---|
43 |
|
---|
44 | find(\&wanted, @directories);
|
---|
45 | find(\%options, @directories);
|
---|
46 |
|
---|
47 | C<find()> does a depth-first search over the given C<@directories> in
|
---|
48 | the order they are given. For each file or directory found, it calls
|
---|
49 | the C<&wanted> subroutine. (See below for details on how to use the
|
---|
50 | C<&wanted> function). Additionally, for each directory found, it will
|
---|
51 | C<chdir()> into that directory and continue the search, invoking the
|
---|
52 | C<&wanted> function on each file or subdirectory in the directory.
|
---|
53 |
|
---|
54 | =item B<finddepth>
|
---|
55 |
|
---|
56 | finddepth(\&wanted, @directories);
|
---|
57 | finddepth(\%options, @directories);
|
---|
58 |
|
---|
59 | C<finddepth()> works just like C<find()> except that is invokes the
|
---|
60 | C<&wanted> function for a directory I<after> invoking it for the
|
---|
61 | directory's contents. It does a postorder traversal instead of a
|
---|
62 | preorder traversal, working from the bottom of the directory tree up
|
---|
63 | where C<find()> works from the top of the tree down.
|
---|
64 |
|
---|
65 | =back
|
---|
66 |
|
---|
67 | =head2 %options
|
---|
68 |
|
---|
69 | The first argument to C<find()> is either a code reference to your
|
---|
70 | C<&wanted> function, or a hash reference describing the operations
|
---|
71 | to be performed for each file. The
|
---|
72 | code reference is described in L<The wanted function> below.
|
---|
73 |
|
---|
74 | Here are the possible keys for the hash:
|
---|
75 |
|
---|
76 | =over 3
|
---|
77 |
|
---|
78 | =item C<wanted>
|
---|
79 |
|
---|
80 | The value should be a code reference. This code reference is
|
---|
81 | described in L<The wanted function> below.
|
---|
82 |
|
---|
83 | =item C<bydepth>
|
---|
84 |
|
---|
85 | Reports the name of a directory only AFTER all its entries
|
---|
86 | have been reported. Entry point C<finddepth()> is a shortcut for
|
---|
87 | specifying C<<{ bydepth => 1 }>> in the first argument of C<find()>.
|
---|
88 |
|
---|
89 | =item C<preprocess>
|
---|
90 |
|
---|
91 | The value should be a code reference. This code reference is used to
|
---|
92 | preprocess the current directory. The name of the currently processed
|
---|
93 | directory is in C<$File::Find::dir>. Your preprocessing function is
|
---|
94 | called after C<readdir()>, but before the loop that calls the C<wanted()>
|
---|
95 | function. It is called with a list of strings (actually file/directory
|
---|
96 | names) and is expected to return a list of strings. The code can be
|
---|
97 | used to sort the file/directory names alphabetically, numerically,
|
---|
98 | or to filter out directory entries based on their name alone. When
|
---|
99 | I<follow> or I<follow_fast> are in effect, C<preprocess> is a no-op.
|
---|
100 |
|
---|
101 | =item C<postprocess>
|
---|
102 |
|
---|
103 | The value should be a code reference. It is invoked just before leaving
|
---|
104 | the currently processed directory. It is called in void context with no
|
---|
105 | arguments. The name of the current directory is in C<$File::Find::dir>. This
|
---|
106 | hook is handy for summarizing a directory, such as calculating its disk
|
---|
107 | usage. When I<follow> or I<follow_fast> are in effect, C<postprocess> is a
|
---|
108 | no-op.
|
---|
109 |
|
---|
110 | =item C<follow>
|
---|
111 |
|
---|
112 | Causes symbolic links to be followed. Since directory trees with symbolic
|
---|
113 | links (followed) may contain files more than once and may even have
|
---|
114 | cycles, a hash has to be built up with an entry for each file.
|
---|
115 | This might be expensive both in space and time for a large
|
---|
116 | directory tree. See I<follow_fast> and I<follow_skip> below.
|
---|
117 | If either I<follow> or I<follow_fast> is in effect:
|
---|
118 |
|
---|
119 | =over 6
|
---|
120 |
|
---|
121 | =item *
|
---|
122 |
|
---|
123 | It is guaranteed that an I<lstat> has been called before the user's
|
---|
124 | C<wanted()> function is called. This enables fast file checks involving S<_>.
|
---|
125 | Note that this guarantee no longer holds if I<follow> or I<follow_fast>
|
---|
126 | are not set.
|
---|
127 |
|
---|
128 | =item *
|
---|
129 |
|
---|
130 | There is a variable C<$File::Find::fullname> which holds the absolute
|
---|
131 | pathname of the file with all symbolic links resolved. If the link is
|
---|
132 | a dangling symbolic link, then fullname will be set to C<undef>.
|
---|
133 |
|
---|
134 | =back
|
---|
135 |
|
---|
136 | This is a no-op on Win32.
|
---|
137 |
|
---|
138 | =item C<follow_fast>
|
---|
139 |
|
---|
140 | This is similar to I<follow> except that it may report some files more
|
---|
141 | than once. It does detect cycles, however. Since only symbolic links
|
---|
142 | have to be hashed, this is much cheaper both in space and time. If
|
---|
143 | processing a file more than once (by the user's C<wanted()> function)
|
---|
144 | is worse than just taking time, the option I<follow> should be used.
|
---|
145 |
|
---|
146 | This is also a no-op on Win32.
|
---|
147 |
|
---|
148 | =item C<follow_skip>
|
---|
149 |
|
---|
150 | C<follow_skip==1>, which is the default, causes all files which are
|
---|
151 | neither directories nor symbolic links to be ignored if they are about
|
---|
152 | to be processed a second time. If a directory or a symbolic link
|
---|
153 | are about to be processed a second time, File::Find dies.
|
---|
154 |
|
---|
155 | C<follow_skip==0> causes File::Find to die if any file is about to be
|
---|
156 | processed a second time.
|
---|
157 |
|
---|
158 | C<follow_skip==2> causes File::Find to ignore any duplicate files and
|
---|
159 | directories but to proceed normally otherwise.
|
---|
160 |
|
---|
161 | =item C<dangling_symlinks>
|
---|
162 |
|
---|
163 | If true and a code reference, will be called with the symbolic link
|
---|
164 | name and the directory it lives in as arguments. Otherwise, if true
|
---|
165 | and warnings are on, warning "symbolic_link_name is a dangling
|
---|
166 | symbolic link\n" will be issued. If false, the dangling symbolic link
|
---|
167 | will be silently ignored.
|
---|
168 |
|
---|
169 | =item C<no_chdir>
|
---|
170 |
|
---|
171 | Does not C<chdir()> to each directory as it recurses. The C<wanted()>
|
---|
172 | function will need to be aware of this, of course. In this case,
|
---|
173 | C<$_> will be the same as C<$File::Find::name>.
|
---|
174 |
|
---|
175 | =item C<untaint>
|
---|
176 |
|
---|
177 | If find is used in taint-mode (-T command line switch or if EUID != UID
|
---|
178 | or if EGID != GID) then internally directory names have to be untainted
|
---|
179 | before they can be chdir'ed to. Therefore they are checked against a regular
|
---|
180 | expression I<untaint_pattern>. Note that all names passed to the user's
|
---|
181 | I<wanted()> function are still tainted. If this option is used while
|
---|
182 | not in taint-mode, C<untaint> is a no-op.
|
---|
183 |
|
---|
184 | =item C<untaint_pattern>
|
---|
185 |
|
---|
186 | See above. This should be set using the C<qr> quoting operator.
|
---|
187 | The default is set to C<qr|^([-+@\w./]+)$|>.
|
---|
188 | Note that the parentheses are vital.
|
---|
189 |
|
---|
190 | =item C<untaint_skip>
|
---|
191 |
|
---|
192 | If set, a directory which fails the I<untaint_pattern> is skipped,
|
---|
193 | including all its sub-directories. The default is to 'die' in such a case.
|
---|
194 |
|
---|
195 | =back
|
---|
196 |
|
---|
197 | =head2 The wanted function
|
---|
198 |
|
---|
199 | The C<wanted()> function does whatever verifications you want on
|
---|
200 | each file and directory. Note that despite its name, the C<wanted()>
|
---|
201 | function is a generic callback function, and does B<not> tell
|
---|
202 | File::Find if a file is "wanted" or not. In fact, its return value
|
---|
203 | is ignored.
|
---|
204 |
|
---|
205 | The wanted function takes no arguments but rather does its work
|
---|
206 | through a collection of variables.
|
---|
207 |
|
---|
208 | =over 4
|
---|
209 |
|
---|
210 | =item C<$File::Find::dir> is the current directory name,
|
---|
211 |
|
---|
212 | =item C<$_> is the current filename within that directory
|
---|
213 |
|
---|
214 | =item C<$File::Find::name> is the complete pathname to the file.
|
---|
215 |
|
---|
216 | =back
|
---|
217 |
|
---|
218 | Don't modify these variables.
|
---|
219 |
|
---|
220 | For example, when examining the file F</some/path/foo.ext> you will have:
|
---|
221 |
|
---|
222 | $File::Find::dir = /some/path/
|
---|
223 | $_ = foo.ext
|
---|
224 | $File::Find::name = /some/path/foo.ext
|
---|
225 |
|
---|
226 | You are chdir()'d to C<$File::Find::dir> when the function is called,
|
---|
227 | unless C<no_chdir> was specified. Note that when changing to
|
---|
228 | directories is in effect the root directory (F</>) is a somewhat
|
---|
229 | special case inasmuch as the concatenation of C<$File::Find::dir>,
|
---|
230 | C<'/'> and C<$_> is not literally equal to C<$File::Find::name>. The
|
---|
231 | table below summarizes all variants:
|
---|
232 |
|
---|
233 | $File::Find::name $File::Find::dir $_
|
---|
234 | default / / .
|
---|
235 | no_chdir=>0 /etc / etc
|
---|
236 | /etc/x /etc x
|
---|
237 |
|
---|
238 | no_chdir=>1 / / /
|
---|
239 | /etc / /etc
|
---|
240 | /etc/x /etc /etc/x
|
---|
241 |
|
---|
242 |
|
---|
243 | When <follow> or <follow_fast> are in effect, there is
|
---|
244 | also a C<$File::Find::fullname>. The function may set
|
---|
245 | C<$File::Find::prune> to prune the tree unless C<bydepth> was
|
---|
246 | specified. Unless C<follow> or C<follow_fast> is specified, for
|
---|
247 | compatibility reasons (find.pl, find2perl) there are in addition the
|
---|
248 | following globals available: C<$File::Find::topdir>,
|
---|
249 | C<$File::Find::topdev>, C<$File::Find::topino>,
|
---|
250 | C<$File::Find::topmode> and C<$File::Find::topnlink>.
|
---|
251 |
|
---|
252 | This library is useful for the C<find2perl> tool, which when fed,
|
---|
253 |
|
---|
254 | find2perl / -name .nfs\* -mtime +7 \
|
---|
255 | -exec rm -f {} \; -o -fstype nfs -prune
|
---|
256 |
|
---|
257 | produces something like:
|
---|
258 |
|
---|
259 | sub wanted {
|
---|
260 | /^\.nfs.*\z/s &&
|
---|
261 | (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_)) &&
|
---|
262 | int(-M _) > 7 &&
|
---|
263 | unlink($_)
|
---|
264 | ||
|
---|
265 | ($nlink || (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_))) &&
|
---|
266 | $dev < 0 &&
|
---|
267 | ($File::Find::prune = 1);
|
---|
268 | }
|
---|
269 |
|
---|
270 | Notice the C<_> in the above C<int(-M _)>: the C<_> is a magical
|
---|
271 | filehandle that caches the information from the preceding
|
---|
272 | C<stat()>, C<lstat()>, or filetest.
|
---|
273 |
|
---|
274 | Here's another interesting wanted function. It will find all symbolic
|
---|
275 | links that don't resolve:
|
---|
276 |
|
---|
277 | sub wanted {
|
---|
278 | -l && !-e && print "bogus link: $File::Find::name\n";
|
---|
279 | }
|
---|
280 |
|
---|
281 | See also the script C<pfind> on CPAN for a nice application of this
|
---|
282 | module.
|
---|
283 |
|
---|
284 | =head1 WARNINGS
|
---|
285 |
|
---|
286 | If you run your program with the C<-w> switch, or if you use the
|
---|
287 | C<warnings> pragma, File::Find will report warnings for several weird
|
---|
288 | situations. You can disable these warnings by putting the statement
|
---|
289 |
|
---|
290 | no warnings 'File::Find';
|
---|
291 |
|
---|
292 | in the appropriate scope. See L<perllexwarn> for more info about lexical
|
---|
293 | warnings.
|
---|
294 |
|
---|
295 | =head1 CAVEAT
|
---|
296 |
|
---|
297 | =over 2
|
---|
298 |
|
---|
299 | =item $dont_use_nlink
|
---|
300 |
|
---|
301 | You can set the variable C<$File::Find::dont_use_nlink> to 1, if you want to
|
---|
302 | force File::Find to always stat directories. This was used for file systems
|
---|
303 | that do not have an C<nlink> count matching the number of sub-directories.
|
---|
304 | Examples are ISO-9660 (CD-ROM), AFS, HPFS (OS/2 file system), FAT (DOS file
|
---|
305 | system) and a couple of others.
|
---|
306 |
|
---|
307 | You shouldn't need to set this variable, since File::Find should now detect
|
---|
308 | such file systems on-the-fly and switch itself to using stat. This works even
|
---|
309 | for parts of your file system, like a mounted CD-ROM.
|
---|
310 |
|
---|
311 | If you do set C<$File::Find::dont_use_nlink> to 1, you will notice slow-downs.
|
---|
312 |
|
---|
313 | =item symlinks
|
---|
314 |
|
---|
315 | Be aware that the option to follow symbolic links can be dangerous.
|
---|
316 | Depending on the structure of the directory tree (including symbolic
|
---|
317 | links to directories) you might traverse a given (physical) directory
|
---|
318 | more than once (only if C<follow_fast> is in effect).
|
---|
319 | Furthermore, deleting or changing files in a symbolically linked directory
|
---|
320 | might cause very unpleasant surprises, since you delete or change files
|
---|
321 | in an unknown directory.
|
---|
322 |
|
---|
323 | =back
|
---|
324 |
|
---|
325 | =head1 NOTES
|
---|
326 |
|
---|
327 | =over 4
|
---|
328 |
|
---|
329 | =item *
|
---|
330 |
|
---|
331 | Mac OS (Classic) users should note a few differences:
|
---|
332 |
|
---|
333 | =over 4
|
---|
334 |
|
---|
335 | =item *
|
---|
336 |
|
---|
337 | The path separator is ':', not '/', and the current directory is denoted
|
---|
338 | as ':', not '.'. You should be careful about specifying relative pathnames.
|
---|
339 | While a full path always begins with a volume name, a relative pathname
|
---|
340 | should always begin with a ':'. If specifying a volume name only, a
|
---|
341 | trailing ':' is required.
|
---|
342 |
|
---|
343 | =item *
|
---|
344 |
|
---|
345 | C<$File::Find::dir> is guaranteed to end with a ':'. If C<$_>
|
---|
346 | contains the name of a directory, that name may or may not end with a
|
---|
347 | ':'. Likewise, C<$File::Find::name>, which contains the complete
|
---|
348 | pathname to that directory, and C<$File::Find::fullname>, which holds
|
---|
349 | the absolute pathname of that directory with all symbolic links resolved,
|
---|
350 | may or may not end with a ':'.
|
---|
351 |
|
---|
352 | =item *
|
---|
353 |
|
---|
354 | The default C<untaint_pattern> (see above) on Mac OS is set to
|
---|
355 | C<qr|^(.+)$|>. Note that the parentheses are vital.
|
---|
356 |
|
---|
357 | =item *
|
---|
358 |
|
---|
359 | The invisible system file "Icon\015" is ignored. While this file may
|
---|
360 | appear in every directory, there are some more invisible system files
|
---|
361 | on every volume, which are all located at the volume root level (i.e.
|
---|
362 | "MacintoshHD:"). These system files are B<not> excluded automatically.
|
---|
363 | Your filter may use the following code to recognize invisible files or
|
---|
364 | directories (requires Mac::Files):
|
---|
365 |
|
---|
366 | use Mac::Files;
|
---|
367 |
|
---|
368 | # invisible() -- returns 1 if file/directory is invisible,
|
---|
369 | # 0 if it's visible or undef if an error occurred
|
---|
370 |
|
---|
371 | sub invisible($) {
|
---|
372 | my $file = shift;
|
---|
373 | my ($fileCat, $fileInfo);
|
---|
374 | my $invisible_flag = 1 << 14;
|
---|
375 |
|
---|
376 | if ( $fileCat = FSpGetCatInfo($file) ) {
|
---|
377 | if ($fileInfo = $fileCat->ioFlFndrInfo() ) {
|
---|
378 | return (($fileInfo->fdFlags & $invisible_flag) && 1);
|
---|
379 | }
|
---|
380 | }
|
---|
381 | return undef;
|
---|
382 | }
|
---|
383 |
|
---|
384 | Generally, invisible files are system files, unless an odd application
|
---|
385 | decides to use invisible files for its own purposes. To distinguish
|
---|
386 | such files from system files, you have to look at the B<type> and B<creator>
|
---|
387 | file attributes. The MacPerl built-in functions C<GetFileInfo(FILE)> and
|
---|
388 | C<SetFileInfo(CREATOR, TYPE, FILES)> offer access to these attributes
|
---|
389 | (see MacPerl.pm for details).
|
---|
390 |
|
---|
391 | Files that appear on the desktop actually reside in an (hidden) directory
|
---|
392 | named "Desktop Folder" on the particular disk volume. Note that, although
|
---|
393 | all desktop files appear to be on the same "virtual" desktop, each disk
|
---|
394 | volume actually maintains its own "Desktop Folder" directory.
|
---|
395 |
|
---|
396 | =back
|
---|
397 |
|
---|
398 | =back
|
---|
399 |
|
---|
400 | =head1 BUGS AND CAVEATS
|
---|
401 |
|
---|
402 | Despite the name of the C<finddepth()> function, both C<find()> and
|
---|
403 | C<finddepth()> perform a depth-first search of the directory
|
---|
404 | hierarchy.
|
---|
405 |
|
---|
406 | =head1 HISTORY
|
---|
407 |
|
---|
408 | File::Find used to produce incorrect results if called recursively.
|
---|
409 | During the development of perl 5.8 this bug was fixed.
|
---|
410 | The first fixed version of File::Find was 1.01.
|
---|
411 |
|
---|
412 | =cut
|
---|
413 |
|
---|
414 | our @ISA = qw(Exporter);
|
---|
415 | our @EXPORT = qw(find finddepth);
|
---|
416 |
|
---|
417 |
|
---|
418 | use strict;
|
---|
419 | my $Is_VMS;
|
---|
420 | my $Is_MacOS;
|
---|
421 |
|
---|
422 | require File::Basename;
|
---|
423 | require File::Spec;
|
---|
424 |
|
---|
425 | # Should ideally be my() not our() but local() currently
|
---|
426 | # refuses to operate on lexicals
|
---|
427 |
|
---|
428 | our %SLnkSeen;
|
---|
429 | our ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
|
---|
430 | $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat,
|
---|
431 | $pre_process, $post_process, $dangling_symlinks);
|
---|
432 |
|
---|
433 | sub contract_name {
|
---|
434 | my ($cdir,$fn) = @_;
|
---|
435 |
|
---|
436 | return substr($cdir,0,rindex($cdir,'/')) if $fn eq $File::Find::current_dir;
|
---|
437 |
|
---|
438 | $cdir = substr($cdir,0,rindex($cdir,'/')+1);
|
---|
439 |
|
---|
440 | $fn =~ s|^\./||;
|
---|
441 |
|
---|
442 | my $abs_name= $cdir . $fn;
|
---|
443 |
|
---|
444 | if (substr($fn,0,3) eq '../') {
|
---|
445 | 1 while $abs_name =~ s!/[^/]*/\.\./!/!;
|
---|
446 | }
|
---|
447 |
|
---|
448 | return $abs_name;
|
---|
449 | }
|
---|
450 |
|
---|
451 | # return the absolute name of a directory or file
|
---|
452 | sub contract_name_Mac {
|
---|
453 | my ($cdir,$fn) = @_;
|
---|
454 | my $abs_name;
|
---|
455 |
|
---|
456 | if ($fn =~ /^(:+)(.*)$/) { # valid pathname starting with a ':'
|
---|
457 |
|
---|
458 | my $colon_count = length ($1);
|
---|
459 | if ($colon_count == 1) {
|
---|
460 | $abs_name = $cdir . $2;
|
---|
461 | return $abs_name;
|
---|
462 | }
|
---|
463 | else {
|
---|
464 | # need to move up the tree, but
|
---|
465 | # only if it's not a volume name
|
---|
466 | for (my $i=1; $i<$colon_count; $i++) {
|
---|
467 | unless ($cdir =~ /^[^:]+:$/) { # volume name
|
---|
468 | $cdir =~ s/[^:]+:$//;
|
---|
469 | }
|
---|
470 | else {
|
---|
471 | return undef;
|
---|
472 | }
|
---|
473 | }
|
---|
474 | $abs_name = $cdir . $2;
|
---|
475 | return $abs_name;
|
---|
476 | }
|
---|
477 |
|
---|
478 | }
|
---|
479 | else {
|
---|
480 |
|
---|
481 | # $fn may be a valid path to a directory or file or (dangling)
|
---|
482 | # symlink, without a leading ':'
|
---|
483 | if ( (-e $fn) || (-l $fn) ) {
|
---|
484 | if ($fn =~ /^[^:]+:/) { # a volume name like DataHD:*
|
---|
485 | return $fn; # $fn is already an absolute path
|
---|
486 | }
|
---|
487 | else {
|
---|
488 | $abs_name = $cdir . $fn;
|
---|
489 | return $abs_name;
|
---|
490 | }
|
---|
491 | }
|
---|
492 | else { # argh!, $fn is not a valid directory/file
|
---|
493 | return undef;
|
---|
494 | }
|
---|
495 | }
|
---|
496 | }
|
---|
497 |
|
---|
498 | sub PathCombine($$) {
|
---|
499 | my ($Base,$Name) = @_;
|
---|
500 | my $AbsName;
|
---|
501 |
|
---|
502 | if ($Is_MacOS) {
|
---|
503 | # $Name is the resolved symlink (always a full path on MacOS),
|
---|
504 | # i.e. there's no need to call contract_name_Mac()
|
---|
505 | $AbsName = $Name;
|
---|
506 |
|
---|
507 | # (simple) check for recursion
|
---|
508 | if ( ( $Base =~ /^$AbsName/) && (-d $AbsName) ) { # recursion
|
---|
509 | return undef;
|
---|
510 | }
|
---|
511 | }
|
---|
512 | else {
|
---|
513 | if (substr($Name,0,1) eq '/') {
|
---|
514 | $AbsName= $Name;
|
---|
515 | }
|
---|
516 | else {
|
---|
517 | $AbsName= contract_name($Base,$Name);
|
---|
518 | }
|
---|
519 |
|
---|
520 | # (simple) check for recursion
|
---|
521 | my $newlen= length($AbsName);
|
---|
522 | if ($newlen <= length($Base)) {
|
---|
523 | if (($newlen == length($Base) || substr($Base,$newlen,1) eq '/')
|
---|
524 | && $AbsName eq substr($Base,0,$newlen))
|
---|
525 | {
|
---|
526 | return undef;
|
---|
527 | }
|
---|
528 | }
|
---|
529 | }
|
---|
530 | return $AbsName;
|
---|
531 | }
|
---|
532 |
|
---|
533 | sub Follow_SymLink($) {
|
---|
534 | my ($AbsName) = @_;
|
---|
535 |
|
---|
536 | my ($NewName,$DEV, $INO);
|
---|
537 | ($DEV, $INO)= lstat $AbsName;
|
---|
538 |
|
---|
539 | while (-l _) {
|
---|
540 | if ($SLnkSeen{$DEV, $INO}++) {
|
---|
541 | if ($follow_skip < 2) {
|
---|
542 | die "$AbsName is encountered a second time";
|
---|
543 | }
|
---|
544 | else {
|
---|
545 | return undef;
|
---|
546 | }
|
---|
547 | }
|
---|
548 | $NewName= PathCombine($AbsName, readlink($AbsName));
|
---|
549 | unless(defined $NewName) {
|
---|
550 | if ($follow_skip < 2) {
|
---|
551 | die "$AbsName is a recursive symbolic link";
|
---|
552 | }
|
---|
553 | else {
|
---|
554 | return undef;
|
---|
555 | }
|
---|
556 | }
|
---|
557 | else {
|
---|
558 | $AbsName= $NewName;
|
---|
559 | }
|
---|
560 | ($DEV, $INO) = lstat($AbsName);
|
---|
561 | return undef unless defined $DEV; # dangling symbolic link
|
---|
562 | }
|
---|
563 |
|
---|
564 | if ($full_check && defined $DEV && $SLnkSeen{$DEV, $INO}++) {
|
---|
565 | if ( ($follow_skip < 1) || ((-d _) && ($follow_skip < 2)) ) {
|
---|
566 | die "$AbsName encountered a second time";
|
---|
567 | }
|
---|
568 | else {
|
---|
569 | return undef;
|
---|
570 | }
|
---|
571 | }
|
---|
572 |
|
---|
573 | return $AbsName;
|
---|
574 | }
|
---|
575 |
|
---|
576 | our($dir, $name, $fullname, $prune);
|
---|
577 | sub _find_dir_symlnk($$$);
|
---|
578 | sub _find_dir($$$);
|
---|
579 |
|
---|
580 | # check whether or not a scalar variable is tainted
|
---|
581 | # (code straight from the Camel, 3rd ed., page 561)
|
---|
582 | sub is_tainted_pp {
|
---|
583 | my $arg = shift;
|
---|
584 | my $nada = substr($arg, 0, 0); # zero-length
|
---|
585 | local $@;
|
---|
586 | eval { eval "# $nada" };
|
---|
587 | return length($@) != 0;
|
---|
588 | }
|
---|
589 |
|
---|
590 | sub _find_opt {
|
---|
591 | my $wanted = shift;
|
---|
592 | die "invalid top directory" unless defined $_[0];
|
---|
593 |
|
---|
594 | # This function must local()ize everything because callbacks may
|
---|
595 | # call find() or finddepth()
|
---|
596 |
|
---|
597 | local %SLnkSeen;
|
---|
598 | local ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
|
---|
599 | $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat,
|
---|
600 | $pre_process, $post_process, $dangling_symlinks);
|
---|
601 | local($dir, $name, $fullname, $prune);
|
---|
602 | local *_ = \my $a;
|
---|
603 |
|
---|
604 | my $cwd = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::getcwd();
|
---|
605 | my $cwd_untainted = $cwd;
|
---|
606 | my $check_t_cwd = 1;
|
---|
607 | $wanted_callback = $wanted->{wanted};
|
---|
608 | $bydepth = $wanted->{bydepth};
|
---|
609 | $pre_process = $wanted->{preprocess};
|
---|
610 | $post_process = $wanted->{postprocess};
|
---|
611 | $no_chdir = $wanted->{no_chdir};
|
---|
612 | $full_check = $^O eq 'MSWin32' ? 0 : $wanted->{follow};
|
---|
613 | $follow = $^O eq 'MSWin32' ? 0 :
|
---|
614 | $full_check || $wanted->{follow_fast};
|
---|
615 | $follow_skip = $wanted->{follow_skip};
|
---|
616 | $untaint = $wanted->{untaint};
|
---|
617 | $untaint_pat = $wanted->{untaint_pattern};
|
---|
618 | $untaint_skip = $wanted->{untaint_skip};
|
---|
619 | $dangling_symlinks = $wanted->{dangling_symlinks};
|
---|
620 |
|
---|
621 | # for compatibility reasons (find.pl, find2perl)
|
---|
622 | local our ($topdir, $topdev, $topino, $topmode, $topnlink);
|
---|
623 |
|
---|
624 | # a symbolic link to a directory doesn't increase the link count
|
---|
625 | $avoid_nlink = $follow || $File::Find::dont_use_nlink;
|
---|
626 |
|
---|
627 | my ($abs_dir, $Is_Dir);
|
---|
628 |
|
---|
629 | Proc_Top_Item:
|
---|
630 | foreach my $TOP (@_) {
|
---|
631 | my $top_item = $TOP;
|
---|
632 |
|
---|
633 | ($topdev,$topino,$topmode,$topnlink) = $follow ? stat $top_item : lstat $top_item;
|
---|
634 |
|
---|
635 | if ($Is_MacOS) {
|
---|
636 | $top_item = ":$top_item"
|
---|
637 | if ( (-d _) && ( $top_item !~ /:/ ) );
|
---|
638 | } elsif ($^O eq 'MSWin32') {
|
---|
639 | $top_item =~ s|/\z|| unless $top_item =~ m|\w:/$|;
|
---|
640 | }
|
---|
641 | else {
|
---|
642 | $top_item =~ s|/\z|| unless $top_item eq '/';
|
---|
643 | }
|
---|
644 |
|
---|
645 | $Is_Dir= 0;
|
---|
646 |
|
---|
647 | if ($follow) {
|
---|
648 |
|
---|
649 | if ($Is_MacOS) {
|
---|
650 | $cwd = "$cwd:" unless ($cwd =~ /:$/); # for safety
|
---|
651 |
|
---|
652 | if ($top_item eq $File::Find::current_dir) {
|
---|
653 | $abs_dir = $cwd;
|
---|
654 | }
|
---|
655 | else {
|
---|
656 | $abs_dir = contract_name_Mac($cwd, $top_item);
|
---|
657 | unless (defined $abs_dir) {
|
---|
658 | warnings::warnif "Can't determine absolute path for $top_item (No such file or directory)\n";
|
---|
659 | next Proc_Top_Item;
|
---|
660 | }
|
---|
661 | }
|
---|
662 |
|
---|
663 | }
|
---|
664 | else {
|
---|
665 | if (substr($top_item,0,1) eq '/') {
|
---|
666 | $abs_dir = $top_item;
|
---|
667 | }
|
---|
668 | elsif ($top_item eq $File::Find::current_dir) {
|
---|
669 | $abs_dir = $cwd;
|
---|
670 | }
|
---|
671 | else { # care about any ../
|
---|
672 | $abs_dir = contract_name("$cwd/",$top_item);
|
---|
673 | }
|
---|
674 | }
|
---|
675 | $abs_dir= Follow_SymLink($abs_dir);
|
---|
676 | unless (defined $abs_dir) {
|
---|
677 | if ($dangling_symlinks) {
|
---|
678 | if (ref $dangling_symlinks eq 'CODE') {
|
---|
679 | $dangling_symlinks->($top_item, $cwd);
|
---|
680 | } else {
|
---|
681 | warnings::warnif "$top_item is a dangling symbolic link\n";
|
---|
682 | }
|
---|
683 | }
|
---|
684 | next Proc_Top_Item;
|
---|
685 | }
|
---|
686 |
|
---|
687 | if (-d _) {
|
---|
688 | _find_dir_symlnk($wanted, $abs_dir, $top_item);
|
---|
689 | $Is_Dir= 1;
|
---|
690 | }
|
---|
691 | }
|
---|
692 | else { # no follow
|
---|
693 | $topdir = $top_item;
|
---|
694 | unless (defined $topnlink) {
|
---|
695 | warnings::warnif "Can't stat $top_item: $!\n";
|
---|
696 | next Proc_Top_Item;
|
---|
697 | }
|
---|
698 | if (-d _) {
|
---|
699 | $top_item =~ s/\.dir\z//i if $Is_VMS;
|
---|
700 | _find_dir($wanted, $top_item, $topnlink);
|
---|
701 | $Is_Dir= 1;
|
---|
702 | }
|
---|
703 | else {
|
---|
704 | $abs_dir= $top_item;
|
---|
705 | }
|
---|
706 | }
|
---|
707 |
|
---|
708 | unless ($Is_Dir) {
|
---|
709 | unless (($_,$dir) = File::Basename::fileparse($abs_dir)) {
|
---|
710 | if ($Is_MacOS) {
|
---|
711 | ($dir,$_) = (':', $top_item); # $File::Find::dir, $_
|
---|
712 | }
|
---|
713 | else {
|
---|
714 | ($dir,$_) = ('./', $top_item);
|
---|
715 | }
|
---|
716 | }
|
---|
717 |
|
---|
718 | $abs_dir = $dir;
|
---|
719 | if (( $untaint ) && (is_tainted($dir) )) {
|
---|
720 | ( $abs_dir ) = $dir =~ m|$untaint_pat|;
|
---|
721 | unless (defined $abs_dir) {
|
---|
722 | if ($untaint_skip == 0) {
|
---|
723 | die "directory $dir is still tainted";
|
---|
724 | }
|
---|
725 | else {
|
---|
726 | next Proc_Top_Item;
|
---|
727 | }
|
---|
728 | }
|
---|
729 | }
|
---|
730 |
|
---|
731 | unless ($no_chdir || chdir $abs_dir) {
|
---|
732 | warnings::warnif "Couldn't chdir $abs_dir: $!\n";
|
---|
733 | next Proc_Top_Item;
|
---|
734 | }
|
---|
735 |
|
---|
736 | $name = $abs_dir . $_; # $File::Find::name
|
---|
737 | $_ = $name if $no_chdir;
|
---|
738 |
|
---|
739 | { $wanted_callback->() }; # protect against wild "next"
|
---|
740 |
|
---|
741 | }
|
---|
742 |
|
---|
743 | unless ( $no_chdir ) {
|
---|
744 | if ( ($check_t_cwd) && (($untaint) && (is_tainted($cwd) )) ) {
|
---|
745 | ( $cwd_untainted ) = $cwd =~ m|$untaint_pat|;
|
---|
746 | unless (defined $cwd_untainted) {
|
---|
747 | die "insecure cwd in find(depth)";
|
---|
748 | }
|
---|
749 | $check_t_cwd = 0;
|
---|
750 | }
|
---|
751 | unless (chdir $cwd_untainted) {
|
---|
752 | die "Can't cd to $cwd: $!\n";
|
---|
753 | }
|
---|
754 | }
|
---|
755 | }
|
---|
756 | }
|
---|
757 |
|
---|
758 | # API:
|
---|
759 | # $wanted
|
---|
760 | # $p_dir : "parent directory"
|
---|
761 | # $nlink : what came back from the stat
|
---|
762 | # preconditions:
|
---|
763 | # chdir (if not no_chdir) to dir
|
---|
764 |
|
---|
765 | sub _find_dir($$$) {
|
---|
766 | my ($wanted, $p_dir, $nlink) = @_;
|
---|
767 | my ($CdLvl,$Level) = (0,0);
|
---|
768 | my @Stack;
|
---|
769 | my @filenames;
|
---|
770 | my ($subcount,$sub_nlink);
|
---|
771 | my $SE= [];
|
---|
772 | my $dir_name= $p_dir;
|
---|
773 | my $dir_pref;
|
---|
774 | my $dir_rel = $File::Find::current_dir;
|
---|
775 | my $tainted = 0;
|
---|
776 | my $no_nlink;
|
---|
777 |
|
---|
778 | if ($Is_MacOS) {
|
---|
779 | $dir_pref= ($p_dir =~ /:$/) ? $p_dir : "$p_dir:"; # preface
|
---|
780 | } elsif ($^O eq 'MSWin32') {
|
---|
781 | $dir_pref = ($p_dir =~ m|\w:/$| ? $p_dir : "$p_dir/" );
|
---|
782 | }
|
---|
783 | else {
|
---|
784 | $dir_pref= ( $p_dir eq '/' ? '/' : "$p_dir/" );
|
---|
785 | }
|
---|
786 |
|
---|
787 | local ($dir, $name, $prune, *DIR);
|
---|
788 |
|
---|
789 | unless ( $no_chdir || ($p_dir eq $File::Find::current_dir)) {
|
---|
790 | my $udir = $p_dir;
|
---|
791 | if (( $untaint ) && (is_tainted($p_dir) )) {
|
---|
792 | ( $udir ) = $p_dir =~ m|$untaint_pat|;
|
---|
793 | unless (defined $udir) {
|
---|
794 | if ($untaint_skip == 0) {
|
---|
795 | die "directory $p_dir is still tainted";
|
---|
796 | }
|
---|
797 | else {
|
---|
798 | return;
|
---|
799 | }
|
---|
800 | }
|
---|
801 | }
|
---|
802 | unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) {
|
---|
803 | warnings::warnif "Can't cd to $udir: $!\n";
|
---|
804 | return;
|
---|
805 | }
|
---|
806 | }
|
---|
807 |
|
---|
808 | # push the starting directory
|
---|
809 | push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth;
|
---|
810 |
|
---|
811 | if ($Is_MacOS) {
|
---|
812 | $p_dir = $dir_pref; # ensure trailing ':'
|
---|
813 | }
|
---|
814 |
|
---|
815 | while (defined $SE) {
|
---|
816 | unless ($bydepth) {
|
---|
817 | $dir= $p_dir; # $File::Find::dir
|
---|
818 | $name= $dir_name; # $File::Find::name
|
---|
819 | $_= ($no_chdir ? $dir_name : $dir_rel ); # $_
|
---|
820 | # prune may happen here
|
---|
821 | $prune= 0;
|
---|
822 | { $wanted_callback->() }; # protect against wild "next"
|
---|
823 | next if $prune;
|
---|
824 | }
|
---|
825 |
|
---|
826 | # change to that directory
|
---|
827 | unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) {
|
---|
828 | my $udir= $dir_rel;
|
---|
829 | if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_rel) )) ) {
|
---|
830 | ( $udir ) = $dir_rel =~ m|$untaint_pat|;
|
---|
831 | unless (defined $udir) {
|
---|
832 | if ($untaint_skip == 0) {
|
---|
833 | if ($Is_MacOS) {
|
---|
834 | die "directory ($p_dir) $dir_rel is still tainted";
|
---|
835 | }
|
---|
836 | else {
|
---|
837 | die "directory (" . ($p_dir ne '/' ? $p_dir : '') . "/) $dir_rel is still tainted";
|
---|
838 | }
|
---|
839 | } else { # $untaint_skip == 1
|
---|
840 | next;
|
---|
841 | }
|
---|
842 | }
|
---|
843 | }
|
---|
844 | unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) {
|
---|
845 | if ($Is_MacOS) {
|
---|
846 | warnings::warnif "Can't cd to ($p_dir) $udir: $!\n";
|
---|
847 | }
|
---|
848 | else {
|
---|
849 | warnings::warnif "Can't cd to (" .
|
---|
850 | ($p_dir ne '/' ? $p_dir : '') . "/) $udir: $!\n";
|
---|
851 | }
|
---|
852 | next;
|
---|
853 | }
|
---|
854 | $CdLvl++;
|
---|
855 | }
|
---|
856 |
|
---|
857 | if ($Is_MacOS) {
|
---|
858 | $dir_name = "$dir_name:" unless ($dir_name =~ /:$/);
|
---|
859 | }
|
---|
860 |
|
---|
861 | $dir= $dir_name; # $File::Find::dir
|
---|
862 |
|
---|
863 | # Get the list of files in the current directory.
|
---|
864 | unless (opendir DIR, ($no_chdir ? $dir_name : $File::Find::current_dir)) {
|
---|
865 | warnings::warnif "Can't opendir($dir_name): $!\n";
|
---|
866 | next;
|
---|
867 | }
|
---|
868 | @filenames = readdir DIR;
|
---|
869 | closedir(DIR);
|
---|
870 | @filenames = $pre_process->(@filenames) if $pre_process;
|
---|
871 | push @Stack,[$CdLvl,$dir_name,"",-2] if $post_process;
|
---|
872 |
|
---|
873 | # default: use whatever was specifid
|
---|
874 | # (if $nlink >= 2, and $avoid_nlink == 0, this will switch back)
|
---|
875 | $no_nlink = $avoid_nlink;
|
---|
876 | # if dir has wrong nlink count, force switch to slower stat method
|
---|
877 | $no_nlink = 1 if ($nlink < 2);
|
---|
878 |
|
---|
879 | if ($nlink == 2 && !$no_nlink) {
|
---|
880 | # This dir has no subdirectories.
|
---|
881 | for my $FN (@filenames) {
|
---|
882 | next if $FN =~ $File::Find::skip_pattern;
|
---|
883 |
|
---|
884 | $name = $dir_pref . $FN; # $File::Find::name
|
---|
885 | $_ = ($no_chdir ? $name : $FN); # $_
|
---|
886 | { $wanted_callback->() }; # protect against wild "next"
|
---|
887 | }
|
---|
888 |
|
---|
889 | }
|
---|
890 | else {
|
---|
891 | # This dir has subdirectories.
|
---|
892 | $subcount = $nlink - 2;
|
---|
893 |
|
---|
894 | # HACK: insert directories at this position. so as to preserve
|
---|
895 | # the user pre-processed ordering of files.
|
---|
896 | # EG: directory traversal is in user sorted order, not at random.
|
---|
897 | my $stack_top = @Stack;
|
---|
898 |
|
---|
899 | for my $FN (@filenames) {
|
---|
900 | next if $FN =~ $File::Find::skip_pattern;
|
---|
901 | if ($subcount > 0 || $no_nlink) {
|
---|
902 | # Seen all the subdirs?
|
---|
903 | # check for directoriness.
|
---|
904 | # stat is faster for a file in the current directory
|
---|
905 | $sub_nlink = (lstat ($no_chdir ? $dir_pref . $FN : $FN))[3];
|
---|
906 |
|
---|
907 | if (-d _) {
|
---|
908 | --$subcount;
|
---|
909 | $FN =~ s/\.dir\z//i if $Is_VMS;
|
---|
910 | # HACK: replace push to preserve dir traversal order
|
---|
911 | #push @Stack,[$CdLvl,$dir_name,$FN,$sub_nlink];
|
---|
912 | splice @Stack, $stack_top, 0,
|
---|
913 | [$CdLvl,$dir_name,$FN,$sub_nlink];
|
---|
914 | }
|
---|
915 | else {
|
---|
916 | $name = $dir_pref . $FN; # $File::Find::name
|
---|
917 | $_= ($no_chdir ? $name : $FN); # $_
|
---|
918 | { $wanted_callback->() }; # protect against wild "next"
|
---|
919 | }
|
---|
920 | }
|
---|
921 | else {
|
---|
922 | $name = $dir_pref . $FN; # $File::Find::name
|
---|
923 | $_= ($no_chdir ? $name : $FN); # $_
|
---|
924 | { $wanted_callback->() }; # protect against wild "next"
|
---|
925 | }
|
---|
926 | }
|
---|
927 | }
|
---|
928 | }
|
---|
929 | continue {
|
---|
930 | while ( defined ($SE = pop @Stack) ) {
|
---|
931 | ($Level, $p_dir, $dir_rel, $nlink) = @$SE;
|
---|
932 | if ($CdLvl > $Level && !$no_chdir) {
|
---|
933 | my $tmp;
|
---|
934 | if ($Is_MacOS) {
|
---|
935 | $tmp = (':' x ($CdLvl-$Level)) . ':';
|
---|
936 | }
|
---|
937 | else {
|
---|
938 | $tmp = join('/',('..') x ($CdLvl-$Level));
|
---|
939 | }
|
---|
940 | die "Can't cd to $dir_name" . $tmp
|
---|
941 | unless chdir ($tmp);
|
---|
942 | $CdLvl = $Level;
|
---|
943 | }
|
---|
944 |
|
---|
945 | if ($Is_MacOS) {
|
---|
946 | # $pdir always has a trailing ':', except for the starting dir,
|
---|
947 | # where $dir_rel eq ':'
|
---|
948 | $dir_name = "$p_dir$dir_rel";
|
---|
949 | $dir_pref = "$dir_name:";
|
---|
950 | }
|
---|
951 | elsif ($^O eq 'MSWin32') {
|
---|
952 | $dir_name = ($p_dir =~ m|\w:/$| ? "$p_dir$dir_rel" : "$p_dir/$dir_rel");
|
---|
953 | $dir_pref = "$dir_name/";
|
---|
954 | }
|
---|
955 | else {
|
---|
956 | $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel");
|
---|
957 | $dir_pref = "$dir_name/";
|
---|
958 | }
|
---|
959 |
|
---|
960 | if ( $nlink == -2 ) {
|
---|
961 | $name = $dir = $p_dir; # $File::Find::name / dir
|
---|
962 | $_ = $File::Find::current_dir;
|
---|
963 | $post_process->(); # End-of-directory processing
|
---|
964 | }
|
---|
965 | elsif ( $nlink < 0 ) { # must be finddepth, report dirname now
|
---|
966 | $name = $dir_name;
|
---|
967 | if ($Is_MacOS) {
|
---|
968 | if ($dir_rel eq ':') { # must be the top dir, where we started
|
---|
969 | $name =~ s|:$||; # $File::Find::name
|
---|
970 | $p_dir = "$p_dir:" unless ($p_dir =~ /:$/);
|
---|
971 | }
|
---|
972 | $dir = $p_dir; # $File::Find::dir
|
---|
973 | $_ = ($no_chdir ? $name : $dir_rel); # $_
|
---|
974 | }
|
---|
975 | else {
|
---|
976 | if ( substr($name,-2) eq '/.' ) {
|
---|
977 | substr($name, length($name) == 2 ? -1 : -2) = '';
|
---|
978 | }
|
---|
979 | $dir = $p_dir;
|
---|
980 | $_ = ($no_chdir ? $dir_name : $dir_rel );
|
---|
981 | if ( substr($_,-2) eq '/.' ) {
|
---|
982 | substr($_, length($_) == 2 ? -1 : -2) = '';
|
---|
983 | }
|
---|
984 | }
|
---|
985 | { $wanted_callback->() }; # protect against wild "next"
|
---|
986 | }
|
---|
987 | else {
|
---|
988 | push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth;
|
---|
989 | last;
|
---|
990 | }
|
---|
991 | }
|
---|
992 | }
|
---|
993 | }
|
---|
994 |
|
---|
995 |
|
---|
996 | # API:
|
---|
997 | # $wanted
|
---|
998 | # $dir_loc : absolute location of a dir
|
---|
999 | # $p_dir : "parent directory"
|
---|
1000 | # preconditions:
|
---|
1001 | # chdir (if not no_chdir) to dir
|
---|
1002 |
|
---|
1003 | sub _find_dir_symlnk($$$) {
|
---|
1004 | my ($wanted, $dir_loc, $p_dir) = @_; # $dir_loc is the absolute directory
|
---|
1005 | my @Stack;
|
---|
1006 | my @filenames;
|
---|
1007 | my $new_loc;
|
---|
1008 | my $updir_loc = $dir_loc; # untainted parent directory
|
---|
1009 | my $SE = [];
|
---|
1010 | my $dir_name = $p_dir;
|
---|
1011 | my $dir_pref;
|
---|
1012 | my $loc_pref;
|
---|
1013 | my $dir_rel = $File::Find::current_dir;
|
---|
1014 | my $byd_flag; # flag for pending stack entry if $bydepth
|
---|
1015 | my $tainted = 0;
|
---|
1016 | my $ok = 1;
|
---|
1017 |
|
---|
1018 | if ($Is_MacOS) {
|
---|
1019 | $dir_pref = ($p_dir =~ /:$/) ? "$p_dir" : "$p_dir:";
|
---|
1020 | $loc_pref = ($dir_loc =~ /:$/) ? "$dir_loc" : "$dir_loc:";
|
---|
1021 | } else {
|
---|
1022 | $dir_pref = ( $p_dir eq '/' ? '/' : "$p_dir/" );
|
---|
1023 | $loc_pref = ( $dir_loc eq '/' ? '/' : "$dir_loc/" );
|
---|
1024 | }
|
---|
1025 |
|
---|
1026 | local ($dir, $name, $fullname, $prune, *DIR);
|
---|
1027 |
|
---|
1028 | unless ($no_chdir) {
|
---|
1029 | # untaint the topdir
|
---|
1030 | if (( $untaint ) && (is_tainted($dir_loc) )) {
|
---|
1031 | ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|; # parent dir, now untainted
|
---|
1032 | # once untainted, $updir_loc is pushed on the stack (as parent directory);
|
---|
1033 | # hence, we don't need to untaint the parent directory every time we chdir
|
---|
1034 | # to it later
|
---|
1035 | unless (defined $updir_loc) {
|
---|
1036 | if ($untaint_skip == 0) {
|
---|
1037 | die "directory $dir_loc is still tainted";
|
---|
1038 | }
|
---|
1039 | else {
|
---|
1040 | return;
|
---|
1041 | }
|
---|
1042 | }
|
---|
1043 | }
|
---|
1044 | $ok = chdir($updir_loc) unless ($p_dir eq $File::Find::current_dir);
|
---|
1045 | unless ($ok) {
|
---|
1046 | warnings::warnif "Can't cd to $updir_loc: $!\n";
|
---|
1047 | return;
|
---|
1048 | }
|
---|
1049 | }
|
---|
1050 |
|
---|
1051 | push @Stack,[$dir_loc,$updir_loc,$p_dir,$dir_rel,-1] if $bydepth;
|
---|
1052 |
|
---|
1053 | if ($Is_MacOS) {
|
---|
1054 | $p_dir = $dir_pref; # ensure trailing ':'
|
---|
1055 | }
|
---|
1056 |
|
---|
1057 | while (defined $SE) {
|
---|
1058 |
|
---|
1059 | unless ($bydepth) {
|
---|
1060 | # change (back) to parent directory (always untainted)
|
---|
1061 | unless ($no_chdir) {
|
---|
1062 | unless (chdir $updir_loc) {
|
---|
1063 | warnings::warnif "Can't cd to $updir_loc: $!\n";
|
---|
1064 | next;
|
---|
1065 | }
|
---|
1066 | }
|
---|
1067 | $dir= $p_dir; # $File::Find::dir
|
---|
1068 | $name= $dir_name; # $File::Find::name
|
---|
1069 | $_= ($no_chdir ? $dir_name : $dir_rel ); # $_
|
---|
1070 | $fullname= $dir_loc; # $File::Find::fullname
|
---|
1071 | # prune may happen here
|
---|
1072 | $prune= 0;
|
---|
1073 | lstat($_); # make sure file tests with '_' work
|
---|
1074 | { $wanted_callback->() }; # protect against wild "next"
|
---|
1075 | next if $prune;
|
---|
1076 | }
|
---|
1077 |
|
---|
1078 | # change to that directory
|
---|
1079 | unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) {
|
---|
1080 | $updir_loc = $dir_loc;
|
---|
1081 | if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_loc) )) ) {
|
---|
1082 | # untaint $dir_loc, what will be pushed on the stack as (untainted) parent dir
|
---|
1083 | ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|;
|
---|
1084 | unless (defined $updir_loc) {
|
---|
1085 | if ($untaint_skip == 0) {
|
---|
1086 | die "directory $dir_loc is still tainted";
|
---|
1087 | }
|
---|
1088 | else {
|
---|
1089 | next;
|
---|
1090 | }
|
---|
1091 | }
|
---|
1092 | }
|
---|
1093 | unless (chdir $updir_loc) {
|
---|
1094 | warnings::warnif "Can't cd to $updir_loc: $!\n";
|
---|
1095 | next;
|
---|
1096 | }
|
---|
1097 | }
|
---|
1098 |
|
---|
1099 | if ($Is_MacOS) {
|
---|
1100 | $dir_name = "$dir_name:" unless ($dir_name =~ /:$/);
|
---|
1101 | }
|
---|
1102 |
|
---|
1103 | $dir = $dir_name; # $File::Find::dir
|
---|
1104 |
|
---|
1105 | # Get the list of files in the current directory.
|
---|
1106 | unless (opendir DIR, ($no_chdir ? $dir_loc : $File::Find::current_dir)) {
|
---|
1107 | warnings::warnif "Can't opendir($dir_loc): $!\n";
|
---|
1108 | next;
|
---|
1109 | }
|
---|
1110 | @filenames = readdir DIR;
|
---|
1111 | closedir(DIR);
|
---|
1112 |
|
---|
1113 | for my $FN (@filenames) {
|
---|
1114 | next if $FN =~ $File::Find::skip_pattern;
|
---|
1115 |
|
---|
1116 | # follow symbolic links / do an lstat
|
---|
1117 | $new_loc = Follow_SymLink($loc_pref.$FN);
|
---|
1118 |
|
---|
1119 | # ignore if invalid symlink
|
---|
1120 | unless (defined $new_loc) {
|
---|
1121 | if ($dangling_symlinks) {
|
---|
1122 | if (ref $dangling_symlinks eq 'CODE') {
|
---|
1123 | $dangling_symlinks->($FN, $dir_pref);
|
---|
1124 | } else {
|
---|
1125 | warnings::warnif "$dir_pref$FN is a dangling symbolic link\n";
|
---|
1126 | }
|
---|
1127 | }
|
---|
1128 |
|
---|
1129 | $fullname = undef;
|
---|
1130 | $name = $dir_pref . $FN;
|
---|
1131 | $_ = ($no_chdir ? $name : $FN);
|
---|
1132 | { $wanted_callback->() };
|
---|
1133 | next;
|
---|
1134 | }
|
---|
1135 |
|
---|
1136 | if (-d _) {
|
---|
1137 | push @Stack,[$new_loc,$updir_loc,$dir_name,$FN,1];
|
---|
1138 | }
|
---|
1139 | else {
|
---|
1140 | $fullname = $new_loc; # $File::Find::fullname
|
---|
1141 | $name = $dir_pref . $FN; # $File::Find::name
|
---|
1142 | $_ = ($no_chdir ? $name : $FN); # $_
|
---|
1143 | { $wanted_callback->() }; # protect against wild "next"
|
---|
1144 | }
|
---|
1145 | }
|
---|
1146 |
|
---|
1147 | }
|
---|
1148 | continue {
|
---|
1149 | while (defined($SE = pop @Stack)) {
|
---|
1150 | ($dir_loc, $updir_loc, $p_dir, $dir_rel, $byd_flag) = @$SE;
|
---|
1151 | if ($Is_MacOS) {
|
---|
1152 | # $p_dir always has a trailing ':', except for the starting dir,
|
---|
1153 | # where $dir_rel eq ':'
|
---|
1154 | $dir_name = "$p_dir$dir_rel";
|
---|
1155 | $dir_pref = "$dir_name:";
|
---|
1156 | $loc_pref = ($dir_loc =~ /:$/) ? $dir_loc : "$dir_loc:";
|
---|
1157 | }
|
---|
1158 | else {
|
---|
1159 | $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel");
|
---|
1160 | $dir_pref = "$dir_name/";
|
---|
1161 | $loc_pref = "$dir_loc/";
|
---|
1162 | }
|
---|
1163 | if ( $byd_flag < 0 ) { # must be finddepth, report dirname now
|
---|
1164 | unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) {
|
---|
1165 | unless (chdir $updir_loc) { # $updir_loc (parent dir) is always untainted
|
---|
1166 | warnings::warnif "Can't cd to $updir_loc: $!\n";
|
---|
1167 | next;
|
---|
1168 | }
|
---|
1169 | }
|
---|
1170 | $fullname = $dir_loc; # $File::Find::fullname
|
---|
1171 | $name = $dir_name; # $File::Find::name
|
---|
1172 | if ($Is_MacOS) {
|
---|
1173 | if ($dir_rel eq ':') { # must be the top dir, where we started
|
---|
1174 | $name =~ s|:$||; # $File::Find::name
|
---|
1175 | $p_dir = "$p_dir:" unless ($p_dir =~ /:$/);
|
---|
1176 | }
|
---|
1177 | $dir = $p_dir; # $File::Find::dir
|
---|
1178 | $_ = ($no_chdir ? $name : $dir_rel); # $_
|
---|
1179 | }
|
---|
1180 | else {
|
---|
1181 | if ( substr($name,-2) eq '/.' ) {
|
---|
1182 | substr($name, length($name) == 2 ? -1 : -2) = ''; # $File::Find::name
|
---|
1183 | }
|
---|
1184 | $dir = $p_dir; # $File::Find::dir
|
---|
1185 | $_ = ($no_chdir ? $dir_name : $dir_rel); # $_
|
---|
1186 | if ( substr($_,-2) eq '/.' ) {
|
---|
1187 | substr($_, length($_) == 2 ? -1 : -2) = '';
|
---|
1188 | }
|
---|
1189 | }
|
---|
1190 |
|
---|
1191 | lstat($_); # make sure file tests with '_' work
|
---|
1192 | { $wanted_callback->() }; # protect against wild "next"
|
---|
1193 | }
|
---|
1194 | else {
|
---|
1195 | push @Stack,[$dir_loc, $updir_loc, $p_dir, $dir_rel,-1] if $bydepth;
|
---|
1196 | last;
|
---|
1197 | }
|
---|
1198 | }
|
---|
1199 | }
|
---|
1200 | }
|
---|
1201 |
|
---|
1202 |
|
---|
1203 | sub wrap_wanted {
|
---|
1204 | my $wanted = shift;
|
---|
1205 | if ( ref($wanted) eq 'HASH' ) {
|
---|
1206 | if ( $wanted->{follow} || $wanted->{follow_fast}) {
|
---|
1207 | $wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip};
|
---|
1208 | }
|
---|
1209 | if ( $wanted->{untaint} ) {
|
---|
1210 | $wanted->{untaint_pattern} = $File::Find::untaint_pattern
|
---|
1211 | unless defined $wanted->{untaint_pattern};
|
---|
1212 | $wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip};
|
---|
1213 | }
|
---|
1214 | return $wanted;
|
---|
1215 | }
|
---|
1216 | else {
|
---|
1217 | return { wanted => $wanted };
|
---|
1218 | }
|
---|
1219 | }
|
---|
1220 |
|
---|
1221 | sub find {
|
---|
1222 | my $wanted = shift;
|
---|
1223 | _find_opt(wrap_wanted($wanted), @_);
|
---|
1224 | }
|
---|
1225 |
|
---|
1226 | sub finddepth {
|
---|
1227 | my $wanted = wrap_wanted(shift);
|
---|
1228 | $wanted->{bydepth} = 1;
|
---|
1229 | _find_opt($wanted, @_);
|
---|
1230 | }
|
---|
1231 |
|
---|
1232 | # default
|
---|
1233 | $File::Find::skip_pattern = qr/^\.{1,2}\z/;
|
---|
1234 | $File::Find::untaint_pattern = qr|^([-+@\w./]+)$|;
|
---|
1235 |
|
---|
1236 | # These are hard-coded for now, but may move to hint files.
|
---|
1237 | if ($^O eq 'VMS') {
|
---|
1238 | $Is_VMS = 1;
|
---|
1239 | $File::Find::dont_use_nlink = 1;
|
---|
1240 | }
|
---|
1241 | elsif ($^O eq 'MacOS') {
|
---|
1242 | $Is_MacOS = 1;
|
---|
1243 | $File::Find::dont_use_nlink = 1;
|
---|
1244 | $File::Find::skip_pattern = qr/^Icon\015\z/;
|
---|
1245 | $File::Find::untaint_pattern = qr|^(.+)$|;
|
---|
1246 | }
|
---|
1247 |
|
---|
1248 | # this _should_ work properly on all platforms
|
---|
1249 | # where File::Find can be expected to work
|
---|
1250 | $File::Find::current_dir = File::Spec->curdir || '.';
|
---|
1251 |
|
---|
1252 | $File::Find::dont_use_nlink = 1
|
---|
1253 | if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32' ||
|
---|
1254 | $^O eq 'interix' || $^O eq 'cygwin' || $^O eq 'epoc' || $^O eq 'qnx' ||
|
---|
1255 | $^O eq 'nto';
|
---|
1256 |
|
---|
1257 | # Set dont_use_nlink in your hint file if your system's stat doesn't
|
---|
1258 | # report the number of links in a directory as an indication
|
---|
1259 | # of the number of files.
|
---|
1260 | # See, e.g. hints/machten.sh for MachTen 2.2.
|
---|
1261 | unless ($File::Find::dont_use_nlink) {
|
---|
1262 | require Config;
|
---|
1263 | $File::Find::dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'});
|
---|
1264 | }
|
---|
1265 |
|
---|
1266 | # We need a function that checks if a scalar is tainted. Either use the
|
---|
1267 | # Scalar::Util module's tainted() function or our (slower) pure Perl
|
---|
1268 | # fallback is_tainted_pp()
|
---|
1269 | {
|
---|
1270 | local $@;
|
---|
1271 | eval { require Scalar::Util };
|
---|
1272 | *is_tainted = $@ ? \&is_tainted_pp : \&Scalar::Util::tainted;
|
---|
1273 | }
|
---|
1274 |
|
---|
1275 | 1;
|
---|