File Coverage

blib/lib/Image/Base/Imager.pm

Criterion	Covered	Total	%
statement	115	121	95.0
branch	54	62	87.1
condition	7	9	77.7
subroutine	19	20	95.0
pod	10	12	83.3
total	205	224	91.5

# Copyright 2010, 2011, 2012, 2019 Kevin Ryde

# This file is part of Image-Base-Imager.
#
# Image-Base-Imager is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 3, or (at your option) any later
# version.
#
# Image-Base-Imager is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Image-Base-Imager.  If not, see .



# cf Imager::Draw -- drawing operations
# Seems to auto-clip to width,height.

package Image::Base::Imager;
use 5.004;
use strict;
use Carp;

# maybe Imager 0.39 of Nov 2001 for oop style tags, or something post 0.20
# for the oopery, but don't think need to force that here (just list in the
# Makefile.PL PREREQ_PM)
use Imager;

use vars '$VERSION', '@ISA';

use Image::Base;
@ISA = ('Image::Base');

$VERSION = 13;

# uncomment this to run the ### lines
# use Smart::Comments '###';


# As of Imager 0.79 there's nothing to set the Zlib compression level for a
# -zlib_compression attribute.
#
# An -allow_partial could set allow_partial=> on read().
#

sub new {
  my ($class, %params) = @_;
  ### Image-Base-Imager new(): %params

  # $obj->new(...) means make a copy, with some extra settings
  if (ref $class) {
    my $self = $class;
    $class = ref $class;
    if (! defined $params{'-imager'}) {
      $params{'-imager'} = $self->get('-imager')->copy;
    }
    # inherit everything else
    %params = (%$self, %params);
    ### copy params: \%params
  }

  my $want_load = 1;
  if (! defined $params{'-imager'}) {
    my $width  = delete $params{'-width'};
    my $height = delete $params{'-height'};
    my $filename = $params{'-file'};
    if (! defined $filename) {
      # default 1x1 image since xsize=>undef,ysize=>undef is a 0x0
      # nothingness where settag() won't store -file_format
      if (! defined $width) { $width = 1; }
      if (! defined $height) { $height = 1; }
    }
    $params{'-imager'} = Imager->new (xsize => $width,
                                      ysize => $height,
                                      file  => $filename)
      || croak "Cannot create image: ",Imager->errstr;
    # set -file as filename, but have already loaded
    $want_load = 0;
  }
  my $self = bless {}, $class;
  $self->set (%params);

  if ($want_load && defined $params{'-file'}) {
    $self->load;
  }

  ### new made: $self
  return $self;
}


my %attr_to_tag = (-hotx => 'cur_hotspotx', # get and set
                   -hoty => 'cur_hotspoty',
                  );
my %attr_to_get_method = (-width    => 'getwidth',
                          -height   => 'getheight',
                          -ncolours => 'colorcount',
                          -file_format => \&_imager_get_file_format,
                         );
sub _get {
  my ($self, $key) = @_;
  ### Image-Base-Imager _get(): $key

  if (my $tag = $attr_to_tag{$key}) {
    ### $tag
    ### is: [$self->{'-imager'}->tags(name=>$tag)]
    return scalar(($self->{'-imager'}->tags(name=>$tag))[0]);
  }
  if (my $method = $attr_to_get_method{$key}) {
    ### $method
    ### is: $self->{'-imager'}->$method()
    return  $self->{'-imager'}->$method();
  }
  return $self->SUPER::_get ($key);
}
sub _imager_get_file_format {
  my ($i) = @_;
  ### _imager_get_file_format() from tags: [$i->tags]
  # tags() returns a list of the values
  return scalar(($i->tags (name => 'i_format'))[0]);
}

my %attr_to_img_set = (-width  => 'xsize',
                       -height => 'ysize',
                      );
sub set {
  my ($self, %param) = @_;
  ### Image-Base-Imager set(): \%param

  foreach my $key ('-ncolours') {
    if (exists $param{$key}) {
      croak "Attribute $key is read-only";
    }
  }

  # apply this first
  if (my $i = delete $param{'-imager'}) {
    $self->{'-imager'} = $i;
  }

  my $i = $self->{'-imager'};
  if (exists $param{'-file_format'}) {
    my $format = delete $param{'-file_format'};
    if (defined $format) { $format = lc($format); }
    ### apply -file_format with settag() i_format: $format
    $i->settag (name => 'i_format', value => $format);
    ### tags now: [$i->tags]
  }
  foreach my $key (keys %param) {
    if (my $tag = $attr_to_tag{$key}) {
      ### settag: $tag
      $i->settag (name => $tag, value => delete $param{$key});
      ### tags now: [$i->tags]
    }
  }

  my @set;
  foreach my $key (keys %param) {
    if (my $attribute = $attr_to_img_set{$key}) {
      push @set, $attribute, delete $param{$key};
    }
  }
  if (@set) {
    ### @set
    $i->img_set(@set);
  }

  %$self = (%$self, %param);
}

sub load {
  my ($self, $filename) = @_;
  ### Image-Base-Imager load(): @_
  if (@_ == 1) {
    $filename = $self->get('-file');
  } else {
    $self->set('-file', $filename);
  }
  my $i = $self->{'-imager'};
  $i->read (file => $filename)
    or croak "Cannot load: ",$i->errstr;
  ### $i
  ### size: $i->getwidth.'x'.$i->getheight
  ### tags: [$i->tags]
}

