line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Image::Hash; |
2
|
|
|
|
|
|
|
|
3
|
2
|
|
|
2
|
|
72966
|
use strict; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
43
|
|
4
|
2
|
|
|
2
|
|
9
|
use warnings; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
61
|
|
5
|
|
|
|
|
|
|
|
6
|
2
|
|
|
2
|
|
8
|
use List::Util qw(sum); |
|
2
|
|
|
|
|
7
|
|
|
2
|
|
|
|
|
177
|
|
7
|
2
|
|
|
2
|
|
8
|
use Carp; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
5346
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
our $VERSION = '0.06'; |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
=head1 NAME |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
Image::Hash - Perceptual image hashing [aHash, dHash, pHash]. |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
=head1 SYNOPSIS |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
use Image::Hash; |
19
|
|
|
|
|
|
|
use File::Slurp; |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
# Read a image from the command line |
22
|
|
|
|
|
|
|
my $image = read_file( shift @ARGV, binmode => ':raw' ) ; |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
my $ihash = Image::Hash->new($image); |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
# Calculate the average hash |
27
|
|
|
|
|
|
|
my $a = $ihash->ahash(); |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
# Calculate the difference hash |
30
|
|
|
|
|
|
|
my $b = $ihash->dhash(); |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
# Calculate the perception hash |
33
|
|
|
|
|
|
|
my $p = $ihash->phash(); |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
print "$a\n$b\n$p\n"; |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
=head1 DESCRIPTION |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
Image::Hash allows you to calculate the average hash, difference hash and perception hash an image. |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
Depending on what is available on your system Image::Hash will use GD, Image::Magick or Imager to interact with your image. |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
=head1 CONSTRUCTOR METHODS |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
my $ihash = Image::Hash->new($image [, $module ]); |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
The first argument is a scalar with a binary representation of an image. |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
You may also optionally specify a second argument of "GD", "ImageMagick" or "Imager" to force Image::Hash to use the specific image module when it interacts with the image. |
54
|
|
|
|
|
|
|
The different image modules may give direct hashes for the same image. Using GD normally hives the best results, and are is highly recommended. |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
=cut |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
sub new { |
60
|
1
|
|
|
1
|
0
|
312
|
my $class = shift; |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
|
63
|
1
|
|
|
|
|
3
|
my $self = {}; |
64
|
1
|
|
|
|
|
2
|
bless( $self, $class ); |
65
|
|
|
|
|
|
|
|
66
|
1
|
|
|
|
|
6
|
$self->{'image'} = shift; |
67
|
1
|
|
|
|
|
3
|
$self->{'module'} = shift; |
68
|
|
|
|
|
|
|
|
69
|
1
|
50
|
|
|
|
3
|
if ($self->{'module'}) { |
70
|
|
|
|
|
|
|
# Try to load the image handler the user asked for |
71
|
0
|
0
|
0
|
|
|
0
|
if ($self->{'module'} eq "GD") { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
72
|
0
|
|
|
|
|
0
|
require GD; |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
elsif ($self->{'module'} eq "ImageMagick" || $self->{'module'} eq "Image::Magick") { |
75
|
0
|
|
|
|
|
0
|
require Image::Magick; |
76
|
0
|
|
|
|
|
0
|
$self->{'module'} = 'ImageMagick'; |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
elsif ($self->{'module'} eq "Imager") { |
79
|
0
|
|
|
|
|
0
|
require Imager; |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
else { |
82
|
0
|
|
|
|
|
0
|
croak("Unknown mudule: '" . $self->{'module'} . "'. Please use either GD, ImageMagick or Imager as module."); |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
else { |
86
|
|
|
|
|
|
|
# Try to load GD, ImageMagic or Imager |
87
|
1
|
50
|
|
|
|
49
|
if (eval 'require GD') { |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
88
|
0
|
|
|
|
|
0
|
$self->{'module'} = "GD"; |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
elsif (eval 'require Image::Magick') { |
91
|
0
|
|
|
|
|
0
|
$self->{'module'} = "ImageMagick"; |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
elsif (eval 'require Imager') { |
94
|
0
|
|
|
|
|
0
|
$self->{'module'} = "Imager"; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
else { |
97
|
1
|
|
|
|
|
484
|
croak("No image maudule avalibal. Can't load GD, ImageMagic or Imager."); |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
|
104
|
0
|
0
|
|
|
|
|
if ($self->{'module'} eq 'GD') { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
105
|
0
|
|
|
|
|
|
$self->{'im'} = GD::Image->new( $self->{'image'} ); |
106
|
0
|
0
|
|
|
|
|
if (not defined $self->{'im'}) { |
107
|
0
|
|
|
|
|
|
carp("Can't make image from this value"); |
108
|
0
|
|
|
|
|
|
return undef; |
109
|
|
|
|
|
|
|
} |
110
|
0
|
|
|
|
|
|
$self->{'reduse'} = \&reduse_GD; |
111
|
0
|
|
|
|
|
|
$self->{'pixels'} = \&pixels_GD; |
112
|
0
|
|
|
|
|
|
$self->{'blob'} = \&blob_GD; |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
elsif ($self->{'module'} eq 'ImageMagick') { |
115
|
0
|
|
|
|
|
|
$self->{'im'} = Image::Magick->new(); |
116
|
0
|
|
|
|
|
|
my $ret = $self->{'im'}->BlobToImage( $self->{'image'} ); |
117
|
0
|
0
|
|
|
|
|
if ($ret == 0) { |
118
|
0
|
|
|
|
|
|
carp("Can't make image from this value"); |
119
|
0
|
|
|
|
|
|
return undef; |
120
|
|
|
|
|
|
|
} |
121
|
0
|
|
|
|
|
|
$self->{'reduse'} = \&reduse_ImageMagick; |
122
|
0
|
|
|
|
|
|
$self->{'pixels'} = \&pixels_ImageMagick; |
123
|
0
|
|
|
|
|
|
$self->{'blob'} = \&blob_ImageMagick; |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
elsif ($self->{'module'} eq 'Imager') { |
127
|
0
|
|
|
|
|
|
$self->{'im'} = Imager->new(data=>$self->{'image'}); |
128
|
0
|
0
|
|
|
|
|
if (not defined $self->{'im'}) { |
129
|
0
|
|
|
|
|
|
carp("Can't make image from this value: " . Imager->errstr()); |
130
|
0
|
|
|
|
|
|
return undef; |
131
|
|
|
|
|
|
|
} |
132
|
0
|
|
|
|
|
|
$self->{'reduse'} = \&reduse_Imager; |
133
|
0
|
|
|
|
|
|
$self->{'pixels'} = \&pixels_Imager; |
134
|
0
|
|
|
|
|
|
$self->{'blob'} = \&blob_Imager; |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
|
139
|
0
|
|
|
|
|
|
return $self; |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
# Helper function: |
144
|
|
|
|
|
|
|
# Convert from binary to hexadecimal |
145
|
|
|
|
|
|
|
# |
146
|
|
|
|
|
|
|
# Borrowed from http://www.perlmonks.org/index.pl?node_id=644225 |
147
|
|
|
|
|
|
|
sub b2h { |
148
|
0
|
|
|
0
|
0
|
|
my $num = shift; |
149
|
0
|
|
|
|
|
|
my $WIDTH = 4; |
150
|
0
|
|
|
|
|
|
my $index = length($num) - $WIDTH; |
151
|
0
|
|
|
|
|
|
my $hex = ''; |
152
|
0
|
|
|
|
|
|
do { |
153
|
0
|
|
|
|
|
|
my $width = $WIDTH; |
154
|
0
|
0
|
|
|
|
|
if ($index < 0) { |
155
|
0
|
|
|
|
|
|
$width += $index; |
156
|
0
|
|
|
|
|
|
$index = 0; |
157
|
|
|
|
|
|
|
} |
158
|
0
|
|
|
|
|
|
my $cut_string = substr($num, $index, $width); |
159
|
0
|
|
|
|
|
|
$hex = sprintf('%X', oct("0b$cut_string")) . $hex; |
160
|
0
|
|
|
|
|
|
$index -= $WIDTH; |
161
|
|
|
|
|
|
|
} while ($index > (-1 * $WIDTH)); |
162
|
0
|
|
|
|
|
|
return $hex; |
163
|
|
|
|
|
|
|
} |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
# Reduse the size of an image using GD |
166
|
|
|
|
|
|
|
sub reduse_GD { |
167
|
0
|
|
|
0
|
0
|
|
my ($self, %opt) = @_; |
168
|
0
|
|
|
|
|
|
$self->{ $opt{'im'} } = $self->{'im'}; |
169
|
|
|
|
|
|
|
|
170
|
0
|
|
|
|
|
|
my ($xs, $ys) = split(/x/, $opt{'geometry'}); |
171
|
|
|
|
|
|
|
|
172
|
0
|
|
|
|
|
|
my $dest = GD::Image->new($xs, $ys); |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
$dest->copyResampled($self->{ $opt{'im'} }, |
175
|
|
|
|
|
|
|
0, 0, # (destX, destY) |
176
|
|
|
|
|
|
|
0, 0, # (srcX, srxY ) |
177
|
|
|
|
|
|
|
$xs, $ys, # (destX, destY) |
178
|
0
|
|
|
|
|
|
$self->{ $opt{'im'} }->width, $self->{ $opt{'im'} }->height |
179
|
|
|
|
|
|
|
); |
180
|
0
|
|
|
|
|
|
$self->{ $opt{'im'} } = $dest; |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
# Reduse the size of an image using Image::Magick |
184
|
|
|
|
|
|
|
sub reduse_ImageMagick { |
185
|
0
|
|
|
0
|
0
|
|
my ($self, %opt) = @_; |
186
|
0
|
|
|
|
|
|
$self->{ $opt{'im'} } = $self->{'im'}; |
187
|
|
|
|
|
|
|
|
188
|
0
|
|
|
|
|
|
$self->{ $opt{'im'} }->Set(antialias=>'True'); |
189
|
0
|
|
|
|
|
|
$self->{ $opt{'im'} }->Resize($opt{'geometry'}); |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
# Reduse the size of an image using Imager |
193
|
|
|
|
|
|
|
sub reduse_Imager { |
194
|
0
|
|
|
0
|
0
|
|
my ($self, %opt) = @_; |
195
|
0
|
|
|
|
|
|
my ($xs, $ys) = split(/x/, $opt{'geometry'}); |
196
|
|
|
|
|
|
|
|
197
|
0
|
|
|
|
|
|
$self->{ $opt{'im'} } = $self->{ 'im' }->scale(xpixels => $xs, ypixels => $ys, type => "nonprop"); |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
# Return the image as a blob using GD |
202
|
|
|
|
|
|
|
sub blob_GD { |
203
|
0
|
|
|
0
|
0
|
|
my ($self, %opt) = @_; |
204
|
|
|
|
|
|
|
|
205
|
0
|
|
|
|
|
|
return $self->{ $opt{'im'} }->png; |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
# Return the image as a blob using Image::Magick |
209
|
|
|
|
|
|
|
sub blob_ImageMagick { |
210
|
0
|
|
|
0
|
0
|
|
my ($self, %opt) = @_; |
211
|
|
|
|
|
|
|
|
212
|
0
|
|
|
|
|
|
my $blobs = $self->{ $opt{'im'} }->ImageToBlob(magick => 'png'); |
213
|
|
|
|
|
|
|
|
214
|
0
|
|
|
|
|
|
return $blobs; |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
# Return the image as a blob using Imager |
218
|
|
|
|
|
|
|
sub blob_Imager { |
219
|
0
|
|
|
0
|
0
|
|
my ($self, %opt) = @_; |
220
|
|
|
|
|
|
|
|
221
|
0
|
|
|
|
|
|
my $data; |
222
|
0
|
0
|
|
|
|
|
$self->{ $opt{'im'} }->write(data => \$data, type => 'png') or carp $self->{ $opt{'im'} }->errstr; |
223
|
|
|
|
|
|
|
|
224
|
0
|
|
|
|
|
|
return $data; |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
# Return the pixel values for an image when using GD |
228
|
|
|
|
|
|
|
sub pixels_GD { |
229
|
0
|
|
|
0
|
0
|
|
my ($self, %opt) = @_; |
230
|
|
|
|
|
|
|
|
231
|
0
|
|
|
|
|
|
my ($xs, $ys) = split(/x/, $opt{'geometry'}); |
232
|
|
|
|
|
|
|
|
233
|
0
|
|
|
|
|
|
my @pixels; |
234
|
0
|
|
|
|
|
|
for(my $y=0; $y<$ys;$y++) { |
235
|
0
|
|
|
|
|
|
for(my $x=0; $x<$xs;$x++) { |
236
|
|
|
|
|
|
|
|
237
|
0
|
|
|
|
|
|
my $color = $self->{ $opt{'im'} }->getPixel($x, $y); |
238
|
0
|
|
|
|
|
|
my ($red, $green, $blue) = $self->{ $opt{'im'} }->rgb($color); |
239
|
0
|
|
|
|
|
|
my $grey = $red*0.3 + $green*0.59 + $blue*0.11; |
240
|
0
|
|
|
|
|
|
push(@pixels, $grey); |
241
|
|
|
|
|
|
|
} |
242
|
|
|
|
|
|
|
} |
243
|
|
|
|
|
|
|
|
244
|
0
|
|
|
|
|
|
return @pixels; |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
# Return the pixel values for an image when using Image::Magick |
248
|
|
|
|
|
|
|
sub pixels_ImageMagick { |
249
|
0
|
|
|
0
|
0
|
|
my ($self, %opt) = @_; |
250
|
0
|
|
|
|
|
|
my ($xs, $ys) = split(/x/, $opt{'geometry'}); |
251
|
|
|
|
|
|
|
|
252
|
0
|
|
|
|
|
|
my @pixels; |
253
|
0
|
|
|
|
|
|
for(my $y=0; $y<$ys;$y++) { |
254
|
0
|
|
|
|
|
|
for(my $x=0; $x<$xs;$x++) { |
255
|
0
|
|
|
|
|
|
my @pixel = $self->{ $opt{'im'} }->GetPixel(x=>$x,y=>$y,normalize => 0); |
256
|
0
|
|
|
|
|
|
my $grey = $pixel[0]*0.3 + $pixel[1]*0.59 + $pixel[2]*0.11; |
257
|
0
|
|
|
|
|
|
push(@pixels, $grey); |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
} |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
|
262
|
0
|
|
|
|
|
|
for (my $i = 0; $i <= $#pixels; $i++) { |
263
|
0
|
|
|
|
|
|
$pixels[$i] = $pixels[$i] / 256; |
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
|
266
|
0
|
|
|
|
|
|
return @pixels; |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
# Return the pixel values for an image when using Imager |
270
|
|
|
|
|
|
|
sub pixels_Imager { |
271
|
0
|
|
|
0
|
0
|
|
my ($self, %opt) = @_; |
272
|
0
|
|
|
|
|
|
my ($xs, $ys) = split(/x/, $opt{'geometry'}); |
273
|
0
|
|
|
|
|
|
my @pixels; |
274
|
0
|
|
|
|
|
|
for(my $y=0; $y<$ys;$y++) { |
275
|
0
|
|
|
|
|
|
for(my $x=0; $x<$xs;$x++) { |
276
|
0
|
|
|
|
|
|
my $c = $self->{ $opt{'im'} }->getpixel(x => $x, y => $y); |
277
|
0
|
|
|
|
|
|
my ($red, $green, $blue, $alpha) = $c->rgba(); |
278
|
0
|
|
|
|
|
|
my $grey = $red*0.3 + $green*0.59 + $blue*0.11; |
279
|
0
|
|
|
|
|
|
push(@pixels, $grey); |
280
|
|
|
|
|
|
|
} |
281
|
|
|
|
|
|
|
} |
282
|
0
|
|
|
|
|
|
return @pixels; |
283
|
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
=head1 HASHES |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
=head2 ahash |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
$ihash->ahash(); |
290
|
|
|
|
|
|
|
$ihash->ahash('geometry' => '8x8'); |
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
Calculate the Average Hash |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
Return an array of binary values in array context and a hex representative in scalar context. |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
=cut |
297
|
|
|
|
|
|
|
sub ahash { |
298
|
0
|
|
|
0
|
1
|
|
my ($self, %opt) = @_; |
299
|
|
|
|
|
|
|
|
300
|
0
|
|
0
|
|
|
|
$opt{'geometry'} ||= '8x8'; |
301
|
0
|
|
0
|
|
|
|
$opt{'im'} ||= 'im_' . $opt{'geometry'}; |
302
|
|
|
|
|
|
|
|
303
|
0
|
0
|
|
|
|
|
if(!$self->{ $opt{'im'} }) { |
304
|
0
|
|
|
|
|
|
$self->{'reduse'}->($self, %opt ); |
305
|
|
|
|
|
|
|
} |
306
|
|
|
|
|
|
|
|
307
|
0
|
|
|
|
|
|
my @pixels = $self->{'pixels'}->($self, %opt ); |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
# aHash specific code |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
# Find the mean values of all the values in the array |
312
|
0
|
|
|
|
|
|
my $m = sum(@pixels)/@pixels; |
313
|
|
|
|
|
|
|
|
314
|
0
|
|
|
|
|
|
my @binvalue; |
315
|
|
|
|
|
|
|
|
316
|
0
|
|
|
|
|
|
foreach my $p (@pixels) { |
317
|
0
|
0
|
|
|
|
|
if ($p > $m) { |
318
|
0
|
|
|
|
|
|
push(@binvalue,'1'); |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
else { |
321
|
0
|
|
|
|
|
|
push(@binvalue,'0'); |
322
|
|
|
|
|
|
|
} |
323
|
|
|
|
|
|
|
} |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
# Return an array of binary values in array context and a hex representative in scalar context. |
326
|
0
|
0
|
|
|
|
|
if ( wantarray() ) { |
327
|
0
|
|
|
|
|
|
return @binvalue; |
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
else { |
330
|
0
|
|
|
|
|
|
return b2h( join('',@binvalue) ); |
331
|
|
|
|
|
|
|
} |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
} |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
=head2 dhash |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
$ihash->dhash(); |
338
|
|
|
|
|
|
|
$ihash->dhash('geometry' => '8x8'); |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
Calculate the Dynamic Hash |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
Return an array of binary values in array context and a hex representative in scalar context. |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
=cut |
345
|
|
|
|
|
|
|
sub dhash { |
346
|
0
|
|
|
0
|
1
|
|
my ($self, %opt) = @_; |
347
|
|
|
|
|
|
|
|
348
|
0
|
|
0
|
|
|
|
$opt{'geometry'} ||= '9x8'; |
349
|
0
|
|
0
|
|
|
|
$opt{'im'} ||= 'im_' . $opt{'geometry'}; |
350
|
|
|
|
|
|
|
|
351
|
0
|
0
|
|
|
|
|
if(!$self->{ $opt{'im'} }) { |
352
|
0
|
|
|
|
|
|
$self->{'reduse'}->($self, %opt ); |
353
|
|
|
|
|
|
|
} |
354
|
|
|
|
|
|
|
|
355
|
0
|
|
|
|
|
|
my @pixels = $self->{'pixels'}->($self, %opt ); |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
# dHash specific code |
358
|
|
|
|
|
|
|
|
359
|
0
|
|
|
|
|
|
my ($xs, $ys) = split(/x/, $opt{'geometry'}); |
360
|
|
|
|
|
|
|
|
361
|
0
|
|
|
|
|
|
my @binvalue; |
362
|
|
|
|
|
|
|
|
363
|
0
|
|
|
|
|
|
for (my $i = 0; $i <= $#pixels; $i++) { |
364
|
|
|
|
|
|
|
|
365
|
0
|
0
|
|
|
|
|
if(($i % $xs) != $xs -1) { |
366
|
0
|
0
|
|
|
|
|
if ($pixels[$i] < $pixels[$i+1]) { |
367
|
0
|
|
|
|
|
|
push(@binvalue,'1'); |
368
|
|
|
|
|
|
|
} |
369
|
|
|
|
|
|
|
else { |
370
|
0
|
|
|
|
|
|
push(@binvalue,'0'); |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
} |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
# Return an array of binary values in array context and a hex representative in scalar context. |
376
|
0
|
0
|
|
|
|
|
if ( wantarray() ) { |
377
|
0
|
|
|
|
|
|
return @binvalue; |
378
|
|
|
|
|
|
|
} |
379
|
|
|
|
|
|
|
else { |
380
|
0
|
|
|
|
|
|
return b2h( join('',@binvalue) ); |
381
|
|
|
|
|
|
|
} |
382
|
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
=head2 phash |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
$ihash->phash(); |
387
|
|
|
|
|
|
|
$ihash->phash('geometry' => '8x8'); |
388
|
|
|
|
|
|
|
|
389
|
|
|
|
|
|
|
Calculate the Perceptual Hash |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
Return an array of binary values in array context and a hex representative in scalar context. |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
=cut |
394
|
|
|
|
|
|
|
# Some code taken from http://jax-work-archive.blogspot.no/2013/05/php-ahash-phash-dhash.html |
395
|
|
|
|
|
|
|
sub getDctConst{ |
396
|
|
|
|
|
|
|
|
397
|
0
|
|
|
0
|
0
|
|
my @_dctConst; |
398
|
0
|
|
|
|
|
|
for (my $dctP=0; $dctP<8; $dctP++) { |
399
|
0
|
|
|
|
|
|
for (my $p=0;$p<32;$p++) { |
400
|
0
|
|
|
|
|
|
$_dctConst[$dctP][$p] = |
401
|
|
|
|
|
|
|
cos( ((2*$p + 1)/64) * $dctP * '3.1415926535898' ); |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
} |
404
|
|
|
|
|
|
|
|
405
|
0
|
|
|
|
|
|
return @_dctConst; |
406
|
|
|
|
|
|
|
} |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
# Some code taken from http://jax-work-archive.blogspot.no/2013/05/php-ahash-phash-dhash.html |
409
|
|
|
|
|
|
|
sub phash { |
410
|
0
|
|
|
0
|
1
|
|
my ($self, %opt) = @_; |
411
|
|
|
|
|
|
|
|
412
|
0
|
|
0
|
|
|
|
$opt{'geometry'} ||= '32x32'; |
413
|
0
|
|
0
|
|
|
|
$opt{'im'} ||= 'im_' . $opt{'geometry'}; |
414
|
|
|
|
|
|
|
|
415
|
0
|
0
|
|
|
|
|
if(!$self->{ $opt{'im'} }) { |
416
|
0
|
|
|
|
|
|
$self->{'reduse'}->($self, %opt ); |
417
|
|
|
|
|
|
|
} |
418
|
|
|
|
|
|
|
|
419
|
0
|
|
|
|
|
|
my @pixels = $self->{'pixels'}->($self, %opt ); |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
# Put the pixel into a multi dimentional array |
422
|
0
|
|
|
|
|
|
my @grays; |
423
|
0
|
|
|
|
|
|
for (my $y=0; $y<32; $y++){ |
424
|
0
|
|
|
|
|
|
for (my $x=0; $x<32; $x++){ |
425
|
0
|
|
|
|
|
|
$grays[$y][$x] = shift @pixels; |
426
|
|
|
|
|
|
|
} |
427
|
|
|
|
|
|
|
} |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
# pHash specific code |
430
|
|
|
|
|
|
|
# DCT 8x8 |
431
|
0
|
|
|
|
|
|
my @dctConst = getDctConst(); |
432
|
0
|
|
|
|
|
|
my $dctSum = 0; |
433
|
0
|
|
|
|
|
|
my @dcts; |
434
|
0
|
|
|
|
|
|
for (my $dctY=0; $dctY<8; $dctY++) { |
435
|
0
|
|
|
|
|
|
for (my $dctX=0; $dctX<8; $dctX++) { |
436
|
|
|
|
|
|
|
|
437
|
0
|
|
|
|
|
|
my $sum = 1; |
438
|
0
|
|
|
|
|
|
for (my $y=0;$y<32;$y++) { |
439
|
0
|
|
|
|
|
|
for (my $x=0;$x<32;$x++) { |
440
|
0
|
|
|
|
|
|
$sum += |
441
|
|
|
|
|
|
|
$dctConst[$dctY][$y] * |
442
|
|
|
|
|
|
|
$dctConst[$dctX][$x] * |
443
|
|
|
|
|
|
|
$grays[$y][$x]; |
444
|
|
|
|
|
|
|
} |
445
|
|
|
|
|
|
|
} |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
# apply coefficients |
448
|
0
|
|
|
|
|
|
$sum *= .25; |
449
|
0
|
0
|
0
|
|
|
|
if ($dctY == 0 || $dctX == 0) { |
450
|
0
|
|
|
|
|
|
$sum *= 1/sqrt(2); |
451
|
|
|
|
|
|
|
} |
452
|
|
|
|
|
|
|
|
453
|
0
|
|
|
|
|
|
push(@dcts,$sum); |
454
|
0
|
|
|
|
|
|
$dctSum += $sum; |
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
} |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
|
459
|
0
|
|
|
|
|
|
my $average = $dctSum/64; |
460
|
|
|
|
|
|
|
|
461
|
0
|
|
|
|
|
|
my @binvalue; |
462
|
0
|
|
|
|
|
|
foreach my $dct (@dcts) { |
463
|
0
|
0
|
|
|
|
|
push(@binvalue,($dct>=$average) ? '1' : '0'); |
464
|
|
|
|
|
|
|
} |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
# Return an array of binary values in array context and a hex representative in scalar context. |
467
|
0
|
0
|
|
|
|
|
if ( wantarray() ) { |
468
|
0
|
|
|
|
|
|
return @binvalue; |
469
|
|
|
|
|
|
|
} |
470
|
|
|
|
|
|
|
else { |
471
|
0
|
|
|
|
|
|
return b2h( join('',@binvalue) ); |
472
|
|
|
|
|
|
|
} |
473
|
|
|
|
|
|
|
} |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
=head1 HELPER |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
=head2 greytones |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
$ihash->greytones(); |
480
|
|
|
|
|
|
|
$ihash->greytones('geometry' => '8x8'); |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
Return the number of different shades of grey after the image are converted to grey tones. The number of shades can be used to indicate the complexity of an image, and exclude images that has a very low complexity. |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
For example, all images with only a single color will be reduced to an image with a single grey color and thus give the same hash. |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
=cut |
487
|
|
|
|
|
|
|
sub greytones { |
488
|
0
|
|
|
0
|
1
|
|
my ($self, %opt) = @_; |
489
|
|
|
|
|
|
|
|
490
|
0
|
|
0
|
|
|
|
$opt{'geometry'} ||= '8x8'; |
491
|
0
|
|
0
|
|
|
|
$opt{'im'} ||= 'im_' . $opt{'geometry'}; |
492
|
|
|
|
|
|
|
|
493
|
0
|
0
|
|
|
|
|
if(!$self->{ $opt{'im'} }) { |
494
|
0
|
|
|
|
|
|
$self->{'reduse'}->($self, %opt ); |
495
|
|
|
|
|
|
|
} |
496
|
|
|
|
|
|
|
|
497
|
0
|
|
|
|
|
|
my @pixels = $self->{'pixels'}->($self, %opt ); |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
# aHash specific code |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
# Find the mean values of all the values in the array |
502
|
0
|
|
|
|
|
|
my $m = sum(@pixels)/@pixels; |
503
|
|
|
|
|
|
|
|
504
|
0
|
|
|
|
|
|
my %seen; |
505
|
0
|
|
|
|
|
|
my $count = 0; |
506
|
0
|
|
|
|
|
|
foreach my $p (@pixels) { |
507
|
0
|
0
|
|
|
|
|
if ($seen{$p}) {next;} |
|
0
|
|
|
|
|
|
|
508
|
0
|
|
|
|
|
|
$seen{$p} = 1; |
509
|
0
|
|
|
|
|
|
$count++; |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
|
|
513
|
0
|
|
|
|
|
|
return $count; |
514
|
|
|
|
|
|
|
} |
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
=head1 DEBUGGING |
517
|
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
Functions useful for debug purposes. |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
=head2 dump |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
my $ihash = Image::Hash->new($image, $module); |
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
my @hash = $ihash->ahash(); |
527
|
|
|
|
|
|
|
$ihash->dump('hash' => \@hash ); |
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
array( [ 183 (1), 189 (1), 117 (0), 80 (0), 183 (1), 189 (1), 189 (1), 189 (1) ], |
531
|
|
|
|
|
|
|
[ 183 (1), 158 (0), 89 (0), 211 (1), 89 (0), 189 (1), 168 (1), 162 (1) ], |
532
|
|
|
|
|
|
|
[ 176 (1), 151 (0), 93 (0), 160 (1), 160 (1), 191 (1), 154 (0), 154 (0) ], |
533
|
|
|
|
|
|
|
[ 195 (1), 139 (0), 53 (0), 168 (1), 83 (0), 205 (1), 146 (0), 146 (0) ], |
534
|
|
|
|
|
|
|
[ 195 (1), 195 (1), 183 (1), 160 (1), 160 (1), 199 (1), 124 (0), 129 (0) ], |
535
|
|
|
|
|
|
|
[ 187 (1), 183 (1), 183 (1), 195 (1), 180 (1), 193 (1), 129 (0), 135 (0) ], |
536
|
|
|
|
|
|
|
[ 176 (1), 180 (1), 174 (1), 183 (1), 176 (1), 176 (1), 135 (0), 146 (0) ], |
537
|
|
|
|
|
|
|
[ 162 (1), 171 (1), 99 (0), 149 (0), 129 (0), 162 (1), 140 (0), 146 (0) ]) |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
Dump the array used when generating hashes. Option 'hash' may be specified to show with pixel has witch value in the hash. |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
=cut |
542
|
|
|
|
|
|
|
sub dump { |
543
|
0
|
|
|
0
|
1
|
|
my ($self, %opt) = @_; |
544
|
|
|
|
|
|
|
|
545
|
0
|
|
0
|
|
|
|
$opt{'geometry'} ||= '8x8'; |
546
|
0
|
|
0
|
|
|
|
$opt{'im'} ||= 'im_' . $opt{'geometry'}; |
547
|
|
|
|
|
|
|
|
548
|
0
|
0
|
|
|
|
|
if(!$self->{ $opt{'im'} }) { |
549
|
0
|
|
|
|
|
|
$self->{'reduse'}->($self, %opt ); |
550
|
|
|
|
|
|
|
} |
551
|
|
|
|
|
|
|
|
552
|
0
|
|
|
|
|
|
my @pixels = $self->{'pixels'}->($self, %opt ); |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
# dump specific code |
555
|
0
|
0
|
0
|
|
|
|
if ($opt{'hash'} && $opt{'geometry'} ne '8x8') { |
556
|
0
|
|
|
|
|
|
carp("The geometry must be 8x8 when calling dump with a hash to highlight."); |
557
|
|
|
|
|
|
|
} |
558
|
|
|
|
|
|
|
|
559
|
0
|
0
|
|
|
|
|
if (scalar @{ $opt{'hash'} } != 64) { |
|
0
|
|
|
|
|
|
|
560
|
0
|
|
|
|
|
|
carp("'hash' must be a 64 element array."); |
561
|
|
|
|
|
|
|
} |
562
|
|
|
|
|
|
|
|
563
|
0
|
|
|
|
|
|
my ($xs, $ys) = split(/x/, $opt{'geometry'}); |
564
|
|
|
|
|
|
|
|
565
|
0
|
|
|
|
|
|
print "array(\t[ "; |
566
|
0
|
|
|
|
|
|
for (my $i = 0; $i <= $#pixels; $i++) { |
567
|
0
|
0
|
0
|
|
|
|
if (($i % $xs) == 0 && $i != 0) {print " ],\n\t[ "} elsif($i != 0) { print ', '; } |
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
|
569
|
0
|
0
|
|
|
|
|
if ($opt{'hash'}) { |
570
|
0
|
|
|
|
|
|
printf("%3s (%1s)", int($pixels[$i]), shift @{ $opt{'hash'} }); |
|
0
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
} |
572
|
|
|
|
|
|
|
else { |
573
|
0
|
|
|
|
|
|
printf("%3s", int($pixels[$i])); |
574
|
|
|
|
|
|
|
} |
575
|
|
|
|
|
|
|
} |
576
|
0
|
|
|
|
|
|
print " ])\n"; |
577
|
|
|
|
|
|
|
|
578
|
|
|
|
|
|
|
} |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
=head2 reducedimage |
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
use Image::Hash; |
583
|
|
|
|
|
|
|
use File::Slurp; |
584
|
|
|
|
|
|
|
|
585
|
|
|
|
|
|
|
my $file = shift @ARGV or die("Pleas spesyfi a file to read!"); |
586
|
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
my $image = read_file( $file, binmode => ':raw' ) ; |
588
|
|
|
|
|
|
|
|
589
|
|
|
|
|
|
|
my $ihash = Image::Hash->new($image); |
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
binmode STDOUT; |
592
|
|
|
|
|
|
|
print STDOUT $ihash->reducedimage(); |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
Returns the reduced image that will be used by the hash functions. |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
=cut |
597
|
|
|
|
|
|
|
sub reducedimage { |
598
|
0
|
|
|
0
|
1
|
|
my ($self, %opt) = @_; |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
|
601
|
0
|
|
0
|
|
|
|
$opt{'geometry'} ||= '8x8'; |
602
|
0
|
|
0
|
|
|
|
$opt{'im'} ||= 'im_' . $opt{'geometry'}; |
603
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
|
605
|
0
|
0
|
|
|
|
|
if(!$self->{ $opt{'im'} }) { |
606
|
0
|
|
|
|
|
|
$self->{'reduse'}->($self, %opt ); |
607
|
|
|
|
|
|
|
} |
608
|
|
|
|
|
|
|
|
609
|
0
|
|
|
|
|
|
$self->{'blob'}->($self, %opt ); |
610
|
|
|
|
|
|
|
} |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
=head1 EXAMPLES |
613
|
|
|
|
|
|
|
|
614
|
|
|
|
|
|
|
Please see the C directory for further examples. |
615
|
|
|
|
|
|
|
|
616
|
|
|
|
|
|
|
=head1 BUGS |
617
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
Image::Hash support different back ends (GD, Image::Magick or Imager), but because the different back ends work slightly different they will not produce the same hash for the same image. More info is available at https://github.com/runarbu/PerlImageHash/blob/master/Hash_differences.md . |
619
|
|
|
|
|
|
|
|
620
|
|
|
|
|
|
|
=head1 AUTHOR |
621
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
Runar Buvik |
623
|
|
|
|
|
|
|
CPAN ID: RUNARB |
624
|
|
|
|
|
|
|
runarb@gmail.com |
625
|
|
|
|
|
|
|
http://www.runarb.com |
626
|
|
|
|
|
|
|
|
627
|
|
|
|
|
|
|
=head1 Git |
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
https://github.com/runarbu/PerlImageHash |
630
|
|
|
|
|
|
|
|
631
|
|
|
|
|
|
|
=head1 COPYRIGHT |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
This program is free software; you can redistribute |
634
|
|
|
|
|
|
|
it and/or modify it under the same terms as Perl itself. |
635
|
|
|
|
|
|
|
|
636
|
|
|
|
|
|
|
The full text of the license can be found in the |
637
|
|
|
|
|
|
|
LICENSE file included with this module. |
638
|
|
|
|
|
|
|
|
639
|
|
|
|
|
|
|
|
640
|
|
|
|
|
|
|
=head1 SEE ALSO |
641
|
|
|
|
|
|
|
|
642
|
|
|
|
|
|
|
Articles L and L by Neal Krawetz that describes the theory behind aHash, dHash, pHash. |
643
|
|
|
|
|
|
|
|
644
|
|
|
|
|
|
|
L image hashing library written in Python that dos the same thing. |
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
L a PHP class that do the same thing. |
647
|
|
|
|
|
|
|
|
648
|
|
|
|
|
|
|
=cut |
649
|
|
|
|
|
|
|
|
650
|
|
|
|
|
|
|
#################### main pod documentation end ################### |
651
|
|
|
|
|
|
|
|
652
|
|
|
|
|
|
|
|
653
|
|
|
|
|
|
|
1; |
654
|
|
|
|
|
|
|
# The preceding line will help the module return a true value |
655
|
|
|
|
|
|
|
|