tools/perl-5.8.0/lib/site_perl/5.8.0/sun4-solaris/Tk/BrowseEntry.pm

#
# BrowseEntry is a stripped down version of ComboBox.tcl from Tix4.0

package Tk::BrowseEntry;

use vars qw($VERSION);
$VERSION = '3.030'; # $Id: //depot/Tk8/Tixish/BrowseEntry.pm#30 $

use Tk qw(Ev);
use Carp;
use strict;

require Tk::Frame;
require Tk::LabEntry;

use base qw(Tk::Frame);
Construct Tk::Widget 'BrowseEntry';

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

    $w->SUPER::Populate($args);

    # entry widget and arrow button
    my $lpack = delete $args->{-labelPack};
    if (not defined $lpack) {
        $lpack = [-side => 'left', -anchor => 'e'];
    }
    my $var = "";
    my $e = $w->LabEntry(-labelPack => $lpack,
                         -label => delete $args->{-label},
                         -textvariable => \$var,);
    my $b = $w->Button(-bitmap => '@' . Tk->findINC('cbxarrow.xbm'));
    $w->Advertise('entry' => $e);
    $w->Advertise('arrow' => $b);
    $b->pack(-side => 'right', -padx => 1);
    $e->pack(-side => 'right', -fill => 'x', -expand => 1, -padx => 1);

    # popup shell for listbox with values.
    my $c = $w->Toplevel(-bd => 2, -relief => 'raised');
    $c->overrideredirect(1);
    $c->withdraw;
    my $sl = $c->Scrolled( qw/Listbox -selectmode browse -scrollbars oe/ );
    $w->Advertise('choices' => $c);
    $w->Advertise('slistbox' => $sl);
    $sl->pack(-expand => 1, -fill => 'both');

    # other initializations
    $w->SetBindings;
    $w->{'popped'} = 0;
    $w->Delegates('insert' => $sl, 'delete' => $sl, get => $sl, DEFAULT => $e);
    $w->ConfigSpecs(
        -listwidth   => [qw/PASSIVE  listWidth   ListWidth/,   undef],
        -listcmd     => [qw/CALLBACK listCmd     ListCmd/,     undef],
        -browsecmd   => [qw/CALLBACK browseCmd   BrowseCmd/,   undef],
        -choices     => [qw/METHOD   choices     Choices/,     undef],
        -state       => [qw/METHOD   state       State         normal/],
        -arrowimage  => [ {-image => $b}, qw/arrowImage ArrowImage/, undef],
        -variable    => '-textvariable',
        -colorstate  => [qw/PASSIVE  colorState  ColorState/,  undef],
        -command     => '-browsecmd',
        -options     => '-choices',
        DEFAULT      => [$e] );
}

sub SetBindings {
    my ($w) = @_;

    my $e = $w->Subwidget('entry');
    my $b = $w->Subwidget('arrow');

    # set bind tags
    $w->bindtags([$w, 'Tk::BrowseEntry', $w->toplevel, 'all']);
    $e->bindtags([$e, $e->toplevel, 'all']);

    # bindings for the button and entry
    $b->bind('<1>',[$w,'BtnDown']);
    $b->toplevel->bind('<ButtonRelease-1>',[$w,'ButtonHack']);
    $b->bind('<space>',[$w,'space']);

    # bindings for listbox
    my $sl = $w->Subwidget('slistbox');
    my $l = $sl->Subwidget('listbox');
    $l->bind('<ButtonRelease-1>',[$w,'ListboxRelease',Ev('x'),Ev('y')]);
    $l->bind('<Escape>' => [$w,'LbClose']);
    $l->bind('<Return>' => [$w,'Return',$l]);

    # allow click outside the popped up listbox to pop it down.
    $w->bind('<1>','BtnDown');
}

sub space
{
 my $w = shift;
 $w->BtnDown;
 $w->{'savefocus'} = $w->focusCurrent;
 $w->Subwidget('slistbox')->focus;
}


sub ListboxRelease
{
 my ($w,$x,$y) = @_;
 $w->ButtonHack;
 $w->LbChoose($x, $y);
}

sub Return
{
 my ($w,$l) = @_;
 my($x, $y) = $l->bbox($l->curselection);
 $w->LbChoose($x, $y)
}


sub BtnDown {
    my ($w) = @_;
    return if $w->cget( '-state' ) eq 'disabled';

    if ($w->{'popped'}) {
        $w->Popdown;
        $w->{'buttonHack'} = 0;
    } else {
        $w->PopupChoices;
        $w->{'buttonHack'} = 1;
    }
}

