package Apache::GD::Graph;

($VERSION) = '$ProjectVersion: 0.7 $' =~ /\$ProjectVersion:\s+(\S+)/;

=head1 NAME

Apache::GD::Graph - Generate Charts in an Apache handler.

=head1 SYNOPSIS

In httpd.conf:

	PerlModule Apache::GD::Graph

	<Location /chart>
	SetHandler	perl-script
	PerlHandler	Apache::GD::Graph
	# These are optional.
	PerlSetVar	Expires		30 # days.
	PerlSetVar	CacheSize	5242880 # 5 megs.
	PerlSetVar	ImageType	png
	# The default image type that graphs should be.
	# png is default, gif requires <= GD 1.19.
	# Any type supported by the installed version of GD will work.
	PerlSetVar	JpegQuality	75 # 0 to 100
	# Best not to specify this one and let GD figure it out.
	</Location>

Then send requests to:

C<http://www.server.com/chart?type=lines&x_labels=[1st,2nd,3rd,4th,5th]&data1=[1,2,3,4,5]&data2=[6,7,8,9,10]&dclrs=[blue,yellow,green]>

=head1 INSTALLATION

Like any other CPAN module, if you are not familiar with CPAN modules, see:
http://www.cpan.org/doc/manual/html/pod/perlmodinstall.html .

=head1 DESCRIPTION

The primary purpose of this module is to allow a very easy to use, lightweight
and fast charting capability for static pages, dynamic pages and CGI scripts,
with the chart creation process abstracted and placed on any server.

For example, embedding a pie chart can be as simple as:

	<img src="http://www.some-server.com/chart?type=pie&x_labels=[greed,pride,wrath]&data1=[10,50,20]&dclrs=[green,purple,red]" alt="pie chart of a few deadly sins">
	<!-- Note that all of the above options are optional except for data1!  -->

And it gets cached both server side, and along any proxies to the client, and
on the client's browser cache. Not to mention, chart generation is
very fast.

=item B<Graphs Without Axes>

To generate a graph without any axes, do not specify x_labels and append
C<y_number_format=""> to your query. Eg.

	http://www.some-server.com/chart?data1=[1,2,3,4,5]&y_number_format=""

=item B<Implementation>

