File Coverage

blib/lib/File/Modified.pm
Criterion Covered Total %
statement 401 409 98.0
branch 19 28 67.8
condition 8 19 42.1
subroutine 121 122 99.1
pod 5 5 100.0
total 554 583 95.0


line stmt bran cond sub pod time code
1             package File::Modified;
2             $File::Modified::VERSION = '0.10';
3 1     1   54648 use 5.006;
  1         3  
4 1     1   4 use strict;
  1         2  
  1         26  
5 1     1   5 use warnings;
  1         6  
  1         177  
6              
7             our @ISA;
8              
9             sub new {
10 18     18 1 3615617 my ($class, %args) = @_;
11              
12 18   50     181 my $method = $args{method} || "MD5";
13 18   100     92 my $files = $args{files} || [];
14              
15 18         76 my $self = {
16             Defaultmethod => $method,
17             Files => {},
18             };
19              
20 18         43 bless $self, $class;
21              
22 18         78 $self->addfile(@$files);
23              
24 18         94 return $self;
25             };
26              
27             sub _make_digest_signature {
28 3     3   9 my ($self,$digest) = @_;
29              
30 1     1   6 eval "use Digest::$digest";
  1     1   2  
  1     1   33  
  1         790  
  0         0  
  0         0  
  1         751  
  0         0  
  0         0  
  3         501  
31              
32 3 100       21 if (! $@) {
33 1     1   5 no strict 'refs';
  1         1  
  1         1942  
34 1 50       1 if (@{"Digest::${digest}::ISA"}) {
  1         7  
35 1         2 @{"File::Modified::Signature::${digest}::ISA"} = qw(File::Modified::Signature::Digest);
  1         20  
36 1         5 return 1;
37             };
38             };
39 2         14 return undef;
40             };
41              
42             sub add {
43 285     285 1 488 my ($self,$filename,$method) = @_;
44 285   33     1068 $method ||= $self->{Defaultmethod};
45              
46 285         448 my $signatureclass = "File::Modified::Signature::$method";
47 285         365 my $s = eval { $signatureclass->new($filename) };
  285         1247  
48 285 100       591 if (! $@) {
49 282         1382 return $self->{Files}->{$filename} = $s;
50             } else {
51             # retry and try Digest::$method
52              
53 3 100       12 if ($self->_make_digest_signature($method)) {
54 1         8 my $s = $signatureclass->new($filename);
55 1         9 return $self->{Files}->{$filename} = $s;
56             } else {
57 2         22 return undef;
58             };
59             };
60             };
61              
62             sub addfile {
63 27     27 1 1673 my ($self,@files) = @_;
64              
65 27         38 my @result;
66              
67             # We only return something if the caller wants it
68 27 100       112 if (defined wantarray) {
69 9         29 push @result, $self->add($_) for @files;
70 9         46 return @result;
71             } else {
72 18         82 $self->add($_) for @files;
73             };
74             };
75              
76             sub update {
77 0     0 1 0 my ($self) = @_;
78              
79 0         0 $_->initialize() for values %{$self->{Files}};
  0         0  
80             };
81              
82             sub changed {
83 11     11 1 374023 my ($self) = @_;
84              
85 11         20 return map {$_->{Filename}} grep {$_->changed()} (values %{$self->{Files}});
  4         50  
  259         585  
  11         88  
86             };
87              
88             1;
89              
90             {
91             package File::Modified::Signature;
92             $File::Modified::Signature::VERSION = '0.10';
93             # This is a case where Python would be nicer. With Python, we could have (paraphrased)
94             # class File::Modified::Signature;
95             # def initialize(self):
96             # self.hash = self.identificate()
97             # return self
98             # def signature(self):
99             # return MD5(self.filename)
100             # def changed(self):
101             # return self.hash != self.signature()
102             # and it would work as expected, (almost) regardless of the structure that is returned
103             # by self.signature(). This is some DWIMmery that I sometimes miss in Perl.
104             # For now, only string comparisions are allowed.
105              
106             sub create {
107 286     286   407 my ($class,$filename,$signature) = @_;
108              
109 286         800 my $self = {
110             Filename => $filename,
111             Signature => $signature,
112             };
113              
114 286         690 bless $self, $class;
115             };
116              
117             sub new {
118 283     283   431 my ($class,$filename) = @_;
119              
120 283         705 my $self = $class->create($filename);
121 283         629 $self->initialize();
122              
123 283         691 return $self;
124             };
125              
126             sub initialize {
127 283     283   390 my ($self) = @_;
128 283         579 $self->{Signature} = $self->signature();
129 283         400 return $self;
130             };
131              
132             sub from_scalar {
133 3     3   12 my ($baseclass,$scalar) = @_;
134 3 50       19 die "Strange value in from_scalar: $scalar\n" unless $scalar =~ /^([^|]+)\|([^|]+)\|(.+)$/;
135 3         12 my ($class,$filename,$signature) = ($1,$2,$3);
136 3         12 return $class->create($filename,$signature);
137             };
138              
139             sub as_scalar {
140 3     3   24 my ($self) = @_;
141 3         16 return ref($self) . "|" . $self->{Filename} . "|" . $self->{Signature};
142             };
143              
144             sub changed {
145 259     259   354 my ($self) = @_;
146 259         484 my $currsig = $self->signature();
147              
148             # FIXME: Deep comparision of the two signatures instead of equality !
149             # And what's this about string comparisions anyway ?
150 259 50 33     1119 if ((ref $currsig) or (ref $self->{Signature})) {
151 0         0 die "Implementation error in $self : changed() can't handle references and complex structures (yet) !\n";
152             #return $currsig != $self->{Signature};
153             } else {
154 259         855 return $currsig ne $self->{Signature};
155             };
156             };
157             };
158              
159             {
160             package File::Modified::Signature::mtime;
161             $File::Modified::Signature::mtime::VERSION = '0.10';
162 1     1   6 use base 'File::Modified::Signature';
  1         2  
  1         716  
163              
164             sub signature {
165 180     180   204 my ($self) = @_;
166              
167 180 50       4392 my @stat = stat $self->{Filename} or die "Couldn't stat '$self->{Filename}' : $!";
168              
169 180         427 return $stat[9];
170             };
171             };
172              
173             {
174             package File::Modified::Signature::Checksum;
175             $File::Modified::Signature::Checksum::VERSION = '0.10';
176 1     1   5 use base 'File::Modified::Signature';
  1         2  
  1         567  
177              
178             sub signature {
179 180     180   242 my ($self) = @_;
180 180         190 my $result;
181 180 50 33     8020 if (-e $self->{Filename} and -r $self->{Filename}) {
182 180         379 local *F;
183 180 50       5794 open F, $self->{Filename} or die "Couldn't read from file '$self->{Filename}' : $!";
184 180         367 binmode F;
185              
186 180         208 my $buf;
187 180         2758 while (read(F,$buf,32768)) {
188 220         14363 $result += unpack("%32C*", $buf);
189 220         1278 $result %= 0xFFFFFFFF;
190             };
191              
192 180         1104 close F;
193             };
194 180         336 return $result;
195             };
196             };
197              
198             {
199             package File::Modified::Signature::Digest;
200             $File::Modified::Signature::Digest::VERSION = '0.10';
201 1     1   5 use base 'File::Modified::Signature';
  1         2  
  1         674  
202              
203             sub digestname {
204 95     95   115 my ($class) = @_;
205 95   33     224 $class = ref $class || $class;
206 95 50       630 return $1 if ($class =~ /^File::Modified::Signature::([^:]+)$/);
207             };
208              
209             sub digest {
210 182     182   237 my ($self) = @_;
211 182 100       392 if (! exists $self->{Digest}) {
212 95         285 my $digestclass = "Digest::" . $self->digestname;
213 1     1   5 eval "use $digestclass";
  1     1   1  
  1     1   25  
  1     1   7  
  1     1   3  
  1     1   41  
  1     1   4  
  1     1   2  
  1     1   27  
  1     1   5  
  1     1   2  
  1     1   26  
  1     1   5  
  1     1   2  
  1     1   25  
  1     1   5  
  1     1   2  
  1     1   24  
  1     1   5  
  1     1   2  
  1     1   24  
  1     1   4  
  1     1   2  
  1     1   25  
  1     1   5  
  1     1   2  
  1     1   26  
  1     1   5  
  1     1   2  
  1     1   25  
  1     1   5  
  1     1   2  
  1     1   26  
  1     1   5  
  1     1   2  
  1     1   25  
  1     1   6  
  1     1   2  
  1     1   50  
  1     1   5  
  1     1   2  
  1     1   25  
  1     1   5  
  1     1   2  
  1     1   26  
  1     1   5  
  1     1   2  
  1     1   24  
  1     1   6  
  1     1   2  
  1     1   25  
  1     1   6  
  1     1   2  
  1     1   25  
  1     1   5  
  1     1   2  
  1     1   25  
  1     1   5  
  1     1   2  
  1     1   24  
  1     1   5  
  1     1   1  
  1     1   25  
  1     1   5  
  1     1   1  
  1     1   26  
  1     1   5  
  1     1   2  
  1     1   25  
  1     1   5  
  1     1   2  
  1     1   25  
  1     1   4  
  1     1   2  
  1     1   24  
  1     1   4  
  1     1   2  
  1     1   24  
  1     1   5  
  1     1   2  
  1     1   28  
  1     1   5  
  1     1   37  
  1     1   28  
  1     1   5  
  1     1   2  
  1     1   25  
  1     1   6  
  1     1   2  
  1     1   24  
  1     1   5  
  1     1   1  
  1     1   26  
  1     1   4  
  1     1   2  
  1         26  
  1         5  
  1         2  
  1         25  
  1         5  
  1         2  
  1         25  
  1         5  
  1         2  
  1         25  
  1         5  
  1         2  
  1         26  
  1         5  
  1         1  
  1         25  
  1         5  
  1         2  
  1         25  
  1         5  
  1         2  
  1         24  
  1         5  
  1         2  
  1         26  
  1         5  
  1         1  
  1         25  
  1         5  
  1         2  
  1         25  
  1         5  
  1         2  
  1         25  
  1         5  
  1         2  
  1         25  
  1         5  
  1         1  
  1         25  
  1         5  
  1         2  
  1         24  
  1         5  
  1         1  
  1         26  
  1         5  
  1         2  
  1         25  
  1         4  
  1         1  
  1         24  
  1         5  
  1         2  
  1         24  
  1         6  
  1         1  
  1         24  
  1         5  
  1         2  
  1         25  
  1         5  
  1         2  
  1         25  
  1         17  
  1         2  
  1         25  
  1         5  
  1         2  
  1         25  
  1         5  
  1         2  
  1         26  
  1         5  
  1         2  
  1         25  
  1         5  
  1         2  
  1         24  
  1         5  
  1         2  
  1         24  
  1         5  
  1         2  
  1         24  
  1         5  
  1         1  
  1         25  
  1         4  
  1         2  
  1         24  
  1         5  
  1         2  
  1         24  
  1         5  
  1         2  
  1         25  
  1         5  
  1         2  
  1         25  
  1         6  
  1         1  
  1         37  
  1         5  
  1         2  
  1         24  
  1         4  
  1         2  
  1         26  
  1         5  
  1         2  
  1         24  
  1         7  
  1         2  
  1         31  
  1         6  
  1         8  
  1         28  
  1         5  
  1         1  
  1         24  
  1         6  
  1         1  
  1         25  
  1         5  
  1         2  
  1         24  
  1         5  
  1         2  
  1         25  
  1         5  
  1         1  
  1         25  
  1         5  
  1         2  
  1         25  
  1         5  
  1         2  
  1         25  
  1         5  
  1         2  
  1         25  
  1         4  
  1         2  
  1         24  
  1         5  
  1         2  
  1         25  
  1         5  
  1         1  
  1         24  
  1         5  
  1         2  
  1         24  
  1         5  
  1         2  
  1         24  
  1         5  
  1         2  
  1         25  
  1         7  
  1         2  
  1         34  
  1         6  
  1         1  
  1         27  
  1         6  
  1         2  
  1         26  
  1         5  
  1         2  
  1         26  
  1         5  
  1         2  
  1         32  
  1         5  
  1         2  
  1         25  
  1         4  
  1         2  
  1         25  
  1         5  
  1         3  
  1         29  
  1         14  
  1         4  
  1         72  
  1         10  
  1         3  
  1         79  
  95         5560  
214 95         514 $self->{Digest} = $digestclass->new();
215             };
216 182         17600 return $self->{Digest};
217             };
218              
219             sub signature {
220 182     182   220 my ($self) = @_;
221 182         217 my $result;
222 182 50 33     8427 if (-e $self->{Filename} and -r $self->{Filename}) {
223 182         402 local *F;
224 182 50       6084 open F, $self->{Filename} or die "Couldn't read from file '$self->{Filename}' : $!";
225 182         394 binmode F;
226 182         611 $result = $self->digest->addfile(*F)->b64digest();
227 182         1311 close F;
228             };
229 182         427 return $result;
230             };
231             };
232              
233             1;
234              
235             __END__