view release on metacpan or  search on metacpan

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

# $Id: TiedListbox.pm 1.5 Mon, 21 Sep 1998 23:02:17 +0200 ach $
#
# TiedListbox: tie together the scrolling and/or selection of Listboxes

package Tk::TiedListbox;

use strict;
use Tk::Listbox;
use Carp;

use vars qw($VERSION @ISA);
$VERSION = substr(q$Revision: 1.5 $, 10) + 1;

@ISA = qw(Tk::Derived Tk::Listbox);

Tk::Widget->Construct('TiedListbox');



use Tk::Submethods ( 'tie' => [qw(scroll selection all)],
                     'selection' => [qw(anchor clear includes set)],
                     'scan' => [qw(mark dragto)]
                   );

sub tie {
  my $cw=shift;
  bless $cw,"Tk::TiedListbox";
  if(@_) {
    $cw->untie;
    $cw->{-tieoption}='all';
    if($_[0] eq 'scroll' || $_[0] eq 'selection' || $_[0] eq 'all') {
      $cw->{-tieoption}=shift;
    }
    @_=@{$_[0]} if ref($_[0]) eq 'ARRAY';
    $cw->{-tiedto}=[@_];
    my $w;
    foreach $w (@_) {
      bless $w,ref($cw) if(ref($w)=~/Listbox$/); # Let's hope this works
      if(ref($w) eq ref($cw)) {
        $w->untie;
        $w->{-tieoption}=$cw->{-tieoption};
        $w->{-tiedto}=[$cw,grep($_ ne $w,@_)];
      }
      else {
        carp "trying to tie a non-Listbox $w";
      }
    }
    return $cw;
  }
  else {
    $cw->{-tieoption}='all',$cw->{-tiedto}=[]
      unless ref $cw->{-tiedto};
    return($cw->{-tieoption},$cw->{-tiedto});
  }
}

sub untie
{
  my $cw=shift;
  my @ret=$cw->tie;
  my $w;
  foreach $w (@{$cw->{-tiedto}}) {
    $w->{-tiedto}=[grep($_ ne $cw,@{$w->{-tiedto}})];
  }
  @ret;
}

sub Tk::Listbox::tie {
  shift->Tk::TiedListbox::tie(@_);
}

sub activate {
  my $cw=shift;
  $cw->CallTie('selection','activate',[$cw->index($_[0])],\&ActivateTie);