File Coverage

blib/lib/WebService/Kaolabo.pm

Criterion	Covered	Total	%
statement	19	21	90.4
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	26	28	92.8

package WebService::Kaolabo;

use warnings;
use strict;
use Carp;

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

use LWP::UserAgent;
use HTTP::Request;
use Data::Average;
use Imager;
use File::Spec;
our $errstr;

use base qw(Class::Accessor);

__PACKAGE__->mk_accessors( qw( socks_proxy proxy target_file convert_file uri apikey imager request_content response_xml face_data area face_area unface_area ave_face_width ave_face_height error));

sub new {
    my $self = shift->SUPER::new(@_);

    my $target_file = $self->target_file;

    $self->uri('https://kaolabo.com/api/detect?apikey=')
      unless ( $self->uri );

    my $imager = Imager->new;
    if ( $target_file && $target_file !~ /(jpg|jpeg)$/ ) {
        $errstr = 'Target file is not jpeg';
        return;
    }
    unless ( $imager->read( file => $target_file ) ) {
        $errstr = 'Cannot read target file ' . $imager->errstr();
        return;
    }

    $self->area([]);
    $self->face_area([]);
    $self->unface_area([]);
    $self->imager($imager);
    $self;
}

sub scale {
    my $self   = shift;
    my $imager = $self->imager;

    unless ( $imager ) {
        $errstr = 'Not found Imager object';
        return;
    }

    unless ( @_ ) {
        $errstr = 'Not found scale param';
        return;
    }

    my $imager_s = $imager->scale(@_);
    $self->imager($imager_s);

    return $imager_s;
}

sub write {
    my $self         = shift;
    my $convert_file = shift;
    $convert_file ||= $self->convert_file;
    my $imager = $self->imager;
    $imager->write( file => $convert_file, jpegquality => 100 )
      or die $imager->errstr;
    return;
}

sub access {
    my $self = shift;
    if ( $self->socks_proxy ) {
        if ( eval { require LWP::Protocol::https::SocksChain } ) {
            LWP::Protocol::implementor(
                https => 'LWP::Protocol::https::SocksChain' );
            @LWP::Protocol::https::SocksChain::EXTRA_SOCK_OPTS = (
                Chain_Len       => 1,
                Debug           => 0,
                Chain_File_Data => $self->socks_proxy,
                Random_Chain    => 1,
                Auto_Save       => 1,
                Restore_Type    => 1
            );
        }
    }

    my $uri = $self->uri . $self->apikey;

    my $request_content;
    my $imager = $self->imager;
    $imager->write( type => 'jpeg', data => \$request_content );

    my $request = HTTP::Request->new( 'POST' => $uri );
    $request->header( 'Content-Type' => 'image/jpeg' );

    $request->content($request_content)
      if ( $request_content );

    my $ua = LWP::UserAgent->new;
    $ua->proxy( [ 'http', 'ftp' ], $self->proxy ) if ( $self->proxy );

    my $response = $ua->request($request);
    unless ( $response->is_success ) {
        $errstr = 'Failed access ' . $response->status_line;
    }
    else {
        $self->response_xml( $response->content );
        $self->_parser();
        $self->_area_score();
    }
    return $response;
}

sub _parser {
    my $self = shift;

    my $content    = $self->response_xml();
    my $face_data  = [];
    my $ave_width  = Data::Average->new;
    my $ave_height = Data::Average->new;
    while ( $content =~ s/<face(.+?)<\/face// ) {
        my $node = $1;
        my ( $height, $score, $width, $face_x, $face_y, $left_eye_x, $left_eye_y, $right_eye_x, $right_eye_y)
          = ( 0, 0, 0, 0, 0, 0, 0, 0, 0 );

        ( $height, $score, $width, $face_x, $face_y ) = ( $1, $2, $3, $4, $5 )
          if ( $node =~
            /height="(\d+)" score="(\d+)" width="(\d+)" x="(\d+)" y="(\d+)"/ );

        ( $left_eye_x, $left_eye_y ) = ( $1, $2 )
          if ( $node =~ /left\-eye x="(\d+)" y="(\d+)"/i );

        ( $right_eye_x, $right_eye_y ) = ( $1, $2 )
          if ( $node =~ /right\-eye x="(\d+)" y="(\d+)"/i );

        my $center_x = $width / 2 + $face_x;
        my $center_y = $height / 2 + $face_y;

        # Maybe API bugs ??
        if ( $left_eye_x == $right_eye_x ) {
            $right_eye_y = $right_eye_y<$left_eye_y?$right_eye_y:$left_eye_y;
            $left_eye_y  = $right_eye_y<$left_eye_y?$right_eye_y:$left_eye_y;
        }

        $ave_width->add($width);
        $ave_height->add($height);
        push @{$face_data},
          {
            height      => $height,
            score       => $score,
            width       => $width,
            face_x      => $face_x,
            face_y      => $face_y,
            left_eye_x  => $left_eye_x,
            left_eye_y  => $left_eye_y,
            right_eye_x => $right_eye_x,
            right_eye_y => $right_eye_y,
#            left_eye_x  => $left_eye_x,
#            left_eye_y  => $left_eye_y,
#            right_eye_x => $right_eye_x,
#            right_eye_y => $right_eye_y,
            center_x    => $center_x,
            center_y    => $center_y,
          };
    }
    $self->ave_face_width( $ave_width->avg );
    $self->ave_face_height( $ave_height->avg );
    $self->face_data($face_data);
    return;
}

