File Coverage

blib/lib/GD/SecurityImage/GD.pm
Criterion Covered Total %
statement 79 81 97.5
branch n/a
condition n/a
subroutine 27 27 100.0
pod n/a
total 106 108 98.1


line stmt bran cond sub pod time code
1             package GD::SecurityImage::GD;
2 4     4   17 use strict;
  4         5  
  4         133  
3 4     4   18 use warnings;
  4         5  
  4         101  
4 4     4   13 use vars qw( $VERSION );
  4         4  
  4         146  
5              
6 4     4   13 use constant LOWLEFTX => 0; # Lower left corner x
  4         4  
  4         168  
7 4     4   16 use constant LOWLEFTY => 1; # Lower left corner y
  4         3  
  4         139  
8 4     4   13 use constant LOWRIGHTX => 2; # Lower right corner x
  4         14  
  4         131  
9 4     4   35 use constant LOWRIGHTY => 3; # Lower right corner y
  4         7  
  4         140  
10 4     4   14 use constant UPRIGHTX => 4; # Upper right corner x
  4         8  
  4         138  
11 4     4   13 use constant UPRIGHTY => 5; # Upper right corner y
  4         5  
  4         128  
12 4     4   16 use constant UPLEFTX => 6; # Upper left corner x
  4         3  
  4         138  
13 4     4   24 use constant UPLEFTY => 7; # Upper left corner y
  4         12  
  4         126  
14              
15 4     4   13 use constant CHX => 0; # character-X
  4         3  
  4         186  
16 4     4   17 use constant CHY => 1; # character-Y
  4         4  
  4         142  
17 4     4   14 use constant CHAR => 2; # character
  4         4  
  4         150  
18 4     4   16 use constant ANGLE => 3; # character angle
  4         4  
  4         156  
19              
20 4     4   18 use constant MAXCOMPRESS => 9;
  4         4  
  4         149  
21              
22 4     4   18 use constant NEWSTUFF => qw( ellipse setThickness _png_compression );
  4         8  
  4         184  
23             # png is first due to various problems with gif() format
24 4     4   16 use constant FORMATS => qw( png gif jpeg );
  4         4  
  4         216  
25 4     4   21 use constant GDFONTS => qw( Small Large MediumBold Tiny Giant );
  4         5  
  4         184  
26              
27 4     4   21 use constant RGB_WHITE => (255, 255, 255);
  4         4  
  4         192  
28 4     4   16 use constant BOX_SIZE => 7;
  4         5  
  4         147  
29              
30 4     4   14 use constant ROTATE_NONE => 0;
  4         4  
  4         145  
31 4     4   14 use constant ROTATE_COUNTERCLOCKWISE => 90;
  4         7  
  4         126  
32 4     4   12 use constant ROTATE_UPSIDEDOWN => 180;
  4         4  
  4         133  
33 4     4   15 use constant ROTATE_CLOCKWISE => 270;
  4         3  
  4         127  
34 4     4   13 use constant FULL_CIRCLE => 360;
  4         4  
  4         139  
35              
36 4     4   3680 use GD;
  0            
  0            
