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

package GD::SecurityImage;
use strict;
use warnings;
use vars qw[@ISA $VERSION $BACKEND];
use GD::SecurityImage::Styles;
use Carp qw(croak);
use constant RGB_WHITE   => ( 255, 255, 255 );
use constant RGB_BLACK   => ( 0, 0, 0 );
use constant RANDOM_DATA => ( 0..9 );
use constant FULL_CIRCLE => 360;
use constant DEFAULT_ANGLES => (0,5,8,15,22,26,29,33,35,36,40,43,45,53,56);

use constant DEFAULT_WIDTH  => 80;
use constant DEFAULT_HEIGHT => 30;
use constant DEFAULT_PTSIZE => 20;
use constant DEFAULT_LINES  => 10;

use constant MAX_RGB_VALUE  => 255;
use constant PARTICLE_MULTIPLIER => 20;
use constant MAX_RGB_PARAMS => 3;

$VERSION = '1.73';

sub import {
   my($class, @args) = @_;
   my %opt     = @args % 2 ? () : @args;
   # init/reset globals
   $BACKEND    = q{}; # name of the back-end
   @ISA        = (); ## no critic (ClassHierarchies::ProhibitExplicitISA)
   # load the drawing interface
   if ( exists $opt{use_magick} && $opt{use_magick} ) {
      require GD::SecurityImage::Magick;
      $BACKEND = 'Magick';
   }
   elsif ( exists $opt{backend} && $opt{backend} ) {
      my $be  = __PACKAGE__.q{::}.$opt{backend};
      my $eok = eval "require $be";
      croak "Unable to locate the $class back-end $be: $@" if $@;
      $BACKEND = $opt{backend} eq 'AC' ? 'GD' : $opt{backend};
   }
   else {
      require GD::SecurityImage::GD;
      $BACKEND = 'GD';
   }
   push @ISA, 'GD::SecurityImage::' . $BACKEND, ## no critic (ClassHierarchies::ProhibitExplicitISA)
              qw(GD::SecurityImage::Styles); # load styles
   return;
}

sub new {
   my($class, @args) = @_;
      $BACKEND || croak "You didn't import $class!";
   my %opt   = @args % 2 ? () : @args;

   my $self  = {
      IS_MAGICK       => $BACKEND eq 'Magick',
      IS_GD           => $BACKEND eq 'GD',
      IS_CORE         => $BACKEND eq 'GD' || $BACKEND eq 'Magick',
      DISABLED        => {}, # list of methods that a backend (or some older version of backend) can't do
      MAGICK          => {}, # Image::Magick configuration options
      GDBOX_EMPTY     => 0,  # GD::SecurityImage::GD::insert_text() failed?
      _RANDOM_NUMBER_ => q{}, # random security code
      _RNDMAX_        => 6,  # maximum number of characters in a random string.
      _COLOR_         => {}, # text and line colors
      _CREATECALLED_  => 0,  # create() called? (check for particle())
      _TEXT_LOCATION_ => {}, # see info_text
   };
   bless $self, $class;

   my %options = $self->_new_options( %opt );

   if ( $opt{text_location}
      && ref $opt{text_location}
      && ref $opt{text_location} eq 'HASH' ) {
      $self->{_TEXT_LOCATION_} = { %{$opt{text_location}}, _place_ => 1 };
   }
   else {
      $self->{_TEXT_LOCATION_}{_place_} = 0;
   }

   $self->{_RNDMAX_} = $options{rndmax};

   $self->{$_} = $options{$_} foreach keys %options;

   if ( $self->{angle} ) { # validate angle
      $self->{angle} = FULL_CIRCLE + $self->{angle} if $self->{angle} < 0;
      if ( $self->{angle} > FULL_CIRCLE ) {
         croak 'Angle parameter can take values in the range -360..360';
      }
   }

   if ( $self->{scramble} ) {
      if ( $self->{angle} ) {
         # Does the user want a fixed angle?
         push @{ $self->{_ANGLES_} }, $self->{angle};
      }
      else {
         # Generate angle range. The reason for hardcoding these is;
         # it'll be less random for 0..60 range
         push @{ $self->{_ANGLES_} }, DEFAULT_ANGLES;
         # push negatives
         push @{ $self->{_ANGLES_} },
              map {FULL_CIRCLE - $_} @{ $self->{_ANGLES_} };
      }
   }

   $self->init;
   return $self;
}

