view release on metacpan or  search on metacpan

lib/Tcl/pTk/Listbox.pm  view on Meta::CPAN

package Tcl::pTk::Listbox;

our ($VERSION) = ('1.11');

@Tcl::pTk::Listbox::ISA = (Tcl::pTk::Widget);

use strict;

use Carp;

# Overridden version of configure that handles storing and tie-ing the  any -listvariable option,
sub configure{
        my $self = shift;
        
        
        my %args = @_;
        
        if( defined($args{-listvariable})  ){
                my $listvariable = $args{-listvariable};
                #     
                if( defined($listvariable) and ref($listvariable) eq 'ARRAY'){
                        
                        my @listVars = @$listvariable;  # Save the values for reseting after the tie
                        # Tie the list var, so that changes to it will be reflected in the
                        #   Listbox
                        tie @$listvariable, 'Tcl::pTk::Listbox', $self;
                        
                        @$listvariable = @listVars; # set the values after the tie
                        
                        
                }
                
                # Untie the currently tied listvar, if it exists
                my $currentListVar;
                if( !defined($listvariable) && 
                     defined( $currentListVar = $self->Tcl::pTk::Derived::_cget(-listvariable)) &&
                     tied($$currentListVar)){
                        untie($$currentListVar);
                }
                        
                
                # Store listvariable in the configuration store, for retreival later
                $self->Tcl::pTk::Derived::_configure(-listvariable, $listvariable);

                
        }
        
        return $self->SUPER::configure(%args);
        
}


# Overridden cget to return the -listvariable ref, if it has been setgrent
# reference it.)
sub cget {
    my $self = shift;
    my @args = @_;
    
    my $option = $args[0];
    
    if( $option eq '-listvariable'){  # return the store list variable
        return $self->Tcl::pTk::Derived::_cget(-listvariable);        
    }
    
    # Otherwise call the parent cget
    return $self->SUPER::cget(@args);
}
    
# Method to enable balloons to be attached to individual items
#   in a listbox by supplying an array as -msg (See the balloon.pl demo for example)
sub BalloonInfo
{
 my ($listbox,$balloon,$X,$Y,@opt) = @_;
 my ($x,$y) = $listbox->pointerxy;
 $x = $x - $listbox->rootx;
 $y = $y - $listbox->rooty;
 #print STDERR "x = $x/$y\n";
 my $index = $listbox->index('@' . $x . ',' . $y);
 foreach my $opt (@opt)
  {
   my $info = $balloon->GetOption($opt,$listbox);
   if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'ARRAY'))
    {
     $balloon->Subclient($index);
     if (defined $info->[$index])
      {
       return $info->[$index];
      }
     return '';
    }
   return $info;
  }
}


############### Methods to implement the tied scalar and array interface #########
####              Copied from perltk Tk::Listbox #######
#
sub TIEARRAY {
  my ( $class, $obj, %options ) = @_;
  return bless {
	    OBJECT => \$obj,
	    OPTION => \%options }, $class;
}

sub TIESCALAR {
  my ( $class, $obj, %options ) = @_;
  return bless {
	    OBJECT => \$obj,
	    OPTION => \%options }, $class;
}

# FETCH
# -----
# Return either the full contents or only the selected items in the
# box depending on whether we tied it to an array or scalar respectively
sub FETCH {
  my $class = shift;

  my $self = ${$class->{OBJECT}};
  my %options = %{$class->{OPTION}} if defined $class->{OPTION};;