File Coverage

blib/lib/IIIF/Magick.pm

Criterion	Covered	Total	%
statement	55	65	84.6
branch	34	44	77.2
condition	11	18	61.1
subroutine	8	10	80.0
pod	5	6	83.3
total	113	143	79.0

package IIIF::Magick;
use 5.014001;

our $VERSION = "0.07";

use parent 'Exporter';
our @EXPORT = qw(info available convert convert_command convert_args);

use IPC::Cmd qw(can_run);
use List::Util qw(min);

sub available {
    return can_run("magick") || ( can_run("identify") && can_run("convert") );
}

sub info {
    my $file = shift;

    -f $file or die "$file: No such file\n";
    my $cmd = join ' ', map shell_quote($_), qw(identify -format %Wx%H), $file;

    ( `$cmd` =~ /^(\d+)x(\d+)$/ )
      or die "$file: Failed to get image dimensions";

    return {
        '@context' => 'http://iiif.io/api/image/3/context.json',
        type       => 'ImageService3',
        protocol   => 'http://iiif.io/api/image',
        width      => 1 * $1,
        height     => 1 * $2,
        @_
    };
}

sub convert_args {
    my $req = shift;
    my @args;

    # apply region
    if ( $req->{region} eq 'square' ) {

     # could be simpler in ImageMagick 7:
     # push @args, qw(-gravity center -crop), "%[fx:w>h?h:w]x%[fx:w>h?h:w]+0+0";
        push @args, qw(-set option:distort:viewport
          %[fx:w>h?h:w]x%[fx:w>h?h:w]+%[fx:w>h?(w-h)/2:0]+%[fx:w>h?0:(h-w)/2]
          -filter point -distort SRT 0 +repage);
    }
    elsif ( my $region_px = $req->{region_px} ) {
        my ( $x, $y, $w, $h ) = @$region_px;
        @args = ( '-crop', "${w}x$h+$x+$y" );
    }
    elsif ( my $region_pct = $req->{region_pct} ) {
        my ( $x, $y, $w, $h ) = @$region_pct;

        if ( $x || $y ) {
            my $px = $x / 100;
            my $py = $y / 100;
            push @args, '-set', 'page', "-%[fx:w*$px]-%[fx:h*$py]";
        }

        # could also be simpler in ImageMagick 7
        push @args, '-crop', "${w}x$h%+0+0";
    }

    # apply size
    if ( $req->{size_pct} ) {
        push @args, '-resize', $req->{size_pct} . '%';
    }
    elsif ( $req->{size_px} ) {
        my ( $x, $y ) = @{ $req->{size_px} };

        if ( $x && !$y ) {
            push @args, '-resize', "${x}";
        }
        elsif ( !$x && $y ) {
            push @args, '-resize', "x${y}";
        }
        elsif ( $req->{ratio} ) {
            push @args, '-resize', "${x}x$y";
        }
        else {
            push @args, '-resize', "${x}x$y!";
        }
    }

    # apply rotation
    push @args, '-flop' if $req->{mirror};
    if ( my $degree = $req->{degree} ) {
        push @args, '-rotate', $degree;
        if ( $degree - 90 * int( $degree / 90 ) ) {
            push @args, '-background', 'none';
        }
    }

    # apply quality
    if ( $req->{quality} eq 'gray' ) {
        push @args, qw(-colorspace Gray);
    }
    elsif ( $req->{quality} eq 'bitonal' ) {
        push @args, qw(-monochrome -colors 2);
    }

    return @args;
}

sub convert_command {
    my ( $req, $in, $out ) = splice @_, 0, 3;

    my @cmd = ( 'convert', @_, convert_args($req) );
    push @cmd, $in  if defined $in  and $in ne '';
    push @cmd, $out if defined $out and $out ne '';
    unshift @cmd, "magick" if can_run("magick");

    return join ' ', map shell_quote($_), @cmd;
}

sub convert {
    my $command = convert_command(@_);
    qx{$command};
    return !$?;
}

# adopted from
sub shell_quote {
    my $arg = shift;

    if ( $^O eq 'MSWin32' ) {
        if ( $arg !~ /\A[\w_+-]+\z/ ) {
            $arg =~ s/\\(?=\\*(?:"|$))/\\\\/g;
            $arg =~ s/"/\\"/g;
            return qq("$arg");
        }
    }
    elsif ( $arg !~ qr{\A[\w,_+/.-]+\z} ) {
        $arg =~ s/'/'"'"'/g;
        return "'$arg'";
    }

    return $arg;
}

1;
__END__