File Coverage

InstanceExporter.pm

Criterion	Covered	Total	%
statement	6	66	9.0
branch	0	30	0.0
condition	0	12	0.0
subroutine	2	8	25.0
pod	0	5	0.0
total	8	121	6.6

package SOAP::Lite::InstanceExporter;
#
# Name:  SOAP::Lite::InstanceExporter
#
# Author: Sean Meisner
#
# Usage: use SOAP::Lite::InstanceExporter qw(bareword_objectname, bareword_objectname);
#
# Purpose: Allow SOAP objects to persist in the main package namespace between SOAP calls
#
# Detailed Description: This class is used to provide a SOAP interface wrapped around
# a reference to an object residing in a package namespace on the server.  SOAP objects
# exported without this wrapper are initialized and destroyed on a per session basis.
# SOAP::Lite::InstanceExporter allows the server to preserve the state of an object across
# sessions.
#

require 5.005_62;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);

our $VERSION = '0.02';

# Set up an array in the package namespace to hold names of objects we
# will allow an instance of SOAP::Lite::InstanceExporter to access
our @allowedObjects = ();


# CLASS METHODS

# Return the list of object names to which we will allow access
sub allowedObjects
{
	return @allowedObjects;
}

# Here we store the object names we will allow SOAP to access
sub import
{
	# Test to be sure the array of allowed objects is empty.
	# This hopes to ensure that import can not be called again
	# on the client side to force access to objects we don't
	# want SOAP clients to be able to access.
	unless (scalar(@allowedObjects))
	{
		push (@allowedObjects, @_);
	}
}

# Return list of available objects
sub getAvailableObjects
{
	return @allowedObjects;
}


# Constructor.  We save a reference to an object residing in another package's namespace
# (defaults to main::), and attempt to set up dispatcher methods to access the object's
# methods from SOAP
sub new
{
	my $self = shift(@_);
	my $class = ref($self) || $self;
	my $objectname = shift(@_);
	my @requestedMethods;
	my $requestedMethod;
	my $allowedObject;
	my $thisObjectAllowed = 0;

	unless (ref $objectname) # This case handles a string passed in representing
				 # the name of a non-lexically scoped variable
				 # somewhere in the address space of the server.
	{

		# Check to see that we have permission from the SOAP server
		# to access the object the remote SOAP client wants to access
		foreach $allowedObject (@allowedObjects)
		{
			# exact match: its all good
			if ($allowedObject eq $objectname)
			{
				$thisObjectAllowed = 1;
				last;
			}
			# Match when the SOAP client has specified main:: or just :: on the requested
			# object, but the server allowed an object without package qualification, assuming
			# the package to default to main
			elsif (($objectname =~ /.*::.*/) && ($allowedObject !~ /.*::.*/) )
			{
				# try sticking a main:: onto allowedObject to match
		     		if ("main::$allowedObject" eq $objectname)
				{
					$thisObjectAllowed = 1;
					last;
				}
				# try sticking a :: onto allowedObject to match
				elsif ("::$allowedObject" eq $objectname)
				{
					$thisObjectAllowed = 1;
					last;
				}
			}

			# Match when the SOAP server has specified main:: or just :: on the allowed
			# object, but the client requested an object without package qualification, assuming
			# the package to default to main
			elsif (($allowedObject =~ /.*::.*/) && ($objectname !~ /.*::.*/) )
			{
				# try sticking a main:: onto $objectname to match
		     		if ($allowedObject eq "main::$objectname")
				{
					$thisObjectAllowed = 1;
					last;
				}
				# try sticking a :: onto $objectname to match
		     		elsif ($allowedObject eq "::$objectname")
				{
					$thisObjectAllowed = 1;
					last;
				}
			}
		}

		unless ($thisObjectAllowed)
		{
			die "Attempting to define a SOAP interface on an object which is not allowed!\n";
		}

		# Prepare a string containing the name of the object we want to wrap to be eval'ed.
		# We don't know the name of the wrapped object until the InstanceExporter is
		# instantiated, so we use eval.

		# First, check to see if there are ::'s existing in the objectname.  If not, we will
		# assume the object exists in the main namespace.  We can't assume it exists in the
		# calling package's namespace, as that would put it somewhere in Paul Kulchenko's
		# SOAP libraries.  This assumption could change in a future version.

		if ($objectname =~ /.*::.*/)
		{
			# if we found a qualifying ::, just stick a $ onto the beginning
			# to make it a valid variable name when given to eval.
			$objectname = "\$$objectname";
		}
		else
		{
			# We found no ::, so append $main:: to the beginning
			$objectname = "\$main::$objectname";
		}

		# Check to see that the object the remote client wants to access has been initialized
		unless (defined eval $objectname && ref eval $objectname)
		{
			die "Attempting to define a SOAP interface on $objectname, which has not been initialized!\n";
		}

		# Store a reference to the requested object
		my $objRefstring = "\\"."$objectname";
		$self = bless
			{
				#objRef => \ eval $objectname
				objRef => eval $objRefstring
			}, $class;
	}
	else	# Special case of a reference being passed in rather than a string..
		# useless to a SOAP client, but we can use it when we want to instantiate
		# an InstanceExporter directly on the server side, to pass a usable
		# reference to a lexically scoped variable to the client.
	{
		$self = bless
			{
				objRef => $objectname
			}, $class;

	}

	# Set up methods to dispatch to the contained object
	@requestedMethods = $self->getAvailableMethods();

	foreach $requestedMethod (@requestedMethods)
	{
		$self->generateDispatcher($requestedMethod);
	}

	return $self;
}

