libgtk2-ex-simple-list-perl 0.50-2 / usr / share / perl5 / Gtk2 / Ex / Simple / TiedList.pm

#
#
#

package Gtk2::Ex::Simple::TiedList;

use strict;
use Gtk2;
use Carp;

use Gtk2::Ex::Simple::TiedCommon;

our $VERSION = '0.1';

=for nothing

TiedList is an array in which each element is a row in the liststore.

=cut

sub TIEARRAY {
	my $class = shift;
	my $model = shift;

	croak "usage tie (\@ary, 'class', model)"
		unless $model && UNIVERSAL::isa ($model, 'Gtk2::TreeModel');

	return bless {
		model => $model,
	}, $class;
}

sub FETCH { # this, index
	my $iter = $_[0]->{model}->iter_nth_child (undef, $_[1]);
	return undef unless defined $iter;
	my @row;
	tie @row, 'Gtk2::Ex::Simple::TiedRow', $_[0]->{model}, $iter;
	return \@row;
}

sub STORE { # this, index, value
	my $iter = $_[0]->{model}->iter_nth_child (undef, $_[1]);
	$iter = $_[0]->{model}->insert ($_[1])
		if not defined $iter;
	my @row;
	tie @row, 'Gtk2::Ex::Simple::TiedRow', $_[0]->{model}, $iter;
	if ('ARRAY' eq ref $_[2]) {
		@row = @{$_[2]};
	} else {
		$row[0] = $_[2];
	}
	return 1;
}

sub FETCHSIZE { # this
	return $_[0]->{model}->iter_n_children (undef);
}

sub PUSH { # this, list
	my $model = shift()->{model};
	my $iter;
	foreach (@_)
	{
		$iter = $model->append;
		my @row;
		tie @row, 'Gtk2::Ex::Simple::TiedRow', $model, $iter;
		if ('ARRAY' eq ref $_) {
			@row = @$_;
		} else {
			$row[0] = $_;
		}
	}
	return $model->iter_n_children (undef);
}

sub POP { # this
	my $model = $_[0]->{model};
	my $index = $model->iter_n_children-1;
	my $iter = $model->iter_nth_child(undef, $index);
	return undef unless ($iter);
	my $ret = [ $model->get ($iter) ];
	$model->remove($iter) if( $index >= 0 );
	return $ret;
}

sub SHIFT { # this
	my $model = $_[0]->{model};
	my $iter = $model->iter_nth_child(undef, 0);
	return undef unless ($iter);
	my $ret = [ $model->get ($iter) ];
	$model->remove($iter) if( $model->iter_n_children );
	return $ret;
}

sub UNSHIFT { # this, list
	my $model = shift()->{model};
	my $iter;
	foreach (@_)
	{
		$iter = $model->prepend;
		my @row;
		tie @row, 'Gtk2::Ex::Simple::TiedRow', $model, $iter;
		if ('ARRAY' eq ref $_) {
			@row = @$_;
		} else {
			$row[0] = $_;
		}
	}
	return $model->iter_n_children (undef);
}

# note: really, arrays aren't supposed to support the delete operator this
#       way, but we don't want to break existing code.
sub DELETE { # this, key
	my $model = $_[0]->{model};
	my $ret;
	if ($_[1] < $model->iter_n_children (undef)) {
		my $iter = $model->iter_nth_child (undef, $_[1]);
		return undef unless ($iter);
		$ret = [ $model->get ($iter) ];
		$model->remove ($iter);
	}
	return $ret;
}

sub CLEAR { # this
	$_[0]->{model}->clear;
}

# note: arrays aren't supposed to support exists, either.
sub EXISTS { # this, key
	return( $_[1] < $_[0]->{model}->iter_n_children );
}

# we can't really, reasonably, extend the tree store in one go, it will be 
# extend as items are added
sub EXTEND {}

sub get_model {
	return $_[0]{model};
}

sub STORESIZE { carp "STORESIZE: operation not supported"; }

sub SPLICE { # this, offset, length, list
	my $self = shift;
	# get the model and the number of rows	
	my $model = $self->{model};
	# get the offset
	my $offset = shift || 0;
	# if offset is neg, invert it
	$offset = $model->iter_n_children (undef) + $offset if ($offset < 0);
	# get the number of elements to remove
	my $length = shift;
	# if len was undef, not just false, calculate it
	$length = $self->FETCHSIZE() - $offset unless (defined ($length));
	# get any elements we need to insert into their place
	my @list = @_;
	
	# place to store any returns
	my @ret = ();

	# remove the desired elements
	my $ret;
	for (my $i = $offset; $i < $offset+$length; $i++)
	{
		# things will be shifting forward, so always delete at offset
		$ret = $self->DELETE ($offset);
		push @ret, $ret if defined $ret;
	}

	# insert the passed list at offset in reverse order, so the will
	# be in the correct order
	foreach (reverse @list)
	{
		# insert a new row
		$model->insert ($offset);
		# and put the data in it
		$self->STORE ($offset, $_);
	}
	
	# return deleted rows in array context, the last row otherwise
	# if nothing deleted return empty
	return (@ret ? (wantarray ? @ret : $ret[-1]) : ());
}

1;
__END__

Copyright (C) 2004 by the gtk2-perl team (see the file AUTHORS for the
full list).  See LICENSE for more information.