view release on metacpan or  search on metacpan

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

		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;

		$type =~ m/^(\w+)$/;
		$type = $1;	# untaint it!

		my @data;
		my $i = 1;
		my $key = "data$i";
		while (exists $args{$key}) {
			my ($type, $array, @rest) = (parse delete $args{$key});
			if ($type == TYPE_LIST) {
				$array = [ $array, @rest ];
			}
			arrayCheck $key, $array;
			push @data, $array;
			$key = "data".(++$i);
		}

		die "Please supply at least a data1 argument."
			if ref $data[0] ne 'ARRAY';

		my $length = scalar @{$data[0]};
		die "data1 empty!" if $length == 0;

		if (exists $args{no_axes}) {
			delete $args{x_labels};
			$args{y_number_format} = "";
			delete $args{no_axes};
		}

		my $x_labels;
		if (exists $args{x_labels}) {
			$x_labels =
				(parse delete $args{x_labels})[1];
		} else {
			$x_labels = undef;
		}
		
# Validate the sizes in order to have a more friendly error.
		if (defined $x_labels) {
			arrayCheck "x_labels" => $x_labels;
			if (scalar @$x_labels != $length) {
				die <<EOF;
Size of x_labels not the same as length of data.
EOF
			}
		} else {
# If x_labels is not an array or empty, fill it with undefs.
			for (1..$length) {
				push @$x_labels, undef;
			}
		}

		my $n = 2;
		for (@data[1..$#data]) {
			if (scalar @$_ != $length) {
				die <<EOF;
Size of data$n does not equal size of data1.
EOF
			}
			$n++;
		}

		my $graph;
		eval {
			no strict 'refs';
			require "GD/Graph/$type.pm";
			$graph = ('GD::Graph::'.$type)->new($width, $height);
		}; if ($@) {
		 die <<EOF;
Could not create an instance of class GD::Graph::$type: $@
EOF
		}

		my $to_file = (parseElement delete $args{to_file})[1];
# Untaint it!
		($to_file) = ($to_file =~ /([\w.\/]+)/);

		for my $option (keys %args) {
			my ($type, $value, @rest) = parse ($args{$option});

			if (my $method = $graph->can("set_$option")) {
				$graph->$method($value, @rest);
			} else {
				if ($type == TYPE_LIST) {
					$value = [ $value, @rest ];
				}
				$args{$option} = $value;
			}

			arrayCheck $option, $value
				if index (ARRAY_OPTIONS, $option) != -1;
		};

# Check if background image specified.
		if (exists $args{background_image}) {
			my $image = new GD::Image($args{background_image});

			die <<EOF if not defined $image;
Could not open your background image: $!
EOF
			$graph->gd->copyResized(
				$image, 0, 0,
				0, 0, $width, $height,
				$image->getBounds
			); 

			delete $args{background_image};
		}

# Check if we need to draw captions, draw them after graph is plotted.
		my @captions;
		$i = 1;
		$key = "caption$i";
		while (exists $args{$key}) {
			die <<EOF unless UNIVERSAL::isa($args{$key}, 'ARRAY');
Caption must be an array. See the Apache::GD::Graph man page or the StringTTF
method in the GD man page for details.
EOF
			push @captions, delete $args{$key};
			$key = "caption".(++$i);
		}

# Style for the special gdStyled color.
		my $gd_style = delete $args{gd_set_style};

		$graph->set(%args);

		my $image = $graph->plot([$x_labels, @data])
			or die <<EOF;
Could not create graph: @{[ $graph->error ]}
EOF

		$image->setStyle (
			map { resolveColor ($graph => $_) }
			@$gd_style