[14489] | 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;
|
---|