=pod

File: PerlCOM.pl
Authors: 
    James A. Snyder (James@ActiveState.com)
    Dick Hardt (Dick_Hardt@ActiveState.com)

    This package is not intended to be used by perl routines,
    it is used by the PerlCOM executible.

    Copyright (C), 1997-2000 ActiveState Tool Corp


($obj) = PerlCOM::UsePackage ($packageName, [optional]$default)
	where $packageName is the name of the package to 
	create as the COM object and $default is the name
	of a property or method that should be used as
	default for the COM Object
	
	returns $obj which is a newly create COM Object that
	wraps the package


(@IDs) PerlCOM::GetIDsOfNames($obj, @NAMES)
returns a matching array of ids for the names passed in
returns -1 if the name is not defined

($HRESULT, $RETVAL, $EXCEPTION, $ARGERR)
	PerlCOM::Invoke($wFlags, $obj, $ID, @PARAMS)
call PerlCOM::CallMethod(), PerlCOM::PropertyGet() and PerlCOM::PropertyPut()

($HRESULT, $RETVAL, $EXCEPTION, $ARGERR)
	PerlCOM::CallMethod( $obj, $id, $bCaseSmash, @params);
does the actual method call
	
($HRESULT, $RETVAL, $EXCEPTION ,$ARGERR)
	PerlCOM::PropertyGet($obj, $ID, @PARAMS);
returns the value of a property

($HRESULT,$EXCEPTION ,$ARGERR)
	PerlCOM::PropertyPut($obj, $ID, @PARAMS);
sets the value of a property

($HRESULT, $RETVAL, $EXCEPTION)
	PerlCOM::TryAutoload( $obj, $id, @params);
called when a Method or Property does not exist

$HRESULT S_OK if everthing fine else the Win32 HRESULT (see below)
$RETVAL return value from subroutine call or the value of the scalar
$EXCEPTION error string if $! was set when sub was executed
$ARGERR not used currently, for future use with type libs

HRESULT values

S_OK     Success.
S_FALSE  False
E_FAIL   Unspecified error

DISP_E_BADPARAMCOUNT The number of elements provided to DISPPARAMS is different from the number of arguments accepted by the method or property.
DISP_E_BADVARTYPE One of the arguments in rgvarg is not a valid variant type.
DISP_E_EXCEPTION The application needs to raise an exception. In this case, the structure passed in pExcepInfo should be filled in.
DISP_E_MEMBERNOTFOUND The requested member does not exist, or the call to Invoke tried to set the value of a read-only property.
DISP_E_OVERFLOW One of the arguments in rgvarg could not be coerced to the specified type.
DISP_E_PARAMNOTFOUND One of the parameter DISPIDs does not correspond to a parameter on the method. In this case, puArgErr should be set to the first argument that contains the error.
DISP_E_TYPEMISMATCH One or more of the arguments could not be coerced. The index within rgvarg of the first parameter with the incorrect type is returned in the puArgErr parameter.
DISP_E_UNKNOWNINTERFACE The interface identifier passed in riid is not IID_NULL.
DISP_E_UNKNOWNLCID The member being invoked interprets string arguments according to the LCID, and the LCID is not recognized. If the LCID is not needed to interpret arguments, this error should not be returned.
DISP_E_PARAMNOTOPTIONAL A required parameter was omitted.

C code returns that might happen
DISP_E_BADVARTYPE One of the arguments in rgvarg is not a valid variant type.
DISP_E_NONAMEDARGS This implementation of IDispatch does not support named arguments.
DISP_E_UNKNOWNLCID The member being invoked interprets string arguments according to the LCID, and the LCID is not recognized. If the LCID is not needed to interpret arguments, this error should not be returned.

.................................................................................
=cut

use Win32::OLE;
package PerlCOM;

$PERLCOM_VERSION = 2.0;

#################################################################################

# HRESULT codes
sub S_OK                    {0x00000000};
sub S_FALSE                 {0x00000001};
sub E_FAIL                  {0x80004005};
sub DISP_E_EXCEPTION        {0x80020009};
sub DISP_E_MEMBERNOTFOUND   {0x80020003};

