lib/File/Path.pm

   1 package File::Path;
   2
   3 =head1 NAME
   4
   5 File::Path - Create or remove directory trees
   6
   7 =head1 VERSION
   8
   9 This document describes version 2.00 of File::Path, released
  10 2007-xx-xx.
  11
  12 =head1 SYNOPSIS
  13
  14     use File::Path;
  15
  16     # modern
  17     mkpath( 'foo/bar/baz', '/zug/zwang', {verbose => 1} );
  18
  19     rmtree(
  20         'foo/bar/baz', '/zug/zwang',
  21         { verbose => 1, error  => \my $err_list }
  22     );
  23
  24     # traditional
  25     mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);
  26     rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);
  27
  28 =head1 DESCRIPTION
  29
  30 The C<mkpath> function provides a convenient way to create directories,
  31 even if your C<mkdir> kernel call won't create more than one level
  32 of directory at a time. Similarly, the C<rmtree> function provides
  33 a convenient way to delete a subtree from the directory structure,
  34 much like the Unix command C<rm -r>.
  35
  36 Both functions may be called in one of two ways, the traditional,
  37 compatible with code written since the dawn of time, and modern,
  38 that offers a more flexible and readable idiom. New code should use
  39 the modern interface.
  40
  41 =head2 FUNCTIONS
  42
  43 The modern way of calling C<mkpath> and C<rmtree> is with an optional
  44 hash reference at the end of the parameter list that holds various
  45 keys that can be used to control the function's behaviour, following
  46 a plain list of directories upon which to operate.
  47
  48 =head3 C<mkpath>
  49
  50 The following keys are recognised as as parameters to C<mkpath>.
  51 It returns the list of files actually created during the call.
  52
  53   my @created = mkpath(
  54     qw(/tmp /flub /home/nobody),
  55     {verbose => 1, mode => 0750},
  56   );
  57   print "created $_\n" for @created;
  58
  59 =over 4
  60
  61 =item mode
  62
  63 The numeric mode to use when creating the directories (defaults
  64 to 07777), to be modified by the current C<umask>. (C<mask> is
  65 recognised as an alias for this parameter).
  66
  67 =item verbose
  68
  69 If present, will cause C<mkpath> to print the name of each directory
  70 as it is created. By default nothing is printed.
  71
  72 =item error
  73
  74 If present, will be interpreted as a reference to a list, and will
  75 be used to store any errors that are encountered.  See the ERROR
  76 HANDLING section below to find out more.
  77
  78 If this parameter is not used, any errors encountered will raise a
  79 fatal error that need to be trapped in an C<eval> block, or the
  80 program will halt.
  81
  82 =back
  83
  84 =head3 C<rmtree>
  85
  86 =over 4
  87
  88 =item verbose
  89
  90 If present, will cause C<rmtree> to print the name of each file as
  91 it is unlinked. By default nothing is printed.
  92
  93 =item skip_others
  94
  95 When set to a true value, will cause C<rmtree> to skip any files
  96 to which you do not have delete access (if running under VMS) or
  97 write access (if running under another OS). This will change in
  98 the future when a criterion for 'delete permission' under OSs other
  99 than VMS is settled.
 100
 101 =item keep_root
 102
 103 When set to a true value, will cause everything except the specified
 104 base directories to be unlinked. This comes in handy when cleaning
 105 out an application's scratch directory.
 106
 107   rmtree( '/tmp', {keep_root => 1} );
 108
 109 =item result
 110
 111 If present, will be interpreted as a reference to a list, and will
 112 be used to store the list of all files and directories unlinked
 113 during the call. If nothing is unlinked, a reference to an empty
 114 list is returned (rather than C<undef>).
 115
 116   rmtree( '/tmp', {result => \my $list} );
 117   print "unlinked $_\n" for @$list;
 118
 119 =item error
 120
 121 If present, will be interpreted as a reference to a list,
 122 and will be used to store any errors that are encountered.
 123 See the ERROR HANDLING section below to find out more.
 124
 125 If this parameter is not used, any errors encountered will
 126 raise a fatal error that need to be trapped in an C<eval>
 127 block, or the program will halt.
 128
 129 =back
 130
 131 =head2 TRADITIONAL INTERFACE
 132
 133 The old interface for C<mkpath> and C<rmtree> take a
 134 reference to a list of directories (to create or remove),
 135 followed by a series of positional numeric modal parameters that
 136 control their behaviour.
 137
 138 This design made it difficult to add
 139 additional functionality, as well as posed the problem
 140 of what to do when you don't care how the initial
 141 positional parameters are specified but only the last
 142 one needs to be specified. The calls themselves are also
 143 less self-documenting.
 144
 145 C<mkpath> takes three arguments:
 146
 147 =over 4
 148
 149 =item *
 150
 151 The name of the path to create, or a reference
 152 to a list of paths to create,
 153
 154 =item *
 155
 156 a boolean value, which if TRUE will cause C<mkpath>
 157 to print the name of each directory as it is created
 158 (defaults to FALSE), and
 159
 160 =item *
 161
 162 the numeric mode to use when creating the directories
 163 (defaults to 0777), to be modified by the current umask.
 164
 165 =back
 166
 167 It returns a list of all directories (including intermediates, determined
 168 using the Unix '/' separator) created.  In scalar context it returns
 169 the number of directories created.
 170
 171 If a system error prevents a directory from being created, then the
 172 C<mkpath> function throws a fatal error with C<Carp::croak>. This error
 173 can be trapped with an C<eval> block:
 174
 175   eval { mkpath($dir) };
 176   if ($@) {
 177     print "Couldn't create $dir: $@";
 178   }
 179
 180 In the traditional form, C<rmtree> takes three arguments:
 181
 182 =over 4
 183
 184 =item *
 185
 186 the root of the subtree to delete, or a reference to
 187 a list of roots.  All of the files and directories
 188 below each root, as well as the roots themselves,
 189 will be deleted.
 190
 191 =item *
 192
 193 a boolean value, which if TRUE will cause C<rmtree> to
 194 print a message each time it examines a file, giving the
 195 name of the file, and indicating whether it's using C<rmdir>
 196 or C<unlink> to remove it, or that it's skipping it.
 197 (defaults to FALSE)
 198
 199 =item *
 200
 201 a boolean value, which if TRUE will cause C<rmtree> to
 202 skip any files to which you do not have delete access
 203 (if running under VMS) or write access (if running
 204 under another OS).  This will change in the future when
 205 a criterion for 'delete permission' under OSs other
 206 than VMS is settled.  (defaults to FALSE)
 207
 208 =back
 209
 210 It returns the number of files, directories and symlinks successfully
 211 deleted.  Symlinks are simply deleted and not followed.
 212
 213 Note also that the occurrence of errors in C<rmtree> using the
 214 traditional interface can be determined I<only> by trapping diagnostic
 215 messages using C<$SIG{__WARN__}>; it is not apparent from the return
 216 value. (The modern interface may use the C<error> parameter to
 217 record any problems encountered.
 218
 219 =head2 ERROR HANDLING
 220
 221 If C<mkpath> or C<rmtree> encounter an error, a diagnostic message
 222 will be printed to C<STDERR> via C<carp> (for non-fatal errors),
 223 or via C<croak> (for fatal errors).
 224
 225 If this behaviour is not desirable, the C<error> attribute may be
 226 used to hold a reference to a variable, which will be used to store
 227 the diagnostics. The result is a reference to a list of hash
 228 references. For each hash reference, the key is the name of the
 229 file, and the value is the error message (usually the contents of
 230 C<$!>). An example usage looks like:
 231
 232   rmpath( 'foo/bar', 'bar/rat', {error => \my $err} );
 233   for my $diag (@$err) {
 234     my ($file, $message) = each %$diag;
 235     print "problem unlinking $file: $message\n";
 236   }
 237
 238 If no errors are encountered, C<$err> will point to an empty list
 239 (thus there is no need to test for C<undef>). If a general error
 240 is encountered (for instance, C<rmtree> attempts to remove a directory
 241 tree that does not exist), the diagnostic key will be empty, only
 242 the value will be set:
 243
 244   rmpath( '/no/such/path', {error => \my $err} );
 245   for my $diag (@$err) {
 246     my ($file, $message) = each %$diag;
 247     if ($file eq '') {
 248       print "general error: $message\n";
 249     }
 250   }
 251
 252 =head2 NOTES
 253
 254 =head3 HEURISTICS
 255
 256 The functions detect (as far as possible) which way they are being
 257 called and will act appropriately. It is important to remember that
 258 the heuristic for detecting the old style is either the presence
 259 of an array reference, or two or three parameters total and second
 260 and third parameters are numeric. Hence...
 261
 262     mkpath '486', '487', '488';
 263
 264 ... will not assume the modern style and create three directories, rather
 265 it will create one directory verbosely, setting the permission to
 266 0750 (488 being the decimal equivalent of octal 750). Here, old
 267 style trumps new. It must, for backwards compatibility reasons.
 268
 269 If you want to ensure there is absolutely no ambiguity about which
 270 way the function will behave, make sure the first parameter is a
 271 reference to a one-element list, to force the old style interpretation:
 272
 273     mkpath ['486'], '487', '488';
 274
 275 and get only one directory created. Or add a reference to an empty
 276 parameter hash, to force the new style:
 277
 278     mkpath '486', '487', '488', {};
 279
 280 ... and hence create the three directories. If the empty hash
 281 reference seems a little strange to your eyes, or you suspect a
 282 subsequent programmer might I<helpfully> optimise it away, you
 283 can add a parameter set to a default value:
 284
 285     mkpath '486', '487', '488', {verbose => 0};
 286
 287 =head3 RACE CONDITIONS
 288
 289 There are race conditions internal to the implementation of C<rmtree>
 290 making it unsafe to use on directory trees which may be altered or
 291 moved while C<rmtree> is running, and in particular on any directory
 292 trees with any path components or subdirectories potentially writable
 293 by untrusted users.
 294
 295 Additionally, if the C<skip_others> parareter is not set (or the
 296 third parameter in the traditional inferface is not TRUE) and
 297 C<rmtree> is interrupted, it may leave files and directories with
 298 permissions altered to allow deletion.
 299
 300 C<File::Path> blindly exports C<mkpath> and C<rmtree> into the
 301 current namespace. These days, this is considered bad style, but
 302 to change it now would break too much code. Nonetheless, you are
 303 invited to specify what it is you are expecting to use:
 304
 305   use File::Path 'rmtree';
 306
 307 =head1 DIAGNOSTICS
 308
 309 =over 4
 310
 311 =item *
 312
 313 On Windows, if C<mkpath> gives you the warning: B<No such file or
 314 directory>, this may mean that you've exceeded your filesystem's
 315 maximum path length.
 316
 317 =back
 318
 319 =head1 SEE ALSO
 320
 321 =over 4
 322
 323 =item *
 324
 325 L<Find::File::Rule>
 326
 327 When removing directory trees, if you want to examine each file
 328 before deciding whether to deleting it (and possibly leaving large
 329 swathes alone), F<File::Find::Rule> offers a convenient and flexible
 330 approach.
 331
 332 =back
 333
 334 =head1 BUGS
 335
 336 Please report all bugs on the RT queue:
 337
 338 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Path>
 339
 340 =head1 AUTHORS
 341
 342 Tim Bunce <F<Tim.Bunce@ig.co.uk>> and
 343 Charles Bailey <F<bailey@newman.upenn.edu>>.
 344
 345 Currently maintained by David Landgren <F<david@landgren.net>>.
 346
 347 =head1 COPYRIGHT
 348
 349 This module is copyright (C) Charles Bailey, Tim Bunce and
 350 David Landgren 1995-2007.  All rights reserved.
 351
 352 =head1 LICENSE
 353
 354 This library is free software; you can redistribute it and/or modify
 355 it under the same terms as Perl itself.
 356
 357 =cut
 358
 359 use 5.005_04;
 360 use strict;
 361
 362 use File::Basename ();
 363 use File::Spec     ();
 364 BEGIN {
 365     if ($] < 5.006) {
 366         # can't say 'opendir my $dh, $dirname'
 367         # need to initialise $dh
 368         eval "use Symbol";
 369     }
 370 }
 371
 372 use Exporter ();
 373 use vars qw($VERSION @ISA @EXPORT);
 374 $VERSION = '2.00';
 375 @ISA     = qw(Exporter);
 376 @EXPORT  = qw(mkpath rmtree);
 377
 378 my $Is_VMS = $^O eq 'VMS';
 379 my $Is_MacOS = $^O eq 'MacOS';
 380
 381 # These OSes complain if you want to remove a file that you have no
 382 # write permission to:
 383 my $Force_Writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' ||
 384                        $^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc');
 385
 386 sub _carp {
 387     require Carp;
 388     goto &Carp::carp;
 389 }
 390
 391 sub _croak {
 392     require Carp;
 393     goto &Carp::croak;
 394 }
 395
 396 sub mkpath {
 397     my $new_style = (
 398         ref($_[0]) eq 'ARRAY'
 399         or (@_ == 2 and $_[1] =~ /\A\d+\z/)
 400         or (@_ == 3 and $_[1] =~ /\A\d+\z/ and $_[2] =~ /\A\d+\z/)
 401     ) ? 0 : 1;
 402
 403     my $arg;
 404     my $paths;
 405
 406     if ($new_style) {
 407         if (ref $_[-1] eq 'HASH') {
 408             $arg = pop @_;
 409             exists $arg->{mask} and $arg->{mode} = delete $arg->{mask};
 410             $arg->{mode} = 0777 unless exists $arg->{mode};
 411             ${$arg->{error}} = [] if exists $arg->{error};
 412         }
 413         else {
 414             @{$arg}{qw(verbose mode)} = (0, 0777);
 415         }
 416         $paths = [@_];
 417     }
 418     else {
 419         my ($verbose, $mode);
 420         ($paths, $verbose, $mode) = @_;
 421         $paths = [$paths] unless ref($paths) eq 'ARRAY';
 422         $arg->{verbose} = defined $verbose ? $verbose : 0;
 423         $arg->{mode}    = defined $mode    ? $mode    : 0777;
 424     }
 425     return _mkpath($arg, $paths);
 426 }
 427
 428 sub _mkpath {
 429     my $arg   = shift;
 430     my $paths = shift;
 431
 432     local($")=$Is_MacOS ? ":" : "/";
 433     my(@created,$path);
 434     foreach $path (@$paths) {
 435         next unless length($path);
 436         $path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT
 437         # Logic wants Unix paths, so go with the flow.
 438         if ($Is_VMS) {
 439             next if $path eq '/';
 440             $path = VMS::Filespec::unixify($path);
 441         }
 442         next if -d $path;
 443         my $parent = File::Basename::dirname($path);
 444         unless (-d $parent or $path eq $parent) {
 445             push(@created,_mkpath($arg, [$parent]));
 446         }
 447         print "mkdir $path\n" if $arg->{verbose};
 448         if (mkdir($path,$arg->{mode})) {
 449             push(@created, $path);
 450         }
 451         else {
 452             my $save_bang = $!;
 453             my ($e, $e1) = ($save_bang, $^E);
 454             $e .= "; $e1" if $e ne $e1;
 455             # allow for another process to have created it meanwhile
 456             if (!-d $path) {
 457                 $! = $save_bang;
 458                 if ($arg->{error}) {
 459                     push @{${$arg->{error}}}, {$path => $e};
 460                 }
 461                 else {
 462                     _croak("mkdir $path: $e");
 463                 }
 464         }
 465     }
 466     }
 467     return @created;
 468 }
 469
 470 sub rmtree {
 471     my $new_style = (
 472         ref($_[0]) eq 'ARRAY'
 473         or (@_ == 2 and $_[1] =~ /\A\d+\z/)
 474         or (@_ == 3 and $_[1] =~ /\A\d+\z/ and $_[2] =~ /\A\d+\z/)
 475     ) ? 0 : 1;
 476
 477     my $arg;
 478     my $paths;
 479
 480     if ($new_style) {
 481         if (ref $_[-1] eq 'HASH') {
 482             $arg = pop @_;
 483             ${$arg->{error}}  = [] if exists $arg->{error};
 484             ${$arg->{result}} = [] if exists $arg->{result};
 485         }
 486         else {
 487             @{$arg}{qw(verbose safe)} = (0, 0);
 488         }
 489         $arg->{depth} = 0;
 490         $paths = [@_];
 491     }
 492     else {
 493         my ($verbose, $safe);
 494         ($paths, $verbose, $safe) = @_;
 495         $paths = [$paths] unless ref($paths) eq 'ARRAY';
 496         $arg->{verbose} = defined $verbose ? $verbose : 0;
 497         $arg->{safe}    = defined $safe    ? $safe    : 0;
 498     }
 499
 500     if (@$paths < 1) {
 501         if ($arg->{error}) {
 502             push @{${$arg->{error}}}, {'' => "No root path(s) specified"};
 503     }
 504     else {
 505             $arg->{verbose} and _carp ("No root path(s) specified\n");
 506         }
 507       return 0;
 508     }
 509     return _rmtree($arg, $paths);
 510 }
 511
 512 sub _rmtree {
 513     my $arg   = shift;
 514     my $paths = shift;
 515     my($count) = 0;
 516     my (@files, $root);
 517     foreach $root (@{$paths}) {
 518         if ($Is_MacOS) {
 519             $root = ":$root" if $root !~ /:/;
 520             $root =~ s/([^:])\z/$1:/;
 521         }
 522         else {
 523             $root =~ s#/\z##;
 524         }
 525         my $rp = (lstat $root)[2] or next;
 526         $rp &= 07777;   # don't forget setuid, setgid, sticky bits
 527         if ( -d _ ) {
 528             # notabene: 0700 is for making readable in the first place,
 529             # it's also intended to change it to writable in case we have
 530             # to recurse in which case we are better than rm -rf for
 531             # subtrees with strange permissions
 532             if (!chmod($rp | 0700,
 533                 ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
 534             ) {
 535                 if (!$arg->{safe}) {
 536                     if ($arg->{error}) {
 537                           push @{${$arg->{error}}},
 538                             {$root => "Can't make directory read+writeable: $!"};
 539                     }
 540                     else {
 541                         _carp ("Can't make directory $root read+writeable: $!");
 542                     }
 543                 }
 544             }
 545
 546             my $d;
 547             $d = gensym() if $] < 5.006;
 548             if (!opendir $d, $root) {
 549                 if ($arg->{error}) {
 550                       push @{${$arg->{error}}}, {$root => "opendir: $!"};
 551                 }
 552                 else {
 553                     _carp ("Can't read $root: $!");
 554                 }
 555                 @files = ();
 556             }
 557             else {
 558                 no strict 'refs';
 559                 if (!defined ${"\cTAINT"} or ${"\cTAINT"}) {
 560                     # Blindly untaint dir names if taint mode is
 561                     # active, or any perl < 5.006
 562                     @files = map { /\A(.*)\z/s; $1 } readdir $d;
 563                 }
 564                 else {
 565                     @files = readdir $d;
 566                 }
 567                 closedir $d;
 568             }
 569
 570             # Deleting large numbers of files from VMS Files-11 filesystems
 571             # is faster if done in reverse ASCIIbetical order
 572             @files = reverse @files if $Is_VMS;
 573             ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS;
 574             if ($Is_MacOS) {
 575                 @files = map("$root$_", @files);
 576             }
 577             else {
 578                 my $updir  = File::Spec->updir();
 579                 my $curdir = File::Spec->curdir();
 580                 @files = map(File::Spec->catfile($root,$_),
 581                     grep {$_ ne $updir and $_ ne $curdir}
 582                     @files
 583                 );
 584             }
 585             $arg->{depth}++;
 586             $count += _rmtree($arg, \@files);
 587             $arg->{depth}--;
 588             if ($arg->{depth} or !$arg->{keep_root}) {
 589                 if ($arg->{safe} &&
 590                 ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
 591                     print "skipped $root\n" if $arg->{verbose};
 592                 next;
 593             }
 594                 if (!chmod $rp | 0700, $root) {
 595                     if ($Force_Writeable) {
 596                         if ($arg->{error}) {
 597                             push @{${$arg->{error}}},
 598                                 {$root => "Can't make directory writeable: $!"};
 599                         }
 600                         else {
 601                             _carp ("Can't make directory $root writeable: $!")
 602                         }
 603                     }
 604                 }
 605                 print "rmdir $root\n" if $arg->{verbose};
 606             if (rmdir $root) {
 607                     push @{${$arg->{result}}}, $root if $arg->{result};
 608                 ++$count;
 609             }
 610             else {
 611                     if ($arg->{error}) {
 612                         push @{${$arg->{error}}}, {$root => "rmdir: $!"};
 613                     }
 614                     else {
 615                         _carp ("Can't remove directory $root: $!");
 616             }
 617                     if (!chmod($rp,
 618                         ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
 619                     ) {
 620                         my $mask = sprintf("0%o",$rp);
 621                         if ($arg->{error}) {
 622                             push @{${$arg->{error}}}, {$root => "restore chmod: $!"};
 623         }
 624         else {
 625                             _carp("and can't restore permissions to $mask\n");
 626                         }
 627                     }
 628                 }
 629             }
 630         }
 631         else {
 632             if ($arg->{safe} &&
 633                 ($Is_VMS ? !&VMS::Filespec::candelete($root)
 634                          : !(-l $root || -w $root)))
 635             {
 636                 print "skipped $root\n" if $arg->{verbose};
 637                 next;
 638             }
 639             if (!chmod $rp | 0600, $root) {
 640                 if ($Force_Writeable) {
 641                     if ($arg->{error}) {
 642                         push @{${$arg->{error}}},
 643                             {$root => "Can't make file writeable: $!"};
 644                     }
 645                     else {
 646                         _carp ("Can't make file $root writeable: $!")
 647                     }
 648                 }
 649             }
 650             print "unlink $root\n" if $arg->{verbose};
 651             # delete all versions under VMS
 652             for (;;) {
 653                 if (unlink $root) {
 654                     push @{${$arg->{result}}}, $root if $arg->{result};
 655                 }
 656                 else {
 657                     if ($arg->{error}) {
 658                         push @{${$arg->{error}}},
 659                             {$root => "unlink: $!"};
 660                     }
 661                     else {
 662                         _carp ("Can't unlink file $root: $!");
 663                     }
 664                     if ($Force_Writeable) {
 665                         if (!chmod $rp, $root) {
 666                             my $mask = sprintf("0%o",$rp);
 667                             if ($arg->{error}) {
 668                                 push @{${$arg->{error}}}, {$root => "restore chmod: $!"};
 669                             }
 670                             else {
 671                                 _carp("and can't restore permissions to $mask\n");
 672                             }
 673                         }
 674                     }
 675                     last;
 676                 }
 677                 ++$count;
 678                 last unless $Is_VMS && lstat $root;
 679             }
 680         }
 681     }
 682
 683     return $count;
 684 }
 685
 686 1;