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