File Coverage

blib/lib/GD/Icons.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package GD::Icons;

our $VERSION = '0.04';

# $Id: Icons.pm,v 1.8 2007/08/06 15:36:54 canaran Exp $

use warnings;
use strict;

use GD::Icons::Config;

use Carp;
use GD;

###############
# CONSTRUCTOR #
###############

sub new {
    my ($class, %params) = @_;

    my $self = bless {}, $class;

    my $config_file     = $params{config_file};
    my $gd_icons_config = GD::Icons::Config->new($config_file);
    $self->config($gd_icons_config->config);

    # Assign alpha
    my $alpha = $params{alpha} ? $params{alpha} : 0;
    if ($alpha =~ /[^0-9]/ or $alpha > 127) {
        croak("alpha must be a value between 0 and 127!");
    }
    $self->alpha($alpha);

    # Parse shapes keys
    my $shape_keys =
        $params{shape_keys}
      ? $params{shape_keys}
      : [":default"];
    $self->shape_keys($shape_keys);

    my $shape_values =
        $params{shape_values}
      ? $params{shape_values}
      : $self->all_shapes;
    $self->shape_values($shape_values);

    # Parse color keys
    my $color_keys =
        $params{color_keys}
      ? $params{color_keys}
      : [":default"];
    $self->color_keys($color_keys);

    my $color_values =
        $params{color_values}
      ? $params{color_values}
      : $self->all_colors;
    $self->color_values($color_values);

    # Parse sval keys
    my $sval_keys =
        $params{sval_keys}
      ? $params{sval_keys}
      : [":default"];
    $self->sval_keys($sval_keys);

    my $sval_values =
        $params{sval_values}
      ? $params{sval_values}
      : [map { $_ / (@$sval_keys) * 100 } (1 .. @$sval_keys)];    # ratio only
    $self->sval_values($sval_values);

    my $icon_dir = $params{icon_dir}
      or croak("A icon_dir is required!");
    $self->icon_dir($icon_dir);

    my $icon_prefix = $params{icon_prefix};
    if (!defined $icon_prefix) {
        croak("A icon_prefix is required!");
    }
    $self->icon_prefix($icon_prefix);

    return $self;
}

##################
# PUBLIC METHODS #
##################

# Function  : Get method that ignores _* names
# Arguments : None
# Returns   : \@all
# Notes     : None provided.

sub all_colors {
    my ($self) = @_;

    my $config = $self->config;

    my @all;
    foreach (sort keys %{$config->{color}}) {
        push @all, $_ unless /^_/;
    }

    return \@all;
}

# Function  : Get method that ignores _* names
# Arguments : None
# Returns   : \@all
# Notes     : None provided.

sub all_shapes {
    my ($self) = @_;

    my $config = $self->config;

    my @all;
    foreach (sort keys %{$config->{shape}}) {
        push @all, $_ unless /^_/;
    }

    return \@all;
}

# Function  : Get/set method for icon location
# Arguments : $shape_key, $color_key, $sval_key, $value
# Returns   : $value
# Notes     : None provided.

sub icon {
    my ($self, $shape_key, $color_key, $sval_key, $value) = @_;

    $self->{icons}->{$shape_key}->{$color_key}->{$sval_key} = $value
      if @_ > 4;

    return $self->{icons}->{$shape_key}->{$color_key}->{$sval_key};
}

# Function  : Make ...
# Arguments :
# Returns   :
# Notes     : None provided.

