package ATR::Tk::UpdateFieldButton;

use strict;
use warnings;
use base qw(ATR::Tk::UpdateField Tk::Button);
Tk::Widget->Construct('UFButton');

use Tk::Button;

=head1 NAME

ATR::Tk::UpdateFieldButton - clickable data-tracking widget

=head1 DESCRIPTION

=cut

# $Id: UpdateFieldButton.pm,v 1.10 2005/03/02 13:35:35 mca Exp $

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

sub accessorsChanged {
    my $self = shift;

    my $haveClick = $self->data->hasCallback('click');
    $self->configure(-command => [ $self, 'ufClick' ],
		     -state => $haveClick ? 'normal' : 'disabled');
}

sub atrPopulatePost {
    my ($self, $args) = @_;

    # No idea why the default for this is not adequate: same problem
    # as SITk::Status, UpdateFieldButton, UpdateFieldEntry
    $self->ConfigSpecs(-foreground => [ 'SELF', 'Foreground', 'foreground', 'black'],
		       -justify    => [ 'SELF', 'justify', 'Justify', 'left' ], # XXX: Tk::Button does not honour this
		      );

    $self->SUPER::atrPopulatePost($args);
}


sub normalcolour { return "#d9d9d9" } # the default button grey

sub get {
    my $self = shift;
    my $tv = $self->cget('-textvariable');
    return $tv ? $$tv : $self->cget('-text');
}

sub set {
    my ($self, $text) = @_;
    my $tv = $self->cget('-textvariable');
    if ($tv) {
	$$tv = $text;
    } else {
	$self->configure(-text => $text);
    }
}


#----------------------------------------------------------------------------
#
# Pop-up menu support

sub popMenu {
    my ($self, %menuSetup) = @_;

    # Propagate the font down cascade menus (stack-based tree scan)
    my @items;
    @items = @{ $menuSetup{-menuitems} } if $menuSetup{-menuitems};
    my $font = $self->getFont('furniture');
    while (@items) {
	my $menuItem = shift @items;
	my %item = @$menuItem;
	push @$menuItem, (-font => $font) if !defined $item{-font};

	next unless $menuItem->[0] eq 'Cascade';
	push @items, @{ $item{-menuitems} } if $item{-menuitems};
	# If we have too many @items, we're probably traversing a loop
	die "Failed to set fonts on deep menu structure" if @items > 10000;
    }

    my $menu = $self->Menu(%menuSetup);

    # Destroying the menu when it unposts seems to be non-trivial,
    # so instead I destroy it when the next is posted anywhere in the same toplevel
    my $P = $self->toplevel->privateData;
    my $old_menu = $P->{menu};
    $old_menu->destroy if Tk::Exists($old_menu);
    $P->{menu} = $menu;

    $menu->Popup(-popover => $self, # or 'cursor'
		 -popanchor => 'nw', -overanchor => 'ne');

    return $menu;
}

1;
