File Coverage

blib/lib/Imager/DTP/Textbox.pm

Criterion	Covered	Total	%
statement	12	275	4.3
branch	0	104	0.0
condition	0	48	0.0
subroutine	4	37	10.8
pod	16	16	100.0
total	32	480	6.6

package Imager::DTP::Textbox;
use strict;
use Carp;
use Imager;
use vars qw($VERSION);

$VERSION = '0.04';

sub new {
	my $self = shift;
	my %o = @_;
	# define properties
	my $p = {
		lines   => [],
		leading => 150,
		width   => 0,
		height  => 0,
		halign  => '',
		valign  => '',
		wrapWidth  => 0,
		wrapHeight => 0,
		isUpdated  => 0, # check flag for _calcWidthHeight needs
	};
	$self = bless($p,$self);
	# set properties
	$self->setLeading(percent=>$o{leading});
	$self->setAlign(valign=>$o{valign},halign=>$o{halign});
	$self->setWrap(width=>$o{wrapWidth},height=>$o{wrapHeight});
	if(defined($o{text})){
		$self->setText(text=>$o{text},font=>$o{font});
		$self->setWspace(pixel=>$o{wspace});
	}
	if($o{xscale} || $o{yscale}){
		$self->setLetterScale(x=>$o{xscale},y=>$o{yscale});
	}
	return $self;
}

sub draw {
	my $self = shift;
	my %o = @_;
	# validation
	if($o{target} && ref($o{target}) !~ /^Imager(::.+)?$/){
		confess "target: must be an Imager Object";
	}
	$o{x} = 0 if(!$o{x});
	$o{y} = 0 if(!$o{y});
	# calculate width and height
	$self->_calcWidthHeight();
	# calculate text wrap
	$self->_calcWrap();
	# draw directly to target image
	if($o{target}){
		my($x,$y) = $self->_draw_getStartPos(x=>$o{x},y=>$o{y});
		$self->_draw_drawLines(target=>$o{target},x=>$x,y=>$y,debug=>$o{debug},others=>$o{others});
		return 1;
	# or return drawn Imager object
	}else{
		my $tmp = Imager->new(xsize=>$self->_getWidth(),
		          ysize=>$self->_getHeight(),channels=>3) or die $Imager::ERRSTR;
		$o{bgcolor} = '$FFFFFF' if(!$o{bgcolor});
		$tmp->box(filled=>1,color=>$o{bgcolor});
		$self->_draw_drawLines(target=>$tmp,debug=>$o{debug},others=>$o{others});
		return $tmp;
	}
}

sub _draw_drawLines {
	confess "_draw_drawLines - this is an abstract method";
}

sub _draw_getAlignPos {
	confess "_draw_getAlignPos - this is an abstract method";
}

sub _draw_getStartPos {
	confess "_draw_getStartPos - this is an abstract method";
}

sub _calcWidthHeight {
	confess "_calcWidthHeight - this is an abstract method";
}

sub _calcWrap {
	my $self = shift;
	# letter wrapping
	$self->_calcWrap_LetterStack();
	# line truncating
	$self->_calcWrap_LineStack();
	return 1;
}

