# ====================================================================
# Copyright (c) 1998 The Apache Group.  All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
#
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer. 
#
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in
#    the documentation and/or other materials provided with the
#    distribution.
#
# 3. All advertising materials mentioning features or use of this
#    software must display the following acknowledgment:
#    "This product includes software developed by the Apache Group
#    for use in the Apache HTTP server project (http://www.apache.org/)."
#
# 4. The names "Apache Server" and "Apache Group" must not be used to
#    endorse or promote products derived from this software without
#    prior written permission.
#
# 5. Redistributions of any form whatsoever must retain the following
#    acknowledgment:
#    "This product includes software developed by the Apache Group
#    for use in the Apache HTTP server project (http://www.apache.org/)."
#
# THIS SOFTWARE IS PROVIDED BY THE APACHE GROUP ``AS IS'' AND ANY
# EXPRESSED OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
# PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE APACHE GROUP OR
# ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
# NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
# OF THE POSSIBILITY OF SUCH DAMAGE.
# ====================================================================
#
# This software consists of voluntary contributions made by many
# individuals on behalf of the Apache Group and was originally based
# on public domain software written at the National Center for
# Supercomputing Applications, University of Illinois, Urbana-Champaign.
# For more information on the Apache Group and the Apache HTTP server
# project, please see <http://www.apache.org/>.
#

# Apache::Servlet - access the Java Servlet engine from mod_perl
# Copyright (c) 1997,1998 by Ian Kluft

package Apache::Servlet;

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

# constatnts
sub SERVLET_AUTH { "A"; }
sub SERVLET_CLASS { "C"; }
sub SERVLET_ENV { "E"; }
sub SERVLET_HDR { "H"; }
sub SERVLET_SERVER { "S"; }

# 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
#   dir - directory where class can be found
#   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)
# [private]
sub do_request
{
	my ( $self, $req, $jdir, $jclass, $env_ref, $header_ref, $entity_ref,
		$entity_type ) = @_;
	my ( $socket, $key, $line, $recvbuf, $resp_buffer, $server );

	# 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
	my $host = $self->{req}->notes("jserv-host");
	if ( !defined $host) {
		$host = "localhost";
	}
	$socket = new Net::TCP ( $host, $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}."\t");
	$self->send(SERVLET_CLASS, $jdir."\t".$self->{jclass});
	$server = $self->{req}->server();
	$self->send(SERVLET_SERVER, $server->server_hostname());
	foreach $key ( sort keys %$env_ref ) {
		$self->send(SERVLET_ENV, $key."\t".$env_ref->{$key});
	}
	foreach $key ( sort keys %$header_ref ) {
		$self->send(SERVLET_HDR, $key."\t".$header_ref->{$key});
	}
	$self->send_entity_hdrs($entity_ref);
	$self->send_entity($entity_ref); # flushes accumulated buffer

	# wait for the response from the servlet
	while ( $recvbuf = $self->{socket}->recv) {
		$resp_buffer .= $recvbuf;
	}

	# extract headers from response
	while ( length($resp_buffer) > 0 ) {
		if ( $resp_buffer =~ /^(\r{0,1}\n)/ ) {
			substr ( $resp_buffer, 0, length($1)) = "";
			last;
		}

		if ( $resp_buffer =~ /^(^[^\n]*)(\r{0,1}\n)/ ) {
			my $line = $1;
			substr ( $resp_buffer, 0, length($1)+length($2)) = "";
			if ( $line =~ /^([^:]+):\s+(.*)/ ) {
				$self->insert_resp_header( $1, $2 );
			}
			next;
		}

		# no remaining newlines's - use this as one header
		if ( $resp_buffer =~ /^([^:]+):\s+(.*)/ ) {
			$self->insert_resp_header( $1, $2 );
		}
		$resp_buffer = "";
		last;
	}

	$self->{resp_entity} = $resp_buffer;
	undef;
}

# save header/log/error line from servlet response
# [private]
sub insert_resp_header
{
	my ( $self, $name, $value ) = @_;
	my $lcname = lc($name);

	if ( $lcname eq "servlet-error" ) {
		if ( ! defined $self->{resp_errors}) {
			$self->{resp_errors} = [];
		}
		push @{$self->{resp_errors}}, $value;
	} elsif ( $lcname eq "servlet-log" ) {
		if ( ! defined $self->{resp_logs}) {
			$self->{resp_logs} = [];
		}
		push @{$self->{resp_logs}}, $value;
	} else {
		if ( ! defined $self->{resp_headers}) {
			$self->{resp_headers} = {};
		}
		if ( defined $self->{resp_headers}{$lcname}) {
			$self->{resp_headers}{$lcname} .= "\n".$value;
		} else {
			$self->{resp_headers}{$lcname} = $value;
		}
	}
	undef;
}

