File Coverage

blib/lib/App/PNGCrush.pm

Criterion	Covered	Total	%
statement	24	70	34.2
branch	1	26	3.8
condition	0	6	0.0
subroutine	7	12	58.3
pod	4	4	100.0
total	36	118	30.5

package App::PNGCrush;

use warnings;
use strict;

our $VERSION = '0.002';

use Carp;
use Proc::Reliable;
use Devel::TakeHashArgs;
use base 'Class::Data::Accessor';

my %Valid_Options = qw(
    already_size            -already
    bit_depth               -bit_depth
    background              -bkgd
    brute_force             -brute
    color_type              -c
    color_counting          -cc
    output_dir              -d
    double_image_gamma      -dou
    output_extension        -e
    filter                  -f
    fix_fatal               -fix
    output_force            -force
    gamma                   -g
    itxt                    -itxt
    level                   -l
    method                  -m
    maximum_idat            -max
    no_output               -n
    no_color_counting       -no_cc
    plte_length             -plte_len
    remove                  -rem
    replace_gamma           -replace_gamma
    resolution              -res
    save_unknown            -save
    srgb                    -srgb
    text                    -text
    transparency            -trns
    window_size             -w
    strategy                -z
    insert_ztxt             -zitxt
    ztxt                    -ztxt
    verbose                 -v
);

my %No_Arg_Options = map { $_ => 1 } qw(
    brute_force
    color_counting
    double_image_gamma
    fix_fatal
    output_force
    no_output
    no_color_counting
    save_unknown
    verbose
);

__PACKAGE__->mk_classaccessors (
    qw( proc error results ),
    keys %Valid_Options
);

sub new {
    my $self = bless {}, shift;
    get_args_as_hash( \@_, \my %args, { maxtime => 300 } )
        or croak $@;

    my $proc = Proc::Reliable->new;

    $proc->$_( $args{$_} ) for keys %args;

    $self->proc( $proc );

    return $self;
}

sub run {
    my $self = shift;
    my $in   = shift;

    get_args_as_hash( \@_, \ my %args, { in => $in }, )
        or croak $@;

    $self->$_(undef) for qw(error results);

    my @options = exists $args{opts}
                ? @{ $args{opts} }
                : $self->_make_options;

    my $proc = $self->proc;
    my %out;
    @out{ qw(stdout stderr status msg) }
    = $proc->run( [ 'pngcrush', @options, $in ] );

    return $self->_set_error("Proc::Reliable error: $out{error}")
        if defined $out{error};

    return $self->_set_error("File $in does not seem to exist")
        if $out{stdout} =~ /Could not find file: \Q$in/;

    @out{ qw(idat size) } = $out{stdout}
    =~ /\(([\d.]+)% IDAT reduction\).+?\(([\d.]+)% filesize reduction\)/s;

    $out{idat} = 0
        if not defined $out{idat}
            and $out{stdout} =~ /\Q(no IDAT change)/;

    $out{size} = 0
        if not defined $out{size}
            and $out{stdout} =~ /\Q(no filesize change)/;

    @{ $out{cpu} }{ qw(total decoding encoding other) } = $out{stdout}
    =~ /CPU \s time \s used \s = \s ([\d.]+) \s seconds \s
            \(decoding \s ([\d.]+), \s+
          encoding \s ([\d.]+), \s other \s ([\d.]+) \s seconds\)
    /x;

    ( $out{total_idat_length} ) = $out{stdout}
    =~ /Total length of data found in IDAT chunks\s+=\s+([\d.]+)/;

    return $self->results( \%out );
}

sub set_options {
    my $self = shift;
    get_args_as_hash( \@_, \my %args, {}, [], [ %Valid_Options ] )
        or croak $@;

    $self->reset_options;

    keys %args;
    my %shell_args = reverse %Valid_Options;
    while ( my ( $key, $value ) = each %args ) {
        $key = $shell_args{$key}
            unless exists $Valid_Options{$key};

        $self->$key( $value );
    }

    return 1;
}

sub reset_options {
    my $self = shift;

    $self->$_(undef) for keys %Valid_Options;

    return 1;
}

sub _make_options {
    my $self = shift;

    my @options;
    for my $opt ( keys %Valid_Options ) {
        my $value = $self->$opt;
        next
            unless defined $value;

        if ( ref $value eq 'ARRAY' ) {
            if ( $opt eq 'verbose' ) {
                push @options, ('-v') x @$value;
                next;
            }
            push @options, map { $Valid_Options{$opt} => $_ } @$value;
        }
        else {
            push @options, $Valid_Options{$opt},
                exists $No_Arg_Options{$opt} ? () : $value;
        }
    }
    return @options;
}

sub _set_error {
    my ( $self, $error ) = @_;
    $self->error($error);
    return;
}

1;
__END__