# wFlags for PerlCOM::Invoke
sub DISPATCH_METHOD         {0x1};
sub DISPATCH_PROPERTYGET    {0x2};
sub DISPATCH_PROPERTYPUT    {0x4};
sub DISPATCH_PROPERTYPUTREF {0x8};


#################################################################################

sub Constructor
{
    # This function is called internally by the PerlCOM runtime
    # to setup the main PerlCOM Objects.  It could have easily
    # been created internally within the runtime, but by placing
    # it here, methods can easily be added to the main PerlCOM Objects.

    my $obj =
    {
	'_self'        => {}, 	
	'_package'     => 'main::',
	'_names'       => [ 'PerlCOM::EvalScript' , 'PerlCOM::CreateObject', 'PerlCOM::UsePackage', 'PerlCOM::CreateHash', 'PerlCOM::CreateScalarContextObject', 'PerlCOM::CreateListContextObject' ],  
	'_ids'         => { 'EvalScript' => 0, 'CreateObject' => 1, 'UsePackage' => 2, 'CreateHash'=> 3, 'Scalar' => 4, 'List' => 5 },
	'_PerlCOMType' => 1,
	'_CallContext' => 0
    };

    bless $obj;
    return $obj;
}


#################################################################################


sub GetIDsOfNames
{
    if (!wantarray) { # defensive coding
	$exception = "PerlCOM::GetIDsOfNames() must be called in List Context.";
	return &DISP_E_EXCEPTION;
    }

    my $obj = shift;
    my ($name, @ids, $id);

    while ($name = shift) {
	if (defined $obj->{_ids}{$name}) {
		push  @ids, $obj->{_ids}{$name};
	}
	else {	
	    # since we don't know what AUTOLOAD might handle in the
	    # object, we say that any name is valid and then let
	    # PerlCOM::Invoke() handle it
	    
	    $id = @{$obj->{_names}};
	    $obj->{_ids}{$name} = $id;
	    $obj->{_names}[$id] = $name;
	    push  @ids, $id;
	}
    }

    return @ids;
}   # PerlCOM::GetIDsOfNames


#################################################################################

