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; no warnings 'newline'; 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.23'; 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 44# Look up the feature settings on VMS using VMS::Feature when available. 45 46my $use_vms_feature = 0; 47BEGIN { 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. 57sub _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. 70sub _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 82sub _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 93sub _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 105sub 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 275sub 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 315sub _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 406sub move { _move(@_,\©); } 407sub mv { _move(@_,\&cp); } 408 409# &syscopy is an XSUB under OS/2 410unless (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 = \© 429 } 430} 431 4321; 433 434__END__ 435 436=head1 NAME 437 438File::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 455The File::Copy module provides two basic functions, C<copy> and 456C<move>, which are useful for getting the contents of a file from 457one place to another. 458 459=over 4 460 461=item copy 462X<copy> X<cp> 463 464The C<copy> function takes two 465parameters: a file to copy from and a file to copy to. Either 466argument may be a string, a FileHandle reference or a FileHandle 467glob. Obviously, if the first argument is a filehandle of some 468sort, it will be read from, and if it is a file I<name> it will 469be opened for reading. Likewise, the second argument will be 470written to (and created if need be). Trying to copy a file on top 471of itself is a fatal error. 472 473If the destination (second argument) already exists and is a directory, 474and the source (first argument) is not a filehandle, then the source 475file will be copied into the directory specified by the destination, 476using the same base name as the source file. It's a failure to have a 477filehandle as the source when the destination is a directory. 478 479B<Note that passing in 480files as handles instead of names may lead to loss of information 481on some operating systems; it is recommended that you use file 482names whenever possible.> Files are opened in binary mode where 483applicable. To get a consistent behaviour when copying from a 484filehandle to a file, use C<binmode> on the filehandle. 485 486An optional third parameter can be used to specify the buffer 487size used for copying. This is the number of bytes from the 488first file, that will be held in memory at any given time, before 489being written to the second file. The default buffer size depends 490upon the file, but will generally be the whole file (up to 2MB), or 4911k for filehandles that do not reference files (eg. sockets). 492 493You may use the syntax C<use File::Copy "cp"> to get at the C<cp> 494alias for this function. The syntax is I<exactly> the same. The 495behavior is nearly the same as well: as of version 2.15, <cp> will 496preserve the source file's permission bits like the shell utility 497C<cp(1)> would do, while C<copy> uses the default permissions for the 498target file (which may depend on the process' C<umask>, file 499ownership, inherited ACLs, etc.). If an error occurs in setting 500permissions, C<cp> will return 0, regardless of whether the file was 501successfully copied. 502 503=item move 504X<move> X<mv> X<rename> 505 506The C<move> function also takes two parameters: the current name 507and the intended name of the file to be moved. If the destination 508already exists and is a directory, and the source is not a 509directory, then the source file will be renamed into the directory 510specified by the destination. 511 512If possible, move() will simply rename the file. Otherwise, it copies 513the file to the new location and deletes the original. If an error occurs 514during this copy-and-delete process, you may be left with a (possibly partial) 515copy of the file under the destination name. 516 517You may use the C<mv> alias for this function in the same way that 518you may use the <cp> alias for C<copy>. 519 520=item syscopy 521X<syscopy> 522 523File::Copy also provides the C<syscopy> routine, which copies the 524file specified in the first parameter to the file specified in the 525second parameter, preserving OS-specific attributes and file 526structure. For Unix systems, this is equivalent to the simple 527C<copy> routine, which doesn't preserve OS-specific attributes. For 528VMS systems, this calls the C<rmscopy> routine (see below). For OS/2 529systems, this calls the C<syscopy> XSUB directly. For Win32 systems, 530this calls C<Win32::CopyFile>. 531 532B<Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)>: 533 534If both arguments to C<copy> are not file handles, 535then C<copy> will perform a "system copy" of 536the input file to a new output file, in order to preserve file 537attributes, indexed file structure, I<etc.> The buffer size 538parameter is ignored. If either argument to C<copy> is a 539handle to an opened file, then data is copied using Perl 540operators, and no effort is made to preserve file attributes 541or record structure. 542 543The system copy routine may also be called directly under VMS and OS/2 544as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which 545is the routine that does the actual work for syscopy). 546 547=item rmscopy($from,$to[,$date_flag]) 548X<rmscopy> 549 550The first and second arguments may be strings, typeglobs, typeglob 551references, or objects inheriting from IO::Handle; 552they are used in all cases to obtain the 553I<filespec> of the input and output files, respectively. The 554name and type of the input file are used as defaults for the 555output file, if necessary. 556 557A new version of the output file is always created, which 558inherits the structure and RMS attributes of the input file, 559except for owner and protections (and possibly timestamps; 560see below). All data from the input file is copied to the 561output file; if either of the first two parameters to C<rmscopy> 562is a file handle, its position is unchanged. (Note that this 563means a file handle pointing to the output file will be 564associated with an old version of that file after C<rmscopy> 565returns, not the newly created version.) 566 567The third parameter is an integer flag, which tells C<rmscopy> 568how to handle timestamps. If it is E<lt> 0, none of the input file's 569timestamps are propagated to the output file. If it is E<gt> 0, then 570it is interpreted as a bitmask: if bit 0 (the LSB) is set, then 571timestamps other than the revision date are propagated; if bit 1 572is set, the revision date is propagated. If the third parameter 573to C<rmscopy> is 0, then it behaves much like the DCL COPY command: 574if the name or type of the output file was explicitly specified, 575then no timestamps are propagated, but if they were taken implicitly 576from the input filespec, then all timestamps other than the 577revision date are propagated. If this parameter is not supplied, 578it defaults to 0. 579 580Like C<copy>, C<rmscopy> returns 1 on success. If an error occurs, 581it sets C<$!>, deletes the output file, and returns 0. 582 583=back 584 585=head1 RETURN 586 587All functions return 1 on success, 0 on failure. 588$! will be set if an error was encountered. 589 590=head1 AUTHOR 591 592File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995, 593and updated by Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> in 1996. 594 595=cut 596 597