sub generate_icons {
    my ($self) = @_;

    my $config = $self->config;

    my $alpha = $self->alpha;

    my @shape_keys   = @{$self->shape_keys};
    my @shape_values = @{$self->shape_values};

    my @color_keys   = @{$self->color_keys};
    my @color_values = @{$self->color_values};

    my @sval_keys   = @{$self->sval_keys};
    my @sval_values = @{$self->sval_values};

    my $icon_dir    = $self->icon_dir;
    my $icon_prefix = $self->icon_prefix;

    foreach my $shape_i (0 .. $#shape_keys) {
        foreach my $color_i (0 .. $#color_keys) {
            foreach my $sval_i (0 .. $#sval_keys) {
                my $shape =
                  $config->{shape}->{$shape_values[$shape_i % @shape_values]
                  };    # @shape_values here, not $#shape_values

                my $color =
                  $self->_resolve_color(
                    $color_values[$color_i % @color_values])
                  ;     # @color_values here, not $#color_values

                my $sval = $sval_values[$sval_i];
                if (@sval_values > 1) {
                    $color = $self->_blend_in_sval($color, $sval);
                }

                my ($line_color) = $shape =~ /lc\[([^\[\]]+)\]/;
                if ($line_color eq ":fill") {
                    $line_color = [@$color];
                }
                $line_color = $self->_resolve_color($line_color);

                my ($line_thickness) = $shape =~ /lt\[(\d+)\]/;
                my ($side_length)    = $shape =~ /sl\[(\d+)\]/;

                my $image = new GD::Image($side_length, $side_length);

                my $white_color = $image->colorAllocateAlpha(255, 255, 255, $alpha);
                my $fill_color  = $image->colorAllocateAlpha(@$color, $alpha);
                my $draw_color  = $image->colorAllocateAlpha(@$line_color, $alpha);

                $image->transparent($white_color);

                $image->setThickness($line_thickness);

                while ($shape =~ /\s*(py|fl|nm)\[([0-9, ]+|:auto)\]\s*/g) {
                    my ($action, $values) = ($1, $2);

                    if ($action eq "py") {
                        my @points = split(" ", $values);

                        foreach my $i (0 .. $#points - 1) {
                            my ($x1, $y1) = split(",", $points[$i]);
                            my ($x2, $y2) = split(",", $points[$i + 1]);

                            $image->line($x1, $y1, $x2, $y2, $draw_color);
                        }
                    }

                    elsif ($action eq "fl") {
                        my ($x1, $y1) = split(",", $values);

                        $image->fill($x1, $y1, $fill_color);
                    }

                    elsif ($action eq "nm" && $values eq ":auto") {
                        my ($number) = $shape_keys[$shape_i] =~ /:(\d+)/;
                        if ($number && $number > 99) {
                            $number = 'M';
                        }
                        if (!$number) {
                            $number = 'U';
                        }

                        my $x = int(($side_length - 5 * length($number)) / 2) + 1;
                        my $y = ($side_length - 8) / 2;

                        $image->string(gdTinyFont, $x, $y, $number, $draw_color);
                    }

                    else {
                        croak(
                            "Unrecognized action ($action) in shapes file!");
                    }
                }

                my $icon_file =
                  qq[$icon_dir/${icon_prefix}-${shape_i}-${color_i}-${sval_i}.png];
                my $icon_file_name =
                  qq[${icon_prefix}-${shape_i}-${color_i}-${sval_i}.png];

                $self->icon(
                    $shape_keys[$shape_i], $color_keys[$color_i],
                    $sval_keys[$sval_i],   $icon_file_name
                );

                open(PNG, ">$icon_file")
                  or croak("Cannot write file ($icon_file): $!");
                binmode PNG;
                print PNG $image->png;
                close PNG;
            }
        }

    }

    return 1;
}

###################
# GET/SET METHODS #
###################

sub alpha {
    my ($self, $value) = @_;
    $self->{alpha} = $value if @_ > 1;
    return $self->{alpha};
}

sub color_keys {
    my ($self, $value) = @_;
    $self->{color_keys} = $value if @_ > 1;
    return $self->{color_keys};
}

sub color_values {
    my ($self, $value) = @_;
    $self->{color_values} = $value if @_ > 1;
    return $self->{color_values};
}

sub config {
    my ($self, $value) = @_;
    $self->{config} = $value if @_ > 1;
    return $self->{config};
}

sub icon_dir {
    my ($self, $value) = @_;
    $self->{icon_dir} = $value if @_ > 1;
    return $self->{icon_dir};
}

sub icon_prefix {
    my ($self, $value) = @_;
    $self->{icon_prefix} = $value if @_ > 1;
    return $self->{icon_prefix};
}

sub shape_keys {
    my ($self, $value) = @_;
    $self->{shape_keys} = $value if @_ > 1;
    return $self->{shape_keys};
}

sub shape_values {
    my ($self, $value) = @_;
    $self->{shape_values} = $value if @_ > 1;
    return $self->{shape_values};
}

sub sval_keys {
    my ($self, $value) = @_;
    $self->{sval_keys} = $value if @_ > 1;
    return $self->{sval_keys};
}

sub sval_values {
    my ($self, $value) = @_;
    $self->{sval_values} = $value if @_ > 1;
    return $self->{sval_values};
}

###########################
# PRIVATE/UTILITY METHODS #
###########################

