| Filename | /home/micha/.plenv/versions/5.38.2/lib/perl5/5.38.2/File/Find.pm |
| Statements | Executed 29 statements in 2.65ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 11µs | 11µs | File::Find::BEGIN@2 |
| 1 | 1 | 1 | 4µs | 8µs | File::Find::BEGIN@7 |
| 1 | 1 | 1 | 4µs | 5µs | File::Find::BEGIN@3 |
| 1 | 1 | 1 | 4µs | 5µs | File::Find::BEGIN@13 |
| 1 | 1 | 1 | 3µs | 19µs | File::Find::BEGIN@4 |
| 1 | 1 | 1 | 3µs | 16µs | File::Find::BEGIN@5 |
| 0 | 0 | 0 | 0s | 0s | File::Find::Follow_SymLink |
| 0 | 0 | 0 | 0s | 0s | File::Find::PathCombine |
| 0 | 0 | 0 | 0s | 0s | File::Find::_find_dir |
| 0 | 0 | 0 | 0s | 0s | File::Find::_find_dir_symlnk |
| 0 | 0 | 0 | 0s | 0s | File::Find::_find_opt |
| 0 | 0 | 0 | 0s | 0s | File::Find::_is_absolute |
| 0 | 0 | 0 | 0s | 0s | File::Find::_is_root |
| 0 | 0 | 0 | 0s | 0s | File::Find::contract_name |
| 0 | 0 | 0 | 0s | 0s | File::Find::find |
| 0 | 0 | 0 | 0s | 0s | File::Find::finddepth |
| 0 | 0 | 0 | 0s | 0s | File::Find::is_tainted_pp |
| 0 | 0 | 0 | 0s | 0s | File::Find::wrap_wanted |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package File::Find; | ||||
| 2 | 2 | 26µs | 1 | 11µs | # spent 11µs within File::Find::BEGIN@2 which was called:
# once (11µs+0s) by Archive::Zip::Archive::BEGIN@7 at line 2 # spent 11µs making 1 call to File::Find::BEGIN@2 |
| 3 | 2 | 14µs | 2 | 7µs | # spent 5µs (4+2) within File::Find::BEGIN@3 which was called:
# once (4µs+2µs) by Archive::Zip::Archive::BEGIN@7 at line 3 # spent 5µs making 1 call to File::Find::BEGIN@3
# spent 2µs making 1 call to strict::import |
| 4 | 2 | 12µs | 2 | 36µs | # spent 19µs (3+16) within File::Find::BEGIN@4 which was called:
# once (3µs+16µs) by Archive::Zip::Archive::BEGIN@7 at line 4 # spent 19µs making 1 call to File::Find::BEGIN@4
# spent 16µs making 1 call to warnings::import |
| 5 | 2 | 24µs | 2 | 28µs | # spent 16µs (3+13) within File::Find::BEGIN@5 which was called:
# once (3µs+13µs) by Archive::Zip::Archive::BEGIN@7 at line 5 # spent 16µs making 1 call to File::Find::BEGIN@5
# spent 13µs making 1 call to warnings::register::import |
| 6 | 1 | 300ns | our $VERSION = '1.43'; | ||
| 7 | 2 | 22µs | 2 | 12µs | # spent 8µs (4+4) within File::Find::BEGIN@7 which was called:
# once (4µs+4µs) by Archive::Zip::Archive::BEGIN@7 at line 7 # spent 8µs making 1 call to File::Find::BEGIN@7
# spent 4µs making 1 call to Exporter::import |
| 8 | 1 | 400ns | require Cwd; | ||
| 9 | |||||
| 10 | 1 | 800ns | our @EXPORT = qw(find finddepth); | ||
| 11 | |||||
| 12 | |||||
| 13 | 2 | 2.52ms | 2 | 6µs | # spent 5µs (4+1) within File::Find::BEGIN@13 which was called:
# once (4µs+1µs) by Archive::Zip::Archive::BEGIN@7 at line 13 # spent 5µs making 1 call to File::Find::BEGIN@13
# spent 1µs making 1 call to strict::import |
| 14 | 1 | 1µs | my $Is_VMS = $^O eq 'VMS'; | ||
| 15 | 1 | 200ns | my $Is_Win32 = $^O eq 'MSWin32'; | ||
| 16 | |||||
| 17 | 1 | 300ns | require File::Basename; | ||
| 18 | 1 | 200ns | require File::Spec; | ||
| 19 | |||||
| 20 | # Should ideally be my() not our() but local() currently | ||||
| 21 | # refuses to operate on lexicals | ||||
| 22 | |||||
| 23 | our %SLnkSeen; | ||||
| 24 | our ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow, | ||||
| 25 | $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat, | ||||
| 26 | $pre_process, $post_process, $dangling_symlinks); | ||||
| 27 | |||||
| 28 | sub contract_name { | ||||
| 29 | my ($cdir,$fn) = @_; | ||||
| 30 | |||||
| 31 | return substr($cdir,0,rindex($cdir,'/')) if $fn eq $File::Find::current_dir; | ||||
| 32 | |||||
| 33 | $cdir = substr($cdir,0,rindex($cdir,'/')+1); | ||||
| 34 | |||||
| 35 | $fn =~ s|^\./||; | ||||
| 36 | |||||
| 37 | my $abs_name= $cdir . $fn; | ||||
| 38 | |||||
| 39 | if (substr($fn,0,3) eq '../') { | ||||
| 40 | 1 while $abs_name =~ s!/[^/]*/\.\./+!/!; | ||||
| 41 | } | ||||
| 42 | |||||
| 43 | return $abs_name; | ||||
| 44 | } | ||||
| 45 | |||||
| 46 | sub _is_absolute { | ||||
| 47 | return $_[0] =~ m|^(?:[A-Za-z]:)?/| if $Is_Win32; | ||||
| 48 | return substr($_[0], 0, 1) eq '/'; | ||||
| 49 | } | ||||
| 50 | |||||
| 51 | sub _is_root { | ||||
| 52 | return $_[0] =~ m|^(?:[A-Za-z]:)?/\z| if $Is_Win32; | ||||
| 53 | return $_[0] eq '/'; | ||||
| 54 | } | ||||
| 55 | |||||
| 56 | sub PathCombine($$) { | ||||
| 57 | my ($Base,$Name) = @_; | ||||
| 58 | my $AbsName; | ||||
| 59 | |||||
| 60 | if (_is_absolute($Name)) { | ||||
| 61 | $AbsName= $Name; | ||||
| 62 | } | ||||
| 63 | else { | ||||
| 64 | $AbsName= contract_name($Base,$Name); | ||||
| 65 | } | ||||
| 66 | |||||
| 67 | # (simple) check for recursion | ||||
| 68 | my $newlen= length($AbsName); | ||||
| 69 | if ($newlen <= length($Base)) { | ||||
| 70 | if (($newlen == length($Base) || substr($Base,$newlen,1) eq '/') | ||||
| 71 | && $AbsName eq substr($Base,0,$newlen)) | ||||
| 72 | { | ||||
| 73 | return undef; | ||||
| 74 | } | ||||
| 75 | } | ||||
| 76 | return $AbsName; | ||||
| 77 | } | ||||
| 78 | |||||
| 79 | sub Follow_SymLink($) { | ||||
| 80 | my ($AbsName) = @_; | ||||
| 81 | |||||
| 82 | my ($NewName,$DEV, $INO); | ||||
| 83 | ($DEV, $INO)= lstat $AbsName; | ||||
| 84 | |||||
| 85 | while (-l _) { | ||||
| 86 | if ($SLnkSeen{$DEV, $INO}++) { | ||||
| 87 | if ($follow_skip < 2) { | ||||
| 88 | die "$AbsName is encountered a second time"; | ||||
| 89 | } | ||||
| 90 | else { | ||||
| 91 | return undef; | ||||
| 92 | } | ||||
| 93 | } | ||||
| 94 | my $Link = readlink($AbsName); | ||||
| 95 | # canonicalize directory separators | ||||
| 96 | $Link =~ s|\\|/|g if $Is_Win32; | ||||
| 97 | $NewName= PathCombine($AbsName, $Link); | ||||
| 98 | unless(defined $NewName) { | ||||
| 99 | if ($follow_skip < 2) { | ||||
| 100 | die "$AbsName is a recursive symbolic link"; | ||||
| 101 | } | ||||
| 102 | else { | ||||
| 103 | return undef; | ||||
| 104 | } | ||||
| 105 | } | ||||
| 106 | else { | ||||
| 107 | $AbsName= $NewName; | ||||
| 108 | } | ||||
| 109 | ($DEV, $INO) = lstat($AbsName); | ||||
| 110 | return undef unless defined $DEV; # dangling symbolic link | ||||
| 111 | } | ||||
| 112 | |||||
| 113 | if ($full_check && defined $DEV && $SLnkSeen{$DEV, $INO}++) { | ||||
| 114 | if ( ($follow_skip < 1) || ((-d _) && ($follow_skip < 2)) ) { | ||||
| 115 | die "$AbsName encountered a second time"; | ||||
| 116 | } | ||||
| 117 | else { | ||||
| 118 | return undef; | ||||
| 119 | } | ||||
| 120 | } | ||||
| 121 | |||||
| 122 | return $AbsName; | ||||
| 123 | } | ||||
| 124 | |||||
| 125 | our($dir, $name, $fullname, $prune); | ||||
| 126 | sub _find_dir_symlnk($$$); | ||||
| 127 | sub _find_dir($$$); | ||||
| 128 | |||||
| 129 | # check whether or not a scalar variable is tainted | ||||
| 130 | # (code straight from the Camel, 3rd ed., page 561) | ||||
| 131 | sub is_tainted_pp { | ||||
| 132 | my $arg = shift; | ||||
| 133 | my $nada = substr($arg, 0, 0); # zero-length | ||||
| 134 | local $@; | ||||
| 135 | eval { eval "# $nada" }; | ||||
| 136 | return length($@) != 0; | ||||
| 137 | } | ||||
| 138 | |||||
| 139 | |||||
| 140 | sub _find_opt { | ||||
| 141 | my $wanted = shift; | ||||
| 142 | return unless @_; | ||||
| 143 | die "invalid top directory" unless defined $_[0]; | ||||
| 144 | |||||
| 145 | # This function must local()ize everything because callbacks may | ||||
| 146 | # call find() or finddepth() | ||||
| 147 | |||||
| 148 | local %SLnkSeen; | ||||
| 149 | local ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow, | ||||
| 150 | $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat, | ||||
| 151 | $pre_process, $post_process, $dangling_symlinks); | ||||
| 152 | local($dir, $name, $fullname, $prune); | ||||
| 153 | local *_ = \my $a; | ||||
| 154 | |||||
| 155 | my $cwd = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::getcwd(); | ||||
| 156 | if ($Is_VMS) { | ||||
| 157 | # VMS returns this by default in VMS format which just doesn't | ||||
| 158 | # work for the rest of this module. | ||||
| 159 | $cwd = VMS::Filespec::unixpath($cwd); | ||||
| 160 | |||||
| 161 | # Apparently this is not expected to have a trailing space. | ||||
| 162 | # To attempt to make VMS/UNIX conversions mostly reversible, | ||||
| 163 | # a trailing slash is needed. The run-time functions ignore the | ||||
| 164 | # resulting double slash, but it causes the perl tests to fail. | ||||
| 165 | $cwd =~ s#/\z##; | ||||
| 166 | |||||
| 167 | # This comes up in upper case now, but should be lower. | ||||
| 168 | # In the future this could be exact case, no need to change. | ||||
| 169 | } | ||||
| 170 | my $cwd_untainted = $cwd; | ||||
| 171 | my $check_t_cwd = 1; | ||||
| 172 | $wanted_callback = $wanted->{wanted}; | ||||
| 173 | $bydepth = $wanted->{bydepth}; | ||||
| 174 | $pre_process = $wanted->{preprocess}; | ||||
| 175 | $post_process = $wanted->{postprocess}; | ||||
| 176 | $no_chdir = $wanted->{no_chdir}; | ||||
| 177 | $full_check = $wanted->{follow}; | ||||
| 178 | $follow = $full_check || $wanted->{follow_fast}; | ||||
| 179 | $follow_skip = $wanted->{follow_skip}; | ||||
| 180 | $untaint = $wanted->{untaint}; | ||||
| 181 | $untaint_pat = $wanted->{untaint_pattern}; | ||||
| 182 | $untaint_skip = $wanted->{untaint_skip}; | ||||
| 183 | $dangling_symlinks = $wanted->{dangling_symlinks}; | ||||
| 184 | |||||
| 185 | # for compatibility reasons (find.pl, find2perl) | ||||
| 186 | local our ($topdir, $topdev, $topino, $topmode, $topnlink); | ||||
| 187 | |||||
| 188 | # a symbolic link to a directory doesn't increase the link count | ||||
| 189 | $avoid_nlink = $follow || $File::Find::dont_use_nlink; | ||||
| 190 | |||||
| 191 | my ($abs_dir, $Is_Dir); | ||||
| 192 | |||||
| 193 | Proc_Top_Item: | ||||
| 194 | foreach my $TOP (@_) { | ||||
| 195 | my $top_item = $TOP; | ||||
| 196 | $top_item = VMS::Filespec::unixify($top_item) if $Is_VMS; | ||||
| 197 | |||||
| 198 | ($topdev,$topino,$topmode,$topnlink) = $follow ? stat $top_item : lstat $top_item; | ||||
| 199 | |||||
| 200 | # canonicalize directory separators | ||||
| 201 | $top_item =~ s|[/\\]|/|g if $Is_Win32; | ||||
| 202 | |||||
| 203 | # no trailing / unless path is root | ||||
| 204 | $top_item =~ s|/\z|| unless _is_root($top_item); | ||||
| 205 | |||||
| 206 | $Is_Dir= 0; | ||||
| 207 | |||||
| 208 | if ($follow) { | ||||
| 209 | |||||
| 210 | if (_is_absolute($top_item)) { | ||||
| 211 | $abs_dir = $top_item; | ||||
| 212 | } | ||||
| 213 | elsif ($top_item eq $File::Find::current_dir) { | ||||
| 214 | $abs_dir = $cwd; | ||||
| 215 | } | ||||
| 216 | else { # care about any ../ | ||||
| 217 | $top_item =~ s/\.dir\z//i if $Is_VMS; | ||||
| 218 | $abs_dir = contract_name("$cwd/",$top_item); | ||||
| 219 | } | ||||
| 220 | $abs_dir= Follow_SymLink($abs_dir); | ||||
| 221 | unless (defined $abs_dir) { | ||||
| 222 | if ($dangling_symlinks) { | ||||
| 223 | if (ref $dangling_symlinks eq 'CODE') { | ||||
| 224 | $dangling_symlinks->($top_item, $cwd); | ||||
| 225 | } else { | ||||
| 226 | warnings::warnif "$top_item is a dangling symbolic link\n"; | ||||
| 227 | } | ||||
| 228 | } | ||||
| 229 | next Proc_Top_Item; | ||||
| 230 | } | ||||
| 231 | |||||
| 232 | if (-d _) { | ||||
| 233 | $top_item =~ s/\.dir\z//i if $Is_VMS; | ||||
| 234 | _find_dir_symlnk($wanted, $abs_dir, $top_item); | ||||
| 235 | $Is_Dir= 1; | ||||
| 236 | } | ||||
| 237 | } | ||||
| 238 | else { # no follow | ||||
| 239 | $topdir = $top_item; | ||||
| 240 | unless (defined $topnlink) { | ||||
| 241 | warnings::warnif "Can't stat $top_item: $!\n"; | ||||
| 242 | next Proc_Top_Item; | ||||
| 243 | } | ||||
| 244 | if (-d _) { | ||||
| 245 | $top_item =~ s/\.dir\z//i if $Is_VMS; | ||||
| 246 | _find_dir($wanted, $top_item, $topnlink); | ||||
| 247 | $Is_Dir= 1; | ||||
| 248 | } | ||||
| 249 | else { | ||||
| 250 | $abs_dir= $top_item; | ||||
| 251 | } | ||||
| 252 | } | ||||
| 253 | |||||
| 254 | unless ($Is_Dir) { | ||||
| 255 | unless (($_,$dir) = File::Basename::fileparse($abs_dir)) { | ||||
| 256 | ($dir,$_) = ('./', $top_item); | ||||
| 257 | } | ||||
| 258 | |||||
| 259 | $abs_dir = $dir; | ||||
| 260 | if (( $untaint ) && (is_tainted($dir) )) { | ||||
| 261 | ( $abs_dir ) = $dir =~ m|$untaint_pat|; | ||||
| 262 | unless (defined $abs_dir) { | ||||
| 263 | if ($untaint_skip == 0) { | ||||
| 264 | die "directory $dir is still tainted"; | ||||
| 265 | } | ||||
| 266 | else { | ||||
| 267 | next Proc_Top_Item; | ||||
| 268 | } | ||||
| 269 | } | ||||
| 270 | } | ||||
| 271 | |||||
| 272 | unless ($no_chdir || chdir $abs_dir) { | ||||
| 273 | warnings::warnif "Couldn't chdir $abs_dir: $!\n"; | ||||
| 274 | next Proc_Top_Item; | ||||
| 275 | } | ||||
| 276 | |||||
| 277 | $name = $abs_dir . $_; # $File::Find::name | ||||
| 278 | $_ = $name if $no_chdir; | ||||
| 279 | |||||
| 280 | { $wanted_callback->() }; # protect against wild "next" | ||||
| 281 | |||||
| 282 | } | ||||
| 283 | |||||
| 284 | unless ( $no_chdir ) { | ||||
| 285 | if ( ($check_t_cwd) && (($untaint) && (is_tainted($cwd) )) ) { | ||||
| 286 | ( $cwd_untainted ) = $cwd =~ m|$untaint_pat|; | ||||
| 287 | unless (defined $cwd_untainted) { | ||||
| 288 | die "insecure cwd in find(depth)"; | ||||
| 289 | } | ||||
| 290 | $check_t_cwd = 0; | ||||
| 291 | } | ||||
| 292 | unless (chdir $cwd_untainted) { | ||||
| 293 | die "Can't cd to $cwd: $!\n"; | ||||
| 294 | } | ||||
| 295 | } | ||||
| 296 | } | ||||
| 297 | } | ||||
| 298 | |||||
| 299 | # API: | ||||
| 300 | # $wanted | ||||
| 301 | # $p_dir : "parent directory" | ||||
| 302 | # $nlink : what came back from the stat | ||||
| 303 | # preconditions: | ||||
| 304 | # chdir (if not no_chdir) to dir | ||||
| 305 | |||||
| 306 | sub _find_dir($$$) { | ||||
| 307 | my ($wanted, $p_dir, $nlink) = @_; | ||||
| 308 | my ($CdLvl,$Level) = (0,0); | ||||
| 309 | my @Stack; | ||||
| 310 | my @filenames; | ||||
| 311 | my ($subcount,$sub_nlink); | ||||
| 312 | my $SE= []; | ||||
| 313 | my $dir_name= $p_dir; | ||||
| 314 | my $dir_pref; | ||||
| 315 | my $dir_rel = $File::Find::current_dir; | ||||
| 316 | my $tainted = 0; | ||||
| 317 | my $no_nlink; | ||||
| 318 | |||||
| 319 | if ($Is_VMS) { | ||||
| 320 | # VMS is returning trailing .dir on directories | ||||
| 321 | # and trailing . on files and symbolic links | ||||
| 322 | # in UNIX syntax. | ||||
| 323 | # | ||||
| 324 | |||||
| 325 | $p_dir =~ s/\.(dir)?$//i unless $p_dir eq '.'; | ||||
| 326 | |||||
| 327 | $dir_pref = ($p_dir =~ m/[\]>]+$/ ? $p_dir : "$p_dir/" ); | ||||
| 328 | } | ||||
| 329 | else { | ||||
| 330 | $dir_pref = _is_root($p_dir) ? $p_dir : "$p_dir/"; | ||||
| 331 | } | ||||
| 332 | |||||
| 333 | local ($dir, $name, $prune); | ||||
| 334 | |||||
| 335 | unless ( $no_chdir || ($p_dir eq $File::Find::current_dir)) { | ||||
| 336 | my $udir = $p_dir; | ||||
| 337 | if (( $untaint ) && (is_tainted($p_dir) )) { | ||||
| 338 | ( $udir ) = $p_dir =~ m|$untaint_pat|; | ||||
| 339 | unless (defined $udir) { | ||||
| 340 | if ($untaint_skip == 0) { | ||||
| 341 | die "directory $p_dir is still tainted"; | ||||
| 342 | } | ||||
| 343 | else { | ||||
| 344 | return; | ||||
| 345 | } | ||||
| 346 | } | ||||
| 347 | } | ||||
| 348 | unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) { | ||||
| 349 | warnings::warnif "Can't cd to $udir: $!\n"; | ||||
| 350 | return; | ||||
| 351 | } | ||||
| 352 | } | ||||
| 353 | |||||
| 354 | # push the starting directory | ||||
| 355 | push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth; | ||||
| 356 | |||||
| 357 | while (defined $SE) { | ||||
| 358 | unless ($bydepth) { | ||||
| 359 | $dir= $p_dir; # $File::Find::dir | ||||
| 360 | $name= $dir_name; # $File::Find::name | ||||
| 361 | $_= ($no_chdir ? $dir_name : $dir_rel ); # $_ | ||||
| 362 | # prune may happen here | ||||
| 363 | $prune= 0; | ||||
| 364 | { $wanted_callback->() }; # protect against wild "next" | ||||
| 365 | next if $prune; | ||||
| 366 | } | ||||
| 367 | |||||
| 368 | # change to that directory | ||||
| 369 | unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) { | ||||
| 370 | my $udir= $dir_rel; | ||||
| 371 | if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_rel) )) ) { | ||||
| 372 | ( $udir ) = $dir_rel =~ m|$untaint_pat|; | ||||
| 373 | unless (defined $udir) { | ||||
| 374 | if ($untaint_skip == 0) { | ||||
| 375 | die "directory (" . ($p_dir ne '/' ? $p_dir : '') . "/) $dir_rel is still tainted"; | ||||
| 376 | } else { # $untaint_skip == 1 | ||||
| 377 | next; | ||||
| 378 | } | ||||
| 379 | } | ||||
| 380 | } | ||||
| 381 | unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) { | ||||
| 382 | warnings::warnif "Can't cd to (" . | ||||
| 383 | ($p_dir ne '/' ? $p_dir : '') . "/) $udir: $!\n"; | ||||
| 384 | next; | ||||
| 385 | } | ||||
| 386 | $CdLvl++; | ||||
| 387 | } | ||||
| 388 | |||||
| 389 | $dir= $dir_name; # $File::Find::dir | ||||
| 390 | |||||
| 391 | # Get the list of files in the current directory. | ||||
| 392 | my $dh; | ||||
| 393 | unless (opendir $dh, ($no_chdir ? $dir_name : $File::Find::current_dir)) { | ||||
| 394 | warnings::warnif "Can't opendir($dir_name): $!\n"; | ||||
| 395 | next; | ||||
| 396 | } | ||||
| 397 | @filenames = readdir $dh; | ||||
| 398 | closedir($dh); | ||||
| 399 | @filenames = $pre_process->(@filenames) if $pre_process; | ||||
| 400 | push @Stack,[$CdLvl,$dir_name,"",-2] if $post_process; | ||||
| 401 | |||||
| 402 | # default: use whatever was specified | ||||
| 403 | # (if $nlink >= 2, and $avoid_nlink == 0, this will switch back) | ||||
| 404 | $no_nlink = $avoid_nlink; | ||||
| 405 | # if dir has wrong nlink count, force switch to slower stat method | ||||
| 406 | $no_nlink = 1 if ($nlink < 2); | ||||
| 407 | |||||
| 408 | if ($nlink == 2 && !$no_nlink) { | ||||
| 409 | # This dir has no subdirectories. | ||||
| 410 | for my $FN (@filenames) { | ||||
| 411 | if ($Is_VMS) { | ||||
| 412 | # Big hammer here - Compensate for VMS trailing . and .dir | ||||
| 413 | # No win situation until this is changed, but this | ||||
| 414 | # will handle the majority of the cases with breaking the fewest | ||||
| 415 | |||||
| 416 | $FN =~ s/\.dir\z//i; | ||||
| 417 | $FN =~ s#\.$## if ($FN ne '.'); | ||||
| 418 | } | ||||
| 419 | next if $FN =~ $File::Find::skip_pattern; | ||||
| 420 | |||||
| 421 | $name = $dir_pref . $FN; # $File::Find::name | ||||
| 422 | $_ = ($no_chdir ? $name : $FN); # $_ | ||||
| 423 | { $wanted_callback->() }; # protect against wild "next" | ||||
| 424 | } | ||||
| 425 | |||||
| 426 | } | ||||
| 427 | else { | ||||
| 428 | # This dir has subdirectories. | ||||
| 429 | $subcount = $nlink - 2; | ||||
| 430 | |||||
| 431 | # HACK: insert directories at this position, so as to preserve | ||||
| 432 | # the user pre-processed ordering of files (thus ensuring | ||||
| 433 | # directory traversal is in user sorted order, not at random). | ||||
| 434 | my $stack_top = @Stack; | ||||
| 435 | |||||
| 436 | for my $FN (@filenames) { | ||||
| 437 | next if $FN =~ $File::Find::skip_pattern; | ||||
| 438 | if ($subcount > 0 || $no_nlink) { | ||||
| 439 | # Seen all the subdirs? | ||||
| 440 | # check for directoriness. | ||||
| 441 | # stat is faster for a file in the current directory | ||||
| 442 | $sub_nlink = (lstat ($no_chdir ? $dir_pref . $FN : $FN))[3]; | ||||
| 443 | |||||
| 444 | if (-d _) { | ||||
| 445 | --$subcount; | ||||
| 446 | $FN =~ s/\.dir\z//i if $Is_VMS; | ||||
| 447 | # HACK: replace push to preserve dir traversal order | ||||
| 448 | #push @Stack,[$CdLvl,$dir_name,$FN,$sub_nlink]; | ||||
| 449 | splice @Stack, $stack_top, 0, | ||||
| 450 | [$CdLvl,$dir_name,$FN,$sub_nlink]; | ||||
| 451 | } | ||||
| 452 | else { | ||||
| 453 | $name = $dir_pref . $FN; # $File::Find::name | ||||
| 454 | $_= ($no_chdir ? $name : $FN); # $_ | ||||
| 455 | { $wanted_callback->() }; # protect against wild "next" | ||||
| 456 | } | ||||
| 457 | } | ||||
| 458 | else { | ||||
| 459 | $name = $dir_pref . $FN; # $File::Find::name | ||||
| 460 | $_= ($no_chdir ? $name : $FN); # $_ | ||||
| 461 | { $wanted_callback->() }; # protect against wild "next" | ||||
| 462 | } | ||||
| 463 | } | ||||
| 464 | } | ||||
| 465 | } | ||||
| 466 | continue { | ||||
| 467 | while ( defined ($SE = pop @Stack) ) { | ||||
| 468 | ($Level, $p_dir, $dir_rel, $nlink) = @$SE; | ||||
| 469 | if ($CdLvl > $Level && !$no_chdir) { | ||||
| 470 | my $tmp; | ||||
| 471 | if ($Is_VMS) { | ||||
| 472 | $tmp = '[' . ('-' x ($CdLvl-$Level)) . ']'; | ||||
| 473 | } | ||||
| 474 | else { | ||||
| 475 | $tmp = join('/',('..') x ($CdLvl-$Level)); | ||||
| 476 | } | ||||
| 477 | die "Can't cd to $tmp from $dir_name: $!" | ||||
| 478 | unless chdir ($tmp); | ||||
| 479 | $CdLvl = $Level; | ||||
| 480 | } | ||||
| 481 | |||||
| 482 | if ($^O eq 'VMS') { | ||||
| 483 | if ($p_dir =~ m/[\]>]+$/) { | ||||
| 484 | $dir_name = $p_dir; | ||||
| 485 | $dir_name =~ s/([\]>]+)$/.$dir_rel$1/; | ||||
| 486 | $dir_pref = $dir_name; | ||||
| 487 | } | ||||
| 488 | else { | ||||
| 489 | $dir_name = "$p_dir/$dir_rel"; | ||||
| 490 | $dir_pref = "$dir_name/"; | ||||
| 491 | } | ||||
| 492 | } | ||||
| 493 | else { | ||||
| 494 | $dir_name = _is_root($p_dir) ? "$p_dir$dir_rel" : "$p_dir/$dir_rel"; | ||||
| 495 | $dir_pref = "$dir_name/"; | ||||
| 496 | } | ||||
| 497 | |||||
| 498 | if ( $nlink == -2 ) { | ||||
| 499 | $name = $dir = $p_dir; # $File::Find::name / dir | ||||
| 500 | $_ = $File::Find::current_dir; | ||||
| 501 | $post_process->(); # End-of-directory processing | ||||
| 502 | } | ||||
| 503 | elsif ( $nlink < 0 ) { # must be finddepth, report dirname now | ||||
| 504 | $name = $dir_name; | ||||
| 505 | if ( substr($name,-2) eq '/.' ) { | ||||
| 506 | substr($name, length($name) == 2 ? -1 : -2) = ''; | ||||
| 507 | } | ||||
| 508 | $dir = $p_dir; | ||||
| 509 | $_ = ($no_chdir ? $dir_name : $dir_rel ); | ||||
| 510 | if ( substr($_,-2) eq '/.' ) { | ||||
| 511 | substr($_, length($_) == 2 ? -1 : -2) = ''; | ||||
| 512 | } | ||||
| 513 | { $wanted_callback->() }; # protect against wild "next" | ||||
| 514 | } | ||||
| 515 | else { | ||||
| 516 | push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth; | ||||
| 517 | last; | ||||
| 518 | } | ||||
| 519 | } | ||||
| 520 | } | ||||
| 521 | } | ||||
| 522 | |||||
| 523 | |||||
| 524 | # API: | ||||
| 525 | # $wanted | ||||
| 526 | # $dir_loc : absolute location of a dir | ||||
| 527 | # $p_dir : "parent directory" | ||||
| 528 | # preconditions: | ||||
| 529 | # chdir (if not no_chdir) to dir | ||||
| 530 | |||||
| 531 | sub _find_dir_symlnk($$$) { | ||||
| 532 | my ($wanted, $dir_loc, $p_dir) = @_; # $dir_loc is the absolute directory | ||||
| 533 | my @Stack; | ||||
| 534 | my @filenames; | ||||
| 535 | my $new_loc; | ||||
| 536 | my $updir_loc = $dir_loc; # untainted parent directory | ||||
| 537 | my $SE = []; | ||||
| 538 | my $dir_name = $p_dir; | ||||
| 539 | my $dir_pref; | ||||
| 540 | my $loc_pref; | ||||
| 541 | my $dir_rel = $File::Find::current_dir; | ||||
| 542 | my $byd_flag; # flag for pending stack entry if $bydepth | ||||
| 543 | my $tainted = 0; | ||||
| 544 | my $ok = 1; | ||||
| 545 | |||||
| 546 | $dir_pref = _is_root($p_dir) ? $p_dir : "$p_dir/"; | ||||
| 547 | $loc_pref = _is_root($dir_loc) ? $dir_loc : "$dir_loc/"; | ||||
| 548 | |||||
| 549 | local ($dir, $name, $fullname, $prune); | ||||
| 550 | |||||
| 551 | unless ($no_chdir) { | ||||
| 552 | # untaint the topdir | ||||
| 553 | if (( $untaint ) && (is_tainted($dir_loc) )) { | ||||
| 554 | ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|; # parent dir, now untainted | ||||
| 555 | # once untainted, $updir_loc is pushed on the stack (as parent directory); | ||||
| 556 | # hence, we don't need to untaint the parent directory every time we chdir | ||||
| 557 | # to it later | ||||
| 558 | unless (defined $updir_loc) { | ||||
| 559 | if ($untaint_skip == 0) { | ||||
| 560 | die "directory $dir_loc is still tainted"; | ||||
| 561 | } | ||||
| 562 | else { | ||||
| 563 | return; | ||||
| 564 | } | ||||
| 565 | } | ||||
| 566 | } | ||||
| 567 | $ok = chdir($updir_loc) unless ($p_dir eq $File::Find::current_dir); | ||||
| 568 | unless ($ok) { | ||||
| 569 | warnings::warnif "Can't cd to $updir_loc: $!\n"; | ||||
| 570 | return; | ||||
| 571 | } | ||||
| 572 | } | ||||
| 573 | |||||
| 574 | push @Stack,[$dir_loc,$updir_loc,$p_dir,$dir_rel,-1] if $bydepth; | ||||
| 575 | |||||
| 576 | while (defined $SE) { | ||||
| 577 | |||||
| 578 | unless ($bydepth) { | ||||
| 579 | # change (back) to parent directory (always untainted) | ||||
| 580 | unless ($no_chdir) { | ||||
| 581 | unless (chdir $updir_loc) { | ||||
| 582 | warnings::warnif "Can't cd to $updir_loc: $!\n"; | ||||
| 583 | next; | ||||
| 584 | } | ||||
| 585 | } | ||||
| 586 | $dir= $p_dir; # $File::Find::dir | ||||
| 587 | $name= $dir_name; # $File::Find::name | ||||
| 588 | $_= ($no_chdir ? $dir_name : $dir_rel ); # $_ | ||||
| 589 | $fullname= $dir_loc; # $File::Find::fullname | ||||
| 590 | # prune may happen here | ||||
| 591 | $prune= 0; | ||||
| 592 | lstat($_); # make sure file tests with '_' work | ||||
| 593 | { $wanted_callback->() }; # protect against wild "next" | ||||
| 594 | next if $prune; | ||||
| 595 | } | ||||
| 596 | |||||
| 597 | # change to that directory | ||||
| 598 | unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) { | ||||
| 599 | $updir_loc = $dir_loc; | ||||
| 600 | if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_loc) )) ) { | ||||
| 601 | # untaint $dir_loc, what will be pushed on the stack as (untainted) parent dir | ||||
| 602 | ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|; | ||||
| 603 | unless (defined $updir_loc) { | ||||
| 604 | if ($untaint_skip == 0) { | ||||
| 605 | die "directory $dir_loc is still tainted"; | ||||
| 606 | } | ||||
| 607 | else { | ||||
| 608 | next; | ||||
| 609 | } | ||||
| 610 | } | ||||
| 611 | } | ||||
| 612 | unless (chdir $updir_loc) { | ||||
| 613 | warnings::warnif "Can't cd to $updir_loc: $!\n"; | ||||
| 614 | next; | ||||
| 615 | } | ||||
| 616 | } | ||||
| 617 | |||||
| 618 | $dir = $dir_name; # $File::Find::dir | ||||
| 619 | |||||
| 620 | # Get the list of files in the current directory. | ||||
| 621 | my $dh; | ||||
| 622 | unless (opendir $dh, ($no_chdir ? $dir_loc : $File::Find::current_dir)) { | ||||
| 623 | warnings::warnif "Can't opendir($dir_loc): $!\n"; | ||||
| 624 | next; | ||||
| 625 | } | ||||
| 626 | @filenames = readdir $dh; | ||||
| 627 | closedir($dh); | ||||
| 628 | |||||
| 629 | for my $FN (@filenames) { | ||||
| 630 | if ($Is_VMS) { | ||||
| 631 | # Big hammer here - Compensate for VMS trailing . and .dir | ||||
| 632 | # No win situation until this is changed, but this | ||||
| 633 | # will handle the majority of the cases with breaking the fewest. | ||||
| 634 | |||||
| 635 | $FN =~ s/\.dir\z//i; | ||||
| 636 | $FN =~ s#\.$## if ($FN ne '.'); | ||||
| 637 | } | ||||
| 638 | next if $FN =~ $File::Find::skip_pattern; | ||||
| 639 | |||||
| 640 | # follow symbolic links / do an lstat | ||||
| 641 | $new_loc = Follow_SymLink($loc_pref.$FN); | ||||
| 642 | |||||
| 643 | # ignore if invalid symlink | ||||
| 644 | unless (defined $new_loc) { | ||||
| 645 | if (!defined -l _ && $dangling_symlinks) { | ||||
| 646 | $fullname = undef; | ||||
| 647 | if (ref $dangling_symlinks eq 'CODE') { | ||||
| 648 | $dangling_symlinks->($FN, $dir_pref); | ||||
| 649 | } else { | ||||
| 650 | warnings::warnif "$dir_pref$FN is a dangling symbolic link\n"; | ||||
| 651 | } | ||||
| 652 | } | ||||
| 653 | else { | ||||
| 654 | $fullname = $loc_pref . $FN; | ||||
| 655 | } | ||||
| 656 | $name = $dir_pref . $FN; | ||||
| 657 | $_ = ($no_chdir ? $name : $FN); | ||||
| 658 | { $wanted_callback->() }; | ||||
| 659 | next; | ||||
| 660 | } | ||||
| 661 | |||||
| 662 | if (-d _) { | ||||
| 663 | if ($Is_VMS) { | ||||
| 664 | $FN =~ s/\.dir\z//i; | ||||
| 665 | $FN =~ s#\.$## if ($FN ne '.'); | ||||
| 666 | $new_loc =~ s/\.dir\z//i; | ||||
| 667 | $new_loc =~ s#\.$## if ($new_loc ne '.'); | ||||
| 668 | } | ||||
| 669 | push @Stack,[$new_loc,$updir_loc,$dir_name,$FN,1]; | ||||
| 670 | } | ||||
| 671 | else { | ||||
| 672 | $fullname = $new_loc; # $File::Find::fullname | ||||
| 673 | $name = $dir_pref . $FN; # $File::Find::name | ||||
| 674 | $_ = ($no_chdir ? $name : $FN); # $_ | ||||
| 675 | { $wanted_callback->() }; # protect against wild "next" | ||||
| 676 | } | ||||
| 677 | } | ||||
| 678 | |||||
| 679 | } | ||||
| 680 | continue { | ||||
| 681 | while (defined($SE = pop @Stack)) { | ||||
| 682 | ($dir_loc, $updir_loc, $p_dir, $dir_rel, $byd_flag) = @$SE; | ||||
| 683 | $dir_name = _is_root($p_dir) ? "$p_dir$dir_rel" : "$p_dir/$dir_rel"; | ||||
| 684 | $dir_pref = "$dir_name/"; | ||||
| 685 | $loc_pref = "$dir_loc/"; | ||||
| 686 | if ( $byd_flag < 0 ) { # must be finddepth, report dirname now | ||||
| 687 | unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) { | ||||
| 688 | unless (chdir $updir_loc) { # $updir_loc (parent dir) is always untainted | ||||
| 689 | warnings::warnif "Can't cd to $updir_loc: $!\n"; | ||||
| 690 | next; | ||||
| 691 | } | ||||
| 692 | } | ||||
| 693 | $fullname = $dir_loc; # $File::Find::fullname | ||||
| 694 | $name = $dir_name; # $File::Find::name | ||||
| 695 | if ( substr($name,-2) eq '/.' ) { | ||||
| 696 | substr($name, length($name) == 2 ? -1 : -2) = ''; # $File::Find::name | ||||
| 697 | } | ||||
| 698 | $dir = $p_dir; # $File::Find::dir | ||||
| 699 | $_ = ($no_chdir ? $dir_name : $dir_rel); # $_ | ||||
| 700 | if ( substr($_,-2) eq '/.' ) { | ||||
| 701 | substr($_, length($_) == 2 ? -1 : -2) = ''; | ||||
| 702 | } | ||||
| 703 | |||||
| 704 | lstat($_); # make sure file tests with '_' work | ||||
| 705 | { $wanted_callback->() }; # protect against wild "next" | ||||
| 706 | } | ||||
| 707 | else { | ||||
| 708 | push @Stack,[$dir_loc, $updir_loc, $p_dir, $dir_rel,-1] if $bydepth; | ||||
| 709 | last; | ||||
| 710 | } | ||||
| 711 | } | ||||
| 712 | } | ||||
| 713 | } | ||||
| 714 | |||||
| 715 | |||||
| 716 | sub wrap_wanted { | ||||
| 717 | my $wanted = shift; | ||||
| 718 | if ( ref($wanted) eq 'HASH' ) { | ||||
| 719 | # RT #122547 | ||||
| 720 | my %valid_options = map {$_ => 1} qw( | ||||
| 721 | wanted | ||||
| 722 | bydepth | ||||
| 723 | preprocess | ||||
| 724 | postprocess | ||||
| 725 | follow | ||||
| 726 | follow_fast | ||||
| 727 | follow_skip | ||||
| 728 | dangling_symlinks | ||||
| 729 | no_chdir | ||||
| 730 | untaint | ||||
| 731 | untaint_pattern | ||||
| 732 | untaint_skip | ||||
| 733 | ); | ||||
| 734 | my @invalid_options = (); | ||||
| 735 | for my $v (keys %{$wanted}) { | ||||
| 736 | push @invalid_options, $v unless exists $valid_options{$v}; | ||||
| 737 | } | ||||
| 738 | warn "Invalid option(s): @invalid_options" if @invalid_options; | ||||
| 739 | |||||
| 740 | unless( exists $wanted->{wanted} and ref( $wanted->{wanted} ) eq 'CODE' ) { | ||||
| 741 | die 'no &wanted subroutine given'; | ||||
| 742 | } | ||||
| 743 | if ( $wanted->{follow} || $wanted->{follow_fast}) { | ||||
| 744 | $wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip}; | ||||
| 745 | } | ||||
| 746 | if ( $wanted->{untaint} ) { | ||||
| 747 | $wanted->{untaint_pattern} = $File::Find::untaint_pattern | ||||
| 748 | unless defined $wanted->{untaint_pattern}; | ||||
| 749 | $wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip}; | ||||
| 750 | } | ||||
| 751 | return $wanted; | ||||
| 752 | } | ||||
| 753 | elsif( ref( $wanted ) eq 'CODE' ) { | ||||
| 754 | return { wanted => $wanted }; | ||||
| 755 | } | ||||
| 756 | else { | ||||
| 757 | die 'no &wanted subroutine given'; | ||||
| 758 | } | ||||
| 759 | } | ||||
| 760 | |||||
| 761 | sub find { | ||||
| 762 | my $wanted = shift; | ||||
| 763 | _find_opt(wrap_wanted($wanted), @_); | ||||
| 764 | } | ||||
| 765 | |||||
| 766 | sub finddepth { | ||||
| 767 | my $wanted = wrap_wanted(shift); | ||||
| 768 | $wanted->{bydepth} = 1; | ||||
| 769 | _find_opt($wanted, @_); | ||||
| 770 | } | ||||
| 771 | |||||
| 772 | # default | ||||
| 773 | 1 | 5µs | 1 | 2µs | $File::Find::skip_pattern = qr/^\.{1,2}\z/; # spent 2µs making 1 call to CORE::qr |
| 774 | 1 | 2µs | 1 | 400ns | $File::Find::untaint_pattern = qr|^([-+@\w./]+)$|; # spent 400ns making 1 call to CORE::qr |
| 775 | |||||
| 776 | # this _should_ work properly on all platforms | ||||
| 777 | # where File::Find can be expected to work | ||||
| 778 | 1 | 4µs | 1 | 1µs | $File::Find::current_dir = File::Spec->curdir || '.'; # spent 1µs making 1 call to File::Spec::Unix::curdir |
| 779 | |||||
| 780 | 1 | 100ns | $File::Find::dont_use_nlink = 1; | ||
| 781 | |||||
| 782 | # We need a function that checks if a scalar is tainted. Either use the | ||||
| 783 | # Scalar::Util module's tainted() function or our (slower) pure Perl | ||||
| 784 | # fallback is_tainted_pp() | ||||
| 785 | { | ||||
| 786 | 2 | 300ns | local $@; | ||
| 787 | 2 | 700ns | eval { require Scalar::Util }; | ||
| 788 | 1 | 1µs | *is_tainted = $@ ? \&is_tainted_pp : \&Scalar::Util::tainted; | ||
| 789 | } | ||||
| 790 | |||||
| 791 | 1 | 7µs | 1; | ||
| 792 | |||||
| 793 | __END__ |