File Coverage

blib/lib/Image/Identicon.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


line stmt bran cond sub pod time code
1             ## ----------------------------------------------------------------------------
2             # Image::Identicon.
3             # -----------------------------------------------------------------------------
4             # Mastering programmed by YAMASHINA Hio
5             #
6             # Copyright 2007 YAMASHINA Hio
7             # -----------------------------------------------------------------------------
8             # $Id: /perl/Image-Identicon/lib/Image/Identicon.pm 344 2007-02-02T16:41:20.275333Z hio $
9             # -----------------------------------------------------------------------------
10             package Image::Identicon;
11              
12 2     2   60064 use strict;
  2         5  
  2         80  
13 2     2   10 use warnings;
  2         4  
  2         55  
14              
15 2     2   2235 use GD;
  0            
  0            
16             BEGIN{
17             # GD::Polyline raise noisy redefine warning.
18             local($^W) = 0;
19             require GD::Polyline;
20             }
21             use Digest::SHA qw(sha1);
22              
23             our $VERSION = '0.03';
24              
25             our $SCALE_LIMIT = 100;
26             our $SIZE_LIMIT = 300;
27              
28             our $DEBUG = 0;
29              
30             1;
31              
32             # -----------------------------------------------------------------------------
33             # Image::Indenticon->new(salt=>$salt);
34             #
35             sub new
36             {
37             my $pkg = shift;
38             my $opts = @_ && ref($_[0]) ? shift : {@_};
39             my $this = {};
40             $this->{salt} = $opts->{salt};
41             $this->{render} = $opts->{render};
42             $this->{salt} or die "no salt";
43             bless $this, $pkg;
44             }
45              
46             # -----------------------------------------------------------------------------
47             # my $code = $obj->identicon_code();
48             # my $code = $obj->identicon_code($addr);
49             # calc 32bit identicon code from ip address.
50             #
51             sub identicon_code
52             {
53             my $this = shift;
54             my $addr = shift || $ENV{REMOTE_ADDR} || '0.0.0.0';
55            
56             $this->{salt} or die "isalt must be set prior to retrieving identicon code";
57             my @ip = $addr =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/;
58             my $packed = pack("C*", @ip);
59             join('.', unpack("C*",$packed)) eq $addr or die "invalid ip addr: $addr";
60            
61             my $ipint = unpack("N", $packed);
62             my $code = unpack("N", sha1("$ipint+$this->{salt}"));
63             $code;
64             }
65              
66             # -----------------------------------------------------------------------------
67             # $obj->decode($code);
68             #
69             sub decode
70             {
71             my $this = shift;
72             my $code = shift;
73            
74             # decode the code into parts
75             #
76             # bit 0-1: center patch type
77             # bit 2: center invert
78             # bit 3-6: corner patch type
79             # bit 7: corner invert
80             # bit 8-9: corner turns
81             # bit 10-13: side patch type
82             # bit 14: side invert
83             # bit 15: corner turns
84             # bit 16-20: blue color component
85             # bit 21-26: green color component
86             # bit 27-31: red color component
87             my $center_type = ($code & 0x3);
88             my $center_invert = (($code >> 2) & 0x01) != 0;
89             my $corner_type = (($code >> 3) & 0x0f);
90             my $corner_invert = (($code >> 7) & 0x01) != 0;
91             my $corner_turn = (($code >> 8) & 0x03);
92             my $side_type = (($code >> 10) & 0x0f);
93             my $side_invert = (($code >> 14) & 0x01) != 0;
94             my $side_turn = (($code >> 15) & 0x03);
95             my $blue = (($code >> 16) & 0x01f)<<3;
96             my $green = (($code >> 21) & 0x01f)<<3;
97             my $red = (($code >> 27) & 0x01f)<<3;
98            
99             if( $DEBUG )
100             {
101             print "[decode]\n";
102             print "- (center) = ($center_type, -, $center_invert)\n";
103             print "- (corner) = ($corner_type, $corner_turn, $corner_invert)\n";
104             print "- (side) = ($side_type, $side_turn, $side_invert)\n";
105             print "- (r,g,b) = ($red, $green, $blue)\n";
106             }
107            
108             my $decode = {
109             center_type => $center_type,
110             center_invert => $center_invert,
111             corner_type => $corner_type,
112             corner_invert => $corner_invert,
113             corner_turn => $corner_turn,
114             side_type => $side_type,
115             side_invert => $side_invert,
116             side_turn => $side_turn,
117            
118             red => $red,
119             green => $green,
120             blue => $blue,
121             };
122             $decode;
123             }
124              
125             # -----------------------------------------------------------------------------
126             # my $result = $obj->identicon_code(\%opts);
127             # render image.
128             # returns GD::Image through $result->{image}.
129             #
130             sub render
131             {
132             my $this = shift;
133             my $opts;
134             if( !@_ )
135             {
136             $opts = {};
137             }elsif( ref($_[0]) )
138             {
139             $opts = shift;
140             }elsif( $_[0]=~/^[-a-z]/ )
141             {
142             $opts = {@_};
143             }else
144             {
145             # deprecated interface: $obj->identicon_code($code);
146             $opts->{code} = shift || $this->identicon_code;
147             $opts->{scale} = shift || 10;
148             }
149             my $code = $opts->{code};
150             my $scale = $opts->{scale};
151             my $size = $opts->{size};
152            
153             if( !$scale )
154             {
155             if( !$size )
156             {
157             $scale = 3;
158             }else
159             {
160             my $patch_size = 5;
161             $scale = int($size*4/3/$patch_size);
162             }
163             }
164             $scale >= $SCALE_LIMIT and $scale = $SCALE_LIMIT;
165             $size && $size>=$SIZE_LIMIT and $size = $SIZE_LIMIT;
166            
167             if( $DEBUG )
168             {
169             $size ||= '';
170             print "[render.prepare]\n";
171             print "- size = $size\n";
172             print "- scale = $scale\n";
173             print "- code = $code\n";
174             }
175            
176             my $decode = $this->decode($code);
177            
178             # render.
179             my $rpkg = $opts->{render} || $this->{render} || 'Image::Identicon::Render';
180             my $r = $rpkg->new({
181             %$decode,
182             code => $code,
183             scale => $scale,
184             size => $size,
185             });
186             $r->render();
187             $r->_resize();
188            
189             $r;
190             }
191              
192             # -----------------------------------------------------------------------------
193             # Renderer.
194             #
195             package Image::Identicon::Render;
196              
197             # 5x5 matrix.
198             # 00 01 02 03 04
199             # 05 06 07 08 09
200             # 10 11 12 13 14
201             # 15 16 17 18 19
202             # 20 21 22 23 24
203             our $PATCHES = [
204             [ 0, 4, 24, 20, 0, ], # 0
205             [ 0, 4, 20, 0, ], # 1
206             [ 2, 24, 20, 2, ], # 2
207             [ 0, 2, 20, 22, 0, ], # 3
208             [ 2, 14, 22, 10, 2, ], # 4
209             [ 0, 14, 24, 22, 0, ], # 5
210             [ 2, 24, 22, 13, 11, 22, 20, 2, ], # 6
211             [ 0, 14, 22, 0, ], # 7
212             [ 6, 8, 18, 16, 6, ], # 8
213             [ 4, 20, 10, 12, 2, 4, ], # 9
214             [ 0, 2, 12, 10, 0, ], # 10
215             [ 10, 14, 22, 10, ], # 11
216             [ 20, 12, 24, 20, ], # 12
217             [ 10, 2, 12, 10, ], # 12
218             [ 0, 2, 10, 0, ], # 14
219             [ 0, 5, 11, 15, 20, 21, 17, 23, 24, 19, 13, 9, 4, 3, 7, 1, 0], # 15
220             ];
221              
222             our $PATCH_SYMMETRIC = 1;
223             our $PATCH_INVERTED = 2;
224              
225             our $PATCH_FLAGS = [
226             $PATCH_SYMMETRIC, 0, 0, 0,
227             $PATCH_SYMMETRIC, 0, 0, 0,
228             $PATCH_SYMMETRIC, 0, 0, 0,
229             0, 0, 0, $PATCH_SYMMETRIC,
230             ];
231              
232             our $CENTER_PATCHES = [ 0, 4, 8, 15, ];
233              
234             our $PATCH_SIZE = 5;
235              
236             1;
237              
238             sub _patch_size() { $PATCH_SIZE }
239              
240             sub new
241             {
242             my $pkg = shift;
243             my $opts = shift;
244             my $this = bless {%$opts}, $pkg;
245            
246             $this->{center_type} = $CENTER_PATCHES->[$this->{center_type}&3];
247            
248             my $scale = $opts->{scale};
249             my $patch_size = $pkg->_patch_size;
250             my $patch_width = ($patch_size-1) * $scale + 1;
251             my $source_size = $patch_width * 3;
252             my $image = new GD::Image($source_size, $source_size, 1);
253            
254             # color components are used at top of the range for color difference
255             # use white background for now.
256             # TODO: support transparency.
257             my ($red, $green, $blue) = @$this{qw(red green blue)};
258             my $fore_color = $image->colorAllocate($red, $green, $blue);
259             my $back_color = $image->colorAllocate(255,255,255);
260             $image->transparent($back_color);
261              
262             # outline shapes with a noticeable color (complementary will do) if
263             # shape color and background color are too similar (measured by color
264             # distance).
265             my $stroke_color = undef;
266             {
267             my $dr = $red-255;
268             my $dg = $green-255;
269             my $db = $blue-255;
270             my $distance = sqrt($dr**2 + $dg**2 + $db**2);
271             $DEBUG and print "distance $distance (< 32.0 ?)\n";
272             if( $distance < 32.0 )
273             {
274             $stroke_color = $image->colorAllocate($red^255, $green^255, $blue^255);
275             }
276             }
277            
278             $this->{image} = $image;
279             $this->{patch_size} = $patch_size;
280             $this->{patch_width} = $patch_width;
281             $this->{scale} = $scale;
282             $this->{fore_color} = $fore_color;
283             $this->{back_color} = $back_color;
284             $this->{stroke_color} = $stroke_color;
285             $this;
286             }
287              
288             sub render
289             {
290             my $r = shift;
291             my $center_type = $r->{center_type};
292             my $center_invert = $r->{center_invert};
293             my $corner_type = $r->{corner_type};
294             my $corner_invert = $r->{corner_invert};
295             my $corner_turn = $r->{corner_turn};
296             my $side_type = $r->{side_type};
297             my $side_invert = $r->{side_invert};
298             my $side_turn = $r->{side_turn};
299            
300             # center patch
301             $DEBUG and print "[center]\n";
302             $r->draw({ x=>1, y=>1, patch=>$center_type, turn=>0, invert=>$center_invert});
303            
304             # side patchs, starting from top and moving clock-wise
305             $DEBUG and print "[sides]\n";
306             $r->draw({ x=>1, y=>0, patch=>$side_type, turn=>$side_turn++, invert=>$side_invert});
307             $r->draw({ x=>2, y=>1, patch=>$side_type, turn=>$side_turn++, invert=>$side_invert});
308             $r->draw({ x=>1, y=>2, patch=>$side_type, turn=>$side_turn++, invert=>$side_invert});
309             $r->draw({ x=>0, y=>1, patch=>$side_type, turn=>$side_turn++, invert=>$side_invert});
310              
311             # corner patchs, starting from top left and moving clock-wise
312             $DEBUG and print "[corneres]\n";
313             $r->draw({ x=>0, y=>0, patch=>$corner_type, turn=>$corner_turn++, invert=>$corner_invert});
314             $r->draw({ x=>2, y=>0, patch=>$corner_type, turn=>$corner_turn++, invert=>$corner_invert});
315             $r->draw({ x=>2, y=>2, patch=>$corner_type, turn=>$corner_turn++, invert=>$corner_invert});
316             $r->draw({ x=>0, y=>2, patch=>$corner_type, turn=>$corner_turn++, invert=>$corner_invert});
317            
318             return $r;
319             }
320              
321             sub draw
322             {
323             my $r = shift;
324             my $opts = ref($_[0])?shift:{@_};
325            
326             my $image = $r->{image};
327             my $scale = $r->{scale};
328             my $fore = $r->{fore_color};
329             my $back = $r->{back_color};
330             my $stroke = $r->{stroke_color};
331            
332             my $patch_size = $r->{patch_size} || $PATCH_SIZE;
333             my $width = $r->{patch_width} || ($patch_size-1) * $scale + 1;
334            
335             my $x = $opts->{x};
336             my $y = $opts->{y};
337             my $patch = $opts->{patch};
338             my $turn = $opts->{turn};
339             my $invert = $opts->{invert};
340            
341             $patch>=0 or die "\$patch >= 0 failed, got $patch";
342             $turn >=0 or die "\$turn >= 0 failed, got $turn";
343            
344             $x *= $width;
345             $y *= $width;
346             $patch %= @$PATCHES;
347             $turn %= 4;
348             if( ($PATCH_FLAGS->[$patch] & $PATCH_INVERTED) != 0 )
349             {
350             $invert = !$invert;
351             }
352             $invert ||= 0;
353             $invert and ($fore, $back) = ($back, $fore);
354              
355             $DEBUG and print "(x,y) = ($x, $y)\n";
356             $DEBUG and print "(patch, turn, invert) = ($patch, $turn, $invert)\n";
357            
358             # paint background
359             $image->filledRectangle($x, $y, $x+$width, $y+$width, $back);
360            
361             # polything.
362             $DEBUG and print "- poly\n";
363             my $pl = GD::Polyline->new();
364             foreach my $pt (@{$PATCHES->[$patch]})
365             {
366             my $dx = $pt % $patch_size;
367             my $dy = int( $pt / $patch_size );
368            
369             my $px = int( $dx / ($patch_size-1) * $width );
370             my $py = int( $dy / ($patch_size-1) * $width );
371            
372             $turn==1 and ($px, $py) = ($width-$py, $px);
373             $turn==2 and ($px, $py) = ($width-$px, $width-$py);
374             $turn==3 and ($px, $py) = ($py, $width-$px);
375            
376             $pl->addPt($x+$px, $y+$py);
377             $DEBUG and print "- ($px, $py) ($dx, $dy, $pt)\n";
378             }
379            
380             # render rotated patch using fore color (back color if inverted)
381             $image->filledPolygon($pl, $fore);
382            
383             # if stroke color was specified, apply stroke
384             # stroke color should be specified if fore color is too close to the
385             # back color.
386             if( $stroke )
387             {
388             $image->polyline($pl, $stroke);
389             $DEBUG and print "- stroke\n";
390             }
391              
392             $r;
393             }
394              
395             sub _resize
396             {
397             my $r = shift;
398             my $image = $r->{image};
399             my $size = $r->{size};
400            
401             if( $size && $image->width!=$size )
402             {
403             my $orig = $image;
404             my $image = GD::Image->new($size, $size, 1);
405             $image->copyResampled($orig, 0, 0, 0, 0, $size, $size, $orig->width, $orig->height);
406             $image->transparent($r->{back_color});
407             if( $DEBUG )
408             {
409             my $ox = $orig->width;
410             my $r = sprintf('%.1f', $ox/$size);
411             print "resize: ($ox, $ox) => ($size, $size) [1/$r]\n";
412             }
413             $r->{image} = $image;
414             }
415            
416             $r;
417             }
418              
419             # -----------------------------------------------------------------------------
420             # End of Module.
421             # -----------------------------------------------------------------------------
422             # -----------------------------------------------------------------------------
423             # End of File.
424             # -----------------------------------------------------------------------------
425             __END__