File Coverage

blib/lib/Tie/Tk/Text.pm

Criterion	Covered	Total	%
statement	6	72	8.3
branch	0	14	0.0
condition			n/a
subroutine	2	17	11.7
pod			n/a
total	8	103	7.7

#===============================================================================
# Tie/Tk/Text.pm
#===============================================================================
package Tie::Tk::Text;
use strict;

use vars qw'$VERSION';
$VERSION = '0.92';

# Notes:
# * Text widgets use 1-based indexing so line number = array index + 1
# * Text widgets *always* have a newline at the end. It's returned by
#   $w->get('1.0', 'end') but isn't deleted by $w->delete('1.0', 'end')
# * $w->get('1.0', '1.0 lineend') doesn't include the trailing newline.
#   You need to use one of these instead:
#       $w->get('1.0', '2.0')
#       $w->get('1.0', '1.0 lineend + 1 chars)

sub TIEARRAY {
	my $class  = shift;
	my $widget = shift;
	return bless \$widget, $class;
}


sub CLEAR {
	my $self = shift;
	$$self->delete('1.0', 'end');
}


sub FETCH {
	my $self = shift;
	my $line = shift() + 1;
	return $$self->get("$line.0", "$line.end + 1 chars");
}


sub STORE {
	my $self = shift;
	my $idx  = shift;
	my $text = shift;
	my $line = $idx + 1;

	$$self->insert('end', "\n")	while ($self->FETCHSIZE <= $idx);
	$self->_delete($idx);
	$$self->insert("$line.0", $text);
}


sub FETCHSIZE {
	my $self = shift;
	my $c    = $$self->get('end - 1 chars');
	my $n    = $c eq "\n" ? 2 : 1; # cf. module notes
	my $l    = (split(/\./, $$self->index("end - $n chars")))[0];
	return $l;
}


sub STORESIZE {
	my $self = shift;
	my $size = shift;

	if ($self->FETCHSIZE > $size) {
		my $n = $size + 1;
		$$self->delete("$n.0", 'end');
	}
	else {
		$$self->insert('end', "\n") while ($self->FETCHSIZE < $size);
	}
}


sub EXISTS {
	my $self = shift;
	my $idx  = shift;
	return $idx < $self->FETCHSIZE;
}


sub DELETE {
	my $self = shift;
	my $idx  = shift;
	my $text = $self->EXISTS($idx) ? $self->FETCH($idx) : undef;

	my $l = $idx + 1;
	$$self->delete("$l.0", "$l.0 lineend"); # don't delete the \n

	# collapse trailing "undef" (\n) values
	while ($self->FETCH($self->FETCHSIZE - 1) eq "\n") {
		$self->POP;
	}

	return $text;
}


sub PUSH {
	my $self = shift;
	$$self->insert('end', $_) foreach @_;
}


sub POP {
	my $self = shift;
	return $self->_delete($self->FETCHSIZE - 1);
}


sub UNSHIFT {
	my $self = shift;
	$$self->insert('1.0', $_) foreach reverse @_;
}


sub SHIFT {
	my $self = shift;
	return $self->_delete(0);
}


sub SPLICE {
	my $self = shift;
	my $o    = shift; # offset
	my $l    = shift; # length

	$o = 0                          unless defined $o;
	$o = $self->FETCHSIZE + $o      if     $o < 0;
	$l = $self->FETCHSIZE - $o      unless defined $l;
	$l = $self->FETCHSIZE - $o + $l if     $l < 0;

	my @deleted;
	foreach my $i (reverse ($o .. $o + $l - 1)) {
		unshift @deleted, $self->_delete($i);
	}

	foreach my $r (reverse @_) {
		my $x = $o + $l - 1;
		$$self->insert("$x.0", $r);
	}

	return @deleted;
}


sub EXTEND {}

#-------------------------------------------------------------------------------
# Method  : Remove and (really) delete element
# Purpose :
# Notes   :
#-------------------------------------------------------------------------------
sub _delete {
	my $self = shift;
	my $idx  = shift;
	my $text = $self->FETCH($idx);
	my $line = $idx+1;

	$$self->delete("$line.0", "$line.end + 1 chars");
	return $text;
}

1;

__END__