sub _new_options {
   my($self, %opt) = @_;
   my %options = (
      width      => $opt{width}               || DEFAULT_WIDTH,
      height     => $opt{height}              || DEFAULT_HEIGHT,
      ptsize     => $opt{ptsize}              || DEFAULT_PTSIZE,
      lines      => $opt{lines}               || DEFAULT_LINES,
      rndmax     => $opt{rndmax}              || $self->{_RNDMAX_},
      rnd_data   => $opt{rnd_data}            || [ RANDOM_DATA ],
      font       => $opt{font}                || q{},
      gd_font    => $self->gdf($opt{gd_font}) || q{},
      bgcolor    => $opt{bgcolor}             || [ RGB_WHITE ],
      send_ctobg => $opt{send_ctobg}          || 0,
      frame      => defined($opt{frame}) ? $opt{frame} : 1,
      scramble   => $opt{scramble}            || 0,
      angle      => $opt{angle}               || 0,
      thickness  => $opt{thickness}           || 0,
      _ANGLES_   => [], # angle list for scrambled images
   );
   return %options;
}

sub backends {
   my $self  = shift;
   my $class = ref($self) || $self;
   my(@list, @dir_list);
   require Symbol;
   foreach my $inc (@INC) {
      my $dir = "$inc/GD/SecurityImage";
      next unless -d $dir;
      my $DIR = Symbol::gensym();
      opendir $DIR, $dir or croak "opendir($dir) failed: $!";
      my @dir = readdir $DIR;
      closedir $DIR;
      push @dir_list, $dir;
      foreach my $file (@dir) {
         next if -d $file;
         next if $file =~ m{ \A [.] }xms;
         next if $file =~ m{ \A (Styles|AC|Handler)[.]pm \z}xms;
         $file =~ s{ [.]pm \z}{}xms;
         push @list, $file;
      }
   }

   return @list if defined wantarray;

   my $report = "Available back-ends in $class v$VERSION are:\n\t"
               . join("\n\t", @list)
               . "\n\n"
               . "Search directories:\n\t"
               . join "\n\t", @dir_list;
   print $report or croak "Unable to print to STDOUT: $!";
   return;
}

sub gdf {
   my($self, @args) = @_;
   return if not $self->{IS_GD};
   return $self->gdfx( @args );
}

sub random_angle {
   my $self   = shift;
   my @angles = @{ $self->{_ANGLES_} };
   my @r;
   push @r, $angles[int rand @angles] for 0..$#angles;
   return $r[int rand @r];
}

sub random_str { return shift->{_RANDOM_NUMBER_} }

sub random {
   my $self = shift;
   my $user = shift;
   if($user and length($user) >= $self->{_RNDMAX_}) {
      $self->{_RANDOM_NUMBER_} = $user;
   }
   else {
      my @keys = @{ $self->{rnd_data} };
      my $lk   = scalar @keys;
      my $random;
         $random .= $keys[int rand $lk] for 1..$self->{rndmax};
         $self->{_RANDOM_NUMBER_} = $random;
   }
   return defined wantarray ? $self : undef;
}

