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