File Coverage

blib/lib/File/NCopy.pm
Criterion Covered Total %
statement 55 215 25.5
branch 18 176 10.2
condition 5 71 7.0
subroutine 9 23 39.1
pod 7 13 53.8
total 94 498 18.8


line stmt bran cond sub pod time code
1             package File::NCopy;
2 1     1   4114 use 5.004; # just because I think you should upgrade :)
  1         3  
3              
4             =head1 NAME
5              
6             File::NCopy - Almost abandoned module. Copy file, file. Copy file[s] | dir[s], dir
7              
8             =head1 SYNOPSIS
9              
10             use File::NCopy qw(copy);
11              
12             copy "file","other_file";
13             copy "file1","file2","file3","directory";
14              
15             # we want to copy the directory recursively
16             copy \1,"directory1","directory2";
17             copy \1,"file1","file2","directory1","file3","directory2","file4",
18             "directory";
19              
20             # can also use references to file handles, this is for backward
21             # compatibility with File::Copy
22             copy \*FILE1,\*FILE2;
23             copy \*FILE1,"file";
24             copy "file1",\*FILE2;
25              
26              
27             # we don't specify \1 as the first argument because we don't want to
28             # copy directories recursively
29             copy "*.c","*.pl","programs";
30             copy "*", "backup";
31              
32             use File::NCopy;
33              
34             # the below are the default config values
35             $file = File::NCopy->new(
36             'recursive' => 0,
37             'preserve' => 0,
38             'follow_links' => 0,
39             'force_write' => 0,
40             'set_permission' => \&File::NCopy::u_chmod,
41             'file_check' => \&File::NCopy::f_check,
42             'set_times' => \&File::NCopy::s_times,
43             );
44              
45             set_permission will take two file names, the original to get the
46             file permissions from and the new file to set the file permissions
47             for.
48              
49             file_check takes two parameters, the file names to check the file to
50             copy from and the file to copy to. I am using flock for Unix
51             systems.
52             Default for this is \&File::NCopy::f_check. On Unix you can also use
53             \&File::NCopy::unix_check. This one compares the inode and device
54             numbers.
55              
56             set_times is used if the preserve attribute is true. It preserves
57             the access and modification time of the file and also attempts to
58             set the owner of the file to the original owner. This can be useful
59             in a script used by root, though enyone can preserve the access and
60             modification times. This also takes two arguments. The file to get
61             the stats from and apply the stats to.
62              
63             On Unix boxes you shouldn't need to worry. On other system you may
64             want to supply your own sub references.
65              
66             $file = File::NCopy->new(recursive => 1);
67             $file->copy "file","other_file";
68             $file->copy "directory1","directory2";
69              
70             $file = File::NCopy->new(u_chmod => \&my_chmod,f_check => \&my_fcheck);
71             $file->copy "directory1","directory2";
72              
73              
74             =head1 DESCRIPTION
75              
76             B copies files to directories, or a single file to
77             another file. You can also use a reference to a file handle if you wish
78             whem doing a file to file copy. The functionality is very similar to
79             B. If the argument is a directory to directory copy and the
80             recursive flag is set then it is done recursively like B.
81             In fact it behaves like cp on Unix for the most part.
82             If called in array context, an array of successful copies is returned,
83             otherwise the number of succesful copies is returned. If passed a file
84             handle, it's difficult to make sure the file we are copying isn't the
85             same that we are copying to, since by opening the file in write mode it
86             gets pooched. To avoid this use file names instead, if at all possible,
87             especially for the to file. If passed a file handle, it is not closed
88             when copy returns, files opened by copy are closed.
89              
90             =over 4
91              
92             =item B
93              
94             Copies a file to another file. Or a file to a directory. Or multiple
95             files and directories to another directory. Or a directory to another
96             directory. Wildcard arguments are expanded, except for the last
97             argument which should not be expanded. The file and directory
98             permissions are set to the orginating file's permissions and if preserve
99             is set the access and modification times are also set. If preserve is
100             set then the uid and gid will also be attempted to be set, though this
101             may only for for the men in white hats.
102             In list context it returns all the names of the files/directories that
103             were successfully copied. In scalar context it returns the number of
104             successful copies made. A directory argument is considerd a single
105             successful copy if it manages to copy anything at all. To make a
106             directory to directory copy the recursive flag must be set.
107              
108             =item B
109              
110             Just calls copy. It's there to be compatible with File::Copy.
111              
112             =item B
113              
114             If used then you can treat this as an object oriented module with some
115             configuration abilities.
116              
117             =item B
118              
119             If used as an object then you can use this to set the recursive
120             attribute. It can also be set when instantiating with new. The other
121             attributes must all be set when instantiating the object. If it isn't
122             specified then directories are not followed.
123              
124             =item B
125              
126             Attempt to preserve the last modification and access time as well as
127             user and group id's. This is a useful feature for sysadmins, though the
128             access and modification time should always be preservable, the uid and
129             gid may not.
130              
131             =item B
132              
133             If the link is to a directory and this attribute is true then the
134             directory is followed and recursively copied. Otherwise a link is made
135             to the root directory the link points to. eg.
136              
137             /sys/ is a link to /usr/src/sys/ is a link to /usr/src/i386/sys
138             then the link /sys/ is actually created in the source directory as a
139             link to /usr/src/i386/sys/ rather than /usr/src/sys/ since if the link
140             /usr/src/sys/ is removed then we lost the link even though the directory
141             we originally intended to link to still exists.
142              
143             =item B
144              
145             Force the writing of a file even if the permissions are read only on it.
146              
147             =back
148              
149             =head1 EXAMPLE
150              
151             See SYNOPSIS.
152              
153             =head1 BUGS
154              
155             When following links the target directory might not exactly the same as
156             the source directory. The reason is that we have to make sure we don't
157             follow circular or dead links. This is really a feature though the
158             result may not quite resemble the source dir, the overall content will
159             be the same. :)
160              
161             From Ken Healy (Version 0.34)
162              
163             On Win32, The use of backslash for paths is required.
164              
165             =head1 AUTHOR
166              
167             Gabor Egressy B
168              
169             Copyright (c) 1998 Gabor Egressy. All rights reserved. All wrongs
170             reversed. This program is free software; you can redistribute and/or
171             modify it under the same terms as Perl itself.
172              
173             Some ideas gleaned from File::Copy by Aaron Sherman & Charles Bailey,
174             but the code was written from scratch.
175              
176             Patch at versions 0.33, and 0.34 added by MZSANFORD.
177              
178             0.34_01 - Alexandr Ciornii (alexchorny AT gmail.com)
179              
180             =cut
181              
182 1     1   3 use Cwd ();
  1         1  
  1         12  