sub Invoke
{
    if (!wantarray) { # defensive coding
	# PerlCOM::Invoke() must be called in List Context
	return &DISP_E_EXCEPTION;
    }	

    if ( scalar( @_ ) < 3 ) { # make sure we have enough params
	$hresult   = &DISP_E_EXCEPTION;
	$exception = "Not enough parameters for PerlCOM::Invoke()";
	return ($hresult, $retval, $exception, $argerr);
    }

    my    $wFlags    = shift;
    my    $obj       = shift;
    my    $id        = shift;
    my    $hresult   = S_OK;
    my    $retval    = undef;
    my    $exception = undef;
    my    $argerr    = undef;
    my    $fullName  = undef;

    # make sure we have a valid DISPID
    if (($id < 0) || ($id >= @{$obj->{_names}} && $id != 0)) { return(&DISP_E_MEMBERNOTFOUND); }

    #--------------------------------------------------------------#
    # make sure this is a valid PerlCOMType
    #
    #	$_PerlCOMtype = 0 is a Perl Object
    #   $_PerlCOMtype = 1 is a Perl Package
    #   $_PerlCOMtype = 2 is a PerlCOM Hash
    #
    #--------------------------------------------------------------#
    
    my $_PerlCOMtype = $obj->{_PerlCOMType};

    if ($_PerlCOMtype < 0 || $_PerlCOMtype > 2) {
	$hresult   = &DISP_E_EXCEPTION;
	$exception = "Unsupported PerlCOM Object Type";
	return ($hresult, $retval, $exception, $argerr);
    }

    #--------------------------------------------------------------#
    # This section handles PerlCOM functions that need special handling
    #--------------------------------------------------------------#

    my $name     = $obj->{_names}[$id];
    my $_package = $obj->{_package};

    if ($name !~ /::/) {
	$fullName = $_package.$name;
    }
    else {
	$fullName = $name;
    }
	
    if (($fullName eq 'PerlCOM::CreateScalarContextObject')
	|| ($fullName eq 'PerlCOM::CreateListContextObject'))
    {
	# These methods need the this pointer ($obj) passed to them
    
	$retval = &$fullName($obj, @_);

	# These methods are expected to return a blessed reference, 
	# if they don't we need to issue a DISP_EXCEPTION
    
	if (!ref($retval)) {
	    $hresult   = DISP_E_EXCEPTION();
	    $exception = $retval;
	}
	return ($hresult, $retval, $exception, $argerr);			
    }
    elsif ( ($fullName eq 'PerlCOM::CreateObject')
		|| ($fullName eq 'PerlCOM::UsePackage')
		|| ($fullName eq 'PerlCOM::CreateHash')) 
    {
	# These methods are expected to return a blessed reference, 
	# if they don't we need to issue a DISP_EXCEPTION
    
	$retval = &$fullName(@_);
    
	if (!ref($retval)) {
	    $hresult   = DISP_E_EXCEPTION();
	    $exception = $retval;
	}
	return ($hresult, $retval, $exception, $argerr);			
    }
	
    #--------------------------------------------------------------#

    #--------------------------------------------------------------#
    # This is the stand Invoke section
    #--------------------------------------------------------------#
	
    if ((&DISPATCH_METHOD & $wFlags) 
	|| (&DISPATCH_PROPERTYGET & $wFlags))
    {
	# DISPATCH_METHOD and DISPATCH_PROPERTYGET are lumped together 
	# here because some host cannot tell the difference between
	# getting a property and calling a method
    
	if ( &DISPATCH_METHOD & $wFlags ) {
	    # Try to call the method
	    ($hresult, $retval, $exception, $argerr) = CallMethod($obj, $id, 0, @_);
	    if ($hresult != DISP_E_MEMBERNOTFOUND) {
		return ($hresult, $retval, $exception, $argerr);			
	    }

	    # The method does not exist, so we will try again with case smashing
	    ($hresult, $retval, $exception, $argerr) = CallMethod($obj, $id, 1, @_);
	    if ($hresult != DISP_E_MEMBERNOTFOUND) {
		return ($hresult, $retval, $exception, $argerr);			
	    }
	}
    
	# Try to retrieve the Property
	($hresult, $retval, $exception) = PropertyGet($obj, $id, 0);
	if ($hresult != DISP_E_MEMBERNOTFOUND) {
	    return ($hresult, $retval, $exception, $argerr);			
	}

	# The property does not exist, so try again with case smashing
	($hresult, $retval, $exception) = PropertyGet($obj, $id, 1);
	if ($hresult != DISP_E_MEMBERNOTFOUND) {
	    return ($hresult, $retval, $exception, $argerr);			
	}
    
	# Method and Property do not exist so let's try Autoload
	($hresult, $retval, $exception, $argerr) = TryAutoload($obj, $id, @_);
	return ($hresult, $retval, $exception, $argerr);
    }
    elsif ((&DISPATCH_PROPERTYPUT & $wFlags) || (&DISPATCH_PROPERTYPUTREF & $wFlags))
    {
	($hresult, $exception) = PropertyPut($obj, $id, @_);
	return ($hresult, $retval, $exception, $argerr);			
    }
    else
    {
	$hresult   = &DISP_E_EXCEPTION;
	$exception = "PerlCOM::Invoke() - Don't know how to handle wFlags = $wFlags";
	return ($hresult, $retval, $exception, $argerr);
    }
}
# PerlCOM::Invoke

#################################################################################

# This function is called by PerlCOM::Invoke()

# ($hresult, $retval, $exception, $argerr) = PerlCOM::CallMethod( $obj, $id, $bCaseSmash, @params);

