lib/File/Copy.pm

   1 # File/Copy.pm. Written in 1994 by Aaron Sherman <ajs@ajs.com>. This
   2 # source code has been placed in the public domain by the author.
   3 # Please be kind and preserve the documentation.
   4 #
   5 # Additions copyright 1996 by Charles Bailey.  Permission is granted
   6 # to distribute the revised code under the same terms as Perl itself.
   7
   8 package File::Copy;
   9
  10 use 5.006;
  11 use strict;
  12 use warnings;
  13 use File::Spec;
  14 use Config;
  15 # During perl build, we need File::Copy but Scalar::Util might not be built yet
  16 # And then we need these games to avoid loading overload, as that will
  17 # confuse miniperl during the bootstrap of perl.
  18 my $Scalar_Util_loaded = eval q{ require Scalar::Util; require overload; 1 };
  19 our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
  20 sub copy;
  21 sub syscopy;
  22 sub cp;
  23 sub mv;
  24
  25 $VERSION = '2.18';
  26
  27 require Exporter;
  28 @ISA = qw(Exporter);
  29 @EXPORT = qw(copy move);
  30 @EXPORT_OK = qw(cp mv);
  31
  32 $Too_Big = 1024 * 1024 * 2;
  33
  34 sub croak {
  35     require Carp;
  36     goto &Carp::croak;
  37 }
  38
  39 sub carp {
  40     require Carp;
  41     goto &Carp::carp;
  42 }
  43
  44 my $macfiles;
  45 if ($^O eq 'MacOS') {
  46         $macfiles = eval { require Mac::MoreFiles };
  47         warn 'Mac::MoreFiles could not be loaded; using non-native syscopy'
  48                 if $@ && $^W;
  49 }
  50
  51 # Look up the feature settings on VMS using VMS::Feature when available.
  52
  53 my $use_vms_feature = 0;
  54 BEGIN {
  55     if ($^O eq 'VMS') {
  56         if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
  57             $use_vms_feature = 1;
  58         }
  59     }
  60 }
  61
  62 # Need to look up the UNIX report mode.  This may become a dynamic mode
  63 # in the future.
  64 sub _vms_unix_rpt {
  65     my $unix_rpt;
  66     if ($use_vms_feature) {
  67         $unix_rpt = VMS::Feature::current("filename_unix_report");
  68     } else {
  69         my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
  70         $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
  71     }
  72     return $unix_rpt;
  73 }
  74
  75 # Need to look up the EFS character set mode.  This may become a dynamic
  76 # mode in the future.
  77 sub _vms_efs {
  78     my $efs;
  79     if ($use_vms_feature) {
  80         $efs = VMS::Feature::current("efs_charset");
  81     } else {
  82         my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
  83         $efs = $env_efs =~ /^[ET1]/i;
  84     }
  85     return $efs;
  86 }
  87
  88
  89 sub _catname {
  90     my($from, $to) = @_;
  91     if (not defined &basename) {
  92         require File::Basename;
  93         import  File::Basename 'basename';
  94     }
  95
  96     if ($^O eq 'MacOS') {
  97         # a partial dir name that's valid only in the cwd (e.g. 'tmp')
  98         $to = ':' . $to if $to !~ /:/;
  99     }
 100
 101     return File::Spec->catfile($to, basename($from));
 102 }
 103
 104 # _eq($from, $to) tells whether $from and $to are identical
 105 sub _eq {
 106     my ($from, $to) = map {
 107         $Scalar_Util_loaded && Scalar::Util::blessed($_)
 108             && overload::Method($_, q{""})
 109             ? "$_"
 110             : $_
 111     } (@_);
 112     return '' if ( (ref $from) xor (ref $to) );
 113     return $from == $to if ref $from;
 114     return $from eq $to;
 115 }
 116
 117 sub copy {
 118     croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ")
 119       unless(@_ == 2 || @_ == 3);
 120
 121     my $from = shift;
 122     my $to = shift;
 123
 124     my $size;
 125     if (@_) {
 126         $size = shift(@_) + 0;
 127         croak("Bad buffer size for copy: $size\n") unless ($size > 0);
 128     }
 129
 130     my $from_a_handle = (ref($from)
 131                          ? (ref($from) eq 'GLOB'
 132                             || UNIVERSAL::isa($from, 'GLOB')
 133                             || UNIVERSAL::isa($from, 'IO::Handle'))
 134                          : (ref(\$from) eq 'GLOB'));
 135     my $to_a_handle =   (ref($to)
 136                          ? (ref($to) eq 'GLOB'
 137                             || UNIVERSAL::isa($to, 'GLOB')
 138                             || UNIVERSAL::isa($to, 'IO::Handle'))
 139                          : (ref(\$to) eq 'GLOB'));
 140
 141     if (_eq($from, $to)) { # works for references, too
 142         carp("'$from' and '$to' are identical (not copied)");
 143         # The "copy" was a success as the source and destination contain
 144         # the same data.
 145         return 1;
 146     }
 147
 148     if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) &&
 149         !($^O eq 'MSWin32' || $^O eq 'os2')) {
 150         my @fs = stat($from);
 151         if (@fs) {
 152             my @ts = stat($to);
 153             if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1] && !-p $from) {
 154                 carp("'$from' and '$to' are identical (not copied)");
 155                 return 0;
 156             }
 157         }
 158     }
 159
 160     if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) {
 161         $to = _catname($from, $to);
 162     }
 163
 164     if (defined &syscopy && !$Syscopy_is_copy
 165         && !$to_a_handle
 166         && !($from_a_handle && $^O eq 'os2' )   # OS/2 cannot handle handles
 167         && !($from_a_handle && $^O eq 'mpeix')  # and neither can MPE/iX.
 168         && !($from_a_handle && $^O eq 'MSWin32')
 169         && !($from_a_handle && $^O eq 'MacOS')
 170         && !($from_a_handle && $^O eq 'NetWare')
 171        )
 172     {
 173         my $copy_to = $to;
 174
 175         if ($^O eq 'VMS' && -e $from) {
 176
 177             if (! -d $to && ! -d $from) {
 178
 179                 my $vms_efs = _vms_efs();
 180                 my $unix_rpt = _vms_unix_rpt();
 181                 my $unix_mode = 0;
 182                 my $from_unix = 0;
 183                 $from_unix = 1 if ($from =~ /^\.\.?$/);
 184                 my $from_vms = 0;
 185                 $from_vms = 1 if ($from =~ m#[\[<\]]#);
 186
 187                 # Need to know if we are in Unix mode.
 188                 if ($from_vms == $from_unix) {
 189                     $unix_mode = $unix_rpt;
 190                 } else {
 191                     $unix_mode = $from_unix;
 192                 }
 193
 194                 # VMS has sticky defaults on extensions, which means that
 195                 # if there is a null extension on the destination file, it
 196                 # will inherit the extension of the source file
 197                 # So add a '.' for a null extension.
 198
 199                 # In unix_rpt mode, the trailing dot should not be added.
 200
 201                 if ($vms_efs) {
 202                     $copy_to = $to;
 203                 } else {
 204                     $copy_to = VMS::Filespec::vmsify($to);
 205                 }
 206                 my ($vol, $dirs, $file) = File::Spec->splitpath($copy_to);
 207                 $file = $file . '.'
 208                     unless (($file =~ /(?<!\^)\./) || $unix_rpt);
 209                 $copy_to = File::Spec->catpath($vol, $dirs, $file);
 210
 211                 # Get rid of the old versions to be like UNIX
 212                 1 while unlink $copy_to;
 213             }
 214         }
 215
 216         return syscopy($from, $copy_to) || 0;
 217     }
 218
 219     my $closefrom = 0;
 220     my $closeto = 0;
 221     my ($status, $r, $buf);
 222     local($\) = '';
 223
 224     my $from_h;
 225     if ($from_a_handle) {
 226        $from_h = $from;
 227     } else {
 228        open $from_h, "<", $from or goto fail_open1;
 229        binmode $from_h or die "($!,$^E)";
 230        $closefrom = 1;
 231     }
 232
 233     # Seems most logical to do this here, in case future changes would want to
 234     # make this croak for some reason.
 235     unless (defined $size) {
 236         $size = tied(*$from_h) ? 0 : -s $from_h || 0;
 237         $size = 1024 if ($size < 512);
 238         $size = $Too_Big if ($size > $Too_Big);
 239     }
 240
 241     my $to_h;
 242     if ($to_a_handle) {
 243        $to_h = $to;
 244     } else {
 245         $to_h = \do { local *FH }; # XXX is this line obsolete?
 246         open $to_h, ">", $to or goto fail_open2;
 247         binmode $to_h or die "($!,$^E)";
 248         $closeto = 1;
 249     }
 250
 251     $! = 0;
 252     for (;;) {
 253         my ($r, $w, $t);
 254        defined($r = sysread($from_h, $buf, $size))
 255             or goto fail_inner;
 256         last unless $r;
 257         for ($w = 0; $w < $r; $w += $t) {
 258            $t = syswrite($to_h, $buf, $r - $w, $w)
 259                 or goto fail_inner;
 260         }
 261     }
 262
 263     close($to_h) || goto fail_open2 if $closeto;
 264     close($from_h) || goto fail_open1 if $closefrom;
 265
 266     # Use this idiom to avoid uninitialized value warning.
 267     return 1;
 268
 269     # All of these contortions try to preserve error messages...
 270   fail_inner:
 271     if ($closeto) {
 272         $status = $!;
 273         $! = 0;
 274        close $to_h;
 275         $! = $status unless $!;
 276     }
 277   fail_open2:
 278     if ($closefrom) {
 279         $status = $!;
 280         $! = 0;
 281        close $from_h;
 282         $! = $status unless $!;
 283     }
 284   fail_open1:
 285     return 0;
 286 }
 287
 288 sub cp {
 289     my($from,$to) = @_;
 290     my(@fromstat) = stat $from;
 291     my(@tostat) = stat $to;
 292     my $perm;
 293
 294     return 0 unless copy(@_) and @fromstat;
 295
 296     if (@tostat) {
 297         $perm = $tostat[2];
 298     } else {
 299         $perm = $fromstat[2] & ~(umask || 0);
 300         @tostat = stat $to;
 301     }
 302     # Might be more robust to look for S_I* in Fcntl, but we're
 303     # trying to avoid dependence on any XS-containing modules,
 304     # since File::Copy is used during the Perl build.
 305     $perm &= 07777;
 306     if ($perm & 06000) {
 307         croak("Unable to check setuid/setgid permissions for $to: $!")
 308             unless @tostat;
 309
 310         if ($perm & 04000 and                     # setuid
 311             $fromstat[4] != $tostat[4]) {         # owner must match
 312             $perm &= ~06000;
 313         }
 314
 315         if ($perm & 02000 && $> != 0) {           # if not root, setgid
 316             my $ok = $fromstat[5] == $tostat[5];  # group must match
 317             if ($ok) {                            # and we must be in group
 318                 $ok = grep { $_ == $fromstat[5] } split /\s+/, $)
 319             }
 320             $perm &= ~06000 unless $ok;
 321         }
 322     }
 323     return 0 unless @tostat;
 324     return 1 if $perm == ($tostat[2] & 07777);
 325     return eval { chmod $perm, $to; } ? 1 : 0;
 326 }
 327
 328 sub _move {
 329     croak("Usage: move(FROM, TO) ") unless @_ == 3;
 330
 331     my($from,$to,$fallback) = @_;
 332
 333     my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
 334
 335     if (-d $to && ! -d $from) {
 336         $to = _catname($from, $to);
 337     }
 338
 339     ($tosz1,$tomt1) = (stat($to))[7,9];
 340     $fromsz = -s $from;
 341     if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) {
 342       # will not rename with overwrite
 343       unlink $to;
 344     }
 345
 346     my $rename_to = $to;
 347     if (-$^O eq 'VMS' && -e $from) {
 348
 349         if (! -d $to && ! -d $from) {
 350
 351             my $vms_efs = _vms_efs();
 352             my $unix_rpt = _vms_unix_rpt();
 353             my $unix_mode = 0;
 354             my $from_unix = 0;
 355             $from_unix = 1 if ($from =~ /^\.\.?$/);
 356             my $from_vms = 0;
 357             $from_vms = 1 if ($from =~ m#[\[<\]]#);
 358
 359             # Need to know if we are in Unix mode.
 360             if ($from_vms == $from_unix) {
 361                 $unix_mode = $unix_rpt;
 362             } else {
 363                 $unix_mode = $from_unix;
 364             }
 365
 366             # VMS has sticky defaults on extensions, which means that
 367             # if there is a null extension on the destination file, it
 368             # will inherit the extension of the source file
 369             # So add a '.' for a null extension.
 370
 371             # In unix_rpt mode, the trailing dot should not be added.
 372
 373             if ($vms_efs) {
 374                 $rename_to = $to;
 375             } else {
 376                 $rename_to = VMS::Filespec::vmsify($to);
 377             }
 378             my ($vol, $dirs, $file) = File::Spec->splitpath($rename_to);
 379             $file = $file . '.'
 380                 unless (($file =~ /(?<!\^)\./) || $unix_rpt);
 381             $rename_to = File::Spec->catpath($vol, $dirs, $file);
 382
 383             # Get rid of the old versions to be like UNIX
 384             1 while unlink $rename_to;
 385         }
 386     }
 387
 388     return 1 if rename $from, $rename_to;
 389
 390     # Did rename return an error even though it succeeded, because $to
 391     # is on a remote NFS file system, and NFS lost the server's ack?
 392     return 1 if defined($fromsz) && !-e $from &&           # $from disappeared
 393                 (($tosz2,$tomt2) = (stat($to))[7,9]) &&    # $to's there
 394                   ((!defined $tosz1) ||                    #  not before or
 395                    ($tosz1 != $tosz2 or $tomt1 != $tomt2)) &&  #   was changed
 396                 $tosz2 == $fromsz;                         # it's all there
 397
 398     ($tosz1,$tomt1) = (stat($to))[7,9];  # just in case rename did something
 399
 400     {
 401         local $@;
 402         eval {
 403             local $SIG{__DIE__};
 404             $fallback->($from,$to) or die;
 405             my($atime, $mtime) = (stat($from))[8,9];
 406             utime($atime, $mtime, $to);
 407             unlink($from)   or die;
 408         };
 409         return 1 unless $@;
 410     }
 411     ($sts,$ossts) = ($! + 0, $^E + 0);
 412
 413     ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1;
 414     unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2;
 415     ($!,$^E) = ($sts,$ossts);
 416     return 0;
 417 }
 418
 419 sub move { _move(@_,\&copy); }
 420 sub mv   { _move(@_,\&cp);   }
 421
 422 # &syscopy is an XSUB under OS/2
 423 unless (defined &syscopy) {
 424     if ($^O eq 'VMS') {
 425         *syscopy = \&rmscopy;
 426     } elsif ($^O eq 'mpeix') {
 427         *syscopy = sub {
 428             return 0 unless @_ == 2;
 429             # Use the MPE cp program in order to
 430             # preserve MPE file attributes.
 431             return system('/bin/cp', '-f', $_[0], $_[1]) == 0;
 432         };
 433     } elsif ($^O eq 'MSWin32' && defined &DynaLoader::boot_DynaLoader) {
 434         # Win32::CopyFile() fill only work if we can load Win32.xs
 435         *syscopy = sub {
 436             return 0 unless @_ == 2;
 437             return Win32::CopyFile(@_, 1);
 438         };
 439     } elsif ($macfiles) {
 440         *syscopy = sub {
 441             my($from, $to) = @_;
 442             my($dir, $toname);
 443
 444             return 0 unless -e $from;
 445
 446             if ($to =~ /(.*:)([^:]+):?$/) {
 447                 ($dir, $toname) = ($1, $2);
 448             } else {
 449                 ($dir, $toname) = (":", $to);
 450             }
 451
 452             unlink($to);
 453             Mac::MoreFiles::FSpFileCopy($from, $dir, $toname, 1);
 454         };
 455     } else {
 456         $Syscopy_is_copy = 1;
 457         *syscopy = \&copy;
 458     }
 459 }
 460
 461 1;
 462
 463 __END__
 464
 465 =head1 NAME
 466
 467 File::Copy - Copy files or filehandles
 468
 469 =head1 SYNOPSIS
 470
 471         use File::Copy;
 472
 473         copy("file1","file2") or die "Copy failed: $!";
 474         copy("Copy.pm",\*STDOUT);
 475         move("/dev1/fileA","/dev2/fileB");
 476
 477         use File::Copy "cp";
 478
 479         $n = FileHandle->new("/a/file","r");
 480         cp($n,"x");
 481
 482 =head1 DESCRIPTION
 483
 484 The File::Copy module provides two basic functions, C<copy> and
 485 C<move>, which are useful for getting the contents of a file from
 486 one place to another.
 487
 488 =over 4
 489
 490 =item copy
 491 X<copy> X<cp>
 492
 493 The C<copy> function takes two
 494 parameters: a file to copy from and a file to copy to. Either
 495 argument may be a string, a FileHandle reference or a FileHandle
 496 glob. Obviously, if the first argument is a filehandle of some
 497 sort, it will be read from, and if it is a file I<name> it will
 498 be opened for reading. Likewise, the second argument will be
 499 written to (and created if need be).  Trying to copy a file on top
 500 of itself is a fatal error.
 501
 502 B<Note that passing in
 503 files as handles instead of names may lead to loss of information
 504 on some operating systems; it is recommended that you use file
 505 names whenever possible.>  Files are opened in binary mode where
 506 applicable.  To get a consistent behaviour when copying from a
 507 filehandle to a file, use C<binmode> on the filehandle.
 508
 509 An optional third parameter can be used to specify the buffer
 510 size used for copying. This is the number of bytes from the
 511 first file, that will be held in memory at any given time, before
 512 being written to the second file. The default buffer size depends
 513 upon the file, but will generally be the whole file (up to 2MB), or
 514 1k for filehandles that do not reference files (eg. sockets).
 515
 516 You may use the syntax C<use File::Copy "cp"> to get at the C<cp>
 517 alias for this function. The syntax is I<exactly> the same.  The
 518 behavior is nearly the same as well: as of version 2.15, <cp> will
 519 preserve the source file's permission bits like the shell utility
 520 C<cp(1)> would do, while C<copy> uses the default permissions for the
 521 target file (which may depend on the process' C<umask>, file
 522 ownership, inherited ACLs, etc.).  If an error occurs in setting
 523 permissions, C<cp> will return 0, regardless of whether the file was
 524 successfully copied.
 525
 526 =item move
 527 X<move> X<mv> X<rename>
 528
 529 The C<move> function also takes two parameters: the current name
 530 and the intended name of the file to be moved.  If the destination
 531 already exists and is a directory, and the source is not a
 532 directory, then the source file will be renamed into the directory
 533 specified by the destination.
 534
 535 If possible, move() will simply rename the file.  Otherwise, it copies
 536 the file to the new location and deletes the original.  If an error occurs
 537 during this copy-and-delete process, you may be left with a (possibly partial)
 538 copy of the file under the destination name.
 539
 540 You may use the C<mv> alias for this function in the same way that
 541 you may use the <cp> alias for C<copy>.
 542
 543 =item syscopy
 544 X<syscopy>
 545
 546 File::Copy also provides the C<syscopy> routine, which copies the
 547 file specified in the first parameter to the file specified in the
 548 second parameter, preserving OS-specific attributes and file
 549 structure.  For Unix systems, this is equivalent to the simple
 550 C<copy> routine, which doesn't preserve OS-specific attributes.  For
 551 VMS systems, this calls the C<rmscopy> routine (see below).  For OS/2
 552 systems, this calls the C<syscopy> XSUB directly. For Win32 systems,
 553 this calls C<Win32::CopyFile>.
 554
 555 On Mac OS (Classic), C<syscopy> calls C<Mac::MoreFiles::FSpFileCopy>,
 556 if available.
 557
 558 B<Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)>:
 559
 560 If both arguments to C<copy> are not file handles,
 561 then C<copy> will perform a "system copy" of
 562 the input file to a new output file, in order to preserve file
 563 attributes, indexed file structure, I<etc.>  The buffer size
 564 parameter is ignored.  If either argument to C<copy> is a
 565 handle to an opened file, then data is copied using Perl
 566 operators, and no effort is made to preserve file attributes
 567 or record structure.
 568
 569 The system copy routine may also be called directly under VMS and OS/2
 570 as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which
 571 is the routine that does the actual work for syscopy).
 572
 573 =item rmscopy($from,$to[,$date_flag])
 574 X<rmscopy>
 575
 576 The first and second arguments may be strings, typeglobs, typeglob
 577 references, or objects inheriting from IO::Handle;
 578 they are used in all cases to obtain the
 579 I<filespec> of the input and output files, respectively.  The
 580 name and type of the input file are used as defaults for the
 581 output file, if necessary.
 582
 583 A new version of the output file is always created, which
 584 inherits the structure and RMS attributes of the input file,
 585 except for owner and protections (and possibly timestamps;
 586 see below).  All data from the input file is copied to the
 587 output file; if either of the first two parameters to C<rmscopy>
 588 is a file handle, its position is unchanged.  (Note that this
 589 means a file handle pointing to the output file will be
 590 associated with an old version of that file after C<rmscopy>
 591 returns, not the newly created version.)
 592
 593 The third parameter is an integer flag, which tells C<rmscopy>
 594 how to handle timestamps.  If it is E<lt> 0, none of the input file's
 595 timestamps are propagated to the output file.  If it is E<gt> 0, then
 596 it is interpreted as a bitmask: if bit 0 (the LSB) is set, then
 597 timestamps other than the revision date are propagated; if bit 1
 598 is set, the revision date is propagated.  If the third parameter
 599 to C<rmscopy> is 0, then it behaves much like the DCL COPY command:
 600 if the name or type of the output file was explicitly specified,
 601 then no timestamps are propagated, but if they were taken implicitly
 602 from the input filespec, then all timestamps other than the
 603 revision date are propagated.  If this parameter is not supplied,
 604 it defaults to 0.
 605
 606 Like C<copy>, C<rmscopy> returns 1 on success.  If an error occurs,
 607 it sets C<$!>, deletes the output file, and returns 0.
 608
 609 =back
 610
 611 =head1 RETURN
 612
 613 All functions return 1 on success, 0 on failure.
 614 $! will be set if an error was encountered.
 615
 616 =head1 NOTES
 617
 618 =over 4
 619
 620 =item *
 621
 622 On Mac OS (Classic), the path separator is ':', not '/', and the
 623 current directory is denoted as ':', not '.'. You should be careful
 624 about specifying relative pathnames. While a full path always begins
 625 with a volume name, a relative pathname should always begin with a
 626 ':'.  If specifying a volume name only, a trailing ':' is required.
 627
 628 E.g.
 629
 630   copy("file1", "tmp");        # creates the file 'tmp' in the current directory
 631   copy("file1", ":tmp:");      # creates :tmp:file1
 632   copy("file1", ":tmp");       # same as above
 633   copy("file1", "tmp");        # same as above, if 'tmp' is a directory (but don't do
 634                                # that, since it may cause confusion, see example #1)
 635   copy("file1", "tmp:file1");  # error, since 'tmp:' is not a volume
 636   copy("file1", ":tmp:file1"); # ok, partial path
 637   copy("file1", "DataHD:");    # creates DataHD:file1
 638
 639   move("MacintoshHD:fileA", "DataHD:fileB"); # moves (doesn't copy) files from one
 640                                              # volume to another
 641
 642 =back
 643
 644 =head1 AUTHOR
 645
 646 File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995,
 647 and updated by Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> in 1996.
 648
 649 =cut
 650