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