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