sub CallMethod
{
    if (!wantarray)  # defensive coding
    {
	# PerlCOM::CallMethod() must be called in List Context
	return &DISP_E_EXCEPTION;
    }	

    my $hresult      = S_OK;
    my $retval       = undef;
    my $exception    = undef;
    my $argerr       = undef;
    my $fullName     = undef;
    my $obj          = undef;
    my $id           = undef;

    if (scalar( @_ ) < 3) { # make sure we have enough params
	$hresult   = &DISP_E_EXCEPTION;
	$exception = "Not enough parameters for PerlCOM::CallMethod()";
	return ($hresult, $retval, $exception, $argerr);
    }

    # Get our Parameters
    $obj             = shift;
    $id              = shift;
    $bCaseSmash      = shift;

    my $name         = $obj->{_names}[$id];
    my $_self        = $obj->{_self};
    my $_package     = $obj->{_package};
    my $_PerlCOMtype = $obj->{_PerlCOMType};
    my $_CallContext = $obj->{_CallContext};

    #--------------------------------------------------------------#
    # Note: _PerlCOMtype
    #	$_PerlCOMtype = 0 is a Perl Object
    #   $_PerlCOMtype = 1 is a Perl Package
    #   $_PerlCOMtype = 2 is a PerlCOM Hash
    #--------------------------------------------------------------#

    #--------------------------------------------------------------#
    # Note: _CallContext	
    # 	$_CallContext = 0 means Invoke will make the method call in Scalar Context 
    # 	$_CallContext = 1 means Invoke will make the method call in List Context 
    #--------------------------------------------------------------#
		
	
    # Setup fullName	
    if ($name !~ /::/) {
	$fullName = $_package.$name;
    }
    else {
	$fullName = $name;
    }

    # Cash Smash if neccessary	
    if ($bCaseSmash) {
	($hresult, $exception, $fullName, $name) = CaseSmash($obj, $fullName, 0);
	if ($hresult != S_OK) {
	    return ($hresult, $retval, $exception, $argerr);
	}
    }

    if (($_PerlCOMtype == 0 || $_PerlCOMtype == 2) 
	&& (defined(&{$fullName}) || $_self->can($name)))
    {  # Perl Object or PerlCOM Hash
	if (@_ > 0 && UNIVERSAL::isa($_[0], 'PerlCOM')) {	
	    $_[0] = $_[0]->{_self};
	}
			
	if ($_CallContext) {
	    $retval = [$_self->$name(@_)];
	}
	else {
	    $retval = $_self->$name(@_);
	}
    
	return ($hresult, $retval, $exception, $argerr);		
    }
    elsif ($_PerlCOMtype == 1 && defined(&{$fullName})) { # Perl Package
	if ($_CallContext) {
	    $retval = [&$fullName(@_)];
	}
	else {
	    $retval = &$fullName(@_);
	}

	return ($hresult, $retval, $exception, $argerr);		
    }

    $hresult   = &DISP_E_MEMBERNOTFOUND;
    $exception = "$fullName Property or Method does not exist.";
    return ($hresult, $retval, $exception, $argerr);

}
# PerlCOM::CallMethod


#################################################################################

# This function is called by PerlCOM::Invoke()

# ($hresult, $retval, $exception) = PerlCOM::PropertyGet( $obj, $id, $bCaseSmash);

