File Coverage

blib/lib/Image/Base/Tk/Photo.pm

Criterion	Covered	Total	%
statement	15	109	13.7
branch	0	58	0.0
condition	0	15	0.0
subroutine	5	17	29.4
pod	7	10	70.0
total	27	209	12.9

# Copyright 2010, 2011, 2012 Kevin Ryde

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


# Tk::Photo
# Tk::Image
# Tk::options  configure(), cget()
#
# Tk::PNG
# Tk::JPEG
# Tk::TIFF
#    loaders

package Image::Base::Tk::Photo;
use 5.004;
use strict;
use Carp;

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

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

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


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

  # $obj->new(...) means make a copy, with some extra settings
  if (ref $class) {
    croak "Cannot clone Image::Base::Tk::Photo";

    #  how to clone a Photo?  how to get its originating widget to create new?
    # my $self = $class;
    # $class = ref $class;
    # if (! defined $params{'-tkphoto'}) {
    #   my $tkphoto = $self->{'-tkphoto'};
    #   my $new_tkphoto = $tkphoto->Photo (map {$_=>$tkphoto->cget($_)}
    #                                      qw(-width -height -gamma -palette));
    #   $new_tkphoto->copy($tkphoto);
    #   $params{'-tkphoto'} = $new_tkphoto;
    # }
    # # inherit everything else
    # %params = (%$self, %params);
    # ### copy params: \%params
  }

  if (! defined $params{'-tkphoto'}) {
    my $for_widget = delete $params{'-for_widget'}
      || croak 'Must have -for_widget to create new Tk::Photo';
    $params{'-tkphoto'} = $for_widget->Photo (-width => $params{'-width'},
                                              -height => $params{'-height'});
  }
  my $self = bless {}, $class;
  $self->set (%params);

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

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

my %attr_to_option = (-width    => '-width',
                      -height   => '-height');
sub _get {
  my ($self, $key) = @_;
  ### Image-Base-Tk-Photo _get(): $key
  if (my $option = $attr_to_option{$key}) {
    ### $option
    return $self->{'-tkphoto'}->cget($option);
  }
  return $self->SUPER::_get ($key);
}

sub set {
  my ($self, %param) = @_;
  ### Image-Base-Tk-Photo set(): \%param

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

  {
    my @configure;
    foreach my $key (keys %param) {
      if (my $option = $attr_to_option{$key}) {
        my $value = delete $param{$key};
        push @configure, $option, $value;
      }
    }
    ### @configure
    if (@configure) {
      $self->{'-tkphoto'}->configure (@configure);
    }
  }

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

sub load {
  my ($self, $filename) = @_;
  ### Image-Base-Tk-Photo load()

  if (@_ == 1) {
    $filename = $self->get('-file');
  } else {
    $self->set('-file', $filename);
  }
  my $tkphoto = $self->{'-tkphoto'};
  $tkphoto->read ($filename);
  $self->set (-file_format => $tkphoto->cget('-format'));
}

# undocumented, untested ...
sub load_string {
  my ($self, $str) = @_;
  ### Image-Base-Tk-Photo load()
  my $tkphoto = $self->{'-tkphoto'};
  $tkphoto->configure (-data => $str);
  $self->set (-file_format => $tkphoto->cget('-format'));
}

my %format_to_module = (png  => 'Tk::PNG',
                        jpeg => 'Tk::JPEG',
                        tiff => 'Tk::TIFF',
                       );
sub _format_use {
  my ($format) = @_;
  if (my $module = $format_to_module{lc($format)}) {
    eval "require $module; 1" or die;
  }
  return $format;
}

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

  # croaks if an error ...
  $tkphoto->write ($filename,
                   -format => _format_use($self->get('-file_format')));
}

# undocumented, untested ...
sub save_fh {
  my ($self, $fh) = @_;
  print $fh $self->save_string;
}

# undocumented, untested ...
sub save_string {
  my ($self, $fh) = @_;
  # croaks if an error ...
  return $self->{'-tkphoto'}->data
    (-format => _format_use($self->get('-file_format')));
}

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

sub xy {
  my ($self, $x, $y, $colour) = @_;
  ### Image-Base-Tk-Photo xy() ...

  # "-to" doesn't allow negative coordinates
  if ($x < 0 || $y < 0) {
    return undef;
  }

  my $tkphoto = $self->{'-tkphoto'};
  if (@_ > 3) {
    if (lc($colour) eq 'none') {
      $tkphoto->transparencySet ($x, $y, 1);
    } else {
      $tkphoto->put ($colour, -to => $x,$y, $x+1,$y+1);
    }
  } else {
    # get() and transparencyGet() don't allow x,y outside photo
    if ($x >= $tkphoto->cget('-width')
        || $y >= $tkphoto->cget('-height')) {
      return undef;
    }

    if ($tkphoto->transparencyGet ($x, $y)) {
      return 'None';
    } else {
      return sprintf ('#%02X%02X%02X', $tkphoto->get ($x, $y));  # r,g,b
    }
  }
}

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

  if ($fill && lc($colour) ne 'none') {
    ### filled rectangle with put() ...

    if ($x2 >= 0 && $y2 >= 0) {
      # "-to" doesn't allow negative coordinates
      if ($x1 < 0) { $x1 = 0; }
      if ($y1 < 0) { $y1 = 0; }

      ### put: "$x1,$y1  ".($x2+1).",".($y2+1)
      $self->{'-tkphoto'}->put ($colour, -to => $x1,$y1, $x2+1,$y2+1);
    }

  } else {
    ### unfilled or transparent rectangle with superclass lines ...
    shift->SUPER::rectangle(@_);
  }
}

sub line {
  my ($self, $x1, $y1, $x2, $y2, $colour) = @_;
  ### Image-Base-Tk-Photo line(): "$x1,$y1, $x2,$y2"

  if (lc($colour) eq 'none') {
    # any transparency by individual xy() pixels (with transparencySet())
    shift->SUPER::line(@_);
    return;
  }

  if ($x1 == $x2) {
    # vertical line by put() rectangle
    if ($x1 < 0) {
      ### vertical line all negative ...
      return;
    }
    if ($y1 > $y2) { ($y1,$y2) = ($y2,$y1) }

  } elsif ($y1 == $y2) {
    # horizontal line by put() rectangle
    if ($y1 < 0) {
      ### horizontal line all negative ...
      return;
    }
    if ($x1 > $x2) { ($x1,$x2) = ($x2,$x1) }

  } else {
    ### sloped line by individual xy() pixels ...
    shift->SUPER::line(@_);
    return;
  }

  # "-to" doesn't allow negative coordinates
  if ($x1 < 0) { $x1 = 0; }
  if ($y1 < 0) { $y1 = 0; }

  ### put(): "$x1,$y1, ".($x2+1).",".($y2+1)
  $self->{'-tkphoto'}->put ($colour, -to => $x1,$y1, $x2+1,$y2+1);
}

1;
__END__