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