File Coverage

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

Criterion	Covered	Total	%
statement	15	112	13.3
branch	0	68	0.0
condition	0	38	0.0
subroutine	5	17	29.4
pod	9	10	90.0
total	29	245	11.8

# 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::Canvas
# Tk::options  configure(), cget()
#

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

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

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

$VERSION = 3;

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

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

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

    # my $self = $class;
    # $class = ref $class;
    # if (! defined $params{'-tkcanvas'}) {
    #   $params{'-tkcanvas'} = $self->get('-tkcanvas')->copy;
    # }
    # # inherit everything else
    # %params = (%$self, %params);
    # ### copy params: \%params
  }

  if (! defined $params{'-tkcanvas'}) {
    my $for_widget = delete $params{'-for_widget'}
      || croak 'Must have -for_widget to create new Tk::Canvas';
    $params{'-tkcanvas'} = $for_widget->Canvas
      ((exists $params{'-width'} ? (-width => $params{'-width'}) : ()),
       (exists $params{'-height'} ? (-height => $params{'-height'}) : ()))->pack;
  }
  my $self = bless { -file_format => "eps" }, $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-Canvas _get(): $key
  if (my $option = $attr_to_option{$key}) {
    ### $option
    return $self->{'-tkcanvas'}->cget($option);
  }
  return $self->SUPER::_get ($key);
}

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

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

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

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

sub load {
  my ($self, $filename) = @_;
  ### Image-Base-Tk-Canvas load()
  croak "Cannot load into canvas";
}

my %format_to_module = (fig  => 'Tk::CanvasFig');
my %format_to_method = (eps  => 'postscript',
                        fig  => 'fig');
sub _format_use {
  my ($format) = @_;
  if (! defined $format) { $format = "eps"; }
  $format = lc($format);
  if (my $module = $format_to_module{$format}) {
    eval "require $module; 1" or die;
  }
  return $format;
}

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

  my $format = _format_use($self->get('-file_format'));
  my $tkcanvas = $self->{'-tkcanvas'};
  if ($format eq 'fig') {
    $tkcanvas->fig (-file => $filename);
  } else {
    my $ret = $tkcanvas->postscript (-file => $filename);
    if (defined $ret) {
      croak $ret;
    }
  }
}

# undocumented ...
sub save_string {
  my ($self, $filename) = @_;
  ### Image-Base-Tk-Canvas save()
  return $self->{'-tkcanvas'}->postscript;
}

#------------------------------------------------------------------------------

my %anchor_is_xcentre = (n => 1, centre => 1, s => 1);
my %anchor_is_xright = (ne => 1, e => 1, se => 1);
my %anchor_is_ycentre = (w => 1, centre => 1, e => 1);
my %anchor_is_ybot = (sw => 1, s => 1, se => 1);

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

  my $tkcanvas = $self->{'-tkcanvas'};
  if (@_ > 3) {
    $tkcanvas->createRectangle($x,$y, $x+1,$y+1,
                               -fill => $colour,
                               -width => 0); # outline width
  } else {
    my $item = ($tkcanvas->find('overlapping',$x,$y,$x,$y))[0];
    if (! defined $item) {
      ### no overlapping item, return background: $tkcanvas->cget('-background')
      return $tkcanvas->cget('-background');
    }
    my $type = $tkcanvas->type($item);
    ### $item
    ### $type
    # FIXME: look at -activefill etc according to state
    if ($type eq 'rectangle' || $type eq 'oval' || $type eq 'polygon'
        || $type eq 'arc') {
      # FIXME: to do this properly would have to check if x,y is on the
      # outline, according to the width, or the fill area
      return (scalar($tkcanvas->itemcget($item,'-fill'))
              || scalar($tkcanvas->itemcget($item,'-outline')));
    }
    if ($type eq 'line' || $type eq 'text') {
      return scalar($tkcanvas->itemcget($item,'-fill'));
    }
    if ($type eq 'window') {
      my ($wx,$wy) = $tkcanvas->coords($item);
      ### $wx
      ### $wy
      my $widget = $tkcanvas->itemcget($item,'-window');
      my $width = $tkcanvas->itemcget($item,'-width') || $widget->reqwidth;
      my $height = $tkcanvas->itemcget($item,'-height') || $widget->reqheight;

      # change wx,wy to its top-left corner according to anchor
      my $anchor = $tkcanvas->itemcget($item,'-anchor');
      if ($anchor_is_xright{$anchor}) {
        $wx -= $width-1;
      } elsif ($anchor_is_xcentre{$anchor}) {
        $wx -= int(($width-1)/2);
      }
      if ($anchor_is_ybot{$anchor}) {
        $wy -= $height-1;
      } elsif ($anchor_is_ycentre{$anchor}) {
        $wy -= int(($height-1)/2);
      }

      # change x,y to a position within the $widget
      $x -= $wx;
      $y -= $wy;

      ### $anchor
      ### $wx
      ### $wy
      ### $width
      ### $height
      ### $x
      ### $y
      ### id: $widget->id
      if ($x < 0 || $y < 0 || $x >= $width || $y >= $height) {
        ### oops, why does overlapping give an out-of-range ? ...
        return undef;
      }
      $widget->update;
      require Tk::WinPhoto;
      my $photo = $widget->Photo (-format => 'window',
                                  -data => oct($widget->id));
      #      $photo->write ('/tmp/x.png', -format => 'xpm');
      ### rgb: $photo->get($x,$y)
      return sprintf ('#%02X%02X%02X', $photo->get ($x, $y));  # r,g,b
    }
    # if ($type eq 'image') {
    #   # copy Tk::Image to Tk::Photo to get its pixels, maybe ...
    # }
    # if ($type eq 'grid') {
    #   # but never occurs as an "overlapping", or something ...
    # }
    # if ($type eq 'bitmap') {
    #   # either its -background or -foreground ...
    # }
    return undef;
  }
}

# lower and right edges are excluded when filled, per X11 style
sub rectangle {
  my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
  ### Image-Base-Tk-Canvas rectangle() ...

  $self->{'-tkcanvas'}->createRectangle($x1,$y1, $x2,$y2,
                                        -outline => $colour,
                                        ($fill ? (-fill => $colour) : ()));
}
sub ellipse {
  my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
  ### Image-Base-Tk-Canvas ellipse() ...

  # seems that a 1xN or Nx1 pixel unfilled doesn't draw anything, so go filled
  $fill ||= ($x1 == $x2 || $y1 == $y2);
  $self->{'-tkcanvas'}->createOval($x1,$y1, $x2,$y2,
                                   -outline => $colour,
                                   ($fill ? (-fill => $colour) : ()));
}

sub line {
  my ($self, $x1, $y1, $x2, $y2, $colour) = @_;

  # must have 'projecting' to ensure the bottom right pixel drawn, per X style
  $self->{'-tkcanvas'}->createLine($x1,$y1, $x2,$y2,
                                   -fill => $colour,
                                   -capstyle => 'projecting');
}

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

  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+$xeven == $x2-$xh
  ### assert: $y1+$yh+$yeven == $y2-$yh

  # my $xh = ($x2 - $x1 + 1);
  # my $yh = ($y2 - $y1 + 1);
  # my $xeven = ! ($xh & 1);
  # my $yeven = ! ($yh & 1);
  # $xh = int($xh / 2);
  # $yh = int($yh / 2);

  my $method = ($fill ? 'createPolygon' : 'createLine');
  $self->{'-tkcanvas'}->$method ($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)),

                                 -fill => $colour,
                                 ($fill ? (-outline => $colour) : ()));
}

1;
__END__