sub cconvert { # convert color codes
   # GD           : return color index number
   # Image::Magick: return hex color code
   my $self   = shift;
   my $data   = shift || croak 'Empty parameter passed to cconvert';
   return $self->backend_cconvert($data) if not $self->{IS_CORE};

   my $is_hex    = $self->is_hex($data);
   my $magick_ok = $self->{IS_MAGICK} && $data && $is_hex;
   # data is a hex color code and Image::Magick has hex support
   return $data if $magick_ok;
   my $color_code = $data                 &&
                    ! $is_hex             &&
                    ! ref($data)          &&
                    $data !~ m{[^0-9]}xms &&
                    $data >= 0;

   if( $color_code ) {
      if ( $self->{IS_MAGICK} ) {
         croak "The number '$data' can not be transformed to a color code!";
      }
      # data is a GD color index number ...
      # ... or it is any number! since there is no way to determine this.
      # GD object' s rgb() method returns 0,0,0 upon failure...
      return $data;
   }

   my @rgb = $self->h2r($data);
   return @rgb && $self->{IS_MAGICK}
         ? $data
         : $self->_cconvert_new( $data, @rgb );
}

sub _cconvert_new {
   my($self, $data, @rgb) = @_;
   $data = [@rgb] if @rgb;
   # initialize if not valid
   if(! $data || ! ref $data || ref $data ne 'ARRAY' || $#{$data} != 2) {
      $data = [0, 0, 0];
   }
   foreach my $i (0..$#{$data}) { # check for bad values
      if ( $data->[$i] > MAX_RGB_VALUE || $data->[$i] < 0 ) {
         $data->[$i] = 0;
      }
   }

   return $self->{IS_MAGICK} ? $self->r2h(@{$data}) # convert to hex
                             : $self->{image}->colorAllocate(@{$data});
}

sub create {
   my $self   = shift;
   my $method = shift || 'normal';  # ttf or normal
   my $style  = shift || 'default'; # default or rect or box
   my $col1   = shift || [ 0, 0, 0]; # text color
   my $col2   = shift || [ 0, 0, 0]; # line/box color

   $self->{send_ctobg} = 0 if $style eq 'box'; # disable for that style
   $self->{_COLOR_}    = { # set the color hash
        text  => $self->cconvert($col1),
        lines => $self->cconvert($col2),
   };

   # be a smart module and auto-disable ttf if we are under a prehistoric GD
   if ( not $self->{IS_MAGICK} ) {
      $method = 'normal' if $self->_versionlt( '1.20' );
   }

   if ( $method eq 'normal' && ! $self->{gd_font} ) {
      $self->{gd_font} = $self->gdf('giant');
   }

   $style = $self->can('style_'.$style) ? 'style_'.$style : 'style_default';

   $self->$style() if not $self->{send_ctobg};
   $self->insert_text($method);
   $self->$style() if     $self->{send_ctobg};

   if ( $self->{frame} ) {
      # put a frame around the image
      my $w = $self->{width}  - 1;
      my $h = $self->{height} - 1;
      $self->rectangle( 0, 0, $w, $h, $self->{_COLOR_}{lines} );
   }

   $self->{_CREATECALLED_}++;
   return defined wantarray ? $self : undef;
}

sub particle {
   # Create random dots. They'll cover all over the surface
   my $self = shift;
   croak q{particle() must be called 'after' create()} if !$self->{_CREATECALLED_};
   my $big  = $self->{height} > $self->{width} ? $self->{height} : $self->{width};
   my $f    = shift || $big * PARTICLE_MULTIPLIER; # particle density
   my $dots = shift || 1; # number of multiple dots
   my $int  = int $big / PARTICLE_MULTIPLIER;

   if ( ! $int ) { # RT#33629
      warn "particle(): image dimension is so small to add particles\n";
      return;
   }

   my @random;
   for (my $x = $int; $x <= $big; $x += $int) { ## no critic (ControlStructures::ProhibitCStyleForLoops)
      push @random, $x;
   }

   my $tc  = $self->{_COLOR_}{text};
   my $len = @random;
   my $r   = sub { $random[ int rand $len ] };

   for ( 1..$f ) {
      my $x = int rand $self->{width};
      my $y = int rand $self->{height};
      foreach my $z (1..$dots) {
         $self->setPixel($x + $z         , $y + $z         , $tc);
         $self->setPixel($x + $z + $r->(), $y + $z + $r->(), $tc);
      }
   }
   undef @random;
   undef $r;

   return defined wantarray ? $self : undef;
}