# INSTANCE METHODS

# Generate a method to pass a specified call to the contained class.
sub generateDispatcher
{
	my $self = shift(@_);
	my $method = shift(@_);

	# Die if this method is not available in the contained class
	unless ( ${$self->{objRef}}->can($method) )
	{
		die "Requested method $method not available!\n";
	}

	# Check to see if this method has already been generated
	unless ($self->can($method))
	{
		# Prepare a string to be eval'ed.  All $s and @s we wish to appear
		# in the eval'ed subroutine are escaped, while the method name undergoes
		# variable expansion.

		#my $methodtemplate =
		#"
		#sub SOAP::Lite::InstanceExporter::${method}
		#{
		#	my \$self = shift(\@_);
		#	return \${\$self->{objRef}}->${method}(\@_);
		#}
		#";

		# EXPERIMENTAL: Make InstanceExporters properly handle shared memory segments
		# created with IPC::Shareable
		my $methodtemplate =
		"
		sub SOAP::Lite::InstanceExporter::${method}
		{
			my \$self = shift(\@_);
			my \$returnvalue;

			# Handle shared memory correctly
			my \$sharedmemoryhandle = (tied \${\$self->{objRef}});
			if ( defined \$sharedmemoryhandle )
			{
				# Check if we can call shlock, if so call it
				if (\$sharedmemoryhandle->can(shlock))
				{
					\$sharedmemoryhandle->shlock()
				}

				# Call the method
				\$returnvalue =	\${\$self->{objRef}}->${method}(\@_);

				# Check if we can call shunlock, if so call it
				if (\$sharedmemoryhandle->can(shunlock))
				{
					\$sharedmemoryhandle->shunlock()
				}

				return \$returnvalue;

			}

			# If we got to this line, we are not dealing with shared
			# memory so just call the method and return
			return \${\$self->{objRef}}->${method}(\@_);
		}
		";

		# Declare our subroutine
		eval $methodtemplate;
	}
}


# Return list of available methods for this instance
sub getAvailableMethods
{
	my $self = shift(@_);
	my $packageName = ref(${$self->{objRef}});
	my @availableMethods = ();

	my %stash;
	my $varName;
	my $globValue;
	my $evalstring = "\%stash = \%${packageName}::";

	eval $evalstring;  # %stash now contains the symbol table
			   # for the class of which ${$self->{objRef}}
			   # is an instance.

	while (($varName) = each %stash)  # Iterate through each symbol name
						      # in the stash
	{
		# Check each to see if it refers
		# to a subroutine
		if (${$self->{objRef}}->can($varName))
		{
			push(@availableMethods,$varName);
		}
	}
	@availableMethods;
}

1;

# End of the code
__END__