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.10';
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.10
13              
14             =cut
15              
16 5     5   35539 use 5.006;
  5         15  
17 5     5   19 use strict; use warnings;
  5     5   7  
  5         123  
  5         15  
  5         13  
  5         188  
18 5     5   18 use Digest::MD5;
  5         5  
  5         198  
19 5     5   23 use File::Spec;
  5         21  
  5         2607  
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 40 my ($original, $files) = @_;
58              
59 6         7 my @results;
60 6         9 my $orig_md5 = $md5s{$original};
61              
62 6 50       14 if (!$orig_md5) {
63 6         29 my $ctx = Digest::MD5->new();
64 6 50       109 open(FILE, $original) || die "Cannot open '$original' : $!";
65 6         13 binmode(FILE);
66 6         71 $ctx->addfile(*FILE);
67 6         21 $orig_md5 = $ctx->hexdigest;
68 6         37 close(FILE);
69             }
70              
71 6         14 foreach my $file (@$files) {
72 18 50       28 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         39 my $ctx = Digest::MD5->new();
79 18 50       232 open(FILE, $file) || die "Cannot open '$file' : $!";
80 18         23 binmode(FILE);
81 18         91 $ctx->addfile(*FILE);
82 18 100       58 if ($orig_md5 eq $ctx->hexdigest) {
83 5         9 push @results, $file;
84             }
85 18         91 close(FILE);
86             }
87             }
88              
89 6         17 return grep {_not_same($_, $original)} @results;
  5         16  
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 28 my ($original, $dir) = @_;
100              
101 5 50       106 opendir(DIR, $dir) || die "Cannot opendir '$dir' : $!";
102 5         48 my @files = grep { -f } map { File::Spec->catfile($dir, $_) } readdir(DIR);
  28         160  
  28         129  
103 5         35 closedir(DIR);
104              
105 5         13 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 55 my ($original, $dirs) = @_;
116              
117 1         1 my @results;
118              
119 1         3 foreach my $dir (@$dirs) {
120 4         9 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   8 my ($file, $orig) = @_;
132              
133 5 100       152 return 0
134             if (File::Spec->rel2abs($file) eq File::Spec->rel2abs($orig));
135              
136 3         13 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             Copyright (C) 2001 MessageLabs Limited.
197              
198             This is free software, you may use it and distribute it under the same terms as
199             Perl itself.
200              
201             Any use, modification, and distribution of the Standard or Modified Versions is
202             governed by this Artistic License.By using, modifying or distributing the Package,
203             you accept this license. Do not use, modify, or distribute the Package, if you do
204             not accept this license.
205              
206             If your Modified Version has been derived from a Modified Version made by someone
207             other than you,you are nevertheless required to ensure that your Modified Version
208             complies with the requirements of this license.
209              
210             This license does not grant you the right to use any trademark, service mark,
211             tradename, or logo of the Copyright Holder.
212              
213             This license includes the non-exclusive, worldwide, free-of-charge patent license
214             to make, have made, use, offer to sell, sell, import and otherwise transfer the
215             Package with respect to any patent claims licensable by the Copyright Holder that
216             are necessarily infringed by the Package. If you institute patent litigation
217             (including a cross-claim or counterclaim) against any party alleging that the
218             Package constitutes direct or contributory patent infringement,then this Artistic
219             License to you shall terminate on the date that such litigation is filed.
220              
221             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND
222             CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED
223             WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR
224             NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL LAW. UNLESS
225             REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT,
226             INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE
227             OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
228              
229             =cut
230              
231             1; # End of File::Same