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