File Coverage

lib/Tie/Tk/Listbox.pm

Criterion	Covered	Total	%
statement	15	107	14.0
branch	0	42	0.0
condition	0	15	0.0
subroutine	5	20	25.0
pod			n/a
total	20	184	10.8

# See the POD documentation at the end of this
# document for detailed copyright information.
# (c) 2003-2006 Steffen Mueller, all rights reserved.

package Tie::Tk::Listbox;

use 5.006;
use strict;
use warnings;
use Carp;

use vars qw/$VERSION/;
$VERSION = '1.02';


sub TIEARRAY  {
   my $proto = shift;
   my $class = ref $proto || $proto;
   my $listbox = shift;
   unless (defined $listbox) {
      croak "Missing listbox argument.";
   }
   unless (ref $listbox eq 'Tk::Listbox') {
      $listbox = $listbox->Subwidget('listbox');
      croak "Trouble finding listbox." if not defined $listbox;
   }

   bless \$listbox, $class;
}

sub STORE     {
   my $self    = shift;
   my $index   = shift;
   # value is $_[0] now.

   my $len     = $_[1] || $self->FETCHSIZE();
   if ($index > $len - 1) {
      $self->EXTEND($index+1, $len);
   } elsif ($index < 0) {
      $index += $len;
      croak "Index out of range." if $index < 0;
   }
   ${$self}->delete($index);
   ${$self}->insert($index, $_[0]);
}

sub FETCHSIZE {
   my $self = shift;
   return ${$self}->index('end');
}

sub STORESIZE {
   my $self  = shift;
   my $tolen = shift;
   my $len   = shift || $self->FETCHSIZE();
   if ($tolen > $len) {
      $self->EXTEND($tolen, $len);
   } elsif ($tolen < $len) {
      ${$self}->delete($tolen, $len-1);
   }
}

sub FETCH     {
   my $self = shift;
   my $ind  = shift;
   my $len  = shift || $self->FETCHSIZE();
   if ($ind < 0) {
      $ind += $len;
   }
   if ($ind >= $len) {
      return undef;
   }
   return ${$self}->get($ind);
}

sub CLEAR     {
   my $self = shift;
   $self->STORESIZE(0);
}

sub EXTEND  {
   my $self  = shift;
   my $tolen = shift;
   my $len   = shift || $self->FETCHSIZE();
   if ($tolen > $len) {
      my $diff = $tolen - $len;
      ${$self}->insert('end', ( (undef) x $diff ));
   }
}

sub DESTROY { }

sub SPLICE {
    my $self = shift;
    my $len  = $self->FETCHSIZE;
    my $off  = (@_) ? shift : 0;
    $off += $len if ($off < 0);
    my $diff = (@_) ? shift : $len - $off;
    $diff += $len - $off if $diff < 0;
    my @result;
    for (my $i = 0; $i < $diff; $i++) {
        push(@result,$self->FETCH($off+$i));
    }
    $off = $len if $off > $len;
    $diff -= $off + $diff - $len if $off + $diff > $len;
    if (@_ > $diff) {
        # Move items up to make room
        my $d = @_ - $diff;
        my $e = $off+$diff;
        $self->EXTEND($len+$d);
        for (my $i=$len-1; $i >= $e; $i--) {
            my $val = $self->FETCH($i);
            $self->STORE($i+$d,$val);
        }
    }
    elsif (@_ < $diff) {
        # Move items down to close the gap
        my $d = $diff - @_;
        my $e = $off+$diff;
        for (my $i=$off+$diff; $i < $len; $i++) {
            my $val = $self->FETCH($i);
            $self->STORE($i-$d,$val);
        }
        $self->STORESIZE($len-$d);
    }
    for (my $i=0; $i < @_; $i++) {
        $self->STORE($off+$i,$_[$i]);
    }
    return wantarray ? @result : pop @result;
}

sub UNSHIFT { scalar shift->SPLICE(0,0,@_) }
sub SHIFT { shift->SPLICE(0,1) }
sub PUSH {
   my $self = shift;
   my $i   = $self->FETCHSIZE;
   $self->STORE($i++, shift) while (@_);
}

sub POP {
   my $self = shift;
   my $newsize = $self->FETCHSIZE - 1;
   my $val;
   if ($newsize >= 0) {
      $val = $self->FETCH($newsize);
      $self->STORESIZE($newsize);
   }
   $val;
}

sub EXISTS {
    my $pkg = ref $_[0];
    croak "$pkg dosn't define an EXISTS method";
}

sub DELETE {
    my $pkg = ref $_[0];
    croak "$pkg dosn't define a DELETE method";
}


1;

__END__