sub PopupChoices {
    my ($w) = @_;

    if (!$w->{'popped'}) {
       $w->Callback(-listcmd => $w);
        my $e = $w->Subwidget('entry');
        my $c = $w->Subwidget('choices');
        my $s = $w->Subwidget('slistbox');
        my $a = $w->Subwidget('arrow');
        my $y1 = $e->rooty + $e->height + 3;
        my $bd = $c->cget(-bd) + $c->cget(-highlightthickness);
        my $ht = $s->reqheight + 2 * $bd;
        my $x1 = $e->rootx;
        my ($width, $x2);
        if (defined $w->cget(-listwidth)) {
            $width = $w->cget(-listwidth);
            $x2 = $x1 + $width;
        } else {
            $x2 = $a->rootx + $a->width;
            $width = $x2 - $x1;
        }
        my $rw = $c->reqwidth;
        if ($rw < $width) {
            $rw = $width
        } else {
            if ($rw > $width * 3) {
                $rw = $width * 3;
            }
            if ($rw > $w->vrootwidth) {
                $rw = $w->vrootwidth;
            }
        }
        $width = $rw;

        # if listbox is too far right, pull it back to the left
        #
        if ($x2 > $w->vrootwidth) {
            $x1 = $w->vrootwidth - $width;
        }

        # if listbox is too far left, pull it back to the right
        #
        if ($x1 < 0) {
            $x1 = 0;
        }

        # if listbox is below bottom of screen, pull it up.
        my $y2 = $y1 + $ht;
        if ($y2 > $w->vrootheight) {
            $y1 = $y1 - $ht - ($e->height - 5);
        }

        $c->geometry(sprintf('%dx%d+%d+%d', $rw, $ht, $x1, $y1));
        $c->deiconify;
        $c->raise;
        $e->focus;
        $w->{'popped'} = 1;

        $c->configure(-cursor => 'arrow');
        $w->grabGlobal;
    }
}

# choose value from listbox if appropriate
sub LbChoose {
    my ($w, $x, $y) = @_;
    my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
    if ((($x < 0) || ($x > $l->Width)) ||
        (($y < 0) || ($y > $l->Height))) {
        # mouse was clicked outside the listbox... close the listbox
        $w->LbClose;
    } else {
        # select appropriate entry and close the listbox
        $w->LbCopySelection;
       $w->Callback(-browsecmd => $w, $w->Subwidget('entry')->get);
    }
}

# close the listbox after clearing selection
sub LbClose {
    my ($w) = @_;
    my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
    $l->selection('clear', 0, 'end');
    $w->Popdown;
}

# copy the selection to the entry and close listbox
sub LbCopySelection {
    my ($w) = @_;
    my $index = $w->LbIndex;
    if (defined $index) {
        $w->{'curIndex'} = $index;
        my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
        my $var_ref = $w->cget( '-textvariable' );
        $$var_ref = $l->get($index);
        if ($w->{'popped'}) {
            $w->Popdown;
        }
    }
    $w->Popdown;
}

sub LbIndex {
    my ($w, $flag) = @_;
    my $sel = $w->Subwidget('slistbox')->Subwidget('listbox')->curselection;
    if (defined $sel) {
        return int($sel);
    } else {
        if (defined $flag && ($flag eq 'emptyOK')) {
            return undef;
        } else {
            return 0;
        }
    }
}

# pop down the listbox
sub Popdown {
    my ($w) = @_;
    if ($w->{'savefocus'} && Tk::Exists($w->{'savefocus'})) {
        $w->{'savefocus'}->focus;
        delete $w->{'savefocus'};
    }
    if ($w->{'popped'}) {
        my $c = $w->Subwidget('choices');
        $c->withdraw;
        $w->grabRelease;
        $w->{'popped'} = 0;
    }
}

# This hack is to prevent the ugliness of the arrow being depressed.
#
sub ButtonHack {
    my ($w) = @_;
    my $b = $w->Subwidget('arrow');
    if ($w->{'buttonHack'}) {
        $b->butUp;
    }
}

sub choices
{
 my ($w,$choices) = @_;
 if (@_ > 1)
  {
   $w->delete( qw/0 end/ );
   my %hash;
   my $var = $w->cget('-textvariable');
   my $old = $$var;
   foreach my $val (@$choices)
    {
     $w->insert( 'end', $val);
     $hash{$val} = 1;
    }
   $old = (@$choices) ? $choices->[0] : undef unless exists $hash{$old};
   $$var = $old;
  }
 else
  {
   return( $w->get( qw/0 end/ ) );
  }
}

sub _set_edit_state {
    my( $w, $state ) = @_;

    my $entry  = $w->Subwidget( 'entry' );
    my $button = $w->Subwidget( 'arrow' );

    if ($w->cget( '-colorstate' )) {
        my $color;
        if( $state eq 'normal' ) {                  # Editable
            $color = 'gray95';
        } else {                                    # Not Editable
            $color = $w->cget( -background ) || 'lightgray';
        }
        $entry->Subwidget( 'entry' )->configure( -background => $color );
    }

    if( $state eq 'readonly' ) {
        $entry->configure( -state => 'disabled' );
        $button->configure( -state => 'normal' );
    } else {
        $entry->configure( -state => $state );
        $button->configure( -state => $state );
    }
}

sub state {
    my $w = shift;
    unless( @_ ) {
        return( $w->{Configure}{-state} );
    } else {
        my $state = shift;
        $w->{Configure}{-state} = $state;
        $w->_set_edit_state( $state );
    }
}

sub _max {
    my $max = shift;
    foreach my $val (@_) {
        $max = $val if $max < $val;
    }
    return( $max );
}

sub shrinkwrap {
    my( $w, $size ) = @_;

    unless( defined $size ) {
        $size = _max( map( length, $w->get( qw/0 end/ ) ) ) || 0;;
    }

    my $lb = $w->Subwidget( 'slistbox' )->Subwidget( 'listbox' );
    $w->configure(  -width => $size );
    $lb->configure( -width => $size );
}


1;

__END__