File Coverage

blib/lib/GD/SecurityImage.pm
Criterion Covered Total %
statement 59 259 22.7
branch 4 124 3.2
condition 3 90 3.3
subroutine 19 36 52.7
pod 15 15 100.0
total 100 524 19.0


line stmt bran cond sub pod time code
1             package GD::SecurityImage;
2 4     4   65127 use strict;
  4         8  
  4         127  
3 4     4   17 use warnings;
  4         4  
  4         126  
4 4     4   16 use vars qw[@ISA $VERSION $BACKEND];
  4         13  
  4         215  
5 4     4   1305 use GD::SecurityImage::Styles;
  4         6  
  4         100  
6 4     4   20 use Carp qw(croak);
  4         22  
  4         192  
7 4     4   17 use constant RGB_WHITE => ( 255, 255, 255 );
  4         5  
  4         227  
8 4     4   15 use constant RGB_BLACK => ( 0, 0, 0 );
  4         9  
  4         164  
9 4     4   15 use constant RANDOM_DATA => ( 0..9 );
  4         3  
  4         150  
10 4     4   19 use constant FULL_CIRCLE => 360;
  4         7  
  4         164  
11 4     4   14 use constant DEFAULT_ANGLES => (0,5,8,15,22,26,29,33,35,36,40,43,45,53,56);
  4         4  
  4         207  
12              
13 4     4   19 use constant DEFAULT_WIDTH => 80;
  4         5  
  4         154  
14 4     4   16 use constant DEFAULT_HEIGHT => 30;
  4         3  
  4         135  
15 4     4   15 use constant DEFAULT_PTSIZE => 20;
  4         5  
  4         136  
16 4     4   18 use constant DEFAULT_LINES => 10;
  4         5  
  4         127  
17              
18 4     4   13 use constant MAX_RGB_VALUE => 255;
  4         7  
  4         142  
19 4     4   13 use constant PARTICLE_MULTIPLIER => 20;
  4         5  
  4         127  
20 4     4   16 use constant MAX_RGB_PARAMS => 3;
  4         3  
  4         8584  