sub PropertyGet
{
    if (!wantarray)  # defensive coding
    {
	# PerlCOM::PropertyGet() must be called in List Context
	return &DISP_E_EXCEPTION;
    }	

    my $hresult      = S_OK;
    my $retval       = undef;
    my $exception    = undef;
    my $fullName     = undef;
    my $obj          = undef;
    my $id           = undef;
    my $property     = undef;

    if (scalar( @_ ) < 3) { # make sure we have enough params
	$hresult   = &DISP_E_EXCEPTION;
	$exception = "Not enough parameters for PerlCOM::PropertyGet()";
	return ($hresult, $retval, $exception);
    }

    # Get our Parameters
    $obj             = shift;
    $id              = shift;
    $bCaseSmash      = shift;

    # make sure our DISPID is valid
    if (($id < 0) || ($id >= @{$obj->{_names}})) { return(&DISP_E_MEMBERNOTFOUND);	}

    my $name         = $obj->{_names}[$id];
    my $_self        = $obj->{_self};
    my $_package     = $obj->{_package};
    my $_PerlCOMtype = $obj->{_PerlCOMType};
    my $_CallContext = $obj->{_CallContext};

    # Setup fullName	
    if ($name !~ /::/) {
	$fullName = $_package.$name;
    }
    else {
	$fullName = $name;
    }

    if ($bCaseSmash) {
	($hresult, $exception, $fullName, $name) = CaseSmash($obj, $fullName, 1);
	if ($hresult != S_OK) {	
	    return ($hresult, $retval, $exception, $argerr);
	}
    }

    if ($_PerlCOMtype == 0) { # Perl Object
	if ($id == 0 && $name eq "") {
	    # The Default Property on a Perl object
	    # allows us to support the overloading of {""}

	    if ($_CallContext) {
		$retval = ["$_self"];
	    }
	    else {
		$retval = "$_self";
	    }
	}
	else {
	    if (defined($_self->{$name})) {
		if ($_CallContext) {
		    $retval = [$_self->{"$name"}];
		}
		else {
		    $retval = $_self->{"$name"};
		}
	    }
	    else
	    {
		$hresult   = &DISP_E_MEMBERNOTFOUND;
		$exception = "$fullName Property or Method does not exist.";
	    }
	}
    }
    elsif ($_PerlCOMtype == 1 ) { # Perl Package
	$property = "$fullName";
	if (defined ${$property}) {
	    if ($_CallContext) {
		$retval = [${$property}];	
	    }
	    else {
		$retval = ${$property};	
	    }
	}
	else {
	    $hresult   = &DISP_E_MEMBERNOTFOUND;
	    $exception = "$fullName Property or Method does not exist.";
	}		
    }
    elsif ($_PerlCOMtype == 2) { # PerlCOM Hash
	$retval =  $_self->Get($name);
    }

    return ($hresult, $retval, $exception);	
}
# PerlCOM::PropertyGet


#################################################################################

# This function is called by PerlCOM::Invoke()

sub PropertyPut
{
    if (!wantarray) { # defensive coding
	# PerlCOM::PropertyPut() must be called in List Context
	return &DISP_E_EXCEPTION;
    }	

    if (scalar( @_ ) < 3) { # make sure we have enough params
	$hresult   = &DISP_E_EXCEPTION;
	$exception = "Not enough parameters for PerlCOM::PropertyPut()";
	return ($hresult, $exception);	
    }

    my $obj          = shift;
    my $id           = shift;
    my $value        = shift;
    my $fullName     = undef;

    # make sure this is a valid DISPID
    if (($id < 0) || ($id >= @{$obj->{_names}})) {
	return(&DISP_E_MEMBERNOTFOUND);
    }

    my $name         = $obj->{_names}[$id];
    my $_self        = $obj->{_self};
    my $_package     = $obj->{_package};
    my $_PerlCOMtype = $obj->{_PerlCOMType};

    # Setup fullName	
    if ($name !~ /::/)  {
	$fullName = $_package.$name;
    }
    else {
	$fullName = $name;
    }

    if ($_PerlCOMtype == 0) { # Perl Object
	if (defined $_self->{$name}) {	
	    $_self->{$name} = $value;
	    return S_OK;
	}
	else {
	    ($hresult, $exception, $fullName, $name) = CaseSmash($obj, $fullName, 1);
	    if ($hresult != S_OK) {
		return ($hresult, $exception, $argerr);
	    }

	    $_self->{$name} = $value;
	    return S_OK;
	}
    }
    elsif ($_PerlCOMtype == 1) { # Perl Package
	if (defined( ${$_package.$obj->{_names}[$id]} )) {		
	    ${$_package.$obj->{_names}[$id]} = $value;
	    return S_OK;
	}
	else {
	    ($hresult, $exception, $fullName, $name) = CaseSmash($obj, $fullName, 1);
	    if ($hresult != S_OK) {
		return ($hresult, $exception, $argerr);
	    }

	    ${$fullName} = $value;
	    return S_OK;
	}
    }
    elsif ($_PerlCOMtype == 2) {
	# This is a PerlCOM Hash
	$retval = $_self->Set($name, $value);
	return S_OK;
    }

    return (&DISP_E_MEMBERNOTFOUND);

}
# PerlCOM::PropertyPut


#################################################################################

# This function is called by PerlCOM::Invoke()

# ($hresult, $retval, $exception) = PerlCOM::TryAutoload( $obj, $id, @params);

