File Coverage

blib/lib/Image/Base/PNGwriter.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

# Copyright 2010, 2011, 2012 Kevin Ryde

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


# Crib notes:
#     ->plot() and in turn everything using that clips to the image size
#     automatically

package Image::Base::PNGwriter;
# Image::Base is good for 5.004 or some such far back, though
# Image::PNGwriter 0.01 requires 5.8.5, so that's the actual minimum.  It
# looks like Image::PNGwriter could probably go earlier, unless maybe it
# needs a new enough xsubpp for C++.
use 5.006;
use strict;
use warnings;
use Carp;
use Image::PNGwriter;

our $VERSION = 8;

# version 1.12 for ellipse() $fill
# version 1.16 for diamond()
use Image::Base 1.12;
our @ISA = ('Image::Base');

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

# Cribs:
#
# /usr/include/pngwriter.h

use constant _DEFAULT_PALETTE => { 'black' => [ 0,0,0 ],
                                   'white' => [ 1,1,1 ] };

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

  # $obj->new(...) means make a copy, with some extra settings
  if (ref $class) {
    # needs the pngwriter copy-constructor ...
    die "Image cloning not yet implemented";
    #     my $self = $class;
    #     $class = ref $class;
    #     if (! defined $params{'-pngwriter'}) {
    #       $params{'-pngwriter'} = $self->get('-pngwriter')->clone;
    #     }
    #     # inherit everything else
    #     %params = (%$self, %params);
  }

  # -palette not yet documented, maybe call it -cindex anyway
  # FIXME: make a per-instance anon hash
  my $self = bless { -palette => _DEFAULT_PALETTE,
                     -zlib_compression => -1,
                   }, $class;
  if (! defined $params{'-pngwriter'}) {
    my $width = delete $params{'-width'};
    if (! defined $width) { $width = 1; }
    my $height = delete $params{'-height'};
    if (! defined $height) { $height = 1; }

    # can't pass undef to Image::PNGwriter->new
    my $filename = $params{'-file'};
    if (! defined $filename) { $filename = ''; }

    # the filename to new() supplied is not read, just recorded in the $pw
    my $pw = $self->{'-pngwriter'}
      = Image::PNGwriter->new ($width, $height,
                               0,  # background
                               $filename);
  }
  my $filename = delete $params{'-file'};

  $self->set (%params);

  if (defined $filename) {
    $self->load ($filename);
  }
  ### $self
  return $self;
}

my %attr_to_get_method = (-width     => 'getwidth',
                          -height    => 'getheight',
                          # these not documented yet ...
                          -bitdepth  => 'getbitdepth',
                          -gamma     => 'getgamma',
                          -colortype => 'getcolortype');
sub _get {
  my ($self, $key) = @_;
  ### Image-Base-PNGwriter _get(): $key
  if (my $method = $attr_to_get_method{$key}) {
    return $self->{'-pngwriter'}->$method;
  }
  ### field: $self->{$key}
  return $self->SUPER::_get ($key);
}

sub set {
  my ($self, %params) = @_;

  if (exists $params{'-pngwriter'}) {
    $self->{'-pngwriter'} = delete $params{'-pngwriter'};
    delete $self->{'-file'};
    delete $self->{'-zlib_compression'};
    delete $self->{'-title'};
    delete $self->{'-author'};
    delete $self->{'-description'};
    delete $self->{'-software'};
  }

  if (exists $params{'-width'} || exists $params{'-height'}) {
    my $width = (exists $params{'-width'}
                 ? delete $params{'-width'}
                 : $self->{'-pngwriter'}->getwidth);
    my $height = (exists $params{'-height'}
                  ? delete $params{'-height'}
                  : $self->{'-pngwriter'}->getheight);
    $self->{'-pngwriter'}->resize ($width, $height);
  }

  # not documented, yet ...
  if (exists $params{'-gamma'}) {
    $self->{'-pngwriter'}->setgamma (delete $params{'-gamma'});
  }

  %$self = (%$self, %params);

  if (exists $params{'-file'}) {
    $self->{'-pngwriter'}->pngwriter_rename ($params{'-file'});
  }
  if (exists $params{'-zlib_compression'}) {
    $self->{'-pngwriter'}->setcompressionlevel ($params{'-zlib_compression'});
  }

  # not documented yet ...
  if (exists $params{'-title'} || exists $params{'-author'} || exists $params{'-description'} || exists $params{'-software'}) {
    $self->{'-pngwriter'}->settext
      (map {defined $params{$_} ? $params{$_} : ''} '-title', '-author', '-description', '-software');
  }
}

#-------------------------------------------------------------------------------
# load/save