37              
38             $VERSION = '1.73';
39              
40             # define the tff drawing method.
41             my $TTF = __PACKAGE__->_versiongt( '1.31' ) ? 'stringFT' : 'stringTTF';
42              
43             sub init {
44             # Create the image object
45             my $self = shift;
46             $self->{image} = GD::Image->new($self->{width}, $self->{height});
47             $self->cconvert($self->{bgcolor}); # set background color
48             $self->setThickness($self->{thickness}) if $self->{thickness};
49             if ( $self->_versionlt( '2.07' ) ) {
50             foreach my $prop ( NEWSTUFF ) {
51             $self->{DISABLED}{$prop} = 1;
52             }
53             }
54             return;
55             }
56              
57             sub out {
58             # return $image_data, $image_mime_type, $random_number
59             my($self, @args) = @_;
60             my %opt = @args % 2 ? () : @args;
61             my $i = $self->{image};
62             my $type;
63             if ( $opt{force} && $i->can($opt{force}) ){
64             $type = $opt{force};
65             }
66             else {
67             # Define the output format.
68             foreach my $f ( FORMATS ) {
69             if ( $i->can( $f ) ) {
70             $type = $f;
71             last;
72             }
73             }
74             }
75              
76             my @iargs = ();
77             if ( $opt{'compress'} ) {
78             push @iargs, MAXCOMPRESS if $type eq 'png' and not $self->{DISABLED}{_png_compression};
79             push @iargs, $opt{'compress'} if $type eq 'jpeg';
80             }
81             return $i->$type(@iargs), $type, $self->{_RANDOM_NUMBER_};
82             }
83              
84             sub gdbox_empty { return shift->{GDBOX_EMPTY} }
85              
86             sub gdfx {
87             # Sets the font for simple GD usage.
88             # Unfortunately, Image::Magick does not have a similar interface.
89             my $self = shift;
90             my $font = shift || return;
91             $font = lc $font;
92             # GD' s standard fonts
93             my %f = map { lc $_ => $_ } GDFONTS;
94             if ( exists $f{$font} ) {
95             $font = $f{$font};
96             return GD::Font->$font();
97             }
98             }
99              
100             sub _insert_text_ttf_scramble {
101             my($self, $key, $ctext) = @_;
102             require Math::Trig;
103              
104             my @char;
105             my $anglex;
106             my $total = 0;
107             my $space = [ $self->ttf_info( 0, 'A' ), 0, q{ } ];
108             my @randomy;
109             my $sy = $space->[CHY] || 1;
110             ## no critic (ValuesAndExpressions::ProhibitMagicNumbers)
111             push @randomy, $_, - $_ foreach $sy*1.2,$sy, $sy/2, $sy/4, $sy/8;
112             ## use critic
113             foreach (split m{}xms, $key) { # get char parameters
114             $anglex = $self->random_angle;
115             $total += $space->[CHX];
116             push @char, [$self->ttf_info($anglex, $_), $anglex, $_], $space, $space, $space;
117             }
118             $total *= 2;
119             my @config = ($ctext, $self->{font}, $self->{ptsize});
120             my($x,$y);
121             foreach my $box (reverse @char) {
122             $x = $self->{width} / 2 + ($box->[CHX] - $total);
123             $y = $self->{height} / 2 + $box->[CHY];
124             $y += $randomy[int rand @randomy];
125             $self->{image}->$TTF(@config, Math::Trig::deg2rad($box->[CHAR]), $x, $y, $box->[ANGLE]);
126             $total -= $space->[CHX];
127             }
128             return;
129             }
130              
131             sub _insert_text_ttf_normal {
132             my($self, $key, $ctext) = @_;
133             require Math::Trig;
134             # don' t draw. we just need info...
135             my $info = sub {
136             my $txt = shift;
137             my $ang = shift || 0;
138             $ang = Math::Trig::deg2rad($ang) if $ang;
139             my @box = GD::Image->$TTF(
140             $ctext, $self->{font}, $self->{ptsize}, $ang, 0, 0, $txt
141             );
142             if ( not @box ) { # use fake values instead of die-ing
143             $self->{GDBOX_EMPTY} = 1; # set this for error checking.
144             $#box = BOX_SIZE;
145             # lets initialize to silence the warnings
146             $box[$_] = 1 for 0..$#box;
147             }
148             return @box;
149             };
150              
151             my(@box, $x, $y);
152             my $tl = $self->{_TEXT_LOCATION_};
153             if ( $tl->{_place_} ) {
154             # put the text to one of the four corners in the image
155             my $white = $self->cconvert( [ RGB_WHITE ] );
156             my $black = $self->cconvert($ctext);
157             if ( $tl->{gd} ) { # draw with standard gd fonts
158             $self->place_gd($key, $tl->{x}, $tl->{y});
159             return; # by-pass ttf method call...
160             }
161             else {
162             @box = $info->($key);
163             $x = $tl->{x} eq 'left'
164             ? 0
165             : ( $self->{width} - ($box[LOWRIGHTX] - $box[LOWLEFTX]) )
166             ;
167             $y = $tl->{y} eq 'up'
168             ? ( $box[LOWLEFTY] - $box[UPLEFTY] )
169             : $self->{height} - 2
170             ;
171             if ($tl->{strip}) {
172             $self->add_strip(
173             $x, $y, $box[LOWRIGHTX] - $box[LOWLEFTX], $box[LOWLEFTY] - $box[UPLEFTY]
174             );
175             }
176             }
177             }
178             else {
179             @box = $info->($key);
180             $x = ($self->{width} - ($box[LOWRIGHTX] - $box[LOWLEFTX])) / 2;
181             $y = ($self->{height} - ($box[UPLEFTY] - $box[LOWLEFTY])) / 2;
182             }
183              
184             # this needs a fix. adjust x,y
185             $self->{angle} = $self->{angle} ? Math::Trig::deg2rad($self->{angle}) : 0;
186             $self->{image}->$TTF( $ctext, $self->{font}, $self->{ptsize}, $self->{angle}, $x, $y, $key );
187             return;
188             }
189              
190             sub _insert_text_gd_scramble {
191             my($self, $key, $ctext) = @_;
192             # without ttf, we can only have 0 and 90 degrees.
193             my @char;
194             my @styles = qw(string stringUp);
195             my $style = $styles[int rand @styles];
196             foreach (split m{}xms, $key) { # get char parameters
197             push @char, [ $_, $style ], [ q{ }, 'string' ];
198             $style = $style eq 'string' ? 'stringUp' : 'string';
199             }
200             my $sw = $self->{gd_font}->width;
201             my $sh = $self->{gd_font}->height;
202             my($x, $y, $m);
203             my $total = $sw * @char;
204             foreach my $c (@char) {
205             $m = $c->[1];
206             $x = ($self->{width} - $total) / 2;
207             $y = $self->{height}/2 + ($m eq 'string' ? -$sh : $sh/2) / 2;
208             $total -= $sw * 2;
209             $self->{image}->$m($self->{gd_font}, $x, $y, $c->[0], $ctext);
210             }
211             return;
212             }
213              
214             sub _insert_text_gd_normal {
215             my($self, $key, $ctext) = @_;
216             my $sw = $self->{gd_font}->width * length $key;
217             my $sh = $self->{gd_font}->height;
218             my $x = ($self->{width} - $sw) / 2;
219             my $y = ($self->{height} - $sh) / 2;
220             $self->{image}->string($self->{gd_font}, $x, $y, $key, $ctext);
221             return;
222             }
223              
224             sub insert_text {
225             # Draw text using GD
226             my $self = shift;
227             my $method = shift;
228             my $key = $self->{_RANDOM_NUMBER_};
229             my $ctext = $self->{_COLOR_}{text};
230             if ($method eq 'ttf') {
231             $self->{scramble} ? $self->_insert_text_ttf_scramble( $key, $ctext )
232             : $self->_insert_text_ttf_normal( $key, $ctext )
233             ;
234             }
235             else {
236             $self->{scramble} ? $self->_insert_text_gd_scramble( $key, $ctext )
237             : $self->_insert_text_gd_normal( $key, $ctext )
238             ;
239             }
240             return;
241             }
242              
243             sub place_gd {
244             my($self, $key, $tx, $ty) = @_;
245             my $tl = $self->{_TEXT_LOCATION_};
246             my $black = $self->cconvert($self->{_COLOR_}{text});
247             my $white = $self->cconvert($tl->{scolor});
248             my $font = GD::Font->Tiny;
249             my $fx = (length($key)+1)*$font->width;
250             my $x1 = $self->{width} - $fx;
251             my $y1 = $ty eq 'up' ? 0 : $self->{height} - $font->height;
252             if ($ty eq 'up') {
253             if($tx eq 'left') {
254             $self->filledRectangle(0, $y1 , $fx , $font->height+2, $black);
255             $self->filledRectangle(1, $y1+1, $fx-1, $font->height+1, $white);
256             }
257             else {
258             $self->filledRectangle($x1-$font->width - 1, $y1 , $self->{width} , $font->height+2, $black);
259             $self->filledRectangle($x1-$font->width , $y1+1, $self->{width}-2, $font->height+1, $white);
260             }
261             }
262             else {
263             if($tx eq 'left') {
264             $self->filledRectangle(0, $y1-2, $fx , $self->{height} , $black);
265             $self->filledRectangle(1 , $y1-1, $fx-1, $self->{height}-2, $white);
266             }
267             else {
268             $self->filledRectangle($x1-$font->width - 1, $y1-2, $self->{width} , $self->{height} , $black);
269             $self->filledRectangle($x1-$font->width , $y1-1, $self->{width}-2, $self->{height}-2, $white);
270             }
271             }
272             return $self->{image}->string(
273             $font,
274             $tx eq 'left' ? 2 : $x1,
275             $ty eq 'up' ? $y1+1 : $y1-1,
276             $key,
277             $self->{_COLOR_}{text}
278             );
279             }
280              
281             sub ttf_info {
282             my $self = shift;
283             my $angle = shift || 0;
284             my $text = shift;
285             require Math::Trig;
286             my @box = GD::Image->$TTF(
287             $self->{_COLOR_}{text},
288             $self->{font},
289             $self->{ptsize},
290             Math::Trig::deg2rad($angle),
291             0,
292             0,
293             $text
294             );
295             if ( not @box ) { # use fake values instead of die-ing
296             $self->{GDBOX_EMPTY} = 1; # set this for error checking.
297             $#box = BOX_SIZE;
298             # lets initialize to silence the warnings
299             $box[$_] = 1 for 0..$#box;
300             }
301              
302             return $self->_ttf_info_xy( $angle, \@box );
303             }
304              
305             sub _ttf_info_xy {
306             my($self, $angle, $box) = @_;
307             my $rnone = ROTATE_NONE;
308             my $rccw = ROTATE_COUNTERCLOCKWISE;
309             my $rusd = ROTATE_UPSIDEDOWN;
310             my $rcw = ROTATE_CLOCKWISE;
311             my $fc = FULL_CIRCLE;
312              
313             my $x = 0;
314             my $y = 0;
315              
316             my($bx, $by) = $self->_ttf_info_box_xy( $angle, $box );
317              
318             $angle == $rnone ? do { $x += $bx/2; $y -= $by/2; }
319             : $angle > $rnone && $angle < $rccw ? do { $x += $bx/2; $y -= $by/2; }
320             : $angle == $rccw ? do { $x -= $bx/2; $y += $by/2; }
321             : $angle > $rccw && $angle < $rusd ? do { $x -= $bx/2; $y += $by/2; }
322             : $angle == $rusd ? do { $x += $bx/2; $y -= $by/2; }
323             : $angle > $rusd && $angle < $rcw ? do { $x += $bx/2; $y += $by/2; }
324             : $angle == $rcw ? do { $x -= $bx/2; $y += $by/2; }
325             : $angle > $rcw && $angle < $fc ? do { $x += $bx/2; $y += $by/2; }
326             : $angle == $fc ? do { $x += $bx/2; $y -= $by/2; }
327             : do {}
328             ;
329             return $x, $y;
330             }
331              
332             sub _ttf_info_box_xy {
333             my($self, $angle, $box) = @_;
334             my $bx = $box->[LOWLEFTX] - $box->[LOWRIGHTX];
335             my $by = $box->[LOWLEFTY] - $box->[LOWRIGHTY];
336              
337             my $rnone = ROTATE_NONE;
338             my $rccw = ROTATE_COUNTERCLOCKWISE;
339             my $rusd = ROTATE_UPSIDEDOWN;
340             my $rcw = ROTATE_CLOCKWISE;
341             my $fc = FULL_CIRCLE;
342              
343             my $is_perp = $angle == $rnone || $angle == $rusd || $angle == $fc;
344              
345             $is_perp ? do { $by = $box->[ UPLEFTY ] - $box->[LOWLEFTY ]; }
346             : $angle == $rccw || $angle == $rcw ? do { $bx = $box->[ UPLEFTX ] - $box->[LOWLEFTX ]; }
347             : $angle > $rcw && $angle < $fc ? do { $bx = $box->[ LOWLEFTX ] - $box->[ UPLEFTX ]; }
348             : $angle > $rusd && $angle < $rcw ? do { $bx = $box->[ LOWRIGHTX] - $box->[ UPRIGHTX]; $by = $box->[ LOWLEFTY ] - $box->[LOWRIGHTY]; }
349             : $angle > $rccw && $angle < $rusd ? do { $bx = $box->[ LOWRIGHTX] - $box->[ LOWLEFTX]; $by = $box->[ LOWRIGHTY] - $box->[ UPRIGHTY]; }
350             : $angle > $rnone && $angle < $rccw ? do { $by = $box->[ UPLEFTY ] - $box->[ LOWLEFTY]; }
351             : do {}
352             ;
353              
354             return $bx, $by;
355             }
356              
357             sub setPixel { ## no critic (NamingConventions::Capitalization)
358             my($self, @args) = @_;
359             return $self->{image}->setPixel(@args);
360             }
361              
362             sub line {
363             my($self, @args) = @_;
364             return $self->{image}->line(@args);
365             }
366              
367             sub rectangle {
368             my($self, @args) = @_;
369             return $self->{image}->rectangle(@args);
370             }
371              
372             sub filledRectangle { ## no critic (NamingConventions::Capitalization)
373             my($self, @args) = @_;
374             return $self->{image}->filledRectangle(@args);
375             }
376              
377             sub ellipse {
378             my($self, @args) = @_;
379             return $self->{image}->ellipse(@args);
380             }
381              
382             sub arc {
383             my($self, @args) = @_;
384             return $self->{image}->arc(@args);
385             }
386              
387             sub setThickness { ## no critic (NamingConventions::Capitalization)
388             my($self, @args) = @_;
389             if( $self->{image}->can('setThickness') ) { # $GD::VERSION >= 2.07
390             $self->{image}->setThickness( @args );
391             }
392             return;
393             }
394              
395             sub _versiongt {
396             my $self = shift;
397             my $check = shift || 0;
398             $check += 0;
399             return $GD::VERSION >= $check ? 1 : 0;
400             }
401              
402             sub _versionlt {
403             my $self = shift;
404             my $check = shift || 0;
405             $check += 0;
406             return $GD::VERSION < $check ? 1 : 0;
407             }
408              
409             1;
410              
411             __END__