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.39'; 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 $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, while C<copy> uses the default permissions for the 399target file (which may depend on the process' C<umask>, file 400ownership, inherited ACLs, etc.). If an error occurs in setting 401permissions, C<cp> will return 0, regardless of whether the file was 402successfully copied. 403 404=item move 405X<move> X<mv> X<rename> 406 407The C<move> function also takes two parameters: the current name 408and the intended name of the file to be moved. If the destination 409already exists and is a directory, and the source is not a 410directory, then the source file will be renamed into the directory 411specified by the destination. 412 413If possible, move() will simply rename the file. Otherwise, it copies 414the file to the new location and deletes the original. If an error occurs 415during this copy-and-delete process, you may be left with a (possibly partial) 416copy of the file under the destination name. 417 418You may use the C<mv> alias for this function in the same way that 419you may use the C<cp> alias for C<copy>. 420 421=item syscopy 422X<syscopy> 423 424File::Copy also provides the C<syscopy> routine, which copies the 425file specified in the first parameter to the file specified in the 426second parameter, preserving OS-specific attributes and file 427structure. For Unix systems, this is equivalent to the simple 428C<copy> routine, which doesn't preserve OS-specific attributes. For 429VMS systems, this calls the C<rmscopy> routine (see below). For OS/2 430systems, this calls the C<syscopy> XSUB directly. For Win32 systems, 431this calls C<Win32::CopyFile>. 432 433B<Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)>: 434 435If both arguments to C<copy> are not file handles, 436then C<copy> will perform a "system copy" of 437the input file to a new output file, in order to preserve file 438attributes, indexed file structure, I<etc.> The buffer size 439parameter is ignored. If either argument to C<copy> is a 440handle to an opened file, then data is copied using Perl 441operators, and no effort is made to preserve file attributes 442or record structure. 443 444The system copy routine may also be called directly under VMS and OS/2 445as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which 446is the routine that does the actual work for syscopy). 447 448=item rmscopy($from,$to[,$date_flag]) 449X<rmscopy> 450 451The first and second arguments may be strings, typeglobs, typeglob 452references, or objects inheriting from IO::Handle; 453they are used in all cases to obtain the 454I<filespec> of the input and output files, respectively. The 455name and type of the input file are used as defaults for the 456output file, if necessary. 457 458A new version of the output file is always created, which 459inherits the structure and RMS attributes of the input file, 460except for owner and protections (and possibly timestamps; 461see below). All data from the input file is copied to the 462output file; if either of the first two parameters to C<rmscopy> 463is a file handle, its position is unchanged. (Note that this 464means a file handle pointing to the output file will be 465associated with an old version of that file after C<rmscopy> 466returns, not the newly created version.) 467 468The third parameter is an integer flag, which tells C<rmscopy> 469how to handle timestamps. If it is E<lt> 0, none of the input file's 470timestamps are propagated to the output file. If it is E<gt> 0, then 471it is interpreted as a bitmask: if bit 0 (the LSB) is set, then 472timestamps other than the revision date are propagated; if bit 1 473is set, the revision date is propagated. If the third parameter 474to C<rmscopy> is 0, then it behaves much like the DCL COPY command: 475if the name or type of the output file was explicitly specified, 476then no timestamps are propagated, but if they were taken implicitly 477from the input filespec, then all timestamps other than the 478revision date are propagated. If this parameter is not supplied, 479it defaults to 0. 480 481C<rmscopy> is VMS specific and cannot be exported; it must be 482referenced by its full name, e.g.: 483 484 File::Copy::rmscopy($from, $to) or die $!; 485 486Like C<copy>, C<rmscopy> returns 1 on success. If an error occurs, 487it sets C<$!>, deletes the output file, and returns 0. 488 489=back 490 491=head1 RETURN 492 493All functions return 1 on success, 0 on failure. 494$! will be set if an error was encountered. 495 496=head1 NOTES 497 498Before calling copy() or move() on a filehandle, the caller should 499close or flush() the file to avoid writes being lost. Note that this 500is the case even for move(), because it may actually copy the file, 501depending on the OS-specific implementation, and the underlying 502filesystem(s). 503 504=head1 AUTHOR 505 506File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995, 507and updated by Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> in 1996. 508 509=cut 510 511