view release on metacpan or  search on metacpan

Wyrd/Site/GDButton.pm  view on Meta::CPAN

}

sub _generate_output {
	my ($self) = @_;
	#trueColor is necessary in order to avoid crappy text rendering
	GD::Image->trueColor(1);
	my $changed = ($self->widgetindex->update_entry($self) or not(-f $self->{'outfile'}));
	if ($changed) {
		my $antialias = 1;
		$antialias = -1 if ($self->_flags->noantialias);

		#prep the background and allocate the foreground
		my ($image, $base_image) = ();
		my $template = $self->{'template'};
		if ($template) {
			my $type = $self->{'template'} =~ /\.(png|gif)/i;
			unless ($type) {
				$self->_raise_exception('template base image must be PNG or GIF.');
			}
			if (lc($type) eq 'gif') {
				$base_image = GD::Image->newFromGif($template);
			} else {
				$base_image = GD::Image->newFromPng($template);
			}
			my $width = $self->{'width'} = $base_image->width;
			my $width = $self->{'height'} = $base_image->height;
			$image = GD::Image->new($self->{'width'} * 5, $self->{'height'} * 5);
			$image->copyResampled($base_image, 0, 0, 0, 0, $self->{'width'} * 5, $self->{'height'} * 5, $self->{'width'}, $self->{'height'});
		} else {
			#Draw everything at 5 times the given size, since font shape and spacing issues are less prominent
			$image= GD::Image->new($self->{'width'} * 5, $self->{'height'} * 5);
			my $bg = $image->colorAllocate($self->_get_color($self->{'bgcolor'}));
			$image->filledRectangle(0, 0, $self->{'width'} * 5, $self->{'height'} * 5, $bg);
		}
		my $fg = $image->colorAllocate($self->_get_color($self->{'color'}));

		#First get the size of the text image.  Since font shapes falling below
		#the drawing line will throw off the placment, this value will be taken
		#into account by _get_startpoint, which attempts to place the text at a
		#more "natural" location. This setting is overridden with the "absolute"
		#flag.
		my @abstract = GD::Image->stringFT($antialias * $fg, $self->{'font'}, $self->{'size'} * 5, 0, 0, 0, $self->{'text'});
		my ($x, $y) = $self->_get_startpoint(@abstract);

		#Then render the actual text using the calculated start point.
		my @bounds = $image->stringFT($antialias * $fg, $self->{'font'}, $self->{'size'} * 5, 0, $x, $y, $self->{'text'}, {resolution => "72,72", kerning => 1});

		#Shrink it down to 1/5 the rendered size.
		my $final = GD::Image->new($self->{'width'}, $self->{'height'});
		$final->copyResampled($image, 0, 0, 0, 0, $self->{'width'}, $self->{'height'}, $self->{'width'} * 5, $self->{'height'} * 5);
		
		open FILE, "> " . $self->{'outfile'};
		binmode FILE;
		print FILE ($self->{'outfile'}=~/gif$/) ? $final->gif : $final->png;
		close FILE;
	}

	#attempt to preserve any normal IMG or INPUT attributes
	my @attrs =  qw(name id action method alt src align onmouseover onmouseout onclick border height width ismap longdesc usemap class style);
	my %attrs =  map {$_ => $self->{$_}} @attrs;
	$attrs{'src'} = Apache::Util::escape_uri($attrs{'src'});
	if ($self->{'type'} eq 'input') {
		$self->_data(q(<input type="image") . $self->_attribute_template(@attrs) . q(>));
	} else {#consider anything else as an image tag.
		$self->_data(q(<img) . $self->_attribute_template(@attrs) . q(>));
	}
	return $self->_set(\%attrs);
}

=pod

=head1 AUTHOR

Barry King E<lt>wyrd@nospam.wyrdwright.comE<gt>

=head1 SEE ALSO

=over

=item Apache::Wyrd

General-purpose HTML-embeddable perl object

=back

=head1 LICENSE

Copyright 2002-2007 Wyrdwright, Inc. and licensed under the GNU GPL.

See LICENSE under the documentation for C<Apache::Wyrd>.

=cut

sub _get_color {
	my ($self, $color) = @_;
	my ($r, $g, $b) = ();
	if (ref($color) ne 'ARRAY') {
		return (hex($1), hex($2), hex($3)) if ($color =~ /^#([0-9a-fA-F][0-9a-fA-F])([0-9a-fA-F][0-9a-fA-F])([0-9a-fA-F][0-9a-fA-F])$/);
		return ($1, $2, $3) if ($color =~ /^\s*(\d+)[\s,]+(\d+)[\s,]+(\d+)\s*/);
		$self->_raise_exception("Illegal color value '$color'");
	}
	return $color if (scalar(@$color) == 3);
	$self->_raise_exception("Illegal color value: " . join ', ', @$color);
}

sub index_digest {
	my ($self) = @_;
	return sha1_hex($self->{'_fingerprint'});
}

sub _get_startpoint {
	my ($self, $lbx, $lby, $rbx, $rby, $rtx, $rty, $ltx, $lty) = @_;
	my $w = $self->{'width'} * 5;
	my $h = $self->{'height'} * 5;
	my $maxrx = ($rtx > $rbx ? $rtx : $rbx);
	my $maxlx = ($ltx < $lbx ? $ltx : $lbx);
	my $dx = $maxrx - $maxlx;
	my $maxty = ($rty < $lty ? $rty : $lty);
	my $maxby = ($lby > $rby ? $lby : $rby);
	my $dy = $maxby - $maxty;
	#internal offsets are the amount to subtract from x or y to reach the starting point