# Function  : Apply an S Value to color in RGB
# Arguments : (\@color, $sval_percent)
# Returns   : \@new_color
# Notes     : This is a private method.

sub _blend_in_sval {
    my ($self, $color, $sval_percent) = @_;

    my ($rval, $gval, $bval) = @$color;

    my ($hval, $sval, $vval) = $self->_RGBtoHSV($rval, $gval, $bval);

    $sval = int($sval * $sval_percent / 100);

    my @new_color = $self->_HSVtoRGB($hval, $sval, $vval);

    return \@new_color;
}

# Function  : Determine the type of color designation
# Arguments : $color
# Returns   : $rgb
# Notes     : This is a private method.

sub _resolve_color {
    my ($self, $color) = @_;

    my $rgb;

    if (ref $color) {
        $rgb = $color;
    }

    elsif ($color =~ /^#/) {
        $rgb = $self->_hex2rgb($color);
    }

    else {
        my $hex = $self->config->{color}->{$color};

        $rgb = $self->_hex2rgb($hex);
    }

    croak("Cannot resolve color ($color)!") unless $rgb;

    return $rgb;
}

# Function  : Convert hex to rgb
# Arguments : $hex
# Returns   : \@rgb
# Notes     : This is a private method.

sub _hex2rgb {
    my ($self, $hex) = @_;

    $hex =~ s/^#//;

    my @rgb = map { hex(substr($hex, $_, 2)); } qw[0 2 4];

    return \@rgb;
}

##################################################
# _HSVtoRGB and _RGBtoHSV subs incorporated from #
# GD::Simple module written by Lincoln Stein     #
##################################################

# ($red,$green,$blue) = GD::Simple->HSVtoRGB($hue,$saturation,$value)
#
# Convert a Hue/Saturation/Value (HSV) color into an RGB triple. The
# hue, saturation and value are integers from 0 to 255.

sub _HSVtoRGB {
    my $self = shift;
    @_ == 3
      or croak "Usage: _HSVtoRGB(\$hue,\$saturation,\$value)";

    my ($h, $s, $v) = @_;
    my ($r, $g, $b, $i, $f, $p, $q, $t);

    if ($s == 0) {
        ## achromatic (grey)
        return ($v, $v, $v);
    }
    $h %= 255;
    $s /= 255;    ## scale saturation from 0.0-1.0
    $h /= 255;    ## scale hue from 0 to 1.0
    $h *= 360;    ## and now scale it to 0 to 360

    $h /= 60;     ## sector 0 to 5
    $i = $h % 6;
    $f = $h - $i;                    ## factorial part of h
    $p = $v * (1 - $s);
    $q = $v * (1 - $s * $f);
    $t = $v * (1 - $s * (1 - $f));

    if ($i < 1) {
        $r = $v;
        $g = $t;
        $b = $p;
    }
    elsif ($i < 2) {
        $r = $q;
        $g = $v;
        $b = $p;
    }
    elsif ($i < 3) {
        $r = $p;
        $g = $v;
        $b = $t;
    }
    elsif ($i < 4) {
        $r = $p;
        $g = $q;
        $b = $v;
    }
    elsif ($i < 5) {
        $r = $t;
        $g = $p;
        $b = $v;
    }
    else {
        $r = $v;
        $g = $p;
        $b = $q;
    }
    return (int($r + 0.5), int($g + 0.5), int($b + 0.5));
}

# ($hue,$saturation,$value) = GD::Simple->RGBtoHSV($hue,$saturation,$value)
#
# Convert a Red/Green/Blue (RGB) value into a Hue/Saturation/Value (HSV)
# triple. The hue, saturation and value are integers from 0 to 255.

sub _RGBtoHSV {
    my $self = shift;
    my ($r, $g, $bl) = @_;
    my ($min, undef, $max) = sort { $a <=> $b } ($r, $g, $bl);
    return (0, 0, 0) unless $max > 0;

    my $v = $max;
    my $s = 255 * ($max - $min) / $max;
    my $h;
    my $range = $max - $min;

    if ($range == 0) {    # all colors are equal, so monochrome
        return (0, 0, $max);
    }

    if ($max == $r) {
        $h = 60 * ($g - $bl) / $range;
    }
    elsif ($max == $g) {
        $h = 60 * ($bl - $r) / $range + 120;
    }
    else {
        $h = 60 * ($r - $g) / $range + 240;
    }

    $h = int($h * 255 / 360 + 0.5);

    return ($h, $s, $v);
}

1;

__END__