File Coverage

blib/lib/Tk/TiedListbox.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

# $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);
}

sub ActivateTie {
  my($w,$sub,$index)=@_;
  $w->$sub($index) if $index<$w->size;
}

sub scan {
  my $cw=shift;
  $cw->SUPER::scan(@_);
  $cw->CallTie('scroll','yview',[int(($cw->SUPER::yview)[0]*$cw->size+.5)]);
}

sub see {
  my $cw=shift;
  $cw->CallTie('scroll','see',[$cw->index($_[0])]);
}

sub selection {
  my $cw=shift;
  if($_[0] eq 'anchor') {
    $cw->CallTie('selection','selection',['anchor',$cw->index($_[1])],
                 \&SelectionAnchorTie);
  }
  if($_[0] eq 'clear' || $_[0] eq 'set') {
    $cw->CallTie('selection','selection',
                 [$_[0],map($cw->index($_),@_[1..@_-1])],
                 \&SelectionSetClearTie);
  }
  elsif($_[0] eq 'includes') {
    return $cw->SUPER::selection(@_);
  }
}

sub SelectionAnchorTie {
  my($w,$sub,$action,$index)=@_;
  $w->$sub($action,$index) if $index<$w->size;
}

sub SelectionSetClearTie {
  my($w,$sub,$action,@index)=@_;
  $w->$sub($action,@index) if $index[0]<$w->size ||
                              ($#index>=1 && $index[1]<$w->size);
}

sub yview {
  my $cw=shift;
  if(@_) {
    if($_[0] eq 'moveto') {
      $cw->SUPER::yview(@_);
      $cw->CallTie('scroll','yview',[int(($cw->SUPER::yview)[0]*$cw->size+.5)]);
    }
    elsif($_[0] eq 'scroll') {
      $cw->SUPER::yview(@_);
      $cw->CallTie('scroll','yview',[int(($cw->SUPER::yview)[0]*$cw->size+.5)]);
    }
    else {
      $cw->CallTie('scroll','yview',[$cw->index($_[0])]);
    }
  }
  else {
    return $cw->SUPER::yview();
  }
}

sub CallTie {
  my($cw,$option,$sub,$args,$tiesub)=@_;
  my $supersub="SUPER::$sub";
  $tiesub=sub{my($w,$sub)=(shift,shift); $w->$sub(@_);}
    unless defined $tiesub;
  my @ret=&$tiesub($cw,$supersub,@$args);
  if(ref($cw->{'-tiedto'}) &&
     ($cw->{'-tieoption'} eq 'all' ||
      $cw->{'-tieoption'} eq $option)) {
    my $w;
    foreach $w (@{$cw->{'-tiedto'}}) {
      &$tiesub($w,$supersub,@$args);
    }
  }
  @ret;
}

1;

__END__