File Coverage

Java.pm

Criterion	Covered	Total	%
statement	42	249	16.8
branch	3	84	3.5
condition	3	35	8.5
subroutine	13	42	30.9
pod	2	27	7.4
total	63	437	14.4

# $Header: /cvsroot/javaserver/javaserver/JavaServer/perl/Java.pm,v 1.3 2004/02/25 07:52:15 zzo Exp $
# $Revision: 1.3 $
# $Log: Java.pm,v $
# Revision 1.3  2004/02/25 07:52:15  zzo
# - Fix test scripts to use local Java.pm & Test & Test2 classes in the
# com.zzo.javaserver package
# - added 'destroy' method to Java.pm so y'all can hand destroy objects
#
# Revision 1.2  2004/01/19 23:28:59  zzo
# Moved the java files around to put them in 'com.zzo.javaserver' package
# Fixed test script
#
# Revision 1.1.1.1  2003/11/17 22:08:07  zzo
# Initial import.
#
# Revision 1.16  2003/06/24 17:28:48  mark
# - Correctly encode parameter value for static set_field calls
# - 'die' instead of exit on authentication failure
# - anchor 'false:b' regex in pretty_args
# - try to make install more platform independent
#
# Revision 1.15  2003/04/14 22:50:51  mark
# allow negative integers, test fix
#
# Revision 1.14  2002/09/03 17:26:43  mark
# bump version #
#
# Revision 1.13  2002/09/03 17:21:03  mark
# Fix Makefile.PL so EXE_FILES are an anon array
# When checking for ERROR make sure it must begin on beginning of line!
# Better perldocs
#
# Revision 1.12  2001/11/30 19:18:52  mark
# Windows fix
#
# Revision 1.11  2001/08/13 18:36:08  mark
# Make the auth secret stuff work w/Winblows & Krapple by getting rid of
# '\015' chars @ end of line
#
# Revision 1.10  2001/08/02 16:05:14  mark
# Fix for Windows authentication
#
# Revision 1.9  2001/08/01 21:53:08  mark
# version to 4.1.1
#
# Revision 1.8  2001/08/01 21:51:38  mark
# Fixed generic handling of pulling out instance data from 'java' object
#
# Revision 1.7  2001/07/29 21:18:37  mark
# VERSION up to 4.1
#
# Revision 1.6  2001/07/20 22:39:44  mark
# Allow blank lines for callbacks
#
# Revision 1.5  2001/07/17 15:50:25  mark
# Made sure exceptions are stored in the 'java' object & not the
# instantiated object.  added some convenience functions for this too
#
# Revision 1.4  2001/07/13 14:59:51  mark
# Put eval'ed callbacks in package main by default like it should have been
# in the first place
#
# Revision 1.3  2001/07/10 18:47:36  mark
# Changed '\r' to more portable '\015'
#
# Revision 1.2  2001/07/09 23:05:51  mark
# Clean up
#
# Revision 1.1.1.1  2001/07/09 22:33:57  mark
# Initial Toss In
#
# Revision 1.2  2000/05/15 21:24:37  markt
# This is da Big Daddy
#

package Java;

# Perl5 is good enough for me I think
require 5;

##
# If you 'use strict' you have to do 'no strict 'subs'' 'cuz all Java
#	function calls are AUTOLOAD'ed - sorry.
##

use Socket;
use Symbol;
use Carp;

# NOTE - you may have to 'use IO::Socket::INET' if yer perl install
#	is cracked...
use IO::Socket;

# Fancy pants array stuff
use JavaArray;

# Now allow '==' to mimic 'same' functionality
use overload '==' => "same", 'fallback' => 1;

use vars qw ($AUTOLOAD @ISA $VERSION);

require Exporter;
@ISA = qw(Exporter);

$VERSION = '4.7';

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Java ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.

# Extremely cheesy
use constant PARAMETER_SEPARATOR => "
";

use constant NULL_TOKEN => "___NULL___";

# Preloaded methods go here.
sub new
{
	my $self = {};
	bless $self, shift;
	$self->_init(@_);
	return $self;
}

