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 Carp; 14use File::Spec; 15use Config; 16our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy); 17sub copy; 18sub syscopy; 19sub cp; 20sub mv; 21 22# Note that this module implements only *part* of the API defined by 23# the File/Copy.pm module of the File-Tools-2.0 package. However, that 24# package has not yet been updated to work with Perl 5.004, and so it 25# would be a Bad Thing for the CPAN module to grab it and replace this 26# module. Therefore, we set this module's version higher than 2.0. 27$VERSION = '2.09'; 28 29require Exporter; 30@ISA = qw(Exporter); 31@EXPORT = qw(copy move); 32@EXPORT_OK = qw(cp mv); 33 34$Too_Big = 1024 * 1024 * 2; 35 36my $macfiles; 37if ($^O eq 'MacOS') { 38 $macfiles = eval { require Mac::MoreFiles }; 39 warn 'Mac::MoreFiles could not be loaded; using non-native syscopy' 40 if $@ && $^W; 41} 42 43sub _catname { 44 my($from, $to) = @_; 45 if (not defined &basename) { 46 require File::Basename; 47 import File::Basename 'basename'; 48 } 49 50 if ($^O eq 'MacOS') { 51 # a partial dir name that's valid only in the cwd (e.g. 'tmp') 52 $to = ':' . $to if $to !~ /:/; 53 } 54 55 return File::Spec->catfile($to, basename($from)); 56} 57 58sub copy { 59 croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ") 60 unless(@_ == 2 || @_ == 3); 61 62 my $from = shift; 63 my $to = shift; 64 65 my $from_a_handle = (ref($from) 66 ? (ref($from) eq 'GLOB' 67 || UNIVERSAL::isa($from, 'GLOB') 68 || UNIVERSAL::isa($from, 'IO::Handle')) 69 : (ref(\$from) eq 'GLOB')); 70 my $to_a_handle = (ref($to) 71 ? (ref($to) eq 'GLOB' 72 || UNIVERSAL::isa($to, 'GLOB') 73 || UNIVERSAL::isa($to, 'IO::Handle')) 74 : (ref(\$to) eq 'GLOB')); 75 76 if ($from eq $to) { # works for references, too 77 carp("'$from' and '$to' are identical (not copied)"); 78 # The "copy" was a success as the source and destination contain 79 # the same data. 80 return 1; 81 } 82 83 if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) && 84 !($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'vms')) { 85 my @fs = stat($from); 86 if (@fs) { 87 my @ts = stat($to); 88 if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1]) { 89 carp("'$from' and '$to' are identical (not copied)"); 90 return 0; 91 } 92 } 93 } 94 95 if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) { 96 $to = _catname($from, $to); 97 } 98 99 if (defined &syscopy && !$Syscopy_is_copy 100 && !$to_a_handle 101 && !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles 102 && !($from_a_handle && $^O eq 'mpeix') # and neither can MPE/iX. 103 && !($from_a_handle && $^O eq 'MSWin32') 104 && !($from_a_handle && $^O eq 'MacOS') 105 && !($from_a_handle && $^O eq 'NetWare') 106 ) 107 { 108 return syscopy($from, $to); 109 } 110 111 my $closefrom = 0; 112 my $closeto = 0; 113 my ($size, $status, $r, $buf); 114 local($\) = ''; 115 116 my $from_h; 117 if ($from_a_handle) { 118 $from_h = $from; 119 } else { 120 $from = _protect($from) if $from =~ /^\s/s; 121 $from_h = \do { local *FH }; 122 open($from_h, "< $from\0") or goto fail_open1; 123 binmode $from_h or die "($!,$^E)"; 124 $closefrom = 1; 125 } 126 127 my $to_h; 128 if ($to_a_handle) { 129 $to_h = $to; 130 } else { 131 $to = _protect($to) if $to =~ /^\s/s; 132 $to_h = \do { local *FH }; 133 open($to_h,"> $to\0") or goto fail_open2; 134 binmode $to_h or die "($!,$^E)"; 135 $closeto = 1; 136 } 137 138 if (@_) { 139 $size = shift(@_) + 0; 140 croak("Bad buffer size for copy: $size\n") unless ($size > 0); 141 } else { 142 $size = tied(*$from_h) ? 0 : -s $from_h || 0; 143 $size = 1024 if ($size < 512); 144 $size = $Too_Big if ($size > $Too_Big); 145 } 146 147 $! = 0; 148 for (;;) { 149 my ($r, $w, $t); 150 defined($r = sysread($from_h, $buf, $size)) 151 or goto fail_inner; 152 last unless $r; 153 for ($w = 0; $w < $r; $w += $t) { 154 $t = syswrite($to_h, $buf, $r - $w, $w) 155 or goto fail_inner; 156 } 157 } 158 159 close($to_h) || goto fail_open2 if $closeto; 160 close($from_h) || goto fail_open1 if $closefrom; 161 162 # Use this idiom to avoid uninitialized value warning. 163 return 1; 164 165 # All of these contortions try to preserve error messages... 166 fail_inner: 167 if ($closeto) { 168 $status = $!; 169 $! = 0; 170 close $to_h; 171 $! = $status unless $!; 172 } 173 fail_open2: 174 if ($closefrom) { 175 $status = $!; 176 $! = 0; 177 close $from_h; 178 $! = $status unless $!; 179 } 180 fail_open1: 181 return 0; 182} 183 184sub move { 185 croak("Usage: move(FROM, TO) ") unless @_ == 2; 186 187 my($from,$to) = @_; 188 189 my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts); 190 191 if (-d $to && ! -d $from) { 192 $to = _catname($from, $to); 193 } 194 195 ($tosz1,$tomt1) = (stat($to))[7,9]; 196 $fromsz = -s $from; 197 if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) { 198 # will not rename with overwrite 199 unlink $to; 200 } 201 return 1 if rename $from, $to; 202 203 # Did rename return an error even though it succeeded, because $to 204 # is on a remote NFS file system, and NFS lost the server's ack? 205 return 1 if defined($fromsz) && !-e $from && # $from disappeared 206 (($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there 207 ($tosz1 != $tosz2 or $tomt1 != $tomt2) && # and changed 208 $tosz2 == $fromsz; # it's all there 209 210 ($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something 211 212 { 213 local $@; 214 eval { 215 local $SIG{__DIE__}; 216 copy($from,$to) or die; 217 my($atime, $mtime) = (stat($from))[8,9]; 218 utime($atime, $mtime, $to); 219 unlink($from) or die; 220 }; 221 return 1 unless $@; 222 } 223 ($sts,$ossts) = ($! + 0, $^E + 0); 224 225 ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1; 226 unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2; 227 ($!,$^E) = ($sts,$ossts); 228 return 0; 229} 230 231*cp = \© 232*mv = \&move; 233 234 235if ($^O eq 'MacOS') { 236 *_protect = sub { MacPerl::MakeFSSpec($_[0]) }; 237} else { 238 *_protect = sub { "./$_[0]" }; 239} 240 241# &syscopy is an XSUB under OS/2 242unless (defined &syscopy) { 243 if ($^O eq 'VMS') { 244 *syscopy = \&rmscopy; 245 } elsif ($^O eq 'mpeix') { 246 *syscopy = sub { 247 return 0 unless @_ == 2; 248 # Use the MPE cp program in order to 249 # preserve MPE file attributes. 250 return system('/bin/cp', '-f', $_[0], $_[1]) == 0; 251 }; 252 } elsif ($^O eq 'MSWin32') { 253 *syscopy = sub { 254 return 0 unless @_ == 2; 255 return Win32::CopyFile(@_, 1); 256 }; 257 } elsif ($macfiles) { 258 *syscopy = sub { 259 my($from, $to) = @_; 260 my($dir, $toname); 261 262 return 0 unless -e $from; 263 264 if ($to =~ /(.*:)([^:]+):?$/) { 265 ($dir, $toname) = ($1, $2); 266 } else { 267 ($dir, $toname) = (":", $to); 268 } 269 270 unlink($to); 271 Mac::MoreFiles::FSpFileCopy($from, $dir, $toname, 1); 272 }; 273 } else { 274 $Syscopy_is_copy = 1; 275 *syscopy = \© 276 } 277} 278 2791; 280 281__END__ 282 283=head1 NAME 284 285File::Copy - Copy files or filehandles 286 287=head1 SYNOPSIS 288 289 use File::Copy; 290 291 copy("file1","file2") or die "Copy failed: $!"; 292 copy("Copy.pm",\*STDOUT); 293 move("/dev1/fileA","/dev2/fileB"); 294 295 use File::Copy "cp"; 296 297 $n = FileHandle->new("/a/file","r"); 298 cp($n,"x"); 299 300=head1 DESCRIPTION 301 302The File::Copy module provides two basic functions, C<copy> and 303C<move>, which are useful for getting the contents of a file from 304one place to another. 305 306=over 4 307 308=item * 309 310The C<copy> function takes two 311parameters: a file to copy from and a file to copy to. Either 312argument may be a string, a FileHandle reference or a FileHandle 313glob. Obviously, if the first argument is a filehandle of some 314sort, it will be read from, and if it is a file I<name> it will 315be opened for reading. Likewise, the second argument will be 316written to (and created if need be). Trying to copy a file on top 317of itself is a fatal error. 318 319B<Note that passing in 320files as handles instead of names may lead to loss of information 321on some operating systems; it is recommended that you use file 322names whenever possible.> Files are opened in binary mode where 323applicable. To get a consistent behaviour when copying from a 324filehandle to a file, use C<binmode> on the filehandle. 325 326An optional third parameter can be used to specify the buffer 327size used for copying. This is the number of bytes from the 328first file, that wil be held in memory at any given time, before 329being written to the second file. The default buffer size depends 330upon the file, but will generally be the whole file (up to 2Mb), or 3311k for filehandles that do not reference files (eg. sockets). 332 333You may use the syntax C<use File::Copy "cp"> to get at the 334"cp" alias for this function. The syntax is I<exactly> the same. 335 336=item * 337 338The C<move> function also takes two parameters: the current name 339and the intended name of the file to be moved. If the destination 340already exists and is a directory, and the source is not a 341directory, then the source file will be renamed into the directory 342specified by the destination. 343 344If possible, move() will simply rename the file. Otherwise, it copies 345the file to the new location and deletes the original. If an error occurs 346during this copy-and-delete process, you may be left with a (possibly partial) 347copy of the file under the destination name. 348 349You may use the "mv" alias for this function in the same way that 350you may use the "cp" alias for C<copy>. 351 352=back 353 354File::Copy also provides the C<syscopy> routine, which copies the 355file specified in the first parameter to the file specified in the 356second parameter, preserving OS-specific attributes and file 357structure. For Unix systems, this is equivalent to the simple 358C<copy> routine, which doesn't preserve OS-specific attributes. For 359VMS systems, this calls the C<rmscopy> routine (see below). For OS/2 360systems, this calls the C<syscopy> XSUB directly. For Win32 systems, 361this calls C<Win32::CopyFile>. 362 363On Mac OS (Classic), C<syscopy> calls C<Mac::MoreFiles::FSpFileCopy>, 364if available. 365 366=head2 Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32) 367 368If both arguments to C<copy> are not file handles, 369then C<copy> will perform a "system copy" of 370the input file to a new output file, in order to preserve file 371attributes, indexed file structure, I<etc.> The buffer size 372parameter is ignored. If either argument to C<copy> is a 373handle to an opened file, then data is copied using Perl 374operators, and no effort is made to preserve file attributes 375or record structure. 376 377The system copy routine may also be called directly under VMS and OS/2 378as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which 379is the routine that does the actual work for syscopy). 380 381=over 4 382 383=item rmscopy($from,$to[,$date_flag]) 384 385The first and second arguments may be strings, typeglobs, typeglob 386references, or objects inheriting from IO::Handle; 387they are used in all cases to obtain the 388I<filespec> of the input and output files, respectively. The 389name and type of the input file are used as defaults for the 390output file, if necessary. 391 392A new version of the output file is always created, which 393inherits the structure and RMS attributes of the input file, 394except for owner and protections (and possibly timestamps; 395see below). All data from the input file is copied to the 396output file; if either of the first two parameters to C<rmscopy> 397is a file handle, its position is unchanged. (Note that this 398means a file handle pointing to the output file will be 399associated with an old version of that file after C<rmscopy> 400returns, not the newly created version.) 401 402The third parameter is an integer flag, which tells C<rmscopy> 403how to handle timestamps. If it is E<lt> 0, none of the input file's 404timestamps are propagated to the output file. If it is E<gt> 0, then 405it is interpreted as a bitmask: if bit 0 (the LSB) is set, then 406timestamps other than the revision date are propagated; if bit 1 407is set, the revision date is propagated. If the third parameter 408to C<rmscopy> is 0, then it behaves much like the DCL COPY command: 409if the name or type of the output file was explicitly specified, 410then no timestamps are propagated, but if they were taken implicitly 411from the input filespec, then all timestamps other than the 412revision date are propagated. If this parameter is not supplied, 413it defaults to 0. 414 415Like C<copy>, C<rmscopy> returns 1 on success. If an error occurs, 416it sets C<$!>, deletes the output file, and returns 0. 417 418=back 419 420=head1 RETURN 421 422All functions return 1 on success, 0 on failure. 423$! will be set if an error was encountered. 424 425=head1 NOTES 426 427=over 4 428 429=item * 430 431On Mac OS (Classic), the path separator is ':', not '/', and the 432current directory is denoted as ':', not '.'. You should be careful 433about specifying relative pathnames. While a full path always begins 434with a volume name, a relative pathname should always begin with a 435':'. If specifying a volume name only, a trailing ':' is required. 436 437E.g. 438 439 copy("file1", "tmp"); # creates the file 'tmp' in the current directory 440 copy("file1", ":tmp:"); # creates :tmp:file1 441 copy("file1", ":tmp"); # same as above 442 copy("file1", "tmp"); # same as above, if 'tmp' is a directory (but don't do 443 # that, since it may cause confusion, see example #1) 444 copy("file1", "tmp:file1"); # error, since 'tmp:' is not a volume 445 copy("file1", ":tmp:file1"); # ok, partial path 446 copy("file1", "DataHD:"); # creates DataHD:file1 447 448 move("MacintoshHD:fileA", "DataHD:fileB"); # moves (don't copies) files from one 449 # volume to another 450 451=back 452 453=head1 AUTHOR 454 455File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995, 456and updated by Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> in 1996. 457 458=cut 459 460