# -*- perl -*-

#
# $Id: FlatCheckbox.pm,v 1.11 2004/10/02 08:49:21 eserte Exp $
# Author: Slaven Rezic
#
# Copyright (C) 1998,2001,2002 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: slaven@rezic.de
# WWW:  http://user.cs.tu-berlin.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.06';

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
		 );
    $w->{'_ImageX'} = 1 + $w->{Configure}{borderwidth};
    $w->{'_ImageY'} = 1 + $w->{Configure}{borderwidth};
    $w->createImage($w->{'_ImageX'}, $w->{'_ImageY'},
		    -anchor => 'nw', -image => $img,
		    -tags => ['image', 'content']);
}

sub image {
    my($w, $img) = @_;
    if (@_ >= 2) {
	$w->{Configure}{'image'} = $img;
	$w->QueueLayout($w, '_set_image');
    }
    $w->{Configure}{'image'};
}

sub text {
    my($w, $text) = @_;
    if (@_ < 2) {
	$w->{Configure}{'text'};
    } else {
	$w->delete('text');
	return if !defined $text;
	$w->{Configure}{'text'} = $text;
	$w->QueueLayout($w, '_draw_text');
    }
}

sub font {
    my($w, $font) = @_;
    if (@_ < 2) {
	$w->{Configure}{'font'};
    } else {
	$w->{Configure}{'font'} = $font;
	$w->draw_text;
    }
}

sub _draw_text {
    my $w = shift;
    my $font = $w->{Configure}{'font'};
    my $text = $w->{Configure}{'text'};
    if (!defined $font) {
	my $dummy = $w->createText(0,0);
	$font = $w->{Configure}{'font'} = $w->itemcget($dummy, '-font');
	$w->delete($dummy);
    }
    my $string_width = $w->fontMeasure($font, $text);
    $w->configure(-width => $string_width + $w->_get_bd*2,
		  -height => $w->fontMetrics($font, -ascent) +
		             $w->fontMetrics($font, -descent) + $w->_get_bd*2,
		 );
    $w->{'_ImageX'} = 1 + $w->{Configure}{borderwidth};
    $w->{'_ImageY'} = 1 + $w->{Configure}{borderwidth};
    $w->createText($w->{'_ImageX'}, $w->{'_ImageY'},
		   -anchor => 'nw', -text => $text, '-font' => $font,
		   -tags => ['text', 'content']);
}

sub variable {
    my($w, $varref) = @_;
    if (@_ < 2) {
	$w->{Configure}{'variable'};
    } else {
	eval {
	    require Tie::Watch;
	};
	if (!$@) {
	    my $watch = $trace{$varref};
	    if (!$watch) {
		$watch = new Tie::Watch
		    -variable => $varref,
		    -store => sub { _store_scalar(@_) };
		$trace_rev{$watch} = [$w];
		$trace{$varref} = $watch;
	    } else {
		if (!grep { $_ eq $w } @{ $trace_rev{$watch} }) {
		    push @{ $trace_rev{$watch} }, $w;
		}
	    }
	} else {
	    warn "Can't find Tie::Watch --- tie of variables will not work";
	}
	$w->{Configure}{'variable'} = $varref;
	$w->afterIdle(sub { $w->_update_state });
    }
}

sub _get_bd {
    my $w = shift;
    if ($w->cget(-raiseonenter)) {
	0;
    } else {
	$w->{Configure}{borderwidth};
    }
}

# XXX really a specilized Tie::Watch method
sub _store_scalar {
    my($self, $newval) = @_;
    $self->Store($newval);
    foreach my $w (@{ $trace_rev{$self} }) {
	$w->_update_state if $w && Tk::Exists($w);
    }
}

sub _update_state {
    my $w = shift;
    my $varref = $w->{Configure}{'variable'};
    if (!defined $varref) {
	$w->{Configure}{'state'} = 0;
    } elsif (defined $$varref) {
	$w->{Configure}{'state'} = $$varref eq $w->cget(-onvalue);
    }
    $w->DrawCheck;
}

sub DrawCheck {
    my $w = shift;
    if ($w->{Configure}{'state'}) {
#  	my $img = $w->{Configure}{'image'};
#  	if (defined $img) {
#  	    $w->createRectangle($w->{'_ImageX'} + $img->width-5,
#  				$w->{'_ImageY'} + $img->height-5,
#  				$w->{'_ImageX'} + $img->width,
#  				$w->{'_ImageY'} + $img->height,
#  				-outline => undef, -fill => 'red',
#  				-tags => 'check');
#	}
	my $item = ($w->find("withtag", "content"))[0];
	if (defined $item) {
	    my(@bbox) = $w->bbox($item);
	    $w->createRectangle($bbox[2]-5, $bbox[3]-5,
				$bbox[2], $bbox[3],
				-outline => undef, -fill => 'red',
				-tags => 'check');
	}
    } else {
	$w->delete('check');
    }
}

sub invoke {
    my $w = shift;
    $w->{Configure}{'state'} = ($w->{Configure}{'state'} ? 0 : 1);
    if ($w->cget('-variable')) {
	$ {$w->cget('-variable')} = $w->{Configure}{'state'} ? $w->cget(-onvalue) : $w->cget(-offvalue);
    }
    $w->DrawCheck;
    if (defined $w->cget(-command)) {
	$w->Callback(-command);
    }
}

sub bind {
    shift->Tk::bind(@_);
}

# sub borderwidth {
#     my $w = shift;
#     if (@_) {
# 	$w->{Configure}{'borderwidth'} = shift;
#     }
#     $w->{Configure}{'borderwidth'};
# }

sub Invoke {
    my $w = shift;
    $w->invoke() unless($w->cget("-state") eq "disabled");
}

sub Enter {
    my $w = shift;
    if ($w->cget(-raiseonenter)) {
	$w->configure(-relief => "raised");
    } else {
	$w->{"_OrigBG_"} = $w->cget(-bg) unless defined $w->{"_OrigBG_"};
	$w->configure(-bg => Tk::ACTIVE_BG);
    }
}

sub Leave {
    my $w = shift;
    if ($w->cget(-raiseonenter)) {
	$w->configure(-relief => "flat");
    } else {
	if (defined $w->{"_OrigBG_"}) {
	    $w->configure(-bg => $w->{"_OrigBG_"});
	    delete $w->{"_OrigBG_"};
	}
    }
}

1;