# Apache::Servlet - access the Java Servlet engine from mod_perl
# Copyright (c) 1997 by Ian Kluft
#
# Usage permissions granted by the author are the same as Perl itself.
# See the Perl5 source code LICENSE or
#    http://language.perl.com/misc/Artistic.html

package Apache::Servlet;

# set up perl environment
use strict;
use Net::TCP;

# constatnts
sub SERVLET_AUTH { "A"; }
sub SERVLET_ENV { "E"; }
sub SERVLET_HDR { "H"; }

# constructor
# This creates an Apache::Servlet object, which encapsulates the information
# to handle a connection to the Servlet Engine for one request.
sub new
{
        my $class = shift;
        my $self  = {};
 
        bless $self, $class;
        $self->do_request(@_);
        return $self;
}

# do_request - initialize the object, do the connection, save results in self
# parameters:
#   req - Apache request record handle
#   jclass - Java servlet class to invoke on the Servlet engine
#   env_ref - reference to hash containing CGI-like environment/headers (opt)
#      may be "0" to omit it but still include later parameters
#   header_ref - reference to hash containing HTTP headers (opt)
#      may be "0" to omit it but still include later parameters
#   entity_ref - if a request entity is to be provided, send it (opt)
#   entity_type - MIME type of entity (opt)
sub do_request
{
	my ( $self, $req, $jclass, $env_ref, $header_ref, $entity_ref,
		$entity_type ) = @_;
	my ( $socket, $key, $line, $recvbuf, $resp_entity );

	# save parameters
	$self->{jclass} = $jclass;
	$self->{req} = $req;

	# get info from Apache
	if ( !$self->set_servlet_auth()) {
		# self->{fatal} should already contain ref to error messages
		return;
	}

	# fill in defaults for missing parameters
	if (( !defined $env_ref ) or ref($env_ref) ne "HASH" ) {
		$env_ref = $self->default_env();
	}
	if (( !defined $header_ref ) or ref($header_ref) ne "HASH" ) {
		$header_ref = $self->default_headers();
	}

	# set up the socket
	$socket = new Net::TCP ( "localhost", $self->{port});
	if ( !$socket ) {
		$self->{fatal} = [ "socket connect failed: $!" ];
		return;
	}
	$self->{socket} = $socket;

	# send the request down the pipe to the servlet engine
	$self->send(SERVLET_AUTH, $self->{auth}, $self->{jclass});
	foreach $key ( sort keys %$env_ref ) {
		$self->send(SERVLET_ENV, $key, $env_ref->{$key});
	}
	foreach $key ( sort keys %$header_ref ) {
		$self->send(SERVLET_HDR, $key, $header_ref->{$key});
	}
	$self->send_entity_hdrs($entity_ref);
	$self->send_entity($entity_ref); # flushes accumulated buffer

	# wait for the response from the servlet
	$self->{response} = {};
	while (( $line = $self->{socket}->getline) and length($line) > 0 ) {
		if ( $line =~ /^([^\s:]):\s*(.*)\r{0,1}\n{0,1}$/ ) {
			my ( $name, $value ) = ( $1, $2 );

			$name =~ tr/[A-Z]/[a-z]/;
			$self->{response}{$name} = $value;
		} else {
			last;
		}
	}
	$self->{resp_entity} = "";
	while ( $recvbuf = $self->{socket}->recv) {
		$self->{resp_entity} .= $recvbuf;
	}
}

# set the servlet engine's port and auth code from info exported by mod_jserv
sub set_servlet_auth
{
	my ( $self ) = @_;
	my ( $auth, $port );

	$auth = $self->{req}->notes("jserv-auth");
	$port = $self->{req}->notes("jserv-port");

	if (( !defined $auth ) or ( !defined $port )) {
		$self->{fatal} = [
			"mod_jserv is either not present or not exporting "
				."its auth code",
			"add \"ServletAuthExport On\" to your config file"
		];
		return 0;
	}
	$self->{auth} = $auth;
	$self->{port} = $port;
	return 1;
}

# send a key/value pair to the servlet engine
# (actually, accumulate them in a buffer for one big send later)
sub send
{
	my ( $self, $type, $name, $value ) = @_;

	$self->{send_buffer} .=
		sprintf("%04x",length($name)+length($value)+2).
			"$type$name\t$value";
}

# send headers that describe the request entity
sub send_entity_hdrs
{
	my ( $self, $entity, $entity_type ) = @_;

	if (( defined $entity ) && length($entity) > 0 ) {
		if (( !defined $entity_type ) or length($entity_type) == 0 ) {
			# default types
			if ( $entity =~ /[^\s\040-\177]/is ) {
				$entity_type = "application/binary";
			} else {
				$entity_type = "text/plain";
			}
		}
		$self->send(SERVLET_HDR,"CONTENT_TYPE",$entity_type);
		$self->send(SERVLET_HDR,"CONTENT_LENGTH",length($entity));
	}
	# if entity is empty, we fall through and do nothing...
}

# send the request entity
# also actually sends the buffer to the servlet engine
sub send_entity
{
	my ( $self, $entity ) = @_;

	# a zero-length line is blank in effect, ends the header section
	$self->{send_buffer} .= "0000";

	# append the request entity, if one exists
	if (( defined $entity ) && length($entity) > 0 ) {
		$self->{send_buffer} .= $entity;
	}

	# send the buffer down the socket
	$self->{socket}->send($self->{send_buffer});
}

# get a default request environment
sub default_env
{
	my ( $self ) = @_;

	# Apache.pm defines a handy CGI environment hash.  So we'll use it.
	# Note: this is a copy of Apache.pm's data, safe to modify it
	my ( %cgi_env ) = $self->{req}->cgi_env();
	return \%cgi_env;
}

# get a default header list (i.e. the real header list)
sub default_headers
{
	my ( $self ) = @_;

	# use Apache.pm's incoming header hash
	# Note: this is a copy of Apache.pm's data, safe to modify it
	my ( %headers_in ) = $self->{req}->headers_in();
	return \%headers_in;
}

# (after initialization) this function accesses the response headers
# returns a reference to the hash
sub get_headers
{
	my ( $self ) = @_;

	return $self->{response};
}

# (after initialization) this function accesses a single response header
# returns a scalar string value
sub get_header
{
	my ( $self, $name ) = @_;

	return $self->{response}{$name};
}

# (after initialization) this function accesses the response entity
# returns a reference to the (possibly huge) scalar string value
sub get_entity
{
	my ( $self ) = @_;

	return \$self->{resp_entity};
}

# After a chance to modify the response, this returns the Servlet results
# as Apache's results.  This is optional - you can actually mangle, extract
# or discard any of the results as needed.
sub return_results
{
	my ( $self ) = @_;
	my ( $key );

	if ( defined $self->{fatal} ) {
		# fatal error in Apache::Servlet module

		# log error
		$self->{req}->log_reason("Failure in Apache::Servlet",
			$self->{req}->uri());
		foreach ( @{$self->{fatal}}) {
			$self->{req}->log_error($_);
		}

		# return fatal result to client
		$self->{req}->status(500);
		$self->{req}->send_http_header();
		$self->{req}->print( "Errors occured in the servlet call.",
			@{$self->{fatal}});
		return;
	}

        # results recovered from Servlet (could be success or failure)
	if ( defined $self->{response}{"servlet-error"}) {
		if ( !defined $self->{response}{status}) {
			$self->{req}->status(500);
		}
		$self->{req}->log_error(
			$self->{response}{"servlet-error"})
	} elsif ( defined $self->{response}{status}) {
		$self->{req}->status_line(($self->{req}->protocol)." "
			.($self->{response}{status}));
	}
        foreach $key ( keys %{$self->{response}} ) {
                if ( $key =~ /^status$/i ) {
			next;	# already been handled
                } elsif ( $key =~ /^servlet-error$/i ) {
			next;	# already been handled
                } elsif ( $key =~ /^servlet-log$/i ) {
                        $self->{req}->log_error($self->{response}{$key})
                } elsif ( $key =~ /^content-type$/i ) {
			$self->{req}->content_type(
				$self->{response}{$key});
                } elsif ( $key =~ /^content-encoding$/i ) {
			$self->{req}->content_encoding(
				$self->{response}{$key});
                } elsif ( $key =~ /^content-language$/i ) {
			$self->{req}->content_language(
				$self->{response}{$key});
		} else {
			$self->{req}->header_out($key,
				$self->{response}{$key});
                }
        }
	$self->{req}->send_http_header();
	if (( defined $self->{resp_entity})
		and length($self->{resp_entity}) > 0 )
	{
		$self->{req}->print($self->{resp_entity});
	}
	return;
}

# for debugging: dump the response from the servlet
sub dump_results
{
	my ( $self ) = @_;
	my ( $key );

	if ( defined $self->{fatal} ) {
		# fatal error in Apache::Servlet module

		# log error
		$self->{req}->log_reason("Failure in Apache::Servlet",
			$self->{req}->uri());
		foreach ( @{$self->{fatal}}) {
			$self->{req}->log_error($_);
		}

		# return fatal result to client
		$self->{req}->status(500);
		$self->{req}->send_http_header();
		$self->{req}->print( "Errors occured in the servlet call.",
			@{$self->{fatal}});
		return;
	}

        # results recovered from Servlet (could be success or failure)
	$self->{req}->status(200);
	$self->{req}->content_type("text/html");
	$self->{req}->send_http_header();
	$self->{req}->print(
		"<html>\n",
		"<head>\n",
		"<title>Servlet Response Dump</title>\n",
		"</head>\n",
		"<body bgcolor=\"#ffffff\">\n",
		"<center>\n",
		"<h1>Servlet Response Dump</h1>\n",
		"</center>\n",
		"<hr>\n",
		"<font size=+2>Response Headers</font>\n",
		"<p>\n" );

        foreach $key ( keys %{$self->{response}} ) {
		$self->{req}->print( "<b>$key</b> = ".
				$self->{response}{$key}."\n",
			"<br>");
        }

	# make a copy so that this is nondestructive to the response entity
	# convert the copy for HTML printing
	my $entity_copy = $self->{resp_entity};
	$entity_copy =~ s/&/&amp;/gs;
	$entity_copy =~ s/</&lt;/gs;
	$entity_copy =~ s/>/&gt;/gs;
	$entity_copy =~ s/"/&quot;/gs;
	$entity_copy =~ s/\t/&#9;/gs;
	#$entity_copy =~ s/\n/&#10;/gs;
	#$entity_copy =~ s/\r/&#13;/gs;
	#$entity_copy =~ s/ /&#32;/gs;

	$self->{req}->print(
		"<hr><p>\n",
		"<font size=+2>Response Content</font>\n",
		"(".length($self->{resp_entity})." characters)\n",
		"<pre>\n",
		"$entity_copy\n",
		"</pre>\n",
		"</body>\n",
		"</html>\n" );
	return;
}

1;