sub _area_score {
    my $self = shift;

    my $w   = $self->imager->getwidth();
    my $h   = $self->imager->getheight();
    my $ddx = $w / 3;
    my $ddy = $h / 3;

    my @area;
    my $area_number = 0;
    for my $i ( 1 .. 3 ) {
        $area_number++;
        push @area,
          {
            area_number => $area_number,
            min_x       => $ddx * ( $i - 1 ),
            min_y       => 0,
            max_x       => $ddx * $i,
            max_y       => $ddy,
            point       => 0
          };
    }
    for my $i ( 1 .. 3 ) {
        $area_number++;
        push @area,
          {
            area_number => $area_number,
            min_x       => $ddx * ( $i - 1 ),
            min_y       => $ddy,
            max_x       => $ddx * $i,
            max_y       => $ddy * 2,
            point       => 0
          };
    }
    for my $i ( 1 .. 3 ) {
        $area_number++;
        push @area,
          {
            area_number => $area_number,
            min_x       => $ddx * ( $i - 1 ),
            min_y       => $ddy * 2,
            max_x       => $ddx * $i,
            max_y       => $ddy * 3,
            point       => 0
          };
    }

    my $face_data = $self->face_data();

    for my $f ( @{$face_data} ) {
        for my $a (@area) {
            if ( $a->{max_x} > $f->{center_x} && $a->{max_y} > $f->{center_y} ) {
                $a->{point}++;
                last;
            }
        }
    }
    $self->area( \@area );

    my @unface_area = grep( { $_->{point} == 0 } @area );
    $self->unface_area( \@unface_area );

    my @face_area = grep( { $_->{point} != 0 } @area );
    $self->face_area( \@face_area );
    return;
}

sub effect_face {
    my $self   = shift;
    my $args   = shift;
    my $effect = $args->{type} || 'line';
    my $color  = $args->{color} || '#000000';
    my $imager = $self->imager;

    my $face_data = $self->face_data || [];
    for my $f ( @{$face_data} ) {
        $imager->box(
            xmin   => $f->{face_x},
            ymin   => $f->{face_y},
            xmax   => $f->{face_x} + $f->{width},
            ymax   => $f->{face_y} + $f->{height},
            color  => $color,
            filled => 1,
        ) if ( $effect eq "box" );

        my $border_h = $f->{height} * 0.1;

        my $ymin = 0;
        my $ymax = 0;
        my $i    = abs( $f->{right_eye_y} - $f->{left_eye_y} );
        if ( $f->{left_eye_y} < $f->{right_eye_y} ) {
            $ymin = $f->{left_eye_y} - $border_h;
            $ymax = $f->{right_eye_y} + $border_h;
        }
        else {
            $ymin = $f->{right_eye_y} - $border_h;
            $ymax = $f->{left_eye_y} + $border_h;
        }

        $imager->box(
            xmin   => $f->{face_x},
            ymin   => $ymin,
            xmax   => $f->{face_x} + $f->{width},
            ymax   => $ymax,
            color  => $color,
            filled => 1,
        ) if ( $effect eq "line" );
    }
    return;
}

1;
__END__

=head1 NAME

WebService::Kaolabo - This module call Kaolabo API (http://kaolabo.com/).


=head1 SYNOPSIS

  use WebService::Kaolabo;
  $kaolab = WebService::Kaolabo->new({
                                       target_file  => 'sample.jpg',
                                       apikey       => 'hogefuga'
                                    });

  unless ( $kaolab->scale( xpixels => 50, ypixels => 50, type => 'max') ) {
      warn "Failed scale $WebService::Kaolabo::errstr";
  }

  my $res = $kaolab->access();
  if ( $res->is_success ) {
      warn "Success ";
  }

  #$kaolab->unface_area();
  for my $k ( @{$kaolab->face_area()} ){
      $k->{area_number}
      $k->{min_x};
      $k->{min_y};
      $k->{max_x};
      $k->{max_y};
      $k->{point};
  }

  my $face_data = $kaolab->face_data;
  for my $f ( @{$face_data} ){
      $f->{face_x};
      $f->{face_y};
      $f->{height};
      $f->{width};
      $f->{right_eye_y};
      $f->{left_eye_y};
  }

  $kaolab->effect_face({type=>'box', color=>'#FF0000'});
  $kaolab->write('output.jpg');
  #my $imager = $kaolab->imager;
  #$imager->write(type=>'jpeg', file=>'output.jpg');


=head1 METHODS


=over 4

=item new({target_file  => '...', apikey => '....'})

The image file and api_key are passed. And Create new instance.
The image should be JPEG.

=item access

Call The Kaolab API . The return value is a response object.
See L<HTTP::Response>.

=item scale

Call L<Imager> scale method. See L<Imager::Transformations/scale>.

=item effect_face

This method draws the line or box on the face.

The line is drawn on eyes.

  $kaolab->effect_face({type=>'line', color=>'#FF0000'});

The box is drawn on faces.

  $kaolab->effect_face({type=>'box', color=>'#FF0000'});

=item write('...')

Write an image to a file.

=item imager

The L<Imager> instance is returned.

=item face_area

The image file is delimited to nine areas. Return face area.

=item unface_area

Return no face area.

=item ave_face_width

Return average width of all faces.

=item ave_face_height

Return average height of all faces.

=item errstr

Error message.

  warn "$WebService::Kaolabo::errstr";

=back

=head1 SEE ALSO

Kaolab API L<http://kaolabo.com/webapi>
Kaolab L<http://kaolabo.com/>

=head1 AUTHOR

Akihito Takeda  C<< <[e-mail]> >>

=head1 LICENCE AND COPYRIGHT

Copyright (c) 2008, Akihito Takeda C<< <[e-mail]> >>. All rights reserved.

This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. See L<perlartistic>.