view release on metacpan or  search on metacpan

Server/t/lib/Apache/AppCluster/Server.pm  view on Meta::CPAN

package Apache::AppCluster::Server;
use strict;
use Apache;
use Apache::Constants qw( :common );
use Storable qw( freeze thaw );
use Digest::MD5 qw( md5_hex );
use Time::HiRes;

use constant SRV_SUCCESS => 7;
use constant SRV_COULD_NOT_UNDERSTAND_REQ => 8;
use constant SRV_NO_SUCH_METHOD => 6;
use constant SRV_METHOD_RETURNED_ERROR => 9;

use vars qw( $VERBOSE $VERSION );

$VERSION = '0.02';

$VERBOSE = 0;

BEGIN
{
	my $begin_r = Apache->request();
	my $module_list = $begin_r->dir_config('AppCModules');
	$module_list =~ s/[\t\s\n\r]//g;
	$module_list =~ s/;$//; #remove trailing ; if found
	my @mods = split(';', $module_list);

	my $lib_list = $begin_r->dir_config('AppCLibs');
	$lib_list =~ s/[\t\s\n\r]//g;
	$lib_list =~ s/;$//; #remove trailing ; if found
	my @libs = split(';', $lib_list);


	foreach my $lib (@libs)
	{
		warn "AppCluster adding library directory: $lib" if($VERBOSE);
		my $p_code = "use lib '$lib';";
		eval $p_code;
		warn "A problem occured in Apache::AppCluster::Server while parsing your library directories: $@" if ($@);
	}

	foreach my $module (@mods)
	{
		warn "AppCluster adding module $module" if($VERBOSE);
		my $p_code = "use $module;";
		eval $p_code;
		warn "A problem occured in Apache::AppCluster::Server while parsing your modules: $@" if($@);
	}
	
}



sub handler
{
	my $r = shift @_;
	$r->send_http_header('text/html');
	if($r->method() eq 'POST')
	{
		my ($buf, $input);
		while($r->read($buf, $r->header_in('Content-Length')))
		{
			$input .= $buf;
		}
		my $response = {};
		if($input =~ m/<frozen>(.*)<\/frozen>/s)
		{
			my $data = $1;
			my $digest = substr($data, 0, 31);
			my $froz = substr($data, 32);
			if($digest == md5_hex($froz) )
			{
				my $struct = thaw($froz);
				my $func_name;
				if($struct->{method} =~ m/(.*?)(?:\(\)|$)/)
				{
					$func_name = $1;
					my $func_found = 0;
					if($func_name =~ m/(.*::)(.*)/)
					{
						no strict 'vars';
						no strict 'refs';
						my $sym_tbl = $1;
						my $func = $2;
						*stash = *{$sym_tbl};
						local (*alias) = $stash{$func};
						
						if(!defined &alias)
						{
							warn "Could not find function: $func_name" if($VERBOSE);
						} else
						{
							$func_found = 1;
						}
						
					}