Prima::Tie - tie widget properties to scalars or arrays.

Prima documentation Contained in the Prima distribution.

Index

Code Index:

NAME

Top

Prima::Tie - tie widget properties to scalars or arrays.

DESCRIPTION

Top

Prima::Tie contains two abstract classes, Prima::Tie::Array and Prima::Tie::Scalar, which tie an array or a scalar to a widget's arbitrary array or scalar property. Also, it contains classes Prima::Tie::items, Prima::Tie::text, and Prima::Tie::value, which tie a variable to a widget's items, text, and value property respectively.

SYNOPSIS

Top

	use Prima::Tie;

	tie @items, 'Prima::Tie::items', $widget;

	tie @some_property, 'Prima::Tie::Array', $widget, 'some_property';

	tie $text, 'Prima::Tie::text', $widget;

	tie $some_property, 'Prima::Tie::Scalar', $widget, 'some_property';

USAGE

Top

These classes provide immediate access to a widget's array and scalar property, in particular to popular properties as items and text. It is considerably simpler to say

	splice(@items,3,1,'new item');

than to say

	my @i = @{$widget->items};
	splice(@i,3,1,'new item');
	$widget->items(\@i);

You can work directly with the text or items rather than at a remove. Furthermore, if the only reason you keep an object around after creation is to access its text or items, you no no longer need to do so:

	tie @some_array, 'Prima::Tie::items', Prima::ListBox->create(@args);

As opposed to:

	my $widget = Prima::ListBox->create(@args);
	tie @some_array, 'Prima::Tie::items', $widget;

Prima::Tie::items requires ::items property to be available on the widget. Also, it takes advantage of additional get_items, add_items, and the like if available.

Prima::Tie::items

The class is applicable to Prima::ListViewer, Prima::ListBox, Prima::Header, and their descendants, and in limited fashion to Prima::OutlineViewer and its descendants Prima::StringOutline and Prima::Outline.

Prima::Tie::text

The class is applicable to any widget.

Prima::Tie::value

The class is applicable to Prima::GroupBox, Prima::ColorDialog, Prima::SpinEdit, Prima::Gauge, Prima::Slider, Prima::CircularSlider, and Prima::ScrollBar.

COPYRIGHT

Top

Copyright 2004 Teo Sankaro

You may redistribute and/or modify this module under the same terms as Perl itself. (Although a credit would be nice.)

AUTHORS

Top

Teo Sankaro, <teo_sankaro@hotmail.com>. Dmitry Karasik, <dmitry@karasik.eu.org>.

Prima documentation Contained in the Prima distribution. 
# $Id$
use strict;

package Prima::Tie::Array;
use Tie::Array;
use vars qw(@ISA);
@ISA = qw(Tie::Array);

sub TIEARRAY {
	my ($class, $widget, $property) = @_;
	bless [ $widget, $property], $class;
}

sub FETCH {
	my ($self, $idx) = @_;
	my ($widget, $property) = @$self; 
	$widget-> $property()-> [$idx];
}

sub STORE {
	my ($self, $idx, $value) = @_;
	my ($widget, $property) = @$self;
	my $array = $widget-> $property();
	$array-> [$idx] = $value;
	$widget-> $property($array);
	return $value;
}

sub FETCHSIZE {
	my ($self) = @_;
	my ($widget, $property) = @$self;
	scalar @{$widget-> $property()};
}

sub STORESIZE {
	my ($self, $size) = @_;
	my ($widget, $property) = @$self;
	my $array = $widget-> $property();
	$#$array = $size - 1;
	$widget-> $property($array);
	return $size;
}


sub EXISTS 
{
	my ( $self, $idx) = ( $_[0], abs($_[1]));
	return $idx >= 0 && $idx < $self-> FETCHSIZE;
}

sub DELETE 
{
}


sub UNTIE {
	my ($obj,$count) = @_;
	die "untie attempted while $count inner references still exist" if $count;
}
#
# Prima::Tie::items - ties an array to a widget's items property
#

package Prima::Tie::items;
use Tie::Array;
use vars qw(@ISA);
@ISA = qw(Tie::Array);

sub TIEARRAY {
	my ($class, $widget) = @_;
	bless {
		self => $widget,
		map {
			$_  => $widget-> can($_),
		} qw(count get_items replace_items insert_items add_items delete_items)
	}, $class;
}

sub FETCH {
	my ($self, $idx) = @_;
	$self-> {self}-> items-> [$idx];
}

