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