##
# When ya first create one of these monsters it'll try to connect
#	to JavaServer running on
#	host => host
#	port => port
#
#	And the JavaServer will attempt to connect to US on event_port...
#	event_port => event port
#
#	supplied in 'new' arguments or use defaults
#	'localhost', 2000 & 2001
#
#       Also it'll use old-style arrays  if specified.
sub _init
{
	my($self,%attrs) = @_;

	$self->{port} = $attrs{port} || 2000;
	$self->{host} = $attrs{host} || "localhost";
	$self->{event_port} = $attrs{event_port} || 2001;

	# It's now the default!
	$self->{use_tied_arrays} = 1 unless $attrs{use_old_style_arrays};

	##
	# Set up them sockets!
	##

	# Client/control socket
	$self->{socket} = IO::Socket::INET->new
		(
			PeerAddr => $self->{host},
			PeerPort => $self->{port}
		);

	if (!$self->{socket})
	{
		croak("Client socket error: $!");
	}
	# Make sure we're autoflushed
	$self->{socket}->autoflush(1);

	my $authSecret = "";

	# Check for authorization file & use it!
	if (defined($attrs{authfile}))
	{
		open(AUTH,$attrs{authfile}) or croak("Could not open ".$attrs{authfile}.": $!\n");
		$authSecret=;
		close(AUTH);
		$authSecret =~ s/\015//g;	# clean up input from Winblows
		chomp($authSecret);
	}

	# Send Auth token
	$self->{socket}->print("AUTH: ".$authSecret."\n");

	# Check response
	my $line = $self->{socket}->getline;
	$line =~ s/\015//g;	# clean up input from Winblows
	chomp $line;

    die("Authentication Failed: $line") unless ($line =~ 'OK');

	# Set to '-1' to disable events
	if ($self->{event_port} > 0)
	{
		#
		# Set up our event_socket server
		#
		$self->{event_server} = IO::Socket::INET->new
			(
				Listen => 5,
				LocalPort => $self->{event_port},
				Proto => 'tcp',
				Reuse => 1
			);

		if (!$self->{event_server})
		{
			croak("Couldn't create event_server socket: $!");
		}
	}

	## Tell JavaServer what port we want our events on...
	$self->{socket}->print($self->{event_port}."\n");

	if ($self->{event_port} > 0)
	{
		# Don't wanna do nuthin' until we hear from JavaServer on our
		#	event_server port
		my $peer_address;
		($self->{event_socket}, $peer_address) = $self->{event_server}->accept;

		#my($port, $iaddr) = sockaddr_in($peer_address);
		#$iaddr = inet_ntoa($iaddr);
		#print STDERR "Event port connexion from $iaddr:$port!\n";

		# Don't wanna accept any more event_server connexions
		undef $self->{event_server};

		# AutoFlush this bad boy
		#	We're only gonna use this monster to read events
		$self->{event_socket}->autoflush(1);
	}
}