21              
22             $VERSION = '1.73';
23              
24             sub import {
25 4     4   2221 my($class, @args) = @_;
26 4 50       21 my %opt = @args % 2 ? () : @args;
27             # init/reset globals
28 4         5 $BACKEND = q{}; # name of the back-end
29 4         20 @ISA = (); ## no critic (ClassHierarchies::ProhibitExplicitISA)
30             # load the drawing interface
31 4 50 66     29 if ( exists $opt{use_magick} && $opt{use_magick} ) {
    50 33        
32 0         0 require GD::SecurityImage::Magick;
33 0         0 $BACKEND = 'Magick';
34             }
35             elsif ( exists $opt{backend} && $opt{backend} ) {
36 0         0 my $be = __PACKAGE__.q{::}.$opt{backend};
37 0         0 my $eok = eval "require $be";
38 0 0       0 croak "Unable to locate the $class back-end $be: $@" if $@;
39 0 0       0 $BACKEND = $opt{backend} eq 'AC' ? 'GD' : $opt{backend};
40             }
41             else {
42 4         1551 require GD::SecurityImage::GD;
43 0         0 $BACKEND = 'GD';
44             }
45 0         0 push @ISA, 'GD::SecurityImage::' . $BACKEND, ## no critic (ClassHierarchies::ProhibitExplicitISA)
46             qw(GD::SecurityImage::Styles); # load styles
47 0         0 return;
48             }
49              
50             sub new {
51 1     1 1 6 my($class, @args) = @_;
52 1 50       236 $BACKEND || croak "You didn't import $class!";
53 0 0         my %opt = @args % 2 ? () : @args;
54              
55 0   0       my $self = {
56             IS_MAGICK => $BACKEND eq 'Magick',
57             IS_GD => $BACKEND eq 'GD',
58             IS_CORE => $BACKEND eq 'GD' || $BACKEND eq 'Magick',
59             DISABLED => {}, # list of methods that a backend (or some older version of backend) can't do
60             MAGICK => {}, # Image::Magick configuration options
61             GDBOX_EMPTY => 0, # GD::SecurityImage::GD::insert_text() failed?
62             _RANDOM_NUMBER_ => q{}, # random security code
63             _RNDMAX_ => 6, # maximum number of characters in a random string.
64             _COLOR_ => {}, # text and line colors
65             _CREATECALLED_ => 0, # create() called? (check for particle())
66             _TEXT_LOCATION_ => {}, # see info_text
67             };
68 0           bless $self, $class;
69              
70 0           my %options = $self->_new_options( %opt );
71              
72 0 0 0       if ( $opt{text_location}
      0        
73             && ref $opt{text_location}
74             && ref $opt{text_location} eq 'HASH' ) {
75 0           $self->{_TEXT_LOCATION_} = { %{$opt{text_location}}, _place_ => 1 };
  0            
76             }
77             else {
78 0           $self->{_TEXT_LOCATION_}{_place_} = 0;
79             }
80              
81 0           $self->{_RNDMAX_} = $options{rndmax};
82              
83 0           $self->{$_} = $options{$_} foreach keys %options;
84              
85 0 0         if ( $self->{angle} ) { # validate angle
86 0 0         $self->{angle} = FULL_CIRCLE + $self->{angle} if $self->{angle} < 0;
87 0 0         if ( $self->{angle} > FULL_CIRCLE ) {
88 0           croak 'Angle parameter can take values in the range -360..360';
89             }
90             }
91              
92 0 0         if ( $self->{scramble} ) {
93 0 0         if ( $self->{angle} ) {
94             # Does the user want a fixed angle?
95 0           push @{ $self->{_ANGLES_} }, $self->{angle};
  0            
96             }
97             else {
98             # Generate angle range. The reason for hardcoding these is;
99             # it'll be less random for 0..60 range
100 0           push @{ $self->{_ANGLES_} }, DEFAULT_ANGLES;
  0            
101             # push negatives
102 0           push @{ $self->{_ANGLES_} },
  0            
103 0           map {FULL_CIRCLE - $_} @{ $self->{_ANGLES_} };
  0            
104             }
105             }
106              
107 0           $self->init;
108 0           return $self;
109             }
110              
111             sub _new_options {
112 0     0     my($self, %opt) = @_;
113 0 0 0       my %options = (
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
114             width => $opt{width} || DEFAULT_WIDTH,
115             height => $opt{height} || DEFAULT_HEIGHT,
116             ptsize => $opt{ptsize} || DEFAULT_PTSIZE,
117             lines => $opt{lines} || DEFAULT_LINES,
118             rndmax => $opt{rndmax} || $self->{_RNDMAX_},
119             rnd_data => $opt{rnd_data} || [ RANDOM_DATA ],
120             font => $opt{font} || q{},
121             gd_font => $self->gdf($opt{gd_font}) || q{},
122             bgcolor => $opt{bgcolor} || [ RGB_WHITE ],
123             send_ctobg => $opt{send_ctobg} || 0,
124             frame => defined($opt{frame}) ? $opt{frame} : 1,
125             scramble => $opt{scramble} || 0,
126             angle => $opt{angle} || 0,
127             thickness => $opt{thickness} || 0,
128             _ANGLES_ => [], # angle list for scrambled images
129             );
130 0           return %options;
131             }
132              
133             sub backends {
134 0     0 1   my $self = shift;
135 0   0       my $class = ref($self) || $self;
136 0           my(@list, @dir_list);
137 0           require Symbol;
138 0           foreach my $inc (@INC) {
139 0           my $dir = "$inc/GD/SecurityImage";
140 0 0         next unless -d $dir;
141 0           my $DIR = Symbol::gensym();
142 0 0         opendir $DIR, $dir or croak "opendir($dir) failed: $!";
143 0           my @dir = readdir $DIR;
144 0           closedir $DIR;
145 0           push @dir_list, $dir;
146 0           foreach my $file (@dir) {
147 0 0         next if -d $file;
148 0 0         next if $file =~ m{ \A [.] }xms;
149 0 0         next if $file =~ m{ \A (Styles|AC|Handler)[.]pm \z}xms;
150 0           $file =~ s{ [.]pm \z}{}xms;
151 0           push @list, $file;
152             }
153             }
154              
155 0 0         return @list if defined wantarray;
156              
157 0           my $report = "Available back-ends in $class v$VERSION are:\n\t"
158             . join("\n\t", @list)
159             . "\n\n"
160             . "Search directories:\n\t"
161             . join "\n\t", @dir_list;
162 0 0         print $report or croak "Unable to print to STDOUT: $!";
163 0           return;
164             }
165              
166             sub gdf {
167 0     0 1   my($self, @args) = @_;
168 0 0         return if not $self->{IS_GD};
169 0           return $self->gdfx( @args );
170             }
171              
172             sub random_angle {
173 0     0 1   my $self = shift;
174 0           my @angles = @{ $self->{_ANGLES_} };
  0            
175 0           my @r;
176 0           push @r, $angles[int rand @angles] for 0..$#angles;
177 0           return $r[int rand @r];
178             }
179              
180 0     0 1   sub random_str { return shift->{_RANDOM_NUMBER_} }
181              
182             sub random {
183 0     0 1   my $self = shift;
184 0           my $user = shift;
185 0 0 0       if($user and length($user) >= $self->{_RNDMAX_}) {
186 0           $self->{_RANDOM_NUMBER_} = $user;
187             }
188             else {
189 0           my @keys = @{ $self->{rnd_data} };
  0            
190 0           my $lk = scalar @keys;
191 0           my $random;
192 0           $random .= $keys[int rand $lk] for 1..$self->{rndmax};
193 0           $self->{_RANDOM_NUMBER_} = $random;
194             }
195 0 0         return defined wantarray ? $self : undef;
196             }
197              
198             sub cconvert { # convert color codes
199             # GD : return color index number
200             # Image::Magick: return hex color code
201 0     0 1   my $self = shift;
202 0   0       my $data = shift || croak 'Empty parameter passed to cconvert';
203 0 0         return $self->backend_cconvert($data) if not $self->{IS_CORE};
204              
205 0           my $is_hex = $self->is_hex($data);
206 0   0       my $magick_ok = $self->{IS_MAGICK} && $data && $is_hex;
207             # data is a hex color code and Image::Magick has hex support
208 0 0         return $data if $magick_ok;
209 0   0       my $color_code = $data &&
210             ! $is_hex &&
211             ! ref($data) &&
212             $data !~ m{[^0-9]}xms &&
213             $data >= 0;
214              
215 0 0         if( $color_code ) {
216 0 0         if ( $self->{IS_MAGICK} ) {
217 0           croak "The number '$data' can not be transformed to a color code!";
218             }
219             # data is a GD color index number ...
220             # ... or it is any number! since there is no way to determine this.
221             # GD object' s rgb() method returns 0,0,0 upon failure...
222 0           return $data;
223             }
224              
225 0           my @rgb = $self->h2r($data);
226 0 0 0       return @rgb && $self->{IS_MAGICK}
227             ? $data
228             : $self->_cconvert_new( $data, @rgb );
229             }
230              
231             sub _cconvert_new {
232 0     0     my($self, $data, @rgb) = @_;
233 0 0         $data = [@rgb] if @rgb;
234             # initialize if not valid
235 0 0 0       if(! $data || ! ref $data || ref $data ne 'ARRAY' || $#{$data} != 2) {
  0   0        
      0        
236 0           $data = [0, 0, 0];
237             }
238 0           foreach my $i (0..$#{$data}) { # check for bad values
  0            
239 0 0 0       if ( $data->[$i] > MAX_RGB_VALUE || $data->[$i] < 0 ) {
240 0           $data->[$i] = 0;
241             }
242             }
243              
244 0           return $self->{IS_MAGICK} ? $self->r2h(@{$data}) # convert to hex
  0            
245 0 0         : $self->{image}->colorAllocate(@{$data});
246             }
247              
248             sub create {
249 0     0 1   my $self = shift;
250 0   0       my $method = shift || 'normal'; # ttf or normal
251 0   0       my $style = shift || 'default'; # default or rect or box
252 0   0       my $col1 = shift || [ 0, 0, 0]; # text color
253 0   0       my $col2 = shift || [ 0, 0, 0]; # line/box color
254              
255 0 0         $self->{send_ctobg} = 0 if $style eq 'box'; # disable for that style
256 0           $self->{_COLOR_} = { # set the color hash
257             text => $self->cconvert($col1),
258             lines => $self->cconvert($col2),
259             };
260              
261             # be a smart module and auto-disable ttf if we are under a prehistoric GD
262 0 0         if ( not $self->{IS_MAGICK} ) {
263 0 0         $method = 'normal' if $self->_versionlt( '1.20' );
264             }
265              
266 0 0 0       if ( $method eq 'normal' && ! $self->{gd_font} ) {
267 0           $self->{gd_font} = $self->gdf('giant');
268             }
269              
270 0 0         $style = $self->can('style_'.$style) ? 'style_'.$style : 'style_default';
271              
272 0 0         $self->$style() if not $self->{send_ctobg};
273 0           $self->insert_text($method);
274 0 0         $self->$style() if $self->{send_ctobg};
275              
276 0 0         if ( $self->{frame} ) {
277             # put a frame around the image
278 0           my $w = $self->{width} - 1;
279 0           my $h = $self->{height} - 1;
280 0           $self->rectangle( 0, 0, $w, $h, $self->{_COLOR_}{lines} );
281             }
282              
283 0           $self->{_CREATECALLED_}++;
284 0 0         return defined wantarray ? $self : undef;
285             }
286              
287             sub particle {
288             # Create random dots. They'll cover all over the surface
289 0     0 1   my $self = shift;
290 0 0         croak q{particle() must be called 'after' create()} if !$self->{_CREATECALLED_};
291 0 0         my $big = $self->{height} > $self->{width} ? $self->{height} : $self->{width};
292 0   0       my $f = shift || $big * PARTICLE_MULTIPLIER; # particle density
293 0   0       my $dots = shift || 1; # number of multiple dots
294 0           my $int = int $big / PARTICLE_MULTIPLIER;
295              
296 0 0         if ( ! $int ) { # RT#33629
297 0           warn "particle(): image dimension is so small to add particles\n";
298 0           return;
299             }
300              
301 0           my @random;
302 0           for (my $x = $int; $x <= $big; $x += $int) { ## no critic (ControlStructures::ProhibitCStyleForLoops)
303 0           push @random, $x;
304             }
305              
306 0           my $tc = $self->{_COLOR_}{text};
307 0           my $len = @random;
308 0     0     my $r = sub { $random[ int rand $len ] };
  0            
309              
310 0           for ( 1..$f ) {
311 0           my $x = int rand $self->{width};
312 0           my $y = int rand $self->{height};
313 0           foreach my $z (1..$dots) {
314 0           $self->setPixel($x + $z , $y + $z , $tc);
315 0           $self->setPixel($x + $z + $r->(), $y + $z + $r->(), $tc);
316             }
317             }
318 0           undef @random;
319 0           undef $r;
320              
321 0 0         return defined wantarray ? $self : undef;
322             }
323              
324 0     0 1   sub raw { return shift->{image} } # raw image object
325              
326             sub info_text { # set text location
327             # x => 'left|right', # text-X
328             # y => 'up|low|down', # text-Y
329             # strip => 1|0, # add strip?
330             # gd => 1|0, # use default GD font?
331             # ptsize => 10, # point size
332             # color => '#000000', # text color
333             # scolor => '#FFFFFF', # strip color
334             # text => 'blah', # modifies random code
335 0     0 1   my($self, @args) = @_;
336 0 0         croak q{info_text() must be called 'after' create()} if ! $self->{_CREATECALLED_};
337 0 0         my %o = @args % 2 ? () : ( qw/ x right y up strip 1 /, @args );
338 0 0         return if not %o;
339              
340 0           $self->{_TEXT_LOCATION_}{_place_} = 1;
341 0 0         $o{scolor} = $self->cconvert($o{scolor}) if $o{scolor};
342              
343 0           my %restore = (
344             random => $self->{_RANDOM_NUMBER_},
345             color => $self->{_COLOR_}{text},
346             ptsize => $self->{ptsize},
347             scramble => $self->{scramble},
348             angle => $self->{angle},
349             );
350              
351 0 0         $self->{_RANDOM_NUMBER_} = delete $o{text} if $o{text};
352 0 0         $self->{_COLOR_}{text} = $self->cconvert(delete $o{color}) if $o{color};
353 0 0         $self->{ptsize} = delete $o{ptsize} if $o{ptsize};
354 0           $self->{scramble} = 0; # disable. we need a straight text
355 0           $self->{angle} = 0; # disable. RT:14618
356              
357 0           $self->{_TEXT_LOCATION_}->{$_} = $o{$_} foreach keys %o;
358 0           $self->insert_text('ttf');
359              
360             # restore
361 0           $self->{_RANDOM_NUMBER_} = $restore{random};
362 0           $self->{_COLOR_}{text} = $restore{color};
363 0           $self->{ptsize} = $restore{ptsize};
364 0           $self->{scramble} = $restore{scramble};
365 0           $self->{angle} = $restore{angle};
366              
367 0           return $self;
368             }
369              
370             #--------------------[ PRIVATE ]--------------------#
371              
372             sub add_strip { # adds a strip to the background of the text
373 0     0 1   my($self, $x, $y, $box_w, $box_h) = @_;
374 0           my $tl = $self->{_TEXT_LOCATION_};
375 0   0       my $c = $self->{_COLOR_} || {};
376 0 0         my $black = $self->cconvert( $c->{text} ? $c->{text} : [ RGB_BLACK ] );
377 0 0         my $white = $self->cconvert( $tl->{scolor} ? $tl->{scolor} : [ RGB_WHITE ] );
378 0 0         my $x2 = $tl->{x} eq 'left' ? $box_w : $self->{width};
379 0           my $y2 = $self->{height} - $box_h;
380 0 0         my $i = $self->{IS_MAGICK} ? $self : $self->{image};
381 0           my $up = $tl->{y} eq 'up';
382 0           my $h = $self->{height};
383 0 0         $i->filledRectangle($up ? ($x-1, 0, $x2, $y+1) : ($x-1, $y2-1, $x2 , $h ), $black);
384 0 0         $i->filledRectangle($up ? ($x , 1, $x2-2, $y) : ($x , $y2 , $x2-2, $h-2), $white);
385 0           return;
386             }
387              
388             sub r2h {
389             # Convert RGB to Hex
390 0     0 1   my($self, @args) = @_;
391 0 0         return if @args != MAX_RGB_PARAMS;
392 0           my $color = q{#};
393 0           $color .= sprintf '%02x', $_ foreach @args;
394 0           return $color;
395             }
396              
397             sub h2r {
398             # Convert Hex to RGB
399 0     0 1   my $self = shift;
400 0           my $color = shift;
401 0 0         return if ref $color;
402 0           my @rgb = $color =~ m/\A \#([a-f0-9]{2})([a-f0-9]{2})([a-f0-9]{2}) \z/xmsi;
403 0 0         return @rgb ? map { hex $_ } @rgb : undef;
  0            
404             }
405              
406             sub is_hex {
407 0     0 1   my $self = shift;
408 0           my $data = shift;
409 0           return $data =~ m/ \A \#([a-f0-9]{2})([a-f0-9]{2})([a-f0-9]{2}) \z /xmsi;
410             }
411              
412             1;
413              
414             __END__