sub TryAutoload
{
    if (!wantarray) { # defensive coding
	# PerlCOM::TryAutoload() must be called in List Context
	return &DISP_E_EXCEPTION;
    }	

    # make sure we have enough params
    if (scalar( @_ ) < 2) {
	$hresult   = &DISP_E_EXCEPTION;
	$exception = "Not enough parameters for PerlCOM::TryAutoload()";
	return ($hresult, $retval, $exception, $argerr);
    }
    
    my $hresult      = S_OK;
    my $retval       = undef;
    my $exception    = undef;
    my $argerr       = undef;
    my $fullName     = undef;
    my $obj          = undef;
    my $id           = undef;
		
    # Get our Parameters
    $obj             = shift;
    $id              = shift;

    my $name         = $obj->{_names}[$id];
    my $_self        = $obj->{_self};
    my $_package     = $obj->{_package};
    my $_PerlCOMtype = $obj->{_PerlCOMType};
    my $_CallContext = $obj->{_CallContext};
    my $auto         = $_package.'AUTOLOAD';

    # Setup fullName	
    if ($name !~ /::/) {
	$fullName = $_package.$name;
    }
    else {
	$fullName = $name;
    }

    # if AUTOLOAD exists, we call our method and let Perl
    # call AUTOLOAD.  If AUTOLOAD doesn't exist
    # we return DISP_E_MEMBERNOTFOUND

    if ($name eq "") {
	# This is the default dispid so we will fix up
	# the name, set $fullName to $package::AUTOLOAD
	$fullName = $auto;
    }

    if ($_PerlCOMtype == 0 && ( defined(&{$auto}) || $_self->can($auto) )) {  # Perl Object
	if ($_CallContext) {
	    $retval = [&$fullName($_self, @_)];
	}
	else {
	    $retval = &$fullName($_self, @_);
	}
	return ($hresult, $retval, $exception, $argerr);		
    }
    elsif ($_PerlCOMtype == 1 && defined(&{$auto})) { # Perl Package
	if ($_CallContext) {
	    $retval = [&$fullName(@_)];
	}
	else {
	    $retval = &$fullName(@_);
	}
	return ($hresult, $retval, $exception, $argerr);		
    }

    # AUTOLOAD does not exist
    $hresult   = &DISP_E_MEMBERNOTFOUND;
    $exception = "$fullName Property or Method does not exist.";
    return ($hresult, $retval, $exception, $argerr);		
}

#################################################################################

# ($hresult, $exception, $newFullName, $newName) = CaseSmash($obj, $fullName. $bProperty);

sub CaseSmash
{
    if (scalar(@_) < 3) {
	return undef;
    }

    my $obj         = shift;
    my $fullName    = shift;
    my $bProperty   = shift;
    my $package     = $obj->{_package};
    my $PerlCOMtype = $obj->{_PerlCOMType};
    my $newFullName = undef;
    my $name        = undef;
    my $test        = undef;
    my @symbols     = undef;
    my $count       = 0;
    my $hresult     = &DISP_E_MEMBERNOTFOUND;
    my $exception   = undef;
    my $retFullName = undef;
    my $retName     = undef;

    # extract Method or Property name
    $fullName =~ /(.*::)(.*)/;
    $name     = $2;

    # Properties for Perl Objects need special handling,
    # instead of looking in the symbol table like we do
    # with Packages, for Perl Objects, we look at the
    # keys of the $_self hash.  Methods of Perl Object
    # are handled the same way as they are in Packages.
    if ($PerlCOMtype == 0 && $bProperty) {
	@symbols =	keys %{$obj->{_self}};
    }
    else {
	@symbols = values %$package;
    }
	
    foreach $method (@symbols) {
	if ($PerlCOMtype == 0 && $bProperty) { # CaseSmash PerlObject Property
	    if (uc($name) eq uc($method)) {
		if ($count < 1) {
		    $fullName    =~ /(.*::)(.*)/;
		    $retFullName = $1 . $method;
		    $retName     = $method;
		    $hresult     = &S_OK;
		}
		$count++;
	    }
	}
	else
	{
	    $method =~ /(.*\*)(.*)/;

	    if (uc($fullName) ne uc($2)) {
		next;
	    }

	    $newFullName = $2;
	    $test = "$newFullName";

	    if ($bProperty && defined ${$test}) { # CaseSmash Property
		if ($count < 1) {
		    $newFullName =~ /(.*::)(.*)/;
		    $retFullName = $newFullName;
		    $retName     = $2;
		    $hresult     = &S_OK;
		}
		$count++;
	    }
	    elsif (!$bProperty && defined(&{$test})) { # CaseSmash Method
		if ($count < 1) {
		    $newFullName =~ /(.*::)(.*)/;
		    $retFullName = $newFullName;
		    $retName     = $2;
		    $hresult     = &S_OK;
		}
		$count++;
	    }
	}
    }
		
    if ($count > 1) {
	# There is more than one Method or Property with the same name
	# and different case, therefore we cannot Case Smash
	$hresult   = &DISP_E_EXCEPTION;
	$exception = "PerlCOM::CaseSmash() Failed: Ambiguous method or property call for $fullName";
	return( $hresult, $exception, undef, undef );
    }

    if ($hresult == &DISP_E_MEMBERNOTFOUND) {
	$exception = "$fullName Property or Method does not exist.";
    }
    return( $hresult, $exception, $retFullName, $retName );
}	
# PerlCOM::CaseSmash

