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