This module is implemented as a simple Apache mod_perl handler that generates
and returns a png format graph (using Martien Verbruggen's GD::Graph module)
based on the arguments passed in via a query string. It responds with the
content-type "image/png" (or whatever is set via C<PerlSetVar ImageType>), and
sends a Expires: header of 30 days (or whatever is set via C<PerlSetVar
Expires>, or expires in the query string, in days) ahead.

In addition, it keeps a server-side cache in the file system using DeWitt
Clinton's File::Cache module, whose size can be specified via C<PerlSetVar
CacheSize> in bytes.

=head1 OPTIONS

=over 8

=item B<type>

Type of graph to generate, can be lines, bars, points, linespoints, area,
mixed, pie. For a description of these, see L<GD::Graph(3)>. Can also be one of
the 3d types if GD::Graph3d is installed, or anything else with prefix
GD::Graph::.

=item B<width>

Width of graph in pixels, 400 by default.

=item B<height>

Height of graph in pixels, 300 by default.

=item B<expires>

Date of Expires header from now, in days. Same as C<PerlSetVar Expires>.

=item B<image_type>

Same as C<PerlSetVar ImageType>. "png" by default, but can be anything
supported by GD.

If not specified via this option or in the config file, the image type can also
be deduced from a single value in the 'Accepts' header of the request.

=item B<jpeg_quality>

Same as C<PerlSetVar JpegQuality>. A number from 0 to 100 that determines the
jpeg quality and the size. If not set at all, the GD library will determine the
optimal setting. Changing this value doesn't seem to do much as far as line
graphs go, but YMMV.

=item B<cache>

Boolean value which determines whether or not the image will get cached
server-side (for client-side caching, use the "expires" parameter). It is true
(1) by default. Setting C<PerlSetVar CacheSize 0> in the config file will
achieve the same affect as C<cache=0> in the query string.

=back

For the following, look at the plot method in L<GD::Graph(3)>.

=over 8

=item B<x_labels>

Labels used on the X axis, the first array given to the plot method of
GD::Graph. If unspecified or undef, no labels will be drawn.

=item B<dataN>

Values to plot, where N is a number starting with 1. Can be given any number of
times with N increasing.

=back

ALL OTHER OPTIONS are passed as a hash to the GD::Graph set method using the
following rules for the values:

=over 8

=item B<undef>

Becomes a real undef.

=item B<[one,two,3]>

Becomes an array reference.

=item B<{one,1,two,2}>

Becomes a hash reference.

=item B<http://somewhere/file.png>

Is pulled into a file and the file name is passed to the respective option.
(Can be any scheme besides http:// that LWP::Simple supports.)

=item B<[undef,something,undef] or {key,undef}>

You can create an array or hash with undefs.

=item B<['foo',bar] or 'baz' or {'key','value'}>

Single and double quoted strings are supported, either as singleton values or
inside arrays and hashes.

Nested arrays/hashes are not supported at this time, let me know if you need
them for some reason.

=back

=cut

use strict;
use Apache;
use Apache::Constants qw/OK/;
use HTTP::Date;
use GD;
use GD::Graph;
use File::Cache;

use constant EXPIRES	=> 30;
use constant CACHE_SIZE	=> 5242880;
use constant IMAGE_TYPE => 'png';

use constant TYPE_UNDEF		=> 0;
use constant TYPE_SCALAR	=> 1;
use constant TYPE_ARRAY		=> 2;
use constant TYPE_HASH		=> 3;
use constant TYPE_URL		=> 4;

use constant STRIP_QUOTES => qr/['"]?(.*)['"]?/;

use constant ARRAY_OPTIONS => qw(
	dclrs borderclrs line_types markers types
);

# Sub prototypes:

sub handler ($);
sub parse ($;$);
sub arrayCheck ($$);
sub error ($);
sub makeDir ($);

# Subs:

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

# Files to delete after request is processed.
	my @cleanup_files;

	eval {
		my $args = scalar $r->args;
		my %args = ($r->args);

		error <<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 = +$args{expires} ||
			      +$r->dir_config('Expires') ||
			      EXPIRES;

		$expires   *= 24 * 60 * 60;
		$expires    = sprintf ("%d", $expires);

# Determine the type of image that the graph should be.
# Allow an Accepts: 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('Accepts');
		if (defined $accepts_header and
		    $accepts_header =~ m!^\s*image/(\w+)\s*$!) {
			my $image_type = $1;
		}

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

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

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

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

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

		unless (defined $cache_size and $cache_size != 0) {
			$image_cache = new File::Cache ( {
				namespace	=> 'Images',
				max_size	=> $cache_size || CACHE_SIZE,
				filemode	=> 0660
			} );

			if (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;
			}
		}

		$image_cache = undef if exists $args{cache} and
					not $args{cache};

		my $type   = delete $args{type}   || 'lines';
		my $width  = delete $args{width}  || 400;
		my $height = delete $args{height} || 300;

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

		my @data;
		my $key = "data1";
		while (exists $args{$key}) {
			my ($array) = (parse delete $args{$key});
			arrayCheck $key, $array;
			push @data, $array;
			$key++;
		}

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

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

		my ($x_labels, $x_labels_type);
		if (exists $args{x_labels}) {
			($x_labels, $x_labels_type) =
				parse delete $args{x_labels};
		} 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) {
				error <<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) {
				error <<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 ($@) {
		 error <<EOF;
Could not create an instance of class GD::Graph::$type: $@
EOF
		}

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

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

			if ($type == TYPE_URL) {
				push @cleanup_files, $args{$option};
			}
		};

		$graph->set(%args);

		my $result = $graph->plot([$x_labels, @data]);

		error <<EOF if not defined $result;
Could not create graph: @{[ $graph->error ]}
EOF

		my $image;
		if (defined $jpeg_quality) {
			$image = $result->jpeg($jpeg_quality);
		} else {
			$image = $result->$image_type();
		}

		$r->header_out("Expires" => time2str(time + $expires));
		$r->send_http_header("image/$image_type");
		$r->print($image);

		$image_cache->set($args, $image) if defined $image_cache;

	}; if ($@) {
		$r->log_error (__PACKAGE__.': '.$r->the_request.': '.$@);
	}

	if (@cleanup_files) {
		unlink @cleanup_files or
			$r->log_error (__PACKAGE__.': '.
			"Could not delete files: @cleanup_files, reason: $!");
	}

	return OK;
}

# parse ($datum[, $tmp_dir])
#
# Parse a datum into a scalar, arrayref or hashref. Using the following semi
# perl-like syntax:
#
# undef			-- a real undef
# foo_bar		-- a scalar
# [1,2,undef,"foo",bar]	-- an array
# {1,2,'3',foo}		-- a hash
# or
# http://some/url.png	-- pull a URL into a file, returning that. The file
# will be relative to a directory given as the second parameter, or /tmp if not
# specified.
sub parse ($;$) {
	local $_ = shift;
	my $dir  = shift || '/tmp';

	return (undef, TYPE_UNDEF) if $_ eq 'undef';

	if (/^\[(.*)\]$/) {
		return ([ map { $_ eq 'undef' ? undef : (/@{[STRIP_QUOTES]}/) }
				split /,/, $1, -1
		        ], TYPE_ARRAY);
	}

	if (/^\{(.*)\}$/) {
		return ({ map { $_ eq 'undef' ? undef : (/@{[STRIP_QUOTES]}/) }
				split /,/, $1, -1
		        }, TYPE_HASH);
	}

	if (m!^\w+://!) {
		use LWP::Simple;

		my ($url, $file_name) = ($_, $_);
		$file_name =~ s|/|\%2f|g;
		$file_name = $dir."/".$file_name;

		my $file = new IO::File "> ".$file_name or
			error "Could not open $file_name for writing: $!";
		binmode $file;
		print $file get($url);
		return ($file_name, TYPE_URL);
	}

	($_) = (/@{[STRIP_QUOTES]}/);

	return ($_, TYPE_SCALAR);
}

# arrayCheck ($name, $value)
#
# Makes sure $value is a defined array reference, otherwise calls error.
sub arrayCheck ($$) {
	my ($name, $value) = @_;
	error <<EOF if !defined $value or !UNIVERSAL::isa($value, 'ARRAY');
$name must be an array, eg. [1,2,3,5]
EOF
}

# error ($message)
#
# Display an error message and throw exception.
sub error ($) {
	my $message	= shift;
	my $r		= Apache->request;
	my $contact	= $r->server->server_admin;
	$r->send_http_header("text/html");
	$r->print(<<"EOF");
<html>
<head></head>
<body bgcolor="lightblue">
<font color="red"><h1>Error:</h1></font>
<p>
$message
<p>
Please contact the server administrator, <a href="$contact">$contact</a> and
inform them of the time the error occured, and anything you might have done to
cause the error.
</body>
</html>
EOF
	die $message;
}

1;

__END__

=head1 AUTHOR

Rafael Kitover (caelum@debian.org)

=head1 COPYRIGHT

This program is Copyright (c) 2000 by Rafael Kitover. This program is free
software; you can redistribute it and/or modify it under the same terms as Perl
itself.

=head1 ACKNOWLEDGEMENTS

This module owes its existance, obviously, to the availability of the wonderful
GD::Graph module from Martien Verbruggen <mgjv@comdyn.com.au>.

Thanks to my employer, marketingmoney.com, for allowing me to work on projects
as free software.

Thanks to Vivek Khera (khera@kciLink.com) and Scott Holdren
<scott@monsterlabs.com> for the bug fixes.

=head1 BUGS

Probably a few.

=head1 TODO

If possible, a comprehensive test suite.
Make it faster?

=head1 SEE ALSO

L<perl>,
L<GD::Graph>,
L<GD>

=cut