sub load {
  my ($self, $filename) = @_;
  if (@_ == 1) {
    $filename = $self->get('-file');
  } else {
    $self->set('-file', $filename);
  }
  $self->{'-pngwriter'}->readfromfile ($filename);
}
sub save {
  my ($self, $filename) = @_;
  if (@_ == 2) {
    $self->set('-file', $filename);
  }
  $self->{'-pngwriter'}->write_png;
}


#-------------------------------------------------------------------------------
# drawing

sub xy {
  my ($self, $x, $y, $colour) = @_;
  ### xy: $x, $y, $colour
  my $pw = $self->{'-pngwriter'};
  $x = int($x);
  $y = int($y);
  $x++;
  $y = $pw->getheight - $y;
  if (@_ == 4) {
    ### plot: $x, $y, $self->colour_to_drgb($colour)
    $pw->plot ($x, $y, $self->colour_to_drgb($colour));
  } else {
    ### dread: $x, $y, $pw->dread($x,$y,1), $pw->dread($x,$y,2), $pw->dread($x,$y,3)
    return sprintf ('#%02X%02X%02X',
                    map {int (255 * $pw->dread($x,$y,$_) + 0.5)} 1,2,3);
  }
}
sub line {
  my ($self, $x1, $y1, $x2, $y2, $colour) = @_;
  my $pw = $self->{'-pngwriter'};
  my $height = $pw->getheight;
  $pw->line ($x1+1, $height-$y1,
             $x2+1, $height-$y2,
             $self->colour_to_drgb($colour));
}
sub rectangle {
  my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
  ### Image-Base-PNGwriter rectangle(): $x1, $y1, $x2, $y2, $colour, $fill

  my $pw = $self->{'-pngwriter'};
  my $height = $pw->getheight;
  my $method = ($fill ? 'filledsquare' : 'square');
  $pw->$method ($x1+1, $height-$y1,
                $x2+1, $height-$y2,
                $self->colour_to_drgb($colour));
}

# Only $pw->circle available, apparently.  For radius 2 it draws something
# like
#
#       O
#      O O
#     O . O
#      O O
#       O
#
# which is x2==x1+4 and y2==y1+4.  The parameters to circle() are integers,
# so only odd number of pixels across like this can be done ($x2-$x1 an even
# number), others go to Image::Base.
#
sub ellipse {
  my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
  ### ellipse(): $x1, $y1, $x2, $y2, $colour, $fill
  my $xr = $x2 - $x1;
  if (! ($xr & 1) && $xr == ($y2 - $y1)) {
    my $pw = $self->{'-pngwriter'};
    $xr /= 2;
    ### $xr
    ### x centre: $x1+$xr
    ### y centre: $pw->getheight() - ($y1+$xr)
    my $method = ($fill ? 'filledcircle' : 'circle');
    $pw->$method ($x1+$xr+1, $pw->getheight() - ($y1+$xr), $xr,
                  $self->colour_to_drgb($colour));
  } else {
    ### plain Image-Base
    shift->SUPER::ellipse(@_);
  }
}

sub diamond {
  my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
  ### diamond(): "$x1,$y1, $x2,$y2, $colour, fill=".($fill||0)
  my $w = $x2 - $x1;
  my $h = $y2 - $y1;
  my $pw = $self->{'-pngwriter'};

  if ($w && $h) {

    ### x centre: $x1+int(($w+1)/2)+1
    ### y centre: $pw->getheight() - ($y1+int($h/2)+1)
    ### $w
    ### $h

    my $method = ($fill ? 'filleddiamond' : 'diamond');
    $pw->$method ($x1+int(($w+1)/2)+1,
                  $pw->getheight() - ($y1+int($h/2)),
                  $w, $h,
                  $self->colour_to_drgb($colour));
  } else {
    # 1xN or Nx1 dubious in PNGwriter 0.5.3, use rectangle instead
    shift->rectangle (@_);
  }
}

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

# not documented, yet ...
sub colour_to_drgb {
  my ($self, $colour) = @_;
  if (exists $self->{'-palette'}->{$colour}) {
    $colour = $self->{'-palette'}->{$colour};
  }
  if (ref $colour) {
    return @$colour;
  }

  # 1 to 4 digit hex, equally spaced from 00 -> 0.0 through FF -> 1.0, or
  # FFFF -> 1.0 etc.
  # Crib: [:xdigit:] matches some wide chars, but hex() as of perl 5.12.4
  # doesn't accept them, so only 0-9A-F
  if ($colour =~ /^#(([0-9A-F]{3}){1,4})$/i) {
    my $len = length($1)/3; # of each group, so 1,2,3 or 4
    my $divisor = hex('F' x $len);
    return (map {hex($_)/$divisor}
            substr ($colour, 1, $len),      # full size groups
            substr ($colour, 1+$len, $len),
            substr ($colour, -$len));
  }

  croak "Unknown colour: $colour";
}

1;
__END__