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