view release on metacpan or  search on metacpan

lib/Tk/FlatCheckbox.pm  view on Meta::CPAN

# -*- perl -*-

#
# $Id: FlatCheckbox.pm,v 1.3 2007/10/19 20:55:38 eserte Exp $
# Author: Slaven Rezic
#
# Copyright (C) 1998,2001,2002,2007 Slaven Rezic. All rights reserved.
# This package is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Mail: srezic@cpan.org
# WWW:  http://www.rezic.de/eserte/
#

# XXX borderwidth ist krampfig ... check it

package Tk::FlatCheckbox;
use Tk::Derived;
use Tk::Canvas;
use strict;
use vars qw($VERSION @ISA);
@ISA = qw(Tk::Derived Tk::Canvas);
Construct Tk::Widget 'FlatCheckbox';

$VERSION = '0.08';

my %trace;
my %trace_rev;

sub ClassInit
{
 my ($class,$mw) = @_;
 $mw->bind($class,"<1>", "Invoke");
 $mw->bind($class,"<space>", "Invoke");
 $mw->bind($class,"<Enter>", "Enter");
 $mw->bind($class,"<Leave>", "Leave");
 return $class;
}

sub Populate {
    my($w, $args) = @_;
    if ($args->{-borderwidth}) {
	$w->{Configure}{borderwidth} = delete $args->{-borderwidth};
    }
    $w->{Configure}{borderwidth} = 2;#XXXXX
    $w->ConfigSpecs
      (
       #-borderwidth => ['METHOD', 'borderWidth', 'BorderWidth', 30],#XXX
       -image        => ['METHOD', 'image', 'Image', undef],
       -variable     => ['METHOD', 'variable', 'Variable', undef],
       -command      => ['CALLBACK', 'command', 'Command', undef],
       -state        => ['PASSIVE', 'state', 'State', 'active'], #XXX
       -text         => ['METHOD', 'text', 'Text', undef],
       '-font'       => ['PASSIVE', 'font', 'Font', undef],
       -raiseonenter => ['PASSIVE', 'raiseOnEnter', 'RaiseOnEnter', 0],
       -onvalue      => ['PASSIVE', 'onValue', 'Value', 1],
       -offvalue     => ['PASSIVE', 'offValue', 'Value', 0],
      );
}

sub ConfigChanged {
    my($w, $args) = @_;

    # XXX hack
    if ($args->{'-raiseonenter'}) {
	$w->Tk::Canvas::configure(-borderwidth => 2);
    }
}

sub QueueLayout {
    my($w, @args) = @_;
    $w->afterIdle([@args]);
}

sub _set_image {
    my($w) = @_;
    $w->delete('image');
    my $img = $w->{Configure}{'image'};
    return if !defined $img;
    $w->configure(-width => $img->width + $w->_get_bd*2,
		  -height => $img->height + $w->_get_bd*2
		 );