#################################################################################

# returns null if everything is ok, otherwise returns the syntax errors
#
# $result EvalScript ($script);
#................................

sub EvalScript 
{
    package main;
    my $script = shift;
    eval ($script);
    return $@;
}


#################################################################################

# $objPerlObject = CreateObject ($ClassMethodName, @CreationParams)
sub CreateObject 
{
    my ($class, $constructor, @params, $use, $_self, $self);

    $class = shift;
    $constructor = shift;
    @params = @_;
    $use = "use $class;";
    eval($use);
    $! = 0;		# clear expected errors
    return $@ if $@;
    
    # hack to use packages that are contained in other packages (like
    # IO::Socket::INET, which is in IO::Socket). The user should pass
    # the full constructor in.
    
    if ($constructor =~ /->/) {
	$constructor =~ /(.*)->(.*)/;
	$class = $1;
	$constructor = $2;
    }
	    
    $obj = $class->$constructor (@params);
    return $obj;
}


#################################################################################

# ($objPackage) = UsePackage ($packageName, [optional]$default)
sub UsePackage
{
    my $packageName = shift;
    my $default     = shift;
    my $use         = 'use '.$packageName.';';
    eval($use);
    $! = 0;		# clear expected errors
    return $@ if $@;

    $obj =
    {
	'_self'        => {},
	'_package'     => $packageName.'::',
	'_names'       => [$default, 'PerlCOM::CreateScalarContextObject', 'PerlCOM::CreateListContextObject'],  
	'_ids'         => {$default => 0, 'Scalar' => 1, 'List' => 2},
	'_PerlCOMType' => 1,
	'_CallContext' => 0
    };

    bless $obj;
    return $obj;
}


#################################################################################

# ($objHash) = CreateHash();
sub CreateHash
{
    my $hashRef = shift;
    my $objHash;

    if (ref($hashRef)) {
	# Called by PerlCOM.dll when returning a HashRef from a PerlCOM method
	$objHash = { '_hash' => $hashRef };
    }
    else {
	$objHash = { '_hash' => { } };
    }

    bless  $objHash, 'PerlCOM::Hash';

    $PerlCOMHash =
    {
	'_self'        => $objHash,
	'_package'     => 'PerlCOM::Hash',
	'_names'       => ['', 'PerlCOM::Hash::Get', 'PerlCOM::Hash::Set', 'PerlCOM::Hash::Delete', 'PerlCOM::Hash::Keys', 'PerlCOM::Hash::Values', 'PerlCOM::Hash::Each'  ],  
	'_ids'         => {"" => 0, 'Get' => 1, 'get' => 1, 'Set' => 2, 'set' => 2, 'Delete' => 3, 'delete' => 3, 'Keys' => 4, 'keys' => 4, 'Values' => 5, 'values' => 5, 'Each' => 6, 'each' => 6 },
	'_PerlCOMType' => 2,
	'_CallContext' => 0
    };
    
    bless  $PerlCOMHash;
    return $PerlCOMHash;	
}

