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