###
# This is used to create a new Java object
###
sub create_object
{
	my($self,$what,@args) = @_;

	# pretty up the arguments for java-land
	@args = pretty_args(@args);

	local($") = PARAMETER_SEPARATOR;
	my $resp = $self->send_command_and_get_response("NEW $what(@args)");
	#
	# Create a new java object
	#
	$self->new_java_object($resp);
}

# Get callback object so server side can make perl calls
sub get_callback_object
{
	my($self) = @_;

	my $resp = $self->send_command_and_get_response("BCK");

	$self->new_java_object($resp);
}

# Guess what this does...
sub create_array
{
	my($self,$what,@indicies) = @_;

	# We don't need to pretty args here....  all assumed to be ints
	#	and need to be separated by commans NOT PARAMETER_SEPARATOR
	local($") = ",";
	my $resp = $self->send_command_and_get_response("NEW [L$what;(@indicies)");
	$self->new_java_object($resp);
}

# Hmmm... wonder what this does?
sub set_field
{
	my($self,$index,@args) = @_;

	# pretty up the arguments for java-land
	@args = pretty_args(@args);

	local($") = PARAMETER_SEPARATOR;
	my $line;

	# Figure out what we're dealing with...
	if ($self->_is_java)
	{
		# static object
		$line = "SET $_[1]#$_[2](@args[1..$#args])";
        print "STATIC LINE: $line\n";
	}
	else
	{
		# instantiated object
		$line = "SET $self->{name}#$index(@args)";
	}

	my $resp = $self->send_command_and_get_response($line);
	$self->new_java_object($resp);
}

sub get_length
{
	# Get an array's length
	my($self) = @_;
	my $line = "GET $self->{name}#LEN";
	my $resp = $self->send_command_and_get_response($line);
	# We're just getting a raw integer back here...
	chomp $resp;
	$resp;
}



###
# Bless the returned string into a 'Java' object
#	& be mindful of if this 'self' already points to a
#	java object or not
###
sub new_java_object
{
	my($self, $line) = @_;
	chomp $line;

	# NULL!
	return 0 if ($line eq 'NUL');

	#
	# If we're creating this object from another one
	#	i.e. from a method call
	# pull the 'java' portion outta there...
	my $java = $self->_get_in_java('java');

	#print STDERR "Created Java Object $line\n";
	my $obj = (bless { name => $line, java => $java }, ref $self);

        #
        # If we're using the tied array syntax convert this guy into
        #       a tied array IF INDEED it is an array that is!
        #
        if ($java->{use_tied_arrays})
        {
                if ($line =~ /^\[/)
                {
                        my @java_object;
                        tie @java_object, 'JavaArray', $obj;
                        return \@java_object;
                }
        }

        # Otherwise just return the thang
        return $obj;
}

# Gets the client socket
sub get_socket
{
	my ($self) = shift;
	$self->_get_in_java('socket');
}

# Gets the incoming event socket
sub get_event_socket
{
	my ($self) = shift;
	$self->_get_in_java('event_socket');
}

sub send_line
{
	my($self,$line) = @_;
	return if (!$self || !defined($line));
	print "Sending line: $line\n" if $DEBUG;
	$self->get_socket->print("$line\n
\n");
}

sub send_command_and_get_response
{
	my($self,$line) = @_;
	my $resp = "";
	if ($self->send_line($line))
	{
		# The response ends w/a 
 on a line by itself
		while (1)
		{
			my $line;
			$line = $self->get_socket->getline;
			if (!defined $line)
			{
				croak("Error receiving response");
			}
			$line =~ s/\015//g;	# clean up input from Winblows

			# Check for end of response
			last if ($line =~ /^
$/);

			$resp .= $line;
		}

		chomp $resp;	# clean up last newline

		# Pull out the Exception object if it's there
		if ($resp =~ /^ERROR/)
		{
			# Peel off Exception object if it's there
			if ($resp =~ s/%%%(.*)$//)
			{
				# & keep track of it in the Java object
				my $ex_obj = $self->new_java_object($1);
				$self->_set_in_java('last_exception',$ex_obj);
			}
			croak($resp);
		}

		return $resp;
	}
	else
	{
		croak("Error sending $line");
	}
}

# Gets the most recent Exception object
sub get_exception
{
	my($self) = @_;
	$self->_get_in_java('last_exception');
}

#
# Does the nasty work for ya to get the Stack Trace for
#	the most recent Exception
# Returns array of stack trace lines
#
sub get_stack_trace
{
	my ($self) = @_;

        my $exception_object = $self->get_exception;

	# Get the Stack Trace - blame Java for this mess!
        my $string_writer = $self->create_object("java.io.StringWriter");
        my $print_writer = $self->create_object("java.io.PrintWriter", $string_writer);
        $exception_object->printStackTrace($print_writer);

	my $line = $string_writer->toString->get_value;
	$line =~ s/\015//g;	# Get rid of Windows/Krapple nastiness
	split(/\n/, $line);
}

## This'll return an objectified field from a static or instantiated reference
# you ken this call 'get_value' on this monster to string-ify it...
#	Also gets array elements...
sub get_field
{
	my($self) = shift;
	my $resp;
	if ($self->_is_java)
	{
		# Get static field
		$resp = $self->send_command_and_get_response("GET $_[0]#$_[1]");
	}
	else
	{
		# Get instantiated field
		$resp = $self->send_command_and_get_response("GET $self->{name}#$_[0]");
	}

	# Objectify it
	return $self->new_java_object($resp);
}

## This'll return an STRING value from a static or instantiated reference
sub get_value
{
	my($self) = shift;
	if ($self->_is_java)
	{
		# Get static value
		$self->send_command_and_get_response("VAL $_[0]");
	}
	else
	{
		# Get instantiated field value
		$self->send_command_and_get_response("VAL $self->{name}");
	}
}

# Convert 'perl' type args to 'java' type args
sub pretty_args
{
	##
	# Append type name to each primitive arg
	#	Gotta add all them other primitive types here...
	##
	foreach (@_)
	{
		if (!defined)
		{
			# Wanna pass 'null' in
			$_ = NULL_TOKEN;
		}
		elsif (/^-?\d+$/)
		{
			# If it looks like an INT it is an int...
			$_ .= ":int";
		}
		elsif (/^true:b$/i || /^false:b$/i)
		{
			# Stick that 'oolean' @ the end of ':b'!
			$_ .= "oolean";
		}
		elsif (/:char$/i || /:short$/ || /:float$/ || /:double$/
			|| /:byte$/ || /:long$/)
		{
			#leave it alone
		}
		elsif (ref $_)
		{
                        # It's a JavaArray - we get the actual underlying
                        #       'Java' object by pop'ing the array...
                        #       who knew?
                        if (ref $_ eq 'ARRAY')
                        {
                                $_ = pop @$_;
                        }

			# It's a Java object already
			$_ = $_->{name};
		}
		else
		{
			# It's a string
			# in case it's an integer w/a ':string' already at the
			#	end of it
			# Or it is an encoding string like "Unicdoe:string_UTF"

			# Either way we gotta put quotes around it & append
			#	it w/:string or w/:string_

			# Put quotes around it
			$_ = "\"".$_;
			unless (s/:string/\":string/)
			{
				# Regular string
				$_ .= "\":string";
			}

		}
	}
	@_;
}

sub get_chars_from_dec
{
	# Makes 2-byte hex ints...
	unpack("H*",pack("n",shift));
}

sub create_raw_string
{
	# This is dicey!!!

	my($self,$encoding,$string) = @_;

	my @all_bytes;
	my @chars = split //, $string;
	foreach (@chars)
	{
		# Makes integers outta chars...
		push @all_bytes, unpack("C",$_);
	}

	## @all_bytes is now an array of integer bytes values representing
	#	the unicode string
	##

	my $len = @all_bytes;
	my $line = "BYTE java.lang.String $encoding $len";
	$self->send_line($line);

	# Wait for response
	my $resp = $self->get_socket->getline;

	# Send bytes
	local($") = " ";
	$resp = $self->send_command_and_get_response("@all_bytes");
	$self->new_java_object($resp);
}

sub do_event
{
	my($self,$object,$func,$callback) = @_;

	my $object_name = $object->{name};
	my $resp = $self->send_command_and_get_response("EVT $object_name(\"$func\")");
	$func =~ s/listener//i;

	##
	# So this'll look like
	#	$self->events->java.awt.Frame^234->Window = $callback
	#	so all 'Window' events for java.awt.Frame^234 will point
	#	to a 2-keyed hash containing the object itself & the callback
	#	to callback...
	#
	if ($func =~ s/^add//)
	{
		$self->{events}->{$object_name}->{$func} =
						{
							obj => $object,
							callback => $callback
						};
	}
	else
	{
		$func =~ s/remove//;
		delete $self->{events}->{$object_name}->{$func};
	}
}

##
# One of our java objects has gone out of scope so tell JavaServer about it
#	OR the main java object is gone & we're done...
sub DESTROY
{
	my($self) = shift;
	if ($self->_is_java)
	{
		# Entire Java hash going out of scope
		$self->{socket}->close() if ($self->{socket});
	        $self->{event_socket}->close() if ($self->{event_socket});
    undef $self;
	}
	else
	{
		# Plain old scalar - java object
		# Tell JavaServer we're done w/it...
		my $resp =
      $self->{java}->send_command_and_get_response("BYE $self->{name}");
    undef $self;
	}
}

sub destroy
{
	my($self) = shift;
	if (!$self->_is_java)
	{
		my $resp =
      $self->{java}->send_command_and_get_response("BYE $self->{name}");
    undef $self;
  }
}

##
# This'll capture all function calls...
##
sub AUTOLOAD
{
	my($self,@args) = @_;
	my ($func) = $Java::AUTOLOAD =~ /::(.+)$/;
	my @goo;

	# it's a static call UNLESS $self is an instantiated class
	if ($func =~ /_/ && $self->_is_java)
	{
		# called like $java->java_lang_Class("forName","java.lang.String");
		# Pull out object name
		my $obj;
		($obj = $func) =~ s/_/\./g;
		push @goo, $obj;
	}
	else
	{
		# regular method call
		# called like $frame->setSize(200,200);
		# Pull out object name & function name
		push @goo, $self->{name}, $func;
	}

	return base_call($self,@goo,@args);
}

#
# Make a static function call if yer object ain't in a package...
#
# Called like
# $java->static_call("MyStaticClass","function_name","param1","param2"....);
#
sub static_call
{
	return base_call(@_);
}

# wrapper routine for instantiated calls
sub call
{
	my $self = shift;
	return base_call($self,$self->{name},@_);
}

sub base_call
{
	my($self,$obj,$func,@args) = @_;
	local($") = PARAMETER_SEPARATOR;

	# Make args java-friendly
	@args = pretty_args(@args);

	my $resp=$self->send_command_and_get_response("CAL $obj%$func(@args)");

	# Handle a callback request
	while ($resp =~ s/^CALLBACK //)
	{
		# eval it  - put it in package main if they don't
		#	specify one themselves
		my $ret = eval("package main;$resp");
		if ($@)
		{
			chomp $@;

			# Something went wrong - send a response back
			$resp = $self->send_command_and_get_response($@);

			# & tell someone
			print STDERR "Remote callback failed: $@";
		}

		$ret ||= "";
		$resp = $self->send_command_and_get_response($ret);
	}

	return $self->new_java_object($resp);
}

##
# This compares two objects to see if they're the same one!
#	pretty much only useful for event handling I think...
##
sub same
{
	my($self,$other_obj) = @_;
	$self->{name} eq $other_obj->{name};
}

###
# The Event Loop
#	Just sit around & wait for 1 line from the JVM
#	return undef is there's a problem
#	return whatever the event handler returned if alls kool
##
sub go
{
	my $self = shift;

	# Mite not be using events
	return if (!$self->get_event_socket);

	my $READBITS = 0;
	vec($READBITS,$self->get_event_socket->fileno,1) = 1;
	my $nf = select(my $rb = $READBITS,undef,undef,0);

	return if (!$nf);

	my $line = $self->get_event_socket->getline;
	return if (!defined $line); 	# lost somebody

	$self->decipher_event($line);
}

##
# Decipher & Dispatch this event
##
sub decipher_event
{
	my($self,$line) = @_;

	chomp $line;
	$line =~ s/\015//g;	# Clean up input from Winblows...

	# figure out who wanted this event
	$line =~ s/^EVE:\s+//;

	# Get the two strings
	my($event_object,$object_name) = split / /,$line;

	# Get rid of 'Event'
	my($event) = $event_object =~ /\.(\w+)Event/;

	# Get the hash for this event object
	my $hash = $self->{events}->{$object_name}->{$event};

	# Make the Event object a 'blessed' java object
	my $new_event_obj = $self->new_java_object($event_object);

	# Call the event callback
	$hash->{callback}->($hash->{obj},$new_event_obj);
}

##
# In case someone wants to do the event loop themselves...
##
sub get_event_FH
{
	my $self = shift;
	$self->get_event_socket;
}

sub _get_in_java
{
	my($self,$what) = @_;
	if ($self->_is_java)
	{
		return $self if ($what eq 'java' && !$self->{java});
		return $self->{$what};
	}
	else
	{
		return $self->{java} if ($what eq 'java');
		return $self->{java}->{$what};
	}
}

sub _set_in_java
{
	my($self,$what,$value) = @_;
	if ($self->_is_java)
	{
		return $self->{$what} = $value
	}
	else
	{
		$self->{java}->{$what} = $value;
	}
}

sub _is_java
{
	shift->{socket};
}

# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__