File Coverage

blib/lib/Directory/Diff/Copy.pm
Criterion Covered Total %
statement 48 75 64.0
branch 10 32 31.2
condition n/a
subroutine 11 12 91.6
pod 1 6 16.6
total 70 125 56.0


line stmt bran cond sub pod time code
1             package Directory::Diff::Copy;
2             require Exporter;
3             @ISA = qw(Exporter);
4             @EXPORT_OK = qw/copy_diff_only/;
5 1     1   70375 use warnings;
  1         3  
  1         32  
6 1     1   5 use strict;
  1         3  
  1         30  
7             our $VERSION = '0.08';
8 1     1   5 use Carp;
  1         2  
  1         51  
9 1     1   472 use File::Copy 'copy';
  1         4324  
  1         109  
10 1     1   8 use File::Path qw/rmtree mkpath/;
  1         2  
  1         60  
11 1     1   457 use Directory::Diff 'directory_diff';
  1         2  
  1         811  
12              
13             #=head2 mdate
14             #
15             #my $mod_date = mdate ($filename);
16             #
17             #Returns time that $filename was last modified.
18             #
19             #=cut
20              
21             sub mdate
22             {
23 2     2 0 20 my ($filename) = @_;
24 2 50       31 if (!-e $filename) {
25 0         0 die "reference file '$filename' not found";
26             }
27 2         24 my @stat = stat ($filename);
28 2 50       9 if (@stat == 0) {
29 0         0 die "'stat' failed for '$filename': $@";
30             }
31 2         8 return $stat[9];
32             }
33              
34             sub make_subdir
35             {
36 1     1 0 4 my ($path, $verbose) = @_;
37 1         9 $path =~ s!/[^/]+$!/!;
38 1 50       19 if (! -d $path) {
39 0 0       0 if ($verbose) {
40 0         0 print "Directory::Diff::Copy: Creating $path.\n";
41             }
42 0         0 mkpath ($path);
43 0 0       0 if (! -d $path) {
44 0         0 die "Could not make path '$path'.\n";
45             }
46             }
47             }
48              
49             sub new_only_callback
50             {
51 0     0 0 0 my ($data, $dir, $file, $verbose) = @_;
52 0         0 my $output_dir = $data->{output_dir};
53 0         0 my $copied_file = "$dir/$file";
54 0 0       0 if ($verbose) {
55 0         0 print "$file will be copied from $copied_file to $output_dir/$file\n";
56             }
57 0         0 my $path = "$output_dir/$file";
58 0 0       0 if ($file =~ m!/$!) {
59 0 0       0 if ($verbose) {
60 0         0 print "Creating $path.\n";
61             }
62             # Make the directory
63 0         0 mkpath ($path);
64             }
65             else {
66 0         0 make_subdir ($path, $verbose);
67 0 0       0 if (! -f $copied_file) {
68 0         0 die "The file to copy, '$copied_file', does not exist";
69             }
70 0         0 sane_copy ("$dir/$file", "$output_dir/$file");
71 0         0 $data->{count}++;
72             }
73             }
74              
75             sub sane_copy
76             {
77 1     1 0 3 my ($from, $to) = @_;
78 1         13 my (undef, undef, $mode) = stat ($from);
79 1 50       4 if (! defined $mode) {
80 0         0 die "Cannot stat $from: $!";
81             }
82             # perldoc -f stat
83 1 50       7 copy ($from, $to)
84             or die "Copy of '$from' to '$to' failed: $!";
85             # perldoc -f chmod
86 1 50       333 chmod $mode & 07777, $to or die "chmod on $to failed: $!";
87             }
88              
89             sub diff_callback
90             {
91 1     1 0 4 my ($data, $old_dir, $new_dir, $file, $verbose) = @_;
92 1         3 my $output_dir = $data->{output_dir};
93 1 50       3 if ($verbose) {
94 0         0 print "$file will be copied from $new_dir to $output_dir/$file\n";
95             }
96 1         4 my $path = "$output_dir/$file";
97 1         4 make_subdir ($path, $verbose);
98 1 50       3 if ($verbose) {
99 0         0 print "Directory::Diff::Copy: Copying '$new_dir/$file' to '$output_dir/$file'.\n";
100             }
101 1         7 sane_copy ("$new_dir/$file", "$output_dir/$file");
102 1         8 $data->{count}++;
103             }
104              
105              
106              
107             sub copy_diff_only
108             {
109 1     1 1 12822 my ($old_dir, $new_dir, $output_dir, $verbose) = @_;
110 1 50       5 if (mdate ($new_dir) < mdate ($old_dir)) {
111 0         0 croak "$new_dir is older than $old_dir\n";
112             }
113 1 50       16 if (-d $output_dir) {
114 0         0 rmtree ($output_dir);
115             }
116 1         156 mkpath $output_dir;
117 1         3 my %data;
118 1         3 $data{output_dir} = $output_dir;
119 1         3 $data{count} = 0;
120 1         11 directory_diff ($old_dir, $new_dir,
121             {
122             dir2_only => \&new_only_callback,
123             diff => \&diff_callback,
124             data => \%data,
125             },
126             $verbose);
127 1         4 return $data{count};
128             }
129              
130             1;