sub _calcWrap_LetterStack {
	my $self = shift;
	my $wrapMax = $self->_calcWrap_LetterStack_getWrapMax();
	return undef if(!$wrapMax);
	my $lines = $self->getLines();
	my $li = 0;
	foreach my $line (@{$lines}){
		my $lineMax = $self->_calcWrap_LetterStack_getLineMax(line=>$line);
		if($wrapMax && $wrapMax < $lineMax){
			my $wi = 0;
			my $nowMax = 0;
			my $exceeded = 0;
			my $letters = $line->getLetters();
			# check exceedance
			while (1){
				my $ltr = $letters->[$wi];
				$nowMax += $self->_calcWrap_LetterStack_getLetterSize(letter=>$ltr);
				if($nowMax > $wrapMax){
					$exceeded = 1;
					last;
				}
				last if($wi == $#{$letters});
				$nowMax += $line->getWspace() if($wi < $#{$letters});
				$wi++;
			}
			# cut off exceeded letters
			if($exceeded){
				my @exceed = ();
				# line contains more than 1 letter & $wrapMax is less than 1 letter size
				if($wi == 0 && $#{$letters} > 0){
					@exceed = @{$letters}[1 .. $#{$letters}];
				# line contains only 1 letter & $wrapMax is less than 1 letter size
				}elsif($wi == 0 && $#{$letters} == 0){
					@exceed = ();
				# other than above (usual case)
				}else{
					# grab some more letters if it's in a middle of an alphabet word
					$wi = $self->_calcWrap_LetterStack_eExceed(wi=>$wi,
					      letters=>$letters);
					@exceed = @{$letters}[$wi .. $#{$letters}];
				}
				# delete space at beginning of exceed letters
				$self->_calcWrap_LetterStack_CutFrontSpace(exceed=>\@exceed);
				# cut off exceeded letters
				my $to = ($wi > 0)? $wi-1 : 0;
				@{$letters} = @{$letters}[0 .. $to];
				# create new line if needed
				if($li == $#{$lines}){
					my $newLine = $self->_getNewLineInstance(wspace=>$line->getWspace(),isWrap=>1);
					$newLine->{letters} = \@exceed;
					$newLine->_calcWidthHeight();
					push(@{$lines},$newLine);
				# un-shift exeeded letters to the later line
				}else{
					my $laterLine = $lines->[$li+1];
					# if the later line was a line created during calcWrap()
					if($laterLine->{isWrap} == 1){
						unshift(@{$laterLine->{letters}},@exceed);
						$laterLine->{isUpdated} = 0; # force re-calculation
						$laterLine->_calcWidthHeight();
					# or else add new line in between this and later line
					}else{
						my $newLine = $self->_getNewLineInstance(wspace=>$line->getWspace(),isWrap=>1);
						$newLine->{letters} = \@exceed;
						$newLine->_calcWidthHeight();
						@{$lines} = (@{$lines}[0 .. $li], $newLine, @{$lines}[$li+1 .. $#{$lines}]);
					}
				}
				# re-calculate width and height of the current line
				$line->{isUpdated} = 0; # register for re-calculation
			}
		}
		$li++;
	}
	# re-calculate width and height
	$self->{isUpdated} = 0;
	$self->_calcWidthHeight();
	return 1;
}

sub _calcWrap_LetterStack_getWrapMax {
	confess "_calcWrap_LetterStack_getWrapMax - this is an abstract method";
}
sub _calcWrap_LetterStack_getLineMax {
	confess "_calcWrap_LetterStack_getLineMax - this is an abstract method";
}
sub _calcWrap_LetterStack_getLetterSize {
	confess "_calcWrap_LetterStack_getLetterSize - this is an abstract method";
}

sub _calcWrap_LetterStack_eExceed {
	my $self = shift;
	my %o = @_;
	my $pattern = qr/[a-zA-Z0-9'!?%$(),.]/;
	# return if exceeded letter was not a single-byte character
	return $o{wi} if($o{letters}->[$o{wi}]->getText() !~ /$pattern/);
	my $i;
	for($i=$o{wi};$i>=0;$i--){
		my $t = $o{letters}->[$i]->getText();
		# find a word breaking spot
		last if($t =~ /\s/ || $t !~ /$pattern/);
	}
	# if $wi spot is at the beggining of line, don't count as exceed,
	# infact, find the end of the word and count that as exceed point.
	if($i+1 == 0){
		my $c;
		for($c=$o{wi};$c<=$#{$o{letters}};$c++){
			my $t = $o{letters}->[$c]->getText();
			# find a word breaking spot
			last if($t =~ /\s/ || $t !~ /$pattern/);
		}
		return $c;
	# else return the spot where the word starts
	}else{
		return $i+1;
	}
}

sub _calcWrap_LetterStack_CutFrontSpace {
	my $self = shift;
	my %o = @_;
	return undef if(@{$o{exceed}} == 0);
	my $firstLetter = $o{exceed}->[0];
	if($firstLetter->getText() =~ /\s/){
		shift(@{$o{exceed}});
		return 1;
	}
	return undef;
}

sub _calcWrap_LineStack {
	my $self = shift;
	my $wrapMax = $self->_calcWrap_LineStack_getWrapMax();
	return undef if(!$wrapMax);
	my $lines = $self->getLines();
	my $li = 0;
	my $nowMax = 0;
	my $lineMax = $self->_getMaxLetterSize();
	my $lineSpace = $self->_calcLineSpace();
	my $exceed = 0;
	foreach my $line (@{$lines}){
		$nowMax += $lineMax;
		if($nowMax > $wrapMax){
			$exceed = 1;
			last;
		}
		$nowMax += $lineSpace if($li < $#{$lines});
		$li++;
	}
	# cut off exceeded lines
	if($exceed){
		my $to = ($li == 0)? 0 : $li-1;
		@{$lines} = @{$lines}[0 .. $to];
		# re-calculate width and height if needed
		$self->{isUpdated} = 0;
		$self->_calcWidthHeight();
	}
	return 1;
}

sub _calcWrap_LineStack_getWrapMax {
	confess "_calcWrap_LineStack_getWrapMax - this is an abstract method";
}

sub _calcLineSpace {
	my $self = shift;
	my $base = $self->_getMaxLetterSize();
	return ($self->getLeading() / 100 - 1) * $base;
}

sub setText {
	my $self = shift;
	my %o = @_;
	# validation
	if(!defined($o{text}) || $o{text} eq ''){
		confess "text: must not be empty or null.";
	}
	$o{text} =~ s/\r\n/\n/g; # replate CR+LF to LF
	$o{text} =~ s/\r/\n/g;   # replate CR to LF
	# get last line object
	my $lastLine;
	if(@{$self->{lines}} > 0){
		$lastLine   = pop(@{$self->{lines}});
		my $letters = $lastLine->getLetters();
		$o{wspace}  = $lastLine->getWspace() if(!defined($o{wspace}));
		$o{font}    = $letters->[-1]{font} if(!defined($o{font}) && scalar @{$letters} > 0);
	}
	# validation for font object
	if(ref($o{font}) !~ /^Imager::Font(::.+)?$/){
		confess "font: must define an Imager::Font Object";
	}
	# clear current lines
	$self->{lines} = [] if(!$o{add});
	# parse by line feeds
	my(@lineTexts,$t,$len);
	($t) = ($o{text} =~ /^(\n+)/); # look for pre-\n's
	$len = ($t)? length($t) : 0;
	if($len > 0){
		push(@lineTexts,'') for (1 .. $len);
	}
	($t) = ($o{text} =~ /(\n+)$/); # look for post-\n's
	$len = ($t)? length($t) : 0;
	@lineTexts = split(/\n/,$o{text}); # split inner text by line feeds
	if($len > 0){
		push(@lineTexts,'') for (1 .. $len);
	}
	@lineTexts = ('') if(scalar @lineTexts == 0); # to create a blank line
	my $i=0;
	foreach my $text (@lineTexts){
		if($i == 0 && $lastLine && $o{add}){
			# add new texts to the end of last line
			$lastLine->setText(text=>$text,font=>$o{font},add=>1);
			push(@{$self->{lines}},$lastLine);
		}else{
			# create new Line instance if a clean blank line is needed
			my $newLine = $self->_getNewLineInstance(wspace=>$o{wspace});
			$newLine->setText(text=>$text,font=>$o{font});
			push(@{$self->{lines}},$newLine);
		}
		$i++;
	}
	$self->{isUpdated} = 0;
	return 1;
}

sub setWrap {
	my $self = shift;
	my %o = @_;
	# validation
	if($o{width} && $o{width} !~ /^\d+$/){
		confess "width: must be an integer ($o{width})";
	}
	if($o{height} && $o{height} !~ /^\d+$/){
		confess "height: must be an integer ($o{height})";
	}
	$self->{wrapWidth}  = $o{width} if($o{width});
	$self->{wrapHeight} = $o{height} if($o{height});
	$self->{isUpdated} = 0;
	return 1;
}

sub setAlign {
	my $self = shift;
	my %o = @_;
	if($o{halign} && $o{halign} !~ /^(left|center|right)$/){
		confess "halign: must be either of left/center/right ($o{h})";
	}
	if($o{valign} && $o{valign} !~ /^(top|center|bottom)$/){
		confess "valign: must be either of top/center/bottom ($o{v})";
	}
	$self->_setAlign_setDefault(%o);
	$self->{halign} = $o{halign} if($o{halign});
	$self->{valign} = $o{valign} if($o{valign});
	return 1;
}

sub setLeading {
	my $self = shift;
	my %o = @_;
	if($o{percent} && $o{percent} !~ /^\d+$/){
		confess "percent: must be a percentage numeral ($o{value})";
	}
	$self->{leading} = $o{percent} if($o{percent});
	$self->{isUpdated} = 0;
	return 1;
}

sub setWspace {
	my $self = shift;
	my %o = @_;
	foreach my $line (@{$self->getLines()}){
		$line->setWspace(@_);
	}
	return 1;
}

sub setLetterScale {
	my $self = shift;
	my %o = @_;
	foreach my $line (@{$self->getLines()}){
		$line->setLetterScale(@_);
	}
	return 1;
}

sub getWidth {
	my $self = shift;
	$self->_calcWidthHeight();
	$self->_calcWrap();
	return $self->_getWidth();
}
sub getHeight {
	my $self = shift;
	$self->_calcWidthHeight();
	$self->_calcWrap();
	return $self->_getHeight();
}
sub getLines {
	return shift->{lines};
}
sub getLeading {
	return shift->{leading};
}
sub getHalign {
	return shift->{halign};
}
sub getValign {
	return shift->{valign};
}
sub getWrapWidth {
	return shift->{wrapWidth};
}
sub getWrapHeight {
	return shift->{wrapHeight};
}
sub _getWidth {
	return shift->{width};
}
sub _getHeight {
	return shift->{height};
}
sub _getMaxLetterSize {
	confess "_getMaxLetterSize - this is an abstract method";
}

1;
__END__