File Coverage

blib/lib/Test/CGI/Multipart/Gen/Image.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package Test::CGI::Multipart::Gen::Image;

use warnings;
use strict;
use Carp;
use Readonly;
use Test::CGI::Multipart;
use GD::Simple;

use version; our $VERSION = qv('0.0.3');

# Module implementation here

Test::CGI::Multipart->register_callback(
    callback => sub {
        my $hashref = shift;

        my %to_delete;
        return $hashref if exists $hashref->{value};

        # If the MIME type is not explicitly image/* its not ours.
        return $hashref if not exists $hashref->{type};
        return $hashref if $hashref->{type} !~ m{\Aimage/(\w+)\z}xms;
        my $type = $1;

        # get dimensions
        croak "no width specified" if not exists $hashref->{width};
        my $width = $hashref->{width};
        $to_delete{width} = 1;
        croak "no height specified" if not exists $hashref->{height};
        my $height = $hashref->{height};
        $to_delete{height} = 1;

        my $image = GD::Simple->new($width, $height);

        croak "no instructions specified"
            if not exists $hashref->{instructions};
        croak "intructions not a list"
            if ref $hashref->{instructions} ne 'ARRAY';
        my @instructions = @{$hashref->{instructions}};
        $to_delete{instructions} = 1;

        foreach my $instr (@instructions) {
            my ($cmd, @args) = @$instr;
            eval {$image->$cmd(@args)};
            if ($@) {
                warn "GD: $@";
                return $hashref;
            }
        }

        $hashref->{value} = eval {$image->$type};
        if ($@) {
            warn "GD: $@";
            delete $hashref->{value};
            return $hashref;
        }

        foreach my $del (keys %to_delete) {
            delete $hashref->{$del};
        }

        return $hashref;
    }
);

1; # Magic true value required at end of module
__END__