#################################################################################

sub CreateScalarContextObject
{
    # This function makes a copy of a PerlCOM object
    # with the _CallContext set to 0 ( scalar Context )

    if (scalar(@_) < 1) {
	return "Not Enough Parameters to Create a Scalar Context Object";	
    }

    my $objPerlCOM = shift;

    $obj =
    {
	'_self'        => $objPerlCOM->{_self},
	'_package'     => $objPerlCOM->{_package},
	'_names'       => $objPerlCOM->{_names},
	'_ids'         => $objPerlCOM->{_ids},
	'_PerlCOMType' => $objPerlCOM->{_PerlCOMType},
	'_CallContext' => 0,
    };

    bless $obj;
    return $obj;
}

#################################################################################

sub CreateListContextObject
{
    # This function makes a copy of a PerlCOM object
    # with the _CallContext set to 1 ( List Context )

    if (scalar(@_) < 1) {
	# this might have to change to return a undef instead
	return "Not Enough Parameters to Create a List Context Object";	
    }

    my $objPerlCOM = shift;

    $obj =
    {
	'_self'        => $objPerlCOM->{_self},
	'_package'     => $objPerlCOM->{_package},
	'_names'       => $objPerlCOM->{_names},
	'_ids'         => $objPerlCOM->{_ids},
	'_PerlCOMType' => $objPerlCOM->{_PerlCOMType},
	'_CallContext' => 1,
    };
    
    bless $obj;
    return $obj;

}

#################################################################################

sub CreateGenericPerlCOMObject 
{
    # This function is called from the PerlCOM runtime
    # when a Perl Object is being returned from a Method

    if (scalar(@_) < 2) {
	return "Not enough Parameters for CreateGenericPerlCOMObject()";
    }

    my $perlObjRef = shift;
    my $package    = shift;

    my $obj =
    {
	'_self'        => $perlObjRef, 	
	'_package'     => $package.'::',
	'_names'       => [ '' , 'PerlCOM::CreateScalarContextObject', 'PerlCOM::CreateListContextObject' ],  
	'_ids'         => { 'Scalar' => 1, 'List' => 2 },
	'_PerlCOMType' => 0,
	'_CallContext' => 0
    };

    bless  $obj;
    return $obj;
}

#################################################################################

package PerlCOM::Hash;

#################################################################################

sub Get
{
    my $self    = shift;
    my $key     = shift;
    my $hashRef = $self->{'_hash'};

    if (ref( $hashRef )) {
	return	$$hashRef{$key};
    }

    return;
}

#################################################################################

sub Set
{
    my $self    = shift;
    my $key     = shift;
    my $val     = shift;
    my $hashRef = $self->{'_hash'};

    if (ref( $hashRef )) {
	return $$hashRef{$key} = $val;
    }

    return;
}

#################################################################################

sub Delete
{
    my $self    = shift;
    my $key     = shift;
    my $hashRef = $self->{'_hash'};

    if (ref( $hashRef )) {	
	delete $$hashRef{$key};
	return;
    }

    return;
}

#################################################################################

sub Keys
{
    my $self    = shift;
    my $hashRef = $self->{'_hash'};
    
    if (not ref( $hashRef )) {	
	return;
    }

    my @array   = keys(%$hashRef);

    if (@array < 1) {
	return;
    }

    return \@array;
}

#################################################################################

sub Values
{
    my $self    = shift;
    my $hashRef = $self->{'_hash'};

    if (not ref( $hashRef )) {	
	return;
    }

    my @array   = values(%$hashRef);

    if (@array < 1) {
	return;
    }

    return \@array;
}

#################################################################################

sub Each
{
    my $self    = shift;
    my $hashRef = $self->{'_hash'};

    if (not ref( $hashRef )) {	
	return;
    }

    my @pair = each( %$hashRef );

    if (@pair < 1) {
	return;
    }

    return \@pair;
}

#################################################################################

1;

__END__