183 1     1   3 use File::Spec;
  1         1  
  1         15  
184 1     1   3 use strict;
  1         1  
  1         18  
185 1     1   2 use vars qw(@EXPORT_OK @ISA $VERSION);
  1         2  
  1         2021  
186             @ISA = qw(Exporter);
187             # we export nothing by default :)
188             @EXPORT_OK = qw(copy cp);
189              
190             $VERSION = '0.34_01';
191              
192             # this works on Unix
193             sub u_chmod($$)
194             {
195 0     0 0 0 my ($file_from,$file_to) = @_;
196              
197 0         0 my ($mode) = (stat $file_from)[2];
198 0 0 0     0 chmod $mode & 0777,$file_to
199             unless ref $file_to eq 'GLOB' || ref $file_to eq 'FileHandle';
200 0         0 1;
201             }
202              
203             # this also works on Unix
204             sub f_check($$)
205             {
206 0     0 0 0 my ($file_from,$file_to) = @_;
207              
208             # get a shared lock on file to copy from
209 0 0       0 flock $file_from,5
210             or return 0;
211             # try and get an exclusive lock on the file to copy to
212             flock $file_to,6
213 0 0       0 or do {
214 0         0 flock $file_from,8;
215 0         0 return 0;
216             };
217 0         0 flock $file_from,8;
218 0         0 flock $file_to,8;
219              
220 0         0 1;
221             }
222              
223             # this also works on Unix, it's not the default but you can easily use
224             # it by using the module in an object oriented way
225             # $copy = File::NCopy->new('file_check' => \&File::NCopy::unix_check);
226             sub unix_check($$)
227             {
228 0     0 0 0 my ($file_from,$file_to) = @_;
229              
230 0         0 my ($fdev,$fino) = (stat $file_from)[0,1];
231 0         0 my ($tdev,$tino) = (stat $file_to)[0,1];
232              
233 0 0 0     0 return 0
234             if $fdev == $tdev && $fino == $tino;
235 0         0 1;
236             }
237              
238             sub s_times($$)
239             {
240 0     0 0 0 my ($file_from,$file_to) = @_;
241              
242 0         0 my ($uid,$gid,$atime,$mtime) = (stat $file_from)[4,5,8,9];
243              
244 0 0 0     0 utime $atime,$mtime,$file_to
245             unless ref $file_to eq 'GLOB' || ref $file_to eq 'FileHandle';
246              
247             # this may only work for men in white hats; on Unix
248 0 0 0     0 chown $uid,$gid,$file_to
249             unless ref $file_to eq 'GLOB' || ref $file_to eq 'FileHandle';
250 0         0 1;
251             }
252              
253             # all the actual copying is done here, folks ;)
254             sub _docopy_file_file($$$)
255             {
256 0     0   0 my $this = shift;
257 0         0 my ($file_from,$file_to) = @_;
258 0         0 local (*FILE_FROM,*FILE_TO);
259 0         0 my ($was_handle);
260              
261             # did we get a file handle ?
262 0 0 0     0 unless(ref $file_from eq 'GLOB' || ref $file_from eq 'FileHandle') {
263             open FILE_FROM,"<$file_from"
264 0 0       0 or do {
265             print "*** Couldn\'t open from file <$!> ==> $file_from\n"
266 0 0       0 if $this->{'_debug'};
267 0         0 return 0;
268             };
269             }
270             else {
271 0         0 *FILE_FROM = *$file_from;
272             }
273              
274 0 0 0     0 unless(ref $file_to eq 'GLOB' || ref $file_to eq 'FileHandle') {
275             # we must open in update mode since on some systems exclusive
276             # locks are only granted to files that are going to be written;
277 0 0       0 open FILE_TO,"+<$file_to"
278             or goto NO_FILE; # no file, so file can't be the same :)
279             }
280             else {
281 0         0 *FILE_TO = *$file_to;
282 0         0 $was_handle = 1;
283             }
284              
285 0 0 0     0 unless(-t FILE_FROM || -t FILE_TO) {
286 0 0       0 $this->{'file_check'}->(\*FILE_FROM,\*FILE_TO)
287             or return 0;
288             }
289              
290             NO_FILE:
291             # files aren't the same; now open for writing unless we got a
292             # filehandle
293 0 0 0     0 if(! $was_handle && ! $this->{test}) {
294             open FILE_TO,">$file_to"
295             or chmod 0644, "$file_to"
296 0 0 0     0 if $this->{'force_write'};
297             open FILE_TO,">$file_to"
298 0 0       0 or do {
299             print "*** Couldn\'t open to file <$!> ==> $file_to\n"
300 0 0       0 if $this->{'_debug'};
301 0         0 return 0;
302             };
303             }
304              
305             # and now for the braindead OS's
306 0 0       0 binmode FILE_FROM unless ($this->{test});
307 0 0       0 binmode FILE_TO unless ($this->{test});
308              
309 0         0 my $buf = '';
310 0         0 my ($len,$write_n);
311             # read file and write to new file, recover from write errors and
312             # read errors; we accept however much we read and try to write it
313             # 8K is a nice buffer size for most file systems
314 0   0     0 while(! $this->{test} && 1) {
315 0         0 $len = sysread(FILE_FROM,$buf,8192);
316 0 0       0 return 0
317             unless defined $len;
318             last
319 0 0       0 unless $len > 0;
320 0         0 while($len) {
321 0         0 $write_n = syswrite(FILE_TO,$buf,$len);
322 0 0       0 return 0
323             unless defined $write_n;
324 0         0 $len -= $write_n;
325             }
326             }
327              
328 0         0 $this->{'set_permission'}->($file_from,$file_to);
329              
330             # we only close files we opened
331 0 0       0 unless ($this->{test}) {
332 0 0 0     0 close FILE_FROM
333             unless ref $file_from eq 'GLOB' || ref $file_from eq 'FileHandle';
334 0 0 0     0 close FILE_TO
335             unless ref $file_to eq 'GLOB' || ref $file_to eq 'FileHandle';
336             }
337              
338             # this was moved from above the unless statement per Ken Healy in version 0.34
339             $this->{'set_times'}->($file_from,$file_to)
340 0 0       0 if $this->{'preserve'};
341              
342             print "$file_from ==> $file_to\n"
343 0 0       0 if $this->{'_debug'};
344              
345 0         0 1;
346             }
347              
348             sub get_path($)
349             {
350 0     0 0 0 my $dir = shift;
351              
352 0         0 my $save_dir = Cwd::cwd;
353 0 0       0 chdir $dir
354             or return undef;
355 0         0 $dir = Cwd::cwd;
356 0         0 chdir $save_dir;
357              
358 0         0 $dir;
359             }
360              
361             sub _recurse_from_dir($$$);
362              
363             # we never actually change the directory :)
364             sub _recurse_from_dir($$$)
365             {
366 0     0   0 my $this = shift;
367 0         0 my ($from_dir,$to_dir) = @_;
368 0         0 local (*DIR);
369             # MZS - v0.39 - Changed from slash to File::Spec;
370 0         0 my $dir_sep = File::Spec->catfile('a','b');
371 0         0 $dir_sep =~ s/^a(.+)b$/$1/;
372              
373              
374             opendir DIR,$from_dir
375 0 0       0 or do {
376             print "*** Couldn\'t opendir <$!> ==> $from_dir\n"
377 0 0       0 if $this->{'_debug'};
378 0         0 return 0;
379             };
380             my @files = readdir DIR
381 0 0       0 or do {
382             print "*** Couldn\'t read dir <$!> ==> $from_dir\n"
383 0 0       0 if $this->{'_debug'};
384 0         0 return 0;
385             };
386 0         0 closedir DIR;
387              
388 0         0 my $made_dir;
389 0 0 0     0 unless(-e $to_dir && ! $this->{test}) {
390 0 0       0 mkdir $to_dir,0777
391             or return 0;
392 0         0 $made_dir = 1;
393             }
394              
395 0         0 my ($retval,$ret,$link,$save_link);
396              
397             # make sure we don't end up with a recursive, circular link
398             # this isn't totally foolproof, though it does prevent circular
399             # links
400 0 0       0 if($this->{'follow_links'}) {
401 0 0       0 if(defined($save_link = get_path $from_dir)) {
402 0         0 $this->{'_links'}->{$save_link} = 1;
403             }
404             }
405              
406 0         0 for (@files) {
407             next
408 0 0       0 if /^\.\.?$/;
409 0 0       0 if(-f $from_dir . $dir_sep . $_) {
    0          
410 0         0 $ret = _docopy_file_file $this, $from_dir . $dir_sep . $_ ,
411             $to_dir . $dir_sep . $_;
412             }
413             elsif(-d "$from_dir$dir_sep$_") {
414 0 0 0     0 if($this->{'follow_links'} && -l "$from_dir$dir_sep$_") {
415 0         0 $link = get_path "$from_dir$dir_sep$_";
416             }
417 0 0 0     0 if(! -l "$from_dir$dir_sep$_" || $this->{'follow_links'}
      0        
      0        
418             && defined $link
419             && ! exists $this->{'_links'}->{$link}) {
420 0         0 $ret = _recurse_from_dir
421             $this,$from_dir . $dir_sep . $_ ,$to_dir . $dir_sep . $_;
422             }
423             else {
424 0 0       0 if(defined($link = get_path "$from_dir$dir_sep$_")) {
425 0         0 $ret = symlink $link, "$to_dir$dir_sep$_";
426             }
427             }
428             }
429 0   0     0 $retval = $retval || $ret;
430             }
431              
432 0 0       0 if($made_dir) {
433 0         0 $this->{'set_permission'}->($from_dir,$to_dir);
434             $this->{'set_times'}->($from_dir,$to_dir)
435 0 0       0 if $this->{'preserve'};
436             }
437              
438             # remove the name so that there can be link to it from other dirs
439             # that are not subdirs of this one
440 0 0       0 if($this->{'follow_links'}) {
441 0         0 delete $this->{'_links'}->{$save_link};
442             }
443              
444 0         0 $retval;
445             }
446              
447             sub _docopy_dir_dir($$$)
448             {
449 0     0   0 my $this = shift;
450 0         0 my ($dir_from,$dir_to) = @_;
451 0         0 my ($from_name);
452             # MZS - v0.39 - Changed from slash to File::Spec;
453 0         0 my $dir_sep = File::Spec->catfile('a','b');
454 0         0 $dir_sep =~ s/^a(.+)b$/$1/;
455              
456 0         0 $dir_from =~ s/$dir_sep$//; # remove trailing slash, if any
457 0 0       0 if($dir_from =~ tr/$dir_sep//) {
458 0         0 $from_name = substr $dir_from,rindex($dir_from,$dir_sep) + 1;
459             }
460             else {
461 0         0 $from_name = $dir_from;
462 0 0       0 if($from_name =~ /^\.\.?$/) {
463 0         0 $from_name = '';
464             }
465             }
466              
467 0 0       0 unless($dir_to =~ /$dir_sep$/) {
468 0         0 $dir_to .= $dir_sep;
469             }
470 0         0 $dir_to .= $from_name;
471              
472 0         0 $this->{'_links'} = {};
473              
474 0         0 _recurse_from_dir $this, $dir_from,$dir_to;
475             }
476              
477             sub _docopy_file_dir($$$)
478             {
479 0     0   0 my $this = shift;
480 0         0 my ($file,$dir) = @_;
481 0         0 my $file_to;
482             # MZS - v0.39 - Changed from slash to File::Spec;
483 0         0 my $dir_sep = File::Spec->catfile('a','b');
484 0         0 $dir_sep =~ s/^a(.+)b$/$1/;
485              
486 0 0       0 if($file =~ tr/$dir_sep//) {
487 0         0 $file_to = substr $file,rindex($file,$dir_sep) + 1;
488             }
489             else {
490 0         0 $file_to = $file;
491             }
492            
493 0         0 $dir =~ s/$dir_sep$//; # remove trailing slash
494              
495 0         0 _docopy_file_file $this, $file,$dir.$dir_sep.$file_to;
496             }
497              
498             # this just redirects calls, like copy ;)
499             sub _docopy_files_dir($$@)
500             {
501 1     1   2 my $this = shift;
502 1         1 my $copies = shift;
503 1         2 my $dir = pop;
504              
505 1         2 for (@_) {
506 1 50 33     13 if(-d $_ && $this->{'recursive'}) {
    0          
507 1 50       3 if ($this->{test}) {
508 1         2 push @$copies, $_;
509             } else {
510 0 0       0 _docopy_dir_dir $this, $_, $dir
511             and push @$copies, $_;
512             }
513             }
514             elsif(-f $_) {
515 0 0       0 if ($this->{test}) {
516 0         0 push @$copies, $_;
517             } else {
518 0 0       0 _docopy_file_dir $this, $_, $dir
519             and push @$copies, $_;
520             }
521             }
522             }
523 1         13 1;
524             }
525              
526             # does glob work on all systems?
527             sub expand(@)
528             {
529 1     1 0 5 my @args;
530              
531             return
532 1 50       3 if @_ < 2;
533              
534 1         4 for (my $i = 0;$i < $#_;++$i) {
535 1         44 push @args,glob $_[$i];
536             }
537 1         3 push @args,$_[$#_];
538              
539 1         6 @args;
540             }
541              
542             sub new(@);
543              
544             # this just redirects calls
545             sub copy(@)
546             {
547 1     1 1 419 my $this;
548              
549             # were we called through an object reference?
550 1 50       4 if(ref $_[0] eq 'File::NCopy') {
551 1         2 $this = shift;
552             }
553             else {
554             # no, so let's make one
555 0         0 $this = new File::NCopy;
556 0 0       0 if(ref $_[0] eq 'SCALAR') {
557 0         0 my $rec = shift;
558 0         0 $this->recursive($$rec);
559             }
560             }
561              
562 1         1 my @copies;
563 1         4 my @args = expand @_;
564              
565 0         0 print "passed args ==> ".join(',',map {"'$_'"} @args)."\n"
566 1 50       5 if $this->{'_debug'};
567              
568             # one or more files/directories to a directory
569 1 50 33     22 if(@args >= 2 && -d $args[$#args]) {
    0 0        
570 1 50       3 print "Copy to dir started.\n" if ($this->{'_debug'});
571 1         4 _docopy_files_dir $this, \@copies, @args;
572             }
573             # file to file
574             elsif(@args == 2 && -f $args[0]) {
575 0 0       0 if ($this->{test}) {
576 0         0 push @copies, $args[0];
577             } else {
578 0 0       0 _docopy_file_file $this, $args[0],$args[1]
579             and push @copies, $args[0];
580             }
581             }
582              
583 1         5 @copies;
584             }
585              
586             sub cp(@) {
587 0     0 1 0 return copy @_;
588             }
589              
590             # instantiate our object
591             sub new(@)
592             {
593 1     1 1 69 my $this = shift;
594            
595 1         10 my $conf = {
596             'test' => 0,
597             'recursive' => 0,
598             'preserve' => 0,
599             'follow_links' => 0,
600             'force_write' => 0,
601             '_debug' => 0,
602             'set_permission' => \&File::NCopy::u_chmod,
603             'file_check' => \&File::NCopy::f_check,
604             'set_times' => \&File::NCopy::s_times,
605             '_links' => {},
606             };
607              
608 1         1 my $ref;
609 1 50       4 if(@_ % 2 == 0) {
    0          
610 1         3 my %ref = @_;
611 1         3 $ref = \%ref;
612             }
613             elsif(ref $_[0] eq 'HASH') {
614 0         0 $ref = shift;
615             }
616              
617 1 50       5 if(ref $ref eq 'HASH') {
618             $conf->{'test'} = abs int $ref->{'test'}
619 1 50       4 if defined $ref->{'test'};
620             $conf->{'recursive'} = abs int $ref->{'recursive'}
621 1 50       3 if defined $ref->{'recursive'};
622             $conf->{'preserve'} = abs int $ref->{'preserve'}
623 1 50       3 if defined $ref->{'preserve'};
624             $conf->{'follow_links'} = abs int $ref->{'follow_links'}
625 1 50       2 if defined $ref->{'follow_links'};
626             $conf->{'force_write'} = abs int $ref->{'force_write'}
627 1 50       2 if defined $ref->{'force_write'};
628             $conf->{'_debug'} = abs int $ref->{'_debug'}
629 1 50       3 if defined $ref->{'_debug'};
630             $conf->{'set_permission'} = $ref->{'set_permission'}
631             if defined $ref->{'set_permission'}
632 1 50 33     3 && ref $ref->{'set_permission'} eq 'CODE';
633             $conf->{'file_check'} = $ref->{'file_check'}
634             if defined $ref->{'file_check'}
635 1 50 33     4 && ref $ref->{'file_check'} eq 'CODE';
636             $conf->{'set_times'} = $ref->{'set_times'}
637             if defined $ref->{'set_times'}
638 1 50 33     3 && ref $ref->{'set_times'} eq 'CODE';
639             }
640              
641 1         3 bless $conf,$this;
642             }
643              
644             sub recursive($;$)
645             {
646             return
647 0 0   0 1   if @_ < 1;
648 0           my $this = shift;
649              
650             return
651 0 0         unless ref $this eq 'File::NCopy';
652              
653             @_ ? $this->{'recursive'} = abs int shift
654 0 0         : $this->{'recursive'};
655             }
656              
657             sub preserve($;$)
658             {
659             return
660 0 0   0 1   if @_ < 1;
661 0           my $this = shift;
662              
663             return
664 0 0         unless ref $this eq 'File::NCopy';
665              
666             @_ ? $this->{'preserve'} = abs int shift
667 0 0         : $this->{'preserve'};
668             }
669              
670             sub follow_links($;$)
671             {
672             return
673 0 0   0 1   if @_ < 1;
674 0           my $this = shift;
675              
676             return
677 0 0         unless ref $this eq 'File::NCopy';
678              
679             @_ ? $this->{'follow_links'} = abs int shift
680 0 0         : $this->{'follow_links'};
681             }
682              
683             sub force_write($;$)
684             {
685             return
686 0 0   0 1   if @_ < 1;
687 0           my $this = shift;
688              
689             return
690 0 0         unless ref $this eq 'File::NCopy';
691              
692             @_ ? $this->{'force_write'} = abs int shift
693 0 0         : $this->{'force_write'};
694             }
695              
696             1;