sub STORE {
	my ($self, $idx, $value) = @_;
	my $size = $self-> FETCHSIZE; 
	if ( $idx == $size) {
		if ( $self-> {add_items}) {
			$self-> {self}-> add_items($value);
		} else {
			my $i = $self-> {self}-> items;
			push @$i, $value;
			$self-> {self}-> items($i);
		}
		return $value;
	} elsif ( $idx > $size) {
		die "Modification of non-creatable array value attempted, subscript $idx";
	} elsif ( $idx < 0) {
		my $ndx = $idx;
		$idx = $size - $idx;
		die "Modification of non-creatable array value attempted, subscript $ndx"
			if $idx < 0;
	}
	if ( $self-> {replace_items}) {
		$self-> {self}-> replace_items($idx, $value);
	} else {
		my $i = $self-> {self}-> items;
		$i-> [$idx] = $value;
		$self-> {self}-> items($i);
	}
	return $value;
}

sub FETCHSIZE {
	my ($self) = @_;
	if ( $self-> {count}) {
		return $self-> {self}-> count;
	} else {
		return scalar @{$self-> {self}-> items};
	}
}

sub STORESIZE {
	my ($self, $new_size) = @_;
	my $old_size =$self-> FETCHSIZE;
	die "Modification of non-creatable array value attempted, size $new_size"
		if $new_size < 0 || $new_size > $old_size;
	if ( $self-> {delete_items}) {
		$self-> {self}-> delete_items( $new_size .. $old_size );
	} else {
		my $i = $self-> {self}-> items;
		$#$i = $new_size - 1;
		$self-> {self}-> items($i);
	}
	return $new_size;
}

sub PUSH {
	my $self = shift;
	if ( $self-> {add_items}) {
		$self-> {self}-> add_items(@_);
	} else {
		my $i = $self-> {self}-> items;
		push @$i, @_;
		$self-> {self}-> items($i);
	}
}

sub SPLICE {
	my $self = shift;
	my $sz  = $self-> FETCHSIZE;
	my $off = (@_) ? shift : 0;
	$off += $sz if ($off < 0);
	die "Modification of non-creatable array value attempted, offset $off"
		if $off < 0;
	my $len = (@_) ? shift : $sz - $off;
	$len += $sz - $off if $len < 0;
	die "Modification of non-creatable array value attempted, length $len"
		if $len < 0;
	my @result;
	my ( $i, $iok);
	if ( $self-> {get_items}) {
		@result = $self-> {self}-> get_items( $off .. $off + $len - 1);
	} else {
		$i = $self-> {self}-> items;
		@result = @$i[ $off .. $off + $len - 1];
		$iok = 1;
	}
	$off = $sz if $off > $sz;
	$len -= $off + $len - $sz if $off + $len > $sz;
	die "Modification of non-creatable array value attempted, length $len"
		if $len < 0;

	if ( @_ == $len) {
		if ( $self-> {replace_items}) {
			$self-> {self}-> replace_items( $off, @_);
		} else {
			$i = $self-> {self}-> items, $iok = 1 unless $iok;
			splice( @$i, $off, $len, @_);
			$self-> {self}-> items( $i);
		}
	} else {
		if ( $self-> {delete_items} && $self-> {insert_items}) {
			$self-> {self}-> delete_items( $off .. $off + $len - 1);
			$self-> {self}-> insert_items( $off, @_);
		} else {
			$i = $self-> {self}-> items, $iok = 1 unless $iok;
			splice( @$i, $off, $len, @_);
			$self-> {self}-> items( $i);
		}
	}
	return wantarray ? @result : pop @result;
}


sub EXISTS 
{
	my ( $self, $idx) = ( $_[0], abs($_[1]));
	return $idx >= 0 && $idx < $self-> FETCHSIZE;
}

sub DELETE 
{
}


sub UNTIE {
	my ($obj,$count) = @_;
	die "untie attempted while $count inner references still exist" if $count;
}

#
# Prima::Tie::Scalar - ties a scalar to a widget's scalar properties
#

package Prima::Tie::Scalar;

sub TIESCALAR {
	my ($class, $widget, $property) = @_;
	bless [ $widget, $property ], $class;
}

sub FETCH {
	my ($self) = @_;
	my ($widget, $property) = @$self; 
	$widget-> $property();
}

sub STORE {
	my ($self, $value) = @_;
	my ( $widget, $property) = @$self; 
	$widget-> $property($value);
	return $value;
}

sub UNTIE {
	my ($obj,$count) = @_;
	die "untie attempted while $count inner references still exist" if $count;
}

# some popular names

package Prima::Tie::text;
use vars qw(@ISA);
@ISA = qw(Prima::Tie::Scalar);
sub TIESCALAR { bless [ $_[1], 'text' ], $_[0] }

package Prima::Tie::value;
use vars qw(@ISA);
@ISA = qw(Prima::Tie::Scalar);
sub TIESCALAR { bless [ $_[1], 'value' ], $_[0] }


1;