view release on metacpan or  search on metacpan

lib/Apache/GD/Graph.pm  view on Meta::CPAN

	gdMediumBoldFont=> gdMediumBoldFont,
	gdTinyFont	=> gdTinyFont,
	gdGiantFont	=> gdGiantFont,
	gdStyled	=> gdStyled,
	gdBrushed	=> gdBrushed,
	gdStyledBrushed	=> gdStyledBrushed,
	gdTransparent	=> gdTransparent
};

# Sub prototypes:

sub init();
sub handler ($);
sub parse ($;$);
sub arrayCheck ($$);
sub error ($);
sub makeDir ($);
sub parseElement ($;$);
sub findFont ($);
sub resolveColor ($$);

# Package variables.

my $first_request = TRUE;
my ($r, $cache_size, $image_cache, $document_root, @cleanup_files);

# Subs:

# init()
#
# Called only once on the first request received. May be called once per child
# in Apache.
sub init() {
# Set the GD::Text fontpath.
	GD::Text->font_path ($r->dir_config('TTFFontPath') || TTF_FONT_PATH);

	$cache_size = $r->dir_config('CacheSize');

	$cache_size = CACHE_SIZE if $cache_size <= 0;

	$image_cache = new File::Cache ({
		namespace	=> 'Images',
		max_size	=> $cache_size,
		filemode	=> 0660
	});

	$document_root = $r->document_root;
}

sub handler ($) {
	$r = shift;
	$r->request($r);

	init, $first_request = FALSE
		if $first_request;

	eval {
		my $args = scalar $r->args || $r->content;
		my %args = map {
				s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
				$_ # unescaped
			    } split /[=&;]/, $args, -1;

		die <<EOF unless $args;
Please supply arguments in the query string, see the Apache::GD::Graph man
page for details.
EOF

# Calculate Expires header based on either an "expires" parameter, the Expires
# configuration variable (via PerlSetVar) or the EXPIRES constant, in days.
# Then convert into seconds and round to an integer.
		my $expires = exists $args{expires} ?
			sprintf "%.0f", $args{expires} * SECONDS_IN_DAY
			:
			$r->dir_config('Expires') || EXPIRES;

# Determine the type of image that the graph should be.
# Allow an Accept: header with one specific image type to set it, a
# PerlSetVar, or the image_type parameter.
		my $image_type = lc($r->dir_config('ImageType')) || IMAGE_TYPE;

		my $accepts_header = $r->header_in('Accept');
		if (defined $accepts_header and
		    $accepts_header =~ m!^\s*image/(\w+)\s*$!) {
			$image_type = $1;
		}

		$image_type = $args{image_type} if $args{image_type};

		$image_type = 'jpeg' if $image_type eq 'jpg';

		die <<EOF unless GD::Image->can($image_type);
The version of GD installed on this server does not support
image_type $image_type.
EOF

		my $jpeg_quality;
		if ($image_type eq 'jpeg') {
			$jpeg_quality = $args{jpeg_quality} ||
					$r->dir_config('JpegQuality');
		}

		$args{cache} = TRUE if not exists $args{cache};

		if ($args{cache} != FALSE && $cache_size > 0 &&
		   defined(my $cached_image = $image_cache->get($args))) {
			$r->header_out (
				"Expires" => time2str(time + $expires)
			);
			$r->send_http_header (
				"image/$image_type"
			);
			$r->print($cached_image);

			return OK;
		}

		my $type   = delete $args{type}   || DEFAULT_TYPE;
		my $width  = delete $args{width}  || DEFAULT_WIDTH;
		my $height = delete $args{height} || DEFAULT_HEIGHT;