File Coverage

blib/lib/Directory/Diff/Copy.pm
Criterion Covered Total %
statement 18 75 24.0
branch 0 32 0.0
condition n/a
subroutine 6 12 50.0
pod 1 6 16.6
total 25 125 20.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   50427 use warnings;
  1         2  
  1         33  
6 1     1   6 use strict;
  1         2  
  1         30  
7             our $VERSION = '0.06';
8 1     1   5 use Carp;
  1         2  
  1         47  
9 1     1   282 use File::Copy 'copy';
  1         3415  
  1         66  
10 1     1   8 use File::Path 'rmtree';
  1         2  
  1         48  
11 1     1   297 use Directory::Diff 'directory_diff';
  1         3  
  1         604  
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 0     0 0   my ($filename) = @_;
24 0 0         if (!-e $filename) {
25 0           die "reference file '$filename' not found";
26             }
27 0           my @stat = stat ($filename);
28 0 0         if (@stat == 0) {
29 0           die "'stat' failed for '$filename': $@";
30             }
31 0           return $stat[9];
32             }
33              
34             sub make_subdir
35             {
36 0     0 0   my ($path, $verbose) = @_;
37 0           $path =~ s!/[^/]+$!/!;
38 0 0         if (! -d $path) {
39 0 0         if ($verbose) {
40 0           print "Directory::Diff::Copy: Creating $path.\n";
41             }
42 0           mkpath ($path);
43 0 0         if (! -d $path) {
44 0           die "Could not make path '$path'.\n";
45             }
46             }
47             }
48              
49             sub new_only_callback
50             {
51 0     0 0   my ($data, $dir, $file, $verbose) = @_;
52 0           my $output_dir = $data->{output_dir};
53 0           my $copied_file = "$dir/$file";
54 0 0         if ($verbose) {
55 0           print "$file will be copied from $copied_file to $output_dir/$file\n";
56             }
57 0           my $path = "$output_dir/$file";
58 0 0         if ($file =~ m!/$!) {
59 0 0         if ($verbose) {
60 0           print "Creating $path.\n";
61             }
62             # Make the directory
63 0           mkpath ($path);
64             }
65             else {
66 0           make_subdir ($path, $verbose);
67 0 0         if (! -f $copied_file) {
68 0           die "The file to copy, '$copied_file', does not exist";
69             }
70 0           sane_copy ("$dir/$file", "$output_dir/$file");
71 0           $data->{count}++;
72             }
73             }
74              
75             sub sane_copy
76             {
77 0     0 0   my ($from, $to) = @_;
78 0           my (undef, undef, $mode) = stat ($from);
79 0 0         if (! defined $mode) {
80 0           die "Cannot stat $from: $!";
81             }
82             # perldoc -f stat
83 0 0         copy ($from, $to)
84             or die "Copy of '$from' to '$to' failed: $!";
85             # perldoc -f chmod
86 0 0         chmod $mode & 07777, $to or die "chmod on $to failed: $!";
87             }
88              
89             sub diff_callback
90             {
91 0     0 0   my ($data, $old_dir, $new_dir, $file, $verbose) = @_;
92 0           my $output_dir = $data->{output_dir};
93 0 0         if ($verbose) {
94 0           print "$file will be copied from $new_dir to $output_dir/$file\n";
95             }
96 0           my $path = "$output_dir/$file";
97 0           make_subdir ($path, $verbose);
98 0 0         if ($verbose) {
99 0           print "Directory::Diff::Copy: Copying '$new_dir/$file' to '$output_dir/$file'.\n";
100             }
101 0           sane_copy ("$new_dir/$file", "$output_dir/$file");
102 0           $data->{count}++;
103             }
104              
105              
106              
107             sub copy_diff_only
108             {
109 0     0 1   my ($old_dir, $new_dir, $output_dir, $verbose) = @_;
110 0 0         if (mdate ($new_dir) < mdate ($old_dir)) {
111 0           croak "$new_dir is older than $old_dir\n";
112             }
113 0 0         if (-d $output_dir) {
114 0           rmtree ($output_dir);
115             }
116 0           mkpath $output_dir;
117 0           my %data;
118 0           $data{output_dir} = $output_dir;
119 0           $data{count} = 0;
120 0           directory_diff ($old_dir, $new_dir,
121             {
122             dir2_only => \&new_only_callback,
123             diff => \&diff_callback,
124             data => \%data,
125             },
126             $verbose);
127 0           return $data{count};
128             }
129              
130             1;