lib/File/Copy.pm

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