File Coverage

blib/lib/File/Same.pm
Criterion Covered Total %
statement 50 52 96.1
branch 9 16 56.2
condition n/a
subroutine 9 9 100.0
pod 3 3 100.0
total 71 80 88.7


line stmt bran cond sub pod time code
1             package File::Same;
2              
3             $File::Same::VERSION = '0.08';
4             $File::Same::AUTHORITY = 'cpan:MANWAR';
5              
6             =head1 NAME
7              
8             File::Same - Detect which files are the same as a given one.
9              
10             =head1 VERSION
11              
12             Version 0.08
13              
14             =cut
15              
16 5     5   151733 use 5.006;
  5         17  
17 5     5   26 use strict; use warnings;
  5     5   7  
  5         126  
  5         24  
  5         19  
  5         157  
18 5     5   22 use Digest::MD5;
  5         10  
  5         198  
19 5     5   90 use File::Spec;
  5         8  
  5         2916  
20              
21             my %md5s;
22              
23             =head1 DESCRIPTION
24              
25             File::Same uses MD5 sums to decide which files are the same in a given directory,
26             set of directories or set of files. It was originally written to test which files
27             are the same picture in multiple directories or under multiple filenames, but can
28             be generally useful for other systems.
29              
30             File::Same will use an internal cache, for performance reasons.
31              
32             File::Same will also be careful not to return C<$original> in the list of matched
33             files.
34              
35             All of the functions return a list of files that match, with full path expanded.
36              
37             =head1 SYNOPSIS
38              
39             use strict; use warnings;
40             use File::Same;
41              
42             my @same1 = File::Same::scan_dirs('sample.txt', ['other', '.']);
43              
44             my @same2 = File::Same::scan_files('sample.txt', ['ex1.txt', 'ex2.txt']);
45              
46             my @same3 = File::Same::scan_dir('sample.txt', 'somedir');
47              
48             =head1 METHODS
49              
50             =head2 scan_files($original, \@list)
51              
52             Scan a list of files to compare against a given file.
53              
54             =cut
55              
56             sub scan_files {
57 6     6 1 81 my ($original, $files) = @_;
58              
59 6         10 my @results;
60 6         14 my $orig_md5 = $md5s{$original};
61              
62 6 50       18 if (!$orig_md5) {
63 6         34 my $ctx = Digest::MD5->new();
64 6 50       138 open(FILE, $original) || die "Cannot open '$original' : $!";
65 6         19 binmode(FILE);
66 6         94 $ctx->addfile(*FILE);
67 6         31 $orig_md5 = $ctx->hexdigest;
68 6         56 close(FILE);
69             }
70              
71 6         15 foreach my $file (@$files) {
72 18 50       48 if (my $md5 = $md5s{$file}) {
73 0 0       0 if ($orig_md5 eq $md5) {
74 0         0 push @results, $file;
75             }
76             }
77             else {
78 18         61 my $ctx = Digest::MD5->new();
79 18 50       356 open(FILE, $file) || die "Cannot open '$file' : $!";
80 18         35 binmode(FILE);
81 18         152 $ctx->addfile(*FILE);
82 18 100       86 if ($orig_md5 eq $ctx->hexdigest) {
83 5         11 push @results, $file;
84             }
85 18         156 close(FILE);
86             }
87             }
88              
89 6         19 return grep {_not_same($_, $original)} @results;
  5         18  
90             }
91              
92             =head2 scan_dir($original, $dir)
93              
94             Scan an entire directory to find files the same as this one.
95              
96             =cut
97              
98             sub scan_dir {
99 5     5 1 32 my ($original, $dir) = @_;
100              
101 5 50       114 opendir(DIR, $dir) || die "Cannot opendir '$dir' : $!";
102 5         57 my @files = grep { -f } map { File::Spec->catfile($dir, $_) } readdir(DIR);
  28         279  
  28         206  
103 5         53 closedir(DIR);
104              
105 5         16 return scan_files($original, \@files);
106             }
107              
108             =head2 scan_dirs($original, \@dirs)
109              
110             Scan a list of directories to find files the same as this one.
111              
112             =cut
113              
114             sub scan_dirs {
115 1     1 1 50 my ($original, $dirs) = @_;
116              
117 1         2 my @results;
118              
119 1         3 foreach my $dir (@$dirs) {
120 4         10 push @results, scan_dir($original, $dir);
121             }
122              
123 1         4 return @results;
124             }
125              
126             #
127             #
128             # PRIVATE METHODS
129              
130             sub _not_same {
131 5     5   11 my ($file, $orig) = @_;
132              
133 5 100       192 return 0
134             if (File::Spec->rel2abs($file) eq File::Spec->rel2abs($orig));
135              
136 3         20 return 1;
137             }
138              
139             =head1 AUTHOR
140              
141             =over 4
142              
143             =item Original author Matt Sergeant, C<< >>
144              
145             =item Currently maintained by Mohammad S Anwar, C<< >>
146              
147             =back
148              
149             =head1 REPOSITORY
150              
151             L
152              
153             =head1 SEE ALSO
154              
155             L - used to generate a checksum for every file.
156              
157             L - another that can be used to find duplicates.
158              
159             =head1 BUGS
160              
161             Please report any bugs or feature requests to C, or
162             through the web interface at L.
163             I will be notified and then you'll automatically be notified of progress on your
164             bug as I make changes.
165              
166             =head1 SUPPORT
167              
168             You can find documentation for this module with the perldoc command.
169              
170             perldoc File::Same
171              
172             You can also look for information at:
173              
174             =over 4
175              
176             =item * RT: CPAN's request tracker (report bugs here)
177              
178             L
179              
180             =item * AnnoCPAN: Annotated CPAN documentation
181              
182             L
183              
184             =item * CPAN Ratings
185              
186             L
187              
188             =item * Search CPAN
189              
190             L
191              
192             =back
193              
194             =head1 LICENSE AND COPYRIGHT
195              
196             =over 4
197              
198             =item Copyright (C) 2001 MessageLabs Limited.
199              
200             =item Copyright (C) 2015 Mohammad S Anwar.
201              
202             =back
203              
204             This is free software, you may use it and distribute it under the same terms as
205             Perl itself.
206              
207             Any use, modification, and distribution of the Standard or Modified Versions is
208             governed by this Artistic License.By using, modifying or distributing the Package,
209             you accept this license. Do not use, modify, or distribute the Package, if you do
210             not accept this license.
211              
212             If your Modified Version has been derived from a Modified Version made by someone
213             other than you,you are nevertheless required to ensure that your Modified Version
214             complies with the requirements of this license.
215              
216             This license does not grant you the right to use any trademark, service mark,
217             tradename, or logo of the Copyright Holder.
218              
219             This license includes the non-exclusive, worldwide, free-of-charge patent license
220             to make, have made, use, offer to sell, sell, import and otherwise transfer the
221             Package with respect to any patent claims licensable by the Copyright Holder that
222             are necessarily infringed by the Package. If you institute patent litigation
223             (including a cross-claim or counterclaim) against any party alleging that the
224             Package constitutes direct or contributory patent infringement,then this Artistic
225             License to you shall terminate on the date that such litigation is filed.
226              
227             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND
228             CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED
229             WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR
230             NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL LAW. UNLESS
231             REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT,
232             INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE
233             OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
234              
235             =cut
236              
237             1; # End of File::Same