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