sub raw { return shift->{image} } # raw image object

sub info_text { # set text location
   # x      => 'left|right',  # text-X
   # y      => 'up|low|down', # text-Y
   # strip  => 1|0,           # add strip?
   # gd     => 1|0,           # use default GD font?
   # ptsize => 10,            # point size
   # color  => '#000000',     # text color
   # scolor => '#FFFFFF',     # strip color
   # text   => 'blah',        # modifies random code
   my($self, @args) = @_;
   croak q{info_text() must be called 'after' create()} if ! $self->{_CREATECALLED_};
   my %o = @args % 2 ? () : ( qw/ x right y up strip 1 /, @args );
   return if not %o;

   $self->{_TEXT_LOCATION_}{_place_} = 1;
   $o{scolor}                        = $self->cconvert($o{scolor})       if $o{scolor};

   my %restore = (
      random   => $self->{_RANDOM_NUMBER_},
      color    => $self->{_COLOR_}{text},
      ptsize   => $self->{ptsize},
      scramble => $self->{scramble},
      angle    => $self->{angle},
   );

   $self->{_RANDOM_NUMBER_}    = delete $o{text}                   if $o{text};
   $self->{_COLOR_}{text}      = $self->cconvert(delete $o{color}) if $o{color};
   $self->{ptsize}             = delete $o{ptsize}                 if $o{ptsize};
   $self->{scramble}           = 0; # disable. we need a straight text
   $self->{angle}              = 0; # disable. RT:14618

   $self->{_TEXT_LOCATION_}->{$_} = $o{$_} foreach keys %o;
   $self->insert_text('ttf');

   # restore
   $self->{_RANDOM_NUMBER_}    = $restore{random};
   $self->{_COLOR_}{text}      = $restore{color};
   $self->{ptsize}             = $restore{ptsize};
   $self->{scramble}           = $restore{scramble};
   $self->{angle}              = $restore{angle};

   return $self;
}

#--------------------[ PRIVATE ]--------------------#

sub add_strip { # adds a strip to the background of the text
   my($self, $x, $y, $box_w, $box_h) = @_;
   my $tl    = $self->{_TEXT_LOCATION_};
   my $c     = $self->{_COLOR_} || {};
   my $black = $self->cconvert( $c->{text}    ? $c->{text}    : [ RGB_BLACK ] );
   my $white = $self->cconvert( $tl->{scolor} ? $tl->{scolor} : [ RGB_WHITE ] );
   my $x2    = $tl->{x} eq 'left' ? $box_w : $self->{width};
   my $y2    = $self->{height} - $box_h;
   my $i     = $self->{IS_MAGICK} ? $self  : $self->{image};
   my $up    = $tl->{y} eq 'up';
   my $h     = $self->{height};
   $i->filledRectangle($up ? ($x-1, 0, $x2, $y+1) : ($x-1, $y2-1, $x2  , $h  ), $black);
   $i->filledRectangle($up ? ($x  , 1, $x2-2, $y) : ($x  , $y2  , $x2-2, $h-2), $white);
   return;
}

sub r2h {
   # Convert RGB to Hex
   my($self, @args) = @_;
   return if @args != MAX_RGB_PARAMS;
   my $color  = q{#};
      $color .= sprintf '%02x', $_ foreach @args;
   return $color;
}

sub h2r {
   # Convert Hex to RGB
   my $self  = shift;
   my $color = shift;
   return if ref $color;
   my @rgb   = $color =~ m/\A \#([a-f0-9]{2})([a-f0-9]{2})([a-f0-9]{2}) \z/xmsi;
   return @rgb ? map { hex $_ } @rgb : undef;
}

sub is_hex {
   my $self = shift;
   my $data = shift;
   return $data =~ m/ \A \#([a-f0-9]{2})([a-f0-9]{2})([a-f0-9]{2}) \z /xmsi;
}

1;

__END__