view release on metacpan or  search on metacpan

lib/App/MathImage/Tk/Drawing.pm  view on Meta::CPAN

# Copyright 2011, 2012, 2013 Kevin Ryde

# This file is part of Math-Image.
#
# Math-Image 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.
#
# Math-Image 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 Math-Image.  If not, see <http://www.gnu.org/licenses/>.

package App::MathImage::Tk::Drawing;
use 5.008;
use strict;
use warnings;
use Tk;
use Image::Base::Tk::Photo;
use App::MathImage::Tk::Perl::WeakAfter;

use base 'Tk::Derived', 'Tk::Label';
Tk::Widget->Construct('AppMathImageTkDrawing');

our $VERSION = 110;

sub ClassInit {
  my ($class, $mw) = @_;
  ### ClassInit(): $class
  $class->SUPER::ClassInit($mw);
  # event handlers for all instances
  $mw->bind($class,'<Expose>',\&_do_expose);
  $mw->bind($class,'<Configure>',\&queue_reimage);
  $mw->bind($class,'<Button-1>', ['DragStart', Ev('x'), Ev('y')]);
  $mw->bind($class,'<B1-Motion>', ['DragMotion', Ev('x'), Ev('y')]);
  $mw->bind($class,'<MouseWheel>', ['MouseWheel', Ev('delta'), Ev('s')]);
  $mw->bind($class,'<Button-4>', ['MouseWheel', 120, Ev('s')]);
  $mw->bind($class,'<Button-5>', ['MouseWheel', -120, Ev('s')]);
}

sub Populate {
  my ($self, $args) = @_;
  ### Drawing Populate(): $args

  my %args = (-background         => 'black',
              -foreground         => 'white',
              -activebackground   => 'black',
              -activeforeground   => 'white',
              -disabledforeground => 'white',
              -borderwidth        => 0, # default

              # must initial -image so that Tk::Label -width and -height are
              # interpreted as pixels, not lines/columns
              -image  => $self->Photo (-width => 1, -height => 1),
              -width  => 1, # desired size any size, not from -image
              -height => 1,

              %$args,
             );
  $self->SUPER::Populate(\%args);

  ### background: $self->cget('-background')
  ### borderwidth: $self->cget('-borderwidth')
  $self->{'dirty'} = 1;
  $self->{'aft'} = App::MathImage::Tk::Perl::WeakAfter->new;
}

sub destroy {
  my ($self) = @_;
  ### Drawing destroy() ...
  if (my $image = $self->cget('-image')) {
    $self->configure('-image',undef);
    $image->delete;
  }
  shift->SUPER::destroy(@_);
}
# sub DESTROY {
#   my ($self) = @_;
#   ### Drawing DESTROY() ...
#   shift->SUPER::DESTROY(@_);
# }