Apache-GDGraph
1 match

 view release on metacpan or  search on metacpan

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

# (3,4,undef,"baz")	-- a list
# {1,2,'3',foo}		-- a hash
# 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.
# ../some/file		-- a file relative to DocumentRoot
sub parse ($;$) {
	local $_ = shift;
	my $dir  = shift || '/tmp';

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

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

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

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

	return parseElement $_, $dir;
}

# parseElement ($value)
#
# First strips quotes off the ends of $value.  Then checks whether $value is a
# URL, and if so, fetches it into a file and returns the (TYPE_URL, file_name),
# otherwise returns (TYPE_SCALAR, $value).
#
# Will also parse paths relative to DocumentRoot, for example
# ../fonts/arial.ttf.
sub parseElement ($;$) {
	$_	= shift;
	my $dir	= shift || '/tmp';

	if (defined(my $constant = GD_CONSTANTS->{$_})) {
		return (TYPE_SCALAR, $constant)
	}

	$_ = $1 if /@{[STRIP_QUOTES]}/;

	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;
		my $contents = get($url);

		error <<EOF unless defined $contents;
Could not retrieve data from: $url
EOF

		print $file $contents;

		push @cleanup_files, $file_name;

		return (TYPE_URL, $file_name);
	} elsif (s!^\.\./!!) {
		my $file_name = $document_root.'/'.$_;

		return (TYPE_URL, $file_name);
	} else {
		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)
#
# Sends a page with the error message to the browser.
sub error ($) {
	my $message	= shift;
# Ending newlines look ugly in the error log.
	chomp $message;
	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>
The Request was:<br>
@{[ $r->the_request ]}
<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

	$r->log_error (__PACKAGE__.': '.$r->the_request.': '.$message);
}



( run in 1.924 second using v1.01-cache-2.11-cpan-cdf2f3d4e48 )