# not yet documented ...
sub load_fh {
  my ($self, $fh) = @_;
  my $i = $self->{'-imager'};
  $i->read (fh => $fh)
    or croak "Cannot load: ",$i->errstr;
}

sub save {
  my ($self, $filename) = @_;
  ### Image-Base-Imager save(): @_
  if (@_ == 2) {
    $self->set('-file', $filename);
  } else {
    $filename = $self->get('-file');
  }
  my $i = $self->{'-imager'};
  my $type = _imager_get_file_format($i);
  my $quality = $self->{'-quality_percent'};
  ### file: $filename
  ### type: $type

  # think it's ok to pass undef as $quality, and that the options can be
  # passed even when not saving to the respective formats
  $i->write (file => $filename,
             type => $type,
             jpegquality      => $quality,
             tiff_jpegquality => $quality)
    or croak "Cannot save: ",$i->errstr;
}

# not yet documented ...
sub save_fh {
  my ($self, $fh) = @_;
  my $i = $self->{'-imager'};
  $i->write (fh => $fh,
             type => _imager_get_file_format($i))
    or croak "Cannot save: ",$i->errstr;
}

sub xy {
  my ($self, $x, $y, $colour) = @_;
  ### Image-Base-Imager xy: $x,$y,$colour
  my $i = $self->{'-imager'};
  if (@_ == 4) {
    $i->setpixel (x => $x, y => $y, color => $colour);

  } else {
    my $cobj = $i->getpixel (x => $x, y => $y);
    if (! defined $cobj) {
      # getpixel() returns undef if x,y outside image size
      return undef;
    }
    my @rgba = $cobj->rgba;
    ### @rgba
    # if ($a == 0) {
    #   return 'None';
    # }
    return sprintf ('#%02X%02X%02X', @rgba[0,1,2]);
  }
}
sub line {
  my ($self, $x1, $y1, $x2, $y2, $colour) = @_;
  ### Image-Base-Imager line: @_
  $self->{'-imager'}->line (x1 => $x1,
                            y1 => $y1,
                            x2 => $x2,
                            y2 => $y2,
                            color => $colour);
}
sub rectangle {
  my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
  ### Image-Base-Imager rectangle: @_

  $self->{'-imager'}->box (xmin => $x1,
                           ymin => $y1,
                           xmax => $x2,
                           ymax => $y2,
                           color => $colour,
                           filled => $fill);
}

sub ellipse {
  my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
  ### Image-Base-Imager ellipse: "$x1, $y1, $x2, $y2, $colour"

  my $diam = $x2-$x1;
  if (! ($diam & 1) && $y2-$y1 == $diam) {
    ### use circle
    $self->{'-imager'}->circle (x => ($x2+$x1)/2,
                                y => ($y2+$y1)/2,
                                r => $diam/2,
                                color => $colour,
                                filled => $fill);
  } else {
    ### use superclass ellipse
    shift->SUPER::ellipse (@_);
  }
}

sub diamond {
  my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
  ### Image-Base-Imager diamond() ...

  # $imager->polygon() for filled poly is always anti-alias, but don't want
  # that, or not by default, so polyline() for unfilled and Image::Base for
  # filled

  if ($fill) {
    shift->SUPER::diamond(@_);

  } else {
    # 0 1 2 3 4
    # x1=0, x2=4 -> xh=2
    #
    # 0 1 2 3 4 5
    # x1=0, x2=5 -> xh=2
    #
    my $xh = ($x2 - $x1);
    my $yh = ($y2 - $y1);
    my $xeven = ($xh & 1);
    my $yeven = ($yh & 1);
    $xh = int($xh / 2);
    $yh = int($yh / 2);
    ### assert: $x1+$xh == $x2-$xh || $x1+$xh+1 == $x2-$xh
    ### assert: $y1+$yh == $y2-$yh || $y1+$yh+1 == $y2-$yh

    $self->{'-imager'}->polyline (points => [ [$x1+$xh,$y1],  # top centre

                                              # left
                                              [$x1,$y1+$yh],
                                              ($yeven ? [$x1,$y2-$yh] : ()),

                                              # bottom
                                              [$x1+$xh,$y2],
                                              ($xeven ? [$x2-$xh,$y2] : ()),

                                              # right
                                              ($yeven ? [$x2,$y2-$yh] : ()),
                                              [$x2,$y1+$yh],

                                              ($xeven ? [$x2-$xh,$y1] : ()),
                                              ($fill ? () : [$x1+$xh,$y1]),
                                            ],
                                  color => $colour);
  }
}

#------------------------------------------------------------------------------
# colours

sub add_colours {
  my $self = shift;
  ### add_colours: @_
  $self->{'-imager'}->addcolors (colors => \@_);
}


# sub _validate_file_format {
#   my ($format) = @_;
#   if (! defined $format) {
#     return; # undef is ok
#   }
#
#   # in Imager 0.80 'cur' works but isn't in the types lists
#   my $lform = lc($format);
#   foreach my $f ('cur', Imager->read_types, Imager->write_types) {
#     if ($lform eq $f) {
#       return;
#     }
#   }
#
#   croak 'Unrecognised -file_format: ',$format;
# }

1;
__END__