# set the servlet engine's port and auth code from info exported by mod_jserv
# [private]
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)
# [private]
sub send
{
	my ( $self, $type, $str ) = @_;

	$self->{send_buffer} .=
		sprintf("%04x",length($str)+1).$type.$str;
}

# send headers that describe the request entity
# [private]
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\t".$entity_type);
		$self->send(SERVLET_HDR,"CONTENT_LENGTH\t".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
# [private]
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
# [private]
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)
# [private]
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->{resp_headers};
}

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

	return $self->{resp_headers}{lc($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->{resp_headers}{"servlet-error"}) {
		if ( !defined $self->{resp_headers}{status}) {
			$self->{req}->status(500);
		}
		$self->{req}->log_error(
			$self->{resp_headers}{"servlet-error"})
	} elsif ( defined $self->{resp_headers}{status}) {
		$self->{req}->status_line(($self->{req}->protocol)." "
			.($self->{resp_headers}{status}));
	}
        foreach $key ( sort keys %{$self->{resp_headers}} ) {
                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->{resp_headers}{$key})
                } elsif ( $key =~ /^content-type$/i ) {
			$self->{req}->content_type(
				$self->{resp_headers}{$key});
                } elsif ( $key =~ /^content-encoding$/i ) {
			$self->{req}->content_encoding(
				$self->{resp_headers}{$key});
                } elsif ( $key =~ /^content-language$/i ) {
			$self->{req}->content_language(
				$self->{resp_headers}{$key});
		} else {
			$self->{req}->header_out($key,
				$self->{resp_headers}{$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 ( sort keys %{$self->{resp_headers}} ) {
		$self->{req}->print( "<b>$key</b> = ".
				$self->{resp_headers}{$key}."\n",
			"<br>");
        }

	# dump servlet response errors
	if (( defined $self->{resp_errors}) and
		$#{$self->{resp_errors}} >= 0 )
	{
		my $line;
		$self->{req}->print (
			"<hr><p>\n",
			"<font size=+2>Response Errors</font>\n",
			"<blockquote>\n" );
		foreach $line ( @{$self->{resp_errors}})
		{
			$self->{req}->print (
				"$line\n",
				"<br>\n" );
		}
		$self->{req}->print (
			"</blockquote>\n",
			"<p>\n" );
	}

	# dump servlet response logs
	if (( defined $self->{resp_logs}) and
		$#{$self->{resp_logs}} >= 0 )
	{
		my $line;

		$self->{req}->print (
			"<hr><p>\n",
			"<font size=+2>Response Log Messages</font>\n",
			"<blockquote>\n" );
		foreach $line ( @{$self->{resp_logs}})
		{
			$self->{req}->print (
				"$line\n",
				"<br>\n" );
		}
		$self->{req}->print (
			"</blockquote>\n",
			"<p>\n" );
	}

	# 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;

__END__

=head1 NAME

Apache::Servlet -
Methods for accessing the I<Apache JServ> servlet engine from I<mod_perl>

=head1 DESCRIPTION

Apache::Servlet is a Perl5 module made to run with I<mod_perl> inside an
I<Apache HTTPD> process.  It can be used to connect to an I<Apache JServ>
Java servlet engine the same way that I<mod_jserv> does.
It only works if I<mod_jserv> is present because I<mod_jserv> starts and
initializes the servlet engine.
But after that point, Apache::Servlet allows I<mod_perl> scripts to
make request to Java Servlets and capture the output for further processing.

=head1 SYNOPSIS

The following methods are available from Apache::Servlet:

C<$obj =  new Apache::Servlet( $request, $servlet_dir, $servlet_class, $env_ref, $header_ref, $entity_ref, $entity_type);>

C<$hashref = $obj-E<gt>get_headers();>

C<$scalar = $obj-E<gt>get_header( $name );>

C<$scalar = $obj-E<gt>get_entity();>

C<$obj-E<gt>return_results();>

C<$obj-E<gt>dump_results();>

=head2 constructor

C<$obj =  new Apache::Servlet( $request, $servlet_dir, $servlet_class, $env_ref, $header_ref, $entity_ref, $entity_type);>

C<$request> is a reference to the Apache API's request structure.
Use C<$r> for the HTTP client request.
Or if needed, you may use a subrequest if you create one.

C<$servlet_dir> is the full path of the directory where the servlet class
file can be found.

C<$servlet_class> is a string with the name of the Java servlet class that
will be invoked by the servlet engine.

C<$env_ref> is a reference to a hash containing a CGI-like environment.
You may construct your own environment from scratch if needed.
Otherwise, the default is the CGI environment from I<mod_perl>
for the current HTTP request via C<$r-E<gt>cgi_env()>.

C<$header_ref> is a reference to a hash containing the
servlet request headers.
You may construct your own request headers.
Otherwise, the default is the HTTP client headers from I<mod_perl>
for the current HTTP request via C<$r-E<gt>headers_in()>.

C<$entity_ref> is a scalar string with the entity contents.
The default is an empty input entity.

C<$entity_type> is the MIME type of the HTTP input entity.
The default is an empty value,
which is appropriate if the input itself is empty.

The servlet response can then be found in variables inside C<$obj>.
C<$obj-E<gt>{resp_headers}> is a reference to a hash containing the
response headers and their values.
(The header names have been converted to lower case for case-insensitive
lookup capability.)

C<$obj-E<gt>{resp_entity}> contains the response entity.
The response type may be any MIME type.
For the most common example, if C<$obj-E<gt>{resp_headers}{"content-type"}>
is "text/html" then the response entity contains HTML text.
However, there's nothing to prevent a servlet from returning
something humanly-unreadable like an audio clip
if the MIME type is appropriately set.

C<$obj-E<gt>{resp_logs}> contains a reference to an array of log entries.

C<$obj-E<gt>{resp_errors}> contains a reference to an array of error messages
from the servlet.

=head2 get_headers

C<$hashref = $obj-E<gt>get_headers();>

returns a reference to a hash containing the response headers returned from
the servlet.

=head2 get_header

C<$scalar = $obj-E<gt>get_header( $name );>

returns the value of a single header by name.

=head2 get_entity

C<$scalar = $obj-E<gt>get_entity();>

returns a scalar containing the full response entity from the servlet.
I<(Caution: this could be enormous!)>

=head2 return_results

C<$obj-E<gt>return_results();>

Send the collected servlet results back to the HTTP client.
This could possibly have been done after modifying the results.

=head2 dump_results

C<$obj-E<gt>dump_results();>

For debugging purposes, this dumps the servlet output on the HTTP client
output, breaking it down by parts of the response.

=head1 CONFIGURATION

You must already have I<mod_jserv> and the I<Apache JServ> 
configured and running before Apache::Servlet will work.

Your Apache configuration must include C<ServletAuthExport On>
in order for Apache::Servlet to obtain the authentication and host
information needed to contact the I<Apache JServ> engine.  Otherwise
I<mod_jserv> will not export this information to other Apache modules.

=head1 DEPENDENCIES

This is the version of Apache::Servlet that comes with version 0.9.10
of the Apache JServ.

In order to build and install Apache::Servlet, you must first have
I<Apache HTTPD> 1.2 or greater, I<mod_jserv> 0.9.10,
I<mod_perl> 1.00 or greater, and any version (preferably current) of
the Net::TCP perl5 module.

B<Note:> I<mod_jserv> and the I<Apache JServ> engine
will undergo a change in their protocol around the
time frame of 0.9.11 or some release after that.
Once that change occurs, this version of
Apache::Servlet will no longer work and will be forever obsolete.
However, a new updated version will be included with the new 
I<Apache JServ> engine.

=head1 SEE ALSO

=for html
<a href="http://java.apache.org/doc/">Java-Apache Project Documentation</a>
<p>

=for text
Java-Apache Project Documentation at http://java.apache.org/doc/

=for html
mod_perl <a href="http://perl.apache.org/">Home Page</a>
and other documentation
<p>

=for text
mod_perl Home Page at http://perl.apache.org/ and other documentation

=head1 AUTHOR

Apache::Servlet was written by Ian Kluft.
The I<Apache JServ> servlet engine and the I<mod_jserv> Apache module
were written by many volunteers of the Java-Apache Project.
I<mod_perl> was written by Doug MacEachern
with contributions by many other volunteers.

=head1 CAVEATS

This is experimental only.
Apache::Servlet will soon undergo changes to
the protocol to talk with the Apache JServ engine
when the Apache JServ Protocol Version 2 is introduced..
If you use this perl module, you probably should join the
Java-Apache developers mail list and watch for patches
(or even provide your own.)

=cut
