File Coverage

blib/lib/Image/Base/Gtk2/Gdk/Image.pm

Criterion	Covered	Total	%
statement	15	64	23.4
branch	0	30	0.0
condition	0	17	0.0
subroutine	5	11	45.4
pod	3	5	60.0
total	23	127	18.1

# Copyright 2010, 2011, 2012 Kevin Ryde

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


package Image::Base::Gtk2::Gdk::Image;
use 5.008;
use strict;
use warnings;
use Carp;

our $VERSION = 11;
use base 'Image::Base';

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


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

  # $obj->new(...) means make a copy, with some extra settings
  if (ref $class) {
    croak "Cannot clone a GdkImage yet";
  }

  if (! exists $params{'-gdkimage'}) {
    ### create new GdkImage

    my $image_type = delete $params{'-image_type'} || 'fastest';
    my $visual = delete $params{'-visual'}
      || ($params{'-colormap'} && $params{'-colormap'}->get_visual)
        || Gtk2::Gdk::Visual->get_system;
    ### $image_type
    ### $visual

    $params{'-gdkimage'} = Gtk2::Gdk::Image->new ($image_type,
                                                  $visual,
                                                  delete $params{'-width'},
                                                  delete $params{'-height'});
  }

  my $self = bless {}, $class;
  $self->set (%params);
  ### $self
  return $self;
}

my %attr_to_get_method = (-colormap   => 'get_colormap',
                          -visual     => 'get_visual',
                          -width      => 'get_width',
                          -height     => 'get_height',
                          -depth      => 'get_depth',

                          # not documented yet, maybe a more specific name ...
                          -image_type => 'get_image_type',
                         );
sub _get {
  my ($self, $key) = @_;

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

sub set {
  my ($self, %params) = @_;
  ### Image-GdkImage set(): \%params

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

  if (defined (my $colormap = delete $self->{'-colormap'})) {
    $self->{'-gdkimage'}->set_colormap ($colormap);
  }
  ### set leaves: $self
}

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

sub xy {
  my ($self, $x, $y, $colour) = @_;

  my $gdkimage = $self->{'-gdkimage'};
  unless ($x >= 0
          && $y >= 0
          && $x < $gdkimage->get_width
          && $y < $gdkimage->get_height) {
    ### outside 0,0,width,height ...
    return undef;  # fetch or store
  }

  if (@_ >= 4) {
    ### Image-GdkImage xy: "$x, $y, $colour"
    $gdkimage->put_pixel ($x,$y, $self->colour_to_pixel($colour));
  } else {
    return $self->pixel_to_colour($gdkimage->get_pixel ($x,$y))
  }
}

sub colour_to_pixel {
  my ($self, $colour) = @_;
  ### colour_to_pixel: $colour
  if (defined (my $pixel = $self->{'-colour_to_pixel'})) {
    return $pixel;
  }
  if ($colour =~ /^\d+$/) {
    return $colour;
  }
  if ($colour eq 'set') {
    return 1;
  }
  if ($colour eq 'clear') {
    return 0;
  }

  my $gdkimage = $self->{'-gdkimage'};
  if (my $colormap = $gdkimage->get_colormap) {
    # think parse and rgb_find are client-side operations, no need to cache
    # the results
    #
    my $colorobj = Gtk2::Gdk::Color->parse ($colour)
      || croak "Cannot parse colour: $colour";
    $colormap->rgb_find_color ($colorobj);
    ### rgb_find_color: $colorobj->to_string
    ### pixel: $colorobj->pixel
    return $colorobj->pixel;
  }
  if ($gdkimage->get_depth == 1) {
    if ($colour =~ /^#(000)+$/) {
      return 0;
    } elsif ($colour  =~ /^#(FFF)+$/i) {
      return 1;
    }
  }
  croak "No colormap to interpret colour: $colour";
}

sub pixel_to_colour {
  my ($self, $pixel) = @_;
  ### pixel_to_colour: $pixel
  if (my $colormap = $self->{'-gdkimage'}->get_colormap) {
    my $colorobj = $colormap->query_color($pixel);
    ### in colormap: $colorobj->to_string
    ### pixel: $colorobj->pixel
    return sprintf '#%04X%04X%04X',
      $colorobj->red, $colorobj->green, $colorobj->blue;
  } else {
    return $pixel;
  }
}

1;
__END__