view release on metacpan or  search on metacpan

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

=over

=item noantialias

Turn off antialiasing for the button.

=back

=head1 BUGS/CAVEATS

Reserves the _format_output and _generate_output methods.

=cut

sub _format_output {
	my ($self) = @_;
	my @required_attributes = qw(src name outfile bgcolor color size font);
	unless ($self->{'template'}) {
		push @required_attributes, qw(width height);
	}
	my @optional_attributes = qw(margin lmargin rmargin bmargin tmargin halign valign);
	my $defaults = $self->_defaults;
	$defaults = {} unless (ref($defaults) eq 'HASH');
	map {$self->{$_} ||= ($defaults->{$_})} @required_attributes, @optional_attributes;
	$self->{'outfile'} = $self->file_attribute('src', 'rw') if ($self->{'src'});
	$self->{'template'} = $self->file_attribute('template', 'rf') if ($self->{'template'});
	$self->{'font'} = $self->file_attribute('font', 'rf') if ($self->{'font'});
	#When these are inputs, the name is more important than the text.
	$self->{'text'} ||= ($self->_data || ucfirst($self->{'name'}) || 'Click Me');
	#When these are images, the name is less important than the SRC attribute
	$self->{'name'} ||= ($self->{'src'});
	$self->{'halign'} ||= ('center');
	$self->{'valign'} ||= ('middle');
	$self->{'type'} ||= ('input');
	my @missing = grep {not($self->{$_})} @required_attributes;
	@missing = grep {$_ ne 'name'} @missing if ($self->{'type'} ne 'input');#inputs must have names, but others don't have to.
	$self->_raise_exception("Missing attributes: " . join ", ", @missing) if (@missing);
	$self->{_fingerprint} = join(':', (map {$self->{$_}} @required_attributes, @optional_attributes));
}

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