File Coverage

blib/lib/Image/Base/Imlib2.pm

Criterion	Covered	Total	%
statement	8	10	80.0
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	12	14	85.7

# Copyright 2011 Kevin Ryde

# This file is part of Image-Base-Imlib2.
#
# Image-Base-Imlib2 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-Imlib2 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-Imlib2.  If not, see .


package Image::Base::Imlib2;
BEGIN { require 5 }
use strict;
use Carp;
use Image::Imlib2 ();

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

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

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


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

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

  if (! defined $params{'-imlib'}) {
    my $width  = delete $params{'-width'};
    my $height = delete $params{'-height'};

    # same 256 default as Image::Imlib2->new() itself
    if (! defined $width) { $width = 256; }
    if (! defined $height) { $height = 256; }

    $params{'-imlib'} = Image::Imlib2->new ($width, $height);
  }
  my $self = bless {}, $class;
  $self->set (%params);

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

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


my %attr_to_get_method = (-width       => 'width',
                          -height      => 'height',
                          -file_format => sub {
                            croak "Cannot get -file_format (write-only)";
                          },
                         );
sub _get {
  my ($self, $key) = @_;
  ### Image-Base-Imlib2 _get(): $key

  my $method;
  if ($method = $attr_to_get_method{$key}) {
    ### $method
    ### is: $self->{'-imlib'}->$method
    return $self->{'-imlib'}->$method();
  }
  return $self->SUPER::_get ($key);
}

my %attr_to_method = (-quality_percent => 'set_quality',
                      -file_format     => sub {
                        my ($imlib, $format) = @_;
                        # Imlib2 expects lower case "png" etc, allow upper
                        # "PNG" for -file_format too.
                        if ($format) {
                          $format = lc($format);
                        }
                        $imlib->image_set_format ($format);
                      },
                     );
sub set {
  my ($self, %param) = @_;
  ### Image-Base-Imlib2 set(): \%param

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

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

  {
    my $key;
    foreach $key (keys %param) {
      my $method;
      if ($method = $attr_to_method{$key}) {
        $imlib->$method($param{$key});
      }
    }
  }

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

sub load {
  my ($self, $filename) = @_;
  ### Image-Base-Imlib2 load(): @_
  if (@_ == 1) {
    $filename = $self->get('-file');
  } else {
    $self->set('-file', $filename);
  }
  $self->{'-imlib'} = Image::Imlib2->load ($filename);

  ### imlib: $self->{'-imlib'}
  ### size: $self->{'-imlib'}->width.'x'.$self->{'-imlib'}->height
}

sub save {
  my ($self, $filename) = @_;
  ### Image-Base-Imlib2 save(): @_
  if (@_ == 2) {
    $self->set('-file', $filename);
  } else {
    $filename = $self->get('-file');
  }
  ### $filename

  $self->{'-imlib'}->save ($filename);
}

sub _set_colour {
  my ($self, $colour) = @_;
  my $imlib = $self->{'-imlib'};

  if ($colour eq 'None') {
    $imlib->set_color (0,0,0,0);

  } elsif ($colour =~ /^#(([0-9A-F]{3}){1,4})$/i) {
    my $len = length($1)/3; # of each group, so 1,2,3 or 4
    $imlib->set_color
      ((map {hex(substr($_ x 2, 0, 2))}  # first 2 chars of replicated
        substr ($colour, 1, $len),      # full groups
        substr ($colour, 1+$len, $len),
        substr ($colour, -$len)),
       255); # alpha
  } else {
    croak "Unrecognised colour: $colour";
  }
  return $imlib;
}


sub xy {
  my ($self, $x, $y, $colour) = @_;
  ### Image-Base-Imlib2 xy: $x,$y,$colour
  my $imlib = $self->{'-imlib'};
  if (@_ == 4) {
    _set_colour($self,$colour)->draw_point ($x, $y);

  } else {
    my ($r,$g,$b,$a) = $imlib->query_pixel ($x, $y);
    ### rgba: "$r,$g,$b,$a"
    if ($a == 0) {
      return 'None';
    }
    return sprintf ('#%02X%02X%02X', $r, $g, $b);
  }
}
sub line {
  my ($self, $x1, $y1, $x2, $y2, $colour) = @_;
  ### Image-Base-Imlib2 line: @_
  _set_colour($self,$colour)->draw_line ($x1,$y1, $x2,$y2);
}
sub rectangle {
  my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
  ### Image-Base-Imlib2 rectangle: @_

  my $method = ($fill ? 'fill_rectangle' : 'draw_rectangle');
  _set_colour($self,$colour)->$method ($x1,$y1,
                                       $x2-$x1+1,
                                       $y2-$y1+1);
}

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

  my $imlib = _set_colour($self,$colour);

  # 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);

  # Imlib2 1.4.4 does something fishy in draw_polygon() for a 1-high shape,
  # ie. y1==y2, ending up not drawing the right half of the shape.
  $fill ||= ($yh == 0);

  my $xeven = ($xh & 1);
  my $yeven = ($yh & 1);
  $xh = int($xh / 2);
  $yh = int($yh / 2);
  ### $xh
  ### $yh
  ### top lo: $x1+$xh
  ### top hi: $x2-$xh

  my $poly = Image::Imlib2::Polygon->new;

  # top centre
  $poly->add_point ($x1+$xh,$y1);

  # left
  $poly->add_point ($x1,$y1+$yh);
  if ($yeven) { $poly->add_point ($x1,$y2-$yh); }

  # bottom
  $poly->add_point ($x1+$xh,$y2);
  if ($xeven) { $poly->add_point ($x2-$xh,$y2); }

  # right
  if ($yeven) { $poly->add_point ($x2,$y2-$yh); }
  $poly->add_point ($x2,$y1+$yh);

  # top again
  if ($xeven) { $poly->add_point ($x2-$xh,$y1); }

  if ($fill) {
    $poly->fill;
  } else {
    $imlib->draw_polygon ($poly, 1);
  }
}

# sub ellipse {
#   my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
#   ### Image-Base-Imlib2 ellipse: "$x1, $y1, $x2, $y2, $colour"
#
#   my $a = $x2 - $x1;
#   my $b = $y2 - $y1;
#   ### diameters ...
#   ### $a
#   ### $b
#
#     shift->SUPER::ellipse(@_);
#
#   # if (($a & 1) || ($b & 1)) {
#   #
#   # } else {
#   #   $a = $a/2;
#   #   $b = $b/2;
#   #   ### centre: $x1+$a, $y1+$b
#   #   ### $a
#   #   ### $b
#   #   my $method = ($fill ? 'fill_ellipse' : 'draw_ellipse');
#   #   _set_colour($self,$colour)->$method ($x1 + $a,
#   #                                        $y1 + $b,
#   #                                        $a, $b);
#   # }
# }

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


1;
__END__