Menu
▾
▴
[Oorexx-svn] SF.net SVN: oorexx: [166] interpreter-3.x/trunk/platform/windows/ole
|
From: <mie...@us...> - 2007-03-18 22:57:30
|
Revision: 166
http://svn.sourceforge.net/oorexx/?rev=166&view=rev
Author: miesfeld
Date: 2007-03-18 14:59:38 -0700 (Sun, 18 Mar 2007)
Log Message:
-----------
Add the OLEVariant class as part of the Windows OLE support. This also fixes
bugs:
[ 1098405 ] OLE-interface to OpenOffice
[ 1323259 ] OleOject Does Not Return Array For Out Parameters
[ 1607010 ] Provide a way to direct object coercion
Modified Paths:
--------------
interpreter-3.x/trunk/platform/windows/ole/orexxole.c
interpreter-3.x/trunk/platform/windows/ole/orexxole.cls
interpreter-3.x/trunk/platform/windows/ole/orexxole.def
interpreter-3.x/trunk/platform/windows/ole/orexxole.mak
Added Paths:
-----------
interpreter-3.x/trunk/platform/windows/ole/OLEVariant.c
interpreter-3.x/trunk/platform/windows/ole/OLEVariant.h
Added: interpreter-3.x/trunk/platform/windows/ole/OLEVariant.c
===================================================================
--- interpreter-3.x/trunk/platform/windows/ole/OLEVariant.c (rev 0)
+++ interpreter-3.x/trunk/platform/windows/ole/OLEVariant.c 2007-03-18 21:59:38 UTC (rev 166)
@@ -0,0 +1,477 @@
+/*----------------------------------------------------------------------------*/
+/* */
+/* Copyright (c) 2006-2007 Rexx Language Association. All rights reserved. */
+/* */
+/* This program and the accompanying materials are made available under */
+/* the terms of the Common Public License v1.0 which accompanies this */
+/* distribution. A copy is also available at the following address: */
+/* http://www.oorexx.org/license.html */
+/* */
+/* Redistribution and use in source and binary forms, with or */
+/* without modification, are permitted provided that the following */
+/* conditions are met: */
+/* */
+/* Redistributions of source code must retain the above copyright */
+/* notice, this list of conditions and the following disclaimer. */
+/* 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. */
+/* */
+/* Neither the name of Rexx Language Association nor the names */
+/* of its contributors may be used to endorse or promote products */
+/* derived from this software without specific prior written permission. */
+/* */
+/* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS */
+/* "AS IS" AND ANY EXPRESS 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 COPYRIGHT */
+/* OWNER OR 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. */
+/* */
+/*----------------------------------------------------------------------------*/
+
+/**
+ * ooRexx OLE Automation Support OLEVariant.c
+ *
+ * Methods for the OLEVariant class.
+ *
+ * OLEVariants are ooRexx objects that represent a VARIANTARG used as a
+ * parameter in an IDispatch::Invoke method call. When the OLEObject class uses
+ * IDispatch to invoke methods on OLE / COM objects the parameters to these
+ * methods must be converted from ooRexx objects to VARIANTARGs. The OLEObject
+ * class does that automatically.
+ *
+ * A primary purpose of the OLEVariant class is to allow an ooRexx programmer to
+ * override the automatic conversion done by the OLEObject. In addition, if the
+ * parameter is an [IN/OUT] parameter, an OLEVariant is used to tranport the
+ * returned value back to the calling ooRexx program.
+ */
+
+#include <stdio.h>
+#include <stdlib.h>
+
+#include "RexxCore.h"
+
+#define INCL_REXXSAA
+#include "rexx.h"
+#include "RexxNativeAPI.h"
+
+#include "OLEVariant.h"
+
+/**
+ * Method: init
+ *
+ * Initializes an OLEVariant using the ooRexx object that will be converted to
+ * a variant arg used as a parameter in an IDispatch invocation.
+ *
+ * @param v_value The ooRexx object to be converted.
+ *
+ * @param v_type The variant type of the parameter, the type the ooRexx
+ * object should be corerced to. This argument is optional.
+ * If is is omitted or .nil, the OLEObject's automatic type
+ * conversion will be used.
+ *
+ * @param param_flags The PARAMFLAG_* flag(s) to use with the parameter in the
+ * IDispatch invocation. This argument is optional. If it
+ * is omitted or .nil, the OLEObject will use its internal
+ * process for determining the flags.
+ *
+ * @return This method returns .nil.
+ */
+RexxMethod4(REXXOBJECT, OLEVariant_Init,
+ OSELF, self,
+ REXXOBJECT, v_value,
+ REXXOBJECT, v_type,
+ REXXOBJECT, param_flags)
+{
+ RexxString *vtString = NULL;
+
+ convertToVT(v_type, 2);
+ convertToParamFlag(param_flags, 3);
+
+ REXX_SETVAR("!_VAR_VALUE_", v_value);
+ REXX_SETVAR("!_CLEAR_VARIANT_", RexxTrue);
+
+ return RexxNil;
+}
+
+/**
+ * Method: !varValue_ =
+ *
+ * Sets (changes) the ooRexx object that will be converted to a variant arg of
+ * this OLE variant.
+ *
+ * @param v_value The new ooRexx object to be converted.
+ *
+ * @return This method returns .nil.
+ */
+RexxMethod2(REXXOBJECT, OLEVariant_VarValueEquals,
+ OSELF, self,
+ REXXOBJECT, v_value)
+{
+ if ( !v_value )
+ {
+ send_exception1(Error_Incorrect_method_noarg,
+ RexxArray1(RexxString("1")));
+ }
+ REXX_SETVAR("!_VAR_VALUE_", v_value);
+
+ return RexxNil;
+}
+
+/**
+ * Method: !varType_ =
+ *
+ * Sets (changes) the VARTYPE value of this OLE variant.
+ *
+ * @param v_type The new value for the VARTYPE.
+ *
+ * @return This method returns .nil.
+ */
+RexxMethod2(REXXOBJECT, OLEVariant_VarTypeEquals,
+ OSELF, self,
+ REXXOBJECT, v_type)
+{
+ convertToVT(v_type, 1);
+ return RexxNil;
+}
+
+/**
+ * Method: !paramFlags_ =
+ *
+ * Sets (changes) the PARAMFLAG_* value of this OLE variant.
+ *
+ * @param param_flags The new value for the param flags.
+ *
+ * @return This method returns .nil.
+ */
+RexxMethod2(REXXOBJECT, OLEVariant_ParamFlagsEquals,
+ OSELF, self,
+ REXXOBJECT, param_flags)
+{
+ convertToParamFlag(param_flags, 1);
+ return RexxNil;
+}
+
+/**
+ * Change the string representation of a VARTYPE, passed as an argument to an
+ * OLEVariant method, to its numerical value, if possible. Throw an exception
+ * if it is not possible.
+ *
+ * @param v_type
+ * @param position
+ */
+static void convertToVT( REXXOBJECT v_type, int position )
+{
+ RexxString *vtString = NULL;
+
+ if ( v_type != NULL && v_type != RexxNil )
+ {
+ vtString = (RexxString *) RexxSend0(v_type, "STRING");
+ if ( ! _isstring(vtString) )
+ {
+ send_exception1(Error_Incorrect_method_string,
+ RexxArray1(RexxInteger(position)));
+ }
+
+ vtString = stringToVT(vtString);
+ if ( ! vtString )
+ {
+ send_exception1(Error_Incorrect_method_argType,
+ RexxArray2(RexxInteger(position),
+ RexxString("VARTYPE")));
+ }
+ }
+
+ REXX_SETVAR("!_VAR_TYPE_", vtString == NULL ? RexxNil : vtString);
+ REXX_SETVAR("!_VAR_TYPE_STR_",
+ vtString == NULL ? RexxString("default") : v_type);
+}
+
+/**
+ * Change the string representation of PARAMFLAGs, passed as an argument in an
+ * OLEVariant method, to its numerical value, if possible. Throw an exception
+ * if it is not possible. This function sets the !_PARAM_FLAGS_ and
+ * !_PARAM_FLAGS_STR_ variables on success.
+ *
+ * @param param_flags The ooRexx object to convert.
+ *
+ * @param position The argument position of param_flags in the OLEVariant
+ * method.
+ */
+static void convertToParamFlag( REXXOBJECT param_flags, int position )
+{
+ RexxString *flagsString = NULL;
+
+ if ( param_flags != NULL && param_flags != RexxNil )
+ {
+ flagsString = (RexxString *)RexxSend0(param_flags, "STRING");
+ if ( ! _isstring(flagsString) )
+ {
+ send_exception1(Error_Incorrect_method_string,
+ RexxArray1(RexxInteger(position)));
+ }
+
+ flagsString = stringToFlags(flagsString);
+ if ( ! flagsString )
+ {
+ send_exception1(Error_Incorrect_method_argType,
+ RexxArray2(RexxInteger(position),
+ RexxString("PARAMFLAG")));
+ }
+ }
+
+ REXX_SETVAR("!_PARAM_FLAGS_", flagsString == NULL ? RexxNil : flagsString);
+ REXX_SETVAR("!_PARAM_FLAGS_STR_",
+ flagsString == NULL ? RexxString("default") : param_flags);
+}
+
+/**
+ * Take a string representing a VARTYPE expression and turn it into a string
+ * representing its numerical value. Only valid VARIANTARGs are allowed, that
+ * is, only VARTYPEs that are valid to use in DISPPARAMS are converted.
+ *
+ * @param rxStr The string to convert.
+ *
+ * @return The numerical value of the VARIANTARG corresponding to rxStr,
+ * or null if the string is not valid.
+ */
+static RexxString * stringToVT( RexxString * rxStr )
+{
+ RexxString *rxResult = NULL;
+ CHAR *pszRxStr;
+ CHAR *pTmp;
+ CHAR szBuffer[6]; // Largest value is 0xFFFF == 65535.
+ VARENUM v1, v2;
+
+ pszRxStr = pszStringDupe(string_data(rxStr));
+ if ( !pszRxStr )
+ send_exception(Error_System_resources);
+
+ // There must be either 1 or 2 VT_xx symbols, anything else is not valid.
+ switch ( countSymbols(pszRxStr, FLAG_SEPARATOR_CHAR) )
+ {
+ case 0 :
+ v1 = findVT(stripNonCSyms(pszRxStr));
+ if ( v1 != VT_ILLEGAL && v1 != VT_VARIANT && v1 != VT_BYREF &&
+ v1 != VT_ARRAY )
+ {
+ sprintf_s(szBuffer, sizeof(szBuffer), "%d", v1);
+ rxResult = (RexxString *)RexxString(szBuffer);
+ }
+ break;
+
+ case 1 :
+ pTmp = strchr(pszRxStr, FLAG_SEPARATOR_CHAR);
+ v2 = findVT(stripNonCSyms(pTmp));
+
+ *pTmp = 0x0;
+ v1 = findVT(stripNonCSyms(pszRxStr));
+
+ if ( v1 != VT_ILLEGAL && v2 != VT_ILLEGAL && areValidVTs(v1, v2) )
+ {
+ sprintf_s(szBuffer, sizeof(szBuffer), "%d", v1 | v2);
+ rxResult = (RexxString *)RexxString(szBuffer);
+ }
+ break;
+
+ default :
+ break;
+ }
+
+ ORexxOleFree(pszRxStr);
+
+ return rxResult;
+}
+
+/**
+ * Take a string representing the wParmFlags field in a PARAMDESC struct and
+ * turn it into a string representing its numerical value.
+ *
+ * wParmFlags are true flags, as long as each token is a valid flag, any number
+ * of tokens can be or'd together any number of times and the result is valid.
+ *
+ * @param The string to convert.
+ *
+ * @return The integer value (as a string) of the wParamFlags, or null if the
+ * string to convert was not valid.
+ */
+static RexxString * stringToFlags( RexxString * rxStr )
+{
+ RexxString *rxResult = NULL; // Return null if invalid.
+ CHAR *pszRxStr;
+ CHAR *ptr;
+ CHAR szBuffer[4]; // Largest possible value is 0x7F == 127
+ int tmp, count, i;
+ int val = 0;
+
+ pszRxStr = pszStringDupe(string_data(rxStr));
+ if ( !pszRxStr )
+ send_exception(Error_System_resources);
+
+ count = countSymbols(pszRxStr, FLAG_SEPARATOR_CHAR);
+
+ // Look at each token, and if valid use it.
+ for ( i = 0; i < count; i++ )
+ {
+ ptr = strrchr(pszRxStr, FLAG_SEPARATOR_CHAR);
+ tmp = findFlag(stripNonCSyms(ptr));
+
+ if ( tmp == PARAMFLAG_ILLEGAL )
+ {
+ val = tmp;
+ break;
+ }
+ val |= tmp;
+ *ptr = 0x0;
+ }
+
+ // If still valid, pick up the last token.
+ if ( val != PARAMFLAG_ILLEGAL )
+ {
+ tmp = findFlag(stripNonCSyms(pszRxStr));
+ if ( tmp != PARAMFLAG_ILLEGAL )
+ {
+ sprintf_s(szBuffer, sizeof(szBuffer), "%d", val | tmp);
+ rxResult = (RexxString *)RexxString(szBuffer);
+ }
+ }
+
+ ORexxOleFree(pszRxStr);
+
+ return rxResult;
+}
+
+/**
+ * Count the number of occurrences of a character symbol in a string.
+ *
+ * @param pszStr The string to examine.
+ *
+ * @param symbol The character to count.
+ *
+ * @return The number counted.
+ */
+static __inline int countSymbols( PSZ pszStr, char symbol )
+{
+ int count = 0;
+ PSZ ptr = pszStr;
+
+ while ( (ptr = strchr(ptr, symbol)) != NULL )
+ {
+ ptr++;
+ count++;
+ }
+ return count;
+}
+
+/**
+ * Return a pointer to the specified string, stripped of leading and trailing
+ * non-C symbol characters.
+ *
+ * Note that pszStr may be changed after return, the first trailing non-C symbol
+ * will be replaced with a null.
+ *
+ * @param pszStr The string to strip.
+ *
+ * @return A pointer to the start of the stripped string.
+ */
+static __inline PSZ stripNonCSyms( PSZ pszStr )
+{
+ CHAR *pFront = pszStr;
+ CHAR *pBack = pszStr + strlen(pszStr);
+
+ while ( pBack > pFront && ! iscsym(*pBack) )
+ pBack--;
+ if ( ! iscsym(*pBack) )
+ {
+ // No C symbols in string.
+ *pBack = 0x0;
+ } else
+ {
+ *(++pBack) = 0x0;
+ while ( pFront < pBack && ! iscsym(*pFront) )
+ pFront++;
+ }
+ return pFront;
+}
+
+/**
+ * Determine if v1 and v2 are VARENUMs that can be combined for a valid
+ * VARIANTARG.
+ *
+ * Assumes: v1 and v2 are valid VARENUMs for a VARIANTARG, and that the only
+ * thing needed to be checked is that the combination is valid.
+ *
+ * @param v1 Value for the first VARENUM.
+ *
+ * @param v2 Value for the second VARENUM.
+ *
+ * @return True if v1 and v2 form a valid VARIANTARG, otherwise false.
+ */
+static __inline BOOL areValidVTs( VARENUM v1, VARENUM v2 )
+{
+ if ( v1 == VT_BYREF || v1 == VT_ARRAY )
+ {
+ if ( v2 != VT_BYREF && v2 != VT_ARRAY && v2 != VT_EMPTY &&
+ v2 != VT_NULL )
+ {
+ return TRUE;
+ }
+ } else if ( v2 == VT_BYREF || v2 == VT_ARRAY )
+ {
+ if ( v1 != VT_BYREF && v1 != VT_ARRAY && v1 != VT_EMPTY &&
+ v1 != VT_NULL )
+ {
+ return TRUE;
+ }
+ }
+ return FALSE;
+}
+
+/**
+ * Return the VARENUM that matches pszStr, or return VT_ILLEGAL if no match.
+ *
+ * @param pszStr The string to examine.
+ *
+ * @return The VARENUM equivalent of pszStr if there is a match, or
+ * VT_ILLEGAL if there is no match.
+ */
+static __inline VARENUM findVT( PSZ pszStr )
+{
+ int i;
+ for ( i = 0; vtStrTable[i] != NULL; i++ )
+ {
+ if ( strcmp(pszStr, vtStrTable[i]) == 0 )
+ {
+ return vtIntTable[i];
+ }
+ }
+ return VT_ILLEGAL;
+}
+
+/**
+ * Find the the PARAMFLAG that matches pszStr.
+ *
+ * @param pszStr The string to match.
+ *
+ * @return The PARAMFLAG matching pszStr, or PARAMFLAG_ILLEAGAL if no
+ * match.
+ */
+static __inline int findFlag( PSZ pszStr )
+{
+ int i;
+ for ( i = 0; flagStrTable[i] != NULL; i++ )
+ {
+ if ( strcmp(pszStr, flagStrTable[i]) == 0 )
+ {
+ return flagIntTable[i];
+ }
+ }
+ return PARAMFLAG_ILLEGAL;
+}
+
Property changes on: interpreter-3.x/trunk/platform/windows/ole/OLEVariant.c
___________________________________________________________________
Name: svn:eol-style
+ native
Added: interpreter-3.x/trunk/platform/windows/ole/OLEVariant.h
===================================================================
--- interpreter-3.x/trunk/platform/windows/ole/OLEVariant.h (rev 0)
+++ interpreter-3.x/trunk/platform/windows/ole/OLEVariant.h 2007-03-18 21:59:38 UTC (rev 166)
@@ -0,0 +1,162 @@
+/*----------------------------------------------------------------------------*/
+/* */
+/* Copyright (c) 2006-2007 Rexx Language Association. All rights reserved. */
+/* */
+/* This program and the accompanying materials are made available under */
+/* the terms of the Common Public License v1.0 which accompanies this */
+/* distribution. A copy is also available at the following address: */
+/* http://www.oorexx.org/license.html */
+/* */
+/* Redistribution and use in source and binary forms, with or */
+/* without modification, are permitted provided that the following */
+/* conditions are met: */
+/* */
+/* Redistributions of source code must retain the above copyright */
+/* notice, this list of conditions and the following disclaimer. */
+/* 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. */
+/* */
+/* Neither the name of Rexx Language Association nor the names */
+/* of its contributors may be used to endorse or promote products */
+/* derived from this software without specific prior written permission. */
+/* */
+/* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS */
+/* "AS IS" AND ANY EXPRESS 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 COPYRIGHT */
+/* OWNER OR 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. */
+/* */
+/*----------------------------------------------------------------------------*/
+/**
+ * ooRexx OLE Automation Support OLEVariant.h
+ *
+ * Constant defines, function prototypes, and globals for OLEVariant.
+ */
+
+#define DEFAULT_PARAMFLAGS "1"
+#define PARAMFLAG_ILLEGAL -1
+#define FLAG_SEPARATOR_CHAR ','
+
+// Function prototypes for local functions
+static void convertToParamFlag( REXXOBJECT, int );
+static void convertToVT( REXXOBJECT, int );
+static RexxString * stringToVT( RexxString * );
+static RexxString * stringToFlags( RexxString * );
+
+static __inline int countSymbols( PSZ, CHAR );
+static __inline PSZ stripNonCSyms( PSZ );
+static __inline VARENUM findVT( PSZ );
+static __inline BOOL areValidVTs( VARENUM, VARENUM );
+static __inline int findFlag( PSZ );
+
+// Some functions borrowed from orexxole.c
+extern PSZ pszStringDupe( PSZ );
+extern VOID ORexxOleFree( PVOID );
+
+// Global data
+
+/**
+ * All the VT types that are valid to use as a VARIANTARG (arguments passed in
+ * DISPPARAMS.)
+ *
+ * There are other VT types defined in VARENUM, but they are not valid to use
+ * through IDispatch::Invoke. In addition there are a few other restrictions,
+ * such as VT_EMPTY and VT_NULL can not be used with VT_BYREF or VT_ARRAY;
+ * VT_VARIANT can not be used alone.
+ */
+static char * vtStrTable[] = {
+ "VT_EMPTY",
+ "VT_NULL",
+ "VT_I2",
+ "VT_I4",
+ "VT_R4",
+ "VT_R8",
+ "VT_CY",
+ "VT_DATE",
+ "VT_BSTR",
+ "VT_DISPATCH",
+ "VT_ERROR",
+ "VT_BOOL",
+ "VT_VARIANT",
+ "VT_UNKNOWN",
+ "VT_DECIMAL",
+ "VT_I1",
+ "VT_UI1",
+ "VT_UI2",
+ "VT_UI4",
+ "VT_I8",
+ "VT_UI8",
+ "VT_INT",
+ "VT_UINT",
+ "VT_ARRAY",
+ "VT_BYREF",
+ NULL
+};
+
+/**
+ * A table for the valid VT types. This must match vtStrTable.
+ */
+static VARENUM vtIntTable[] = {
+ VT_EMPTY,
+ VT_NULL,
+ VT_I2,
+ VT_I4,
+ VT_R4,
+ VT_R8,
+ VT_CY,
+ VT_DATE,
+ VT_BSTR,
+ VT_DISPATCH,
+ VT_ERROR,
+ VT_BOOL,
+ VT_VARIANT,
+ VT_UNKNOWN,
+ VT_DECIMAL,
+ VT_I1,
+ VT_UI1,
+ VT_UI2,
+ VT_UI4,
+ VT_I8,
+ VT_UI8,
+ VT_INT,
+ VT_UINT,
+ VT_ARRAY,
+ VT_BYREF
+};
+
+/**
+ * The string names for the valid PARAMFLAGS used in a PARAMDESC structure.
+ */
+static char * flagStrTable[] = {
+ "NONE",
+ "IN",
+ "OUT",
+ "LCID",
+ "RETVAL",
+ "OPT",
+ "HASDEFAULT",
+ "HASCUSTDATA",
+ NULL
+};
+
+/**
+ * The actual PARAMFLAGS to match the flagStrTable.
+ */
+static int flagIntTable[] = {
+ PARAMFLAG_NONE,
+ PARAMFLAG_FIN,
+ PARAMFLAG_FOUT,
+ PARAMFLAG_FLCID,
+ PARAMFLAG_FRETVAL,
+ PARAMFLAG_FOPT,
+ PARAMFLAG_FHASDEFAULT,
+ PARAMFLAG_FHASCUSTDATA
+};
+
Property changes on: interpreter-3.x/trunk/platform/windows/ole/OLEVariant.h
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: interpreter-3.x/trunk/platform/windows/ole/orexxole.c
===================================================================
--- interpreter-3.x/trunk/platform/windows/ole/orexxole.c 2007-03-18 18:11:29 UTC (rev 165)
+++ interpreter-3.x/trunk/platform/windows/ole/orexxole.c 2007-03-18 21:59:38 UTC (rev 166)
@@ -99,10 +99,15 @@
VOID Rexx2Variant(RexxObject *RxObject, VARIANT *pVariant, VARTYPE DestVt, INT iArgPos);
BOOL fIsRexxArray(RexxObject *TestObject);
BOOL fIsOLEObject(RexxObject *TestObject);
+BOOL fIsOleVariant(RexxObject *TestObject);
BOOL fRexxArray2SafeArray(RexxObject *RxArray, VARIANT FAR *VarArray, INT iArgPos);
BOOL fExploreTypeAttr( ITypeInfo *pTypeInfo, TYPEATTR *pTypeAttr, POLECLASSINFO pClsInfo );
VARTYPE getUserDefinedVT( ITypeInfo *pTypeInfo, HREFTYPE hrt );
BOOL fExploreTypeInfo( ITypeInfo *pTypeInfo, POLECLASSINFO pClsInfo );
+BOOL checkForOverride( VARIANT *, RexxObject *, VARTYPE, RexxObject **, VARTYPE * );
+BOOL isOutParam( RexxObject *, POLEFUNCINFO, INT );
+VOID handleVariantClear( VARIANT *, RexxObject * );
+__inline BOOL okayToClear( RexxObject * );
int (__stdcall *creationCallback)(CLSID, IUnknown*) = NULL;
void setCreationCallback(int (__stdcall *f)(CLSID, IUnknown*))
@@ -1290,6 +1295,9 @@
case VT_UNKNOWN:
/* try to get a dispatch pointer and then create an OLE Object */
+ /* DFX TODO: IUnknown can also be passed by reference. This should be
+ * handled in the same manner as VT_DISPATCH.
+ */
pUnknown = V_UNKNOWN(pVariant);
if (pUnknown)
{
@@ -1364,14 +1372,14 @@
*
* Notes:
* VT_BOOL
- * Microsoft uses a non-intuitive value for this variant,
- * and documents it this way: A value of 0xFFFF (all bits
- * 1) indicates True; a value of 0 (all bits 0) indicates
- * False. No other values are valid.
+ * Microsoft uses a non-intuitive value for this variant, and documents it
+ * this way: A value of 0xFFFF (all bits 1) indicates True; a value of 0
+ * (all bits 0) indicates False. No other values are valid.
*
- * Setting a VT_BOOL's value to 1 for true, is not correct.
- */
-VOID Rexx2Variant(RexxObject *RxObject, VARIANT *pVariant, VARTYPE DestVt, INT iArgPos)
+ * Setting a VT_BOOL's value to 1 for true does not produce the correct
+ * result.
+ */
+VOID Rexx2Variant(RexxObject *_RxObject, VARIANT *pVariant, VARTYPE _DestVt, INT iArgPos)
{
BOOL fDone = FALSE;
BOOL fByRef = FALSE;
@@ -1379,7 +1387,12 @@
RexxString *RxString;
VARIANT sVariant;
HRESULT hResult;
+ RexxObject *RxObject;
+ VARTYPE DestVt;
+ if ( checkForOverride(pVariant, _RxObject, _DestVt, &RxObject, &DestVt) )
+ return;
+
if (DestVt & VT_BYREF) {
DestVt ^= VT_BYREF;
fByRef = TRUE;
@@ -1574,8 +1587,9 @@
BOOL fIsRexxArray(RexxObject *TestObject)
{
- if ((RexxSend1(TestObject, "HASMETHOD", RexxString("DIMENSION")) == RexxTrue) &&
- (RexxSend1(TestObject, "HASMETHOD", RexxString("HASINDEX")) == RexxTrue))
+ if ( TestObject &&
+ (RexxSend1(TestObject, "HASMETHOD", RexxString("DIMENSION")) == RexxTrue) &&
+ (RexxSend1(TestObject, "HASMETHOD", RexxString("HASINDEX")) == RexxTrue))
return TRUE;
else
return FALSE;
@@ -1584,12 +1598,22 @@
BOOL fIsOLEObject(RexxObject *TestObject)
{
- if (RexxSend1(TestObject, "HASMETHOD", RexxString("!OLEOBJECT")) == RexxTrue)
+ if (TestObject &&
+ RexxSend1(TestObject, "HASMETHOD", RexxString("!OLEOBJECT")) == RexxTrue)
return TRUE;
else
return FALSE;
}
+BOOL fIsOleVariant(RexxObject *TestObject)
+{
+ if ( TestObject &&
+ RexxSend1(TestObject, "HASMETHOD", RexxString("!OLEVARIANT_")) == RexxTrue)
+ return TRUE;
+ else
+ return FALSE;
+}
+
BOOL fRexxArray2SafeArray(RexxObject *RxArray, VARIANT FAR *VarArray, INT iArgPos)
{
BOOL fDone = FALSE;
@@ -2942,27 +2966,21 @@
Rexx2Variant(arrItem, &(pVarArgs[iArgCount - i - 1]), DestVt, i + 1);
- /* if this is an out parameter, we need to pass the variant as a reference */
- /* retval is return value and does not have to be modified */
- if (pFuncInfo) {
- if (i < pFuncInfo->iParmCount) { // do not read into non-existing memory!
- int j=pFuncInfo->pusOptFlags[i];
- if (pFuncInfo->pusOptFlags[i] & PARAMFLAG_FOUT &&
- !(pFuncInfo->pusOptFlags[i] & PARAMFLAG_FRETVAL) ) {
- referenceVariant(&pVarArgs[iArgCount - i - 1]);
- // store the original input VARIANT
- // if it is getting changed, free the original!!!
- memcpy(&pInputParameters[iArgCount - i - 1],&pVarArgs[iArgCount - i - 1],sizeof(VARIANT));
- }
-
-
- }
+ /* If an out parameter, the variant must be passed as a reference. The
+ * original input variant is saved so that, if a new value is returned, the
+ * original can be freed.
+ */
+ if ( isOutParam(arrItem, pFuncInfo, i) )
+ {
+ referenceVariant(&pVarArgs[iArgCount - i - 1]);
+ memcpy(&pInputParameters[iArgCount - i - 1],&pVarArgs[iArgCount - i- 1],
+ sizeof(VARIANT));
}
} /* endfor */
- /* if we have a property put then the new property value needs */
- /* to be a named argument */
-
+ /* if we have a property put then the new property value needs to be a named
+ * argument
+ */
if (wFlags == DISPATCH_PROPERTYPUT)
{
dp.cNamedArgs = 1;
@@ -3019,45 +3037,50 @@
wFlags, &dp, NULL, &sExc, &uArgErr);
} /* endif */
-
-
for (i=0; i < (INT) dp.cArgs; i++)
{
+ arrItem = array_at(msgArgs, i + 1);
- /* was this an out parameter? */
- if (pFuncInfo)
- if (i < pFuncInfo->iParmCount) { // do not read into non-existing memory!
- if (pFuncInfo->pusOptFlags[i] & PARAMFLAG_FOUT) {
- /* yes, then change the REXX object to a new state */
+ /* was this an out parameter? */
+ if ( isOutParam(arrItem, pFuncInfo, i) )
+ {
+ /* yes, then change the REXX object to a new state */
+ RexxObject *outObject;
+ RexxObject *outArray=(RexxObject*) REXX_GETVAR("!OUTARRAY");
+ int index=1;
+ char indexBuffer[32];
- RexxObject *outArray=(RexxObject*) REXX_GETVAR("!OUTARRAY");
- int index=1;
- char indexBuffer[32];
-
- if (outArray == RexxNil) {
- outArray = RexxArray(1);
- REXX_SETVAR("!OUTARRAY",outArray);
- }
- else {
- arrItem = RexxSend0(outArray, "LAST");
- pszRxString = string_data((RexxString*) RexxSend0(arrItem,"STRING"));
- sscanf(pszRxString, "%d", &index);
- index++; // next entry
- }
- sprintf(indexBuffer,"%d",index);
- RexxSend2(outArray,"PUT",Variant2Rexx(&(dp.rgvarg[dp.cArgs-i-1])),RexxString(indexBuffer));
- // if the call changed an out parameter, we have to clear the original variant that
- // was overwritten
- if (memcmp(&pInputParameters[iArgCount - i - 1],&pVarArgs[iArgCount - i - 1],sizeof(VARIANT))) {
- dereferenceVariant(&pInputParameters[iArgCount - i - 1]);
- VariantClear(&pInputParameters[iArgCount - i - 1]);
- } else
- dereferenceVariant(&dp.rgvarg[iArgCount - i - 1]);
- }
+ if (outArray == RexxNil) {
+ outArray = RexxArray(1);
+ REXX_SETVAR("!OUTARRAY",outArray);
}
+ else {
+ arrItem = RexxSend0(outArray, "LAST");
+ pszRxString = string_data((RexxString*) RexxSend0(arrItem,"STRING"));
+ sscanf(pszRxString, "%d", &index);
+ index++; // next entry
+ }
+ outObject = Variant2Rexx(&(dp.rgvarg[dp.cArgs-i-1]));
+ sprintf(indexBuffer,"%d",index);
+ RexxSend2(outArray,"PUT",outObject,RexxString(indexBuffer));
- /* clear the argument */
- VariantClear(&(dp.rgvarg[dp.cArgs-i-1]));
+ if ( fIsOleVariant(arrItem) )
+ RexxSend1(arrItem, "!VARVALUE_=", outObject);
+
+ // if the call changed an out parameter, we have to clear the original variant that
+ // was overwritten
+ if (memcmp(&pInputParameters[iArgCount - i - 1],&pVarArgs[iArgCount - i - 1],sizeof(VARIANT))) {
+ dereferenceVariant(&pInputParameters[iArgCount - i - 1]);
+ handleVariantClear(&pInputParameters[iArgCount - i - 1], arrItem);
+ } else
+ dereferenceVariant(&dp.rgvarg[iArgCount - i - 1]);
+ }
+
+ /* Clear the argument and, if an OLEVariant, reset the clear variant flag.
+ */
+ handleVariantClear(&(dp.rgvarg[dp.cArgs-i-1]), arrItem);
+ if ( fIsOleVariant(arrItem) )
+ RexxSend1(arrItem, "!CLEARVARIANT_=", RexxTrue);
} /* endfor */
/* free the argument array */
@@ -3139,7 +3162,231 @@
return ResultObj;
}
+/**
+ * Determine if the user wants to override OLEObject's automatic conversion of
+ * ooRexx objects to variants.
+ *
+ * The use of an OLEVariant object for a parameter signals that the ooRexx
+ * programmer may want to override the default type conversion. Often simply
+ * specifying what the ooRexx object is to be converted to is sufficient. Cases
+ * where the default conversion is known to be wrong are handled here and then
+ * the caller is informed that the conversion has already taken place.
+ *
+ * @param pVariant The variant receiving the converted ooRexx object.
+ *
+ * @param RxObject The ooRexx object to be converted. If this is an
+ * OLEVariant object, the actual object to convert is
+ * contained withing the OLEVariant object.
+ *
+ * @param DestVt The VT type that the automatic conversion believes the
+ * ooRexx object should be coerced to.
+ *
+ * @param pRxObject [Returned] The real ooRexx object to convert.
+ *
+ * @param pDestVt [Returned] The real VT type to coerce the ooRexx object to.
+ *
+ * @return True, the conversion is complete, or false, the conversion
+ * is not complete - continue with the automatic conversion.
+ */
+BOOL checkForOverride( VARIANT *pVariant, RexxObject *RxObject, VARTYPE DestVt,
+ RexxObject **pRxObject, VARTYPE *pDestVt )
+{
+ BOOL converted = FALSE;
+ if ( ! fIsOleVariant(RxObject) )
+ {
+ *pRxObject = RxObject;
+ *pDestVt = DestVt;
+ }
+ else
+ {
+ RexxObject *tmpRxObj = RexxSend0(RxObject, "!_VT_");
+
+ *pRxObject = RexxSend0(RxObject, "!VARVALUE_");
+ if ( tmpRxObj == RexxNil )
+ {
+ /* Do not override default conversion. */
+ *pDestVt = DestVt;
+ }
+ else
+ {
+ *pDestVt = (VARTYPE)_integer(tmpRxObj);
+
+ switch ( *pDestVt & VT_TYPEMASK )
+ {
+ case VT_NULL :
+ V_VT(pVariant) = VT_NULL;
+ converted = TRUE;
+ break;
+
+ case VT_EMPTY :
+ V_VT(pVariant) = VT_EMPTY;
+ converted = TRUE;
+ break;
+
+ case VT_DISPATCH :
+ if ( *pRxObject == RexxNil || *pRxObject == NULL )
+ {
+ if ( *pDestVt & VT_BYREF )
+ {
+ IDispatch **ppDisp;
+
+ ppDisp = (IDispatch **)ORexxOleAlloc(sizeof(IDispatch **));
+ if ( ! ppDisp )
+ send_exception(Error_System_resources);
+
+ *ppDisp = (IDispatch *)NULL;
+
+ V_VT(pVariant) = VT_DISPATCH | VT_BYREF;
+ V_DISPATCHREF(pVariant) = ppDisp;
+ }
+ else
+ {
+ V_VT(pVariant) = VT_DISPATCH;
+ V_DISPATCH(pVariant) = NULL;
+ }
+ /* ooRexx, not VariantClear, must clear this variant. */
+ RexxSend1(RxObject, "!CLEARVARIANT_=", RexxFalse);
+ converted = TRUE;
+ break;
+ }
+ /* Let default conversion handle non-nil. */
+ break;
+
+ case VT_UNKNOWN :
+ if ( *pRxObject == RexxNil || *pRxObject == NULL )
+ {
+ if ( *pDestVt & VT_BYREF )
+ {
+ IUnknown **ppU;
+
+ ppU = (IUnknown **)ORexxOleAlloc(sizeof(IUnknown **));
+ if ( ! ppU )
+ send_exception(Error_System_resources);
+
+ *ppU = (IUnknown *)NULL;
+ V_VT(pVariant) = VT_UNKNOWN | VT_BYREF;
+ V_UNKNOWNREF(pVariant) = ppU;
+ }
+ else
+ {
+ V_VT(pVariant) = VT_UNKNOWN;
+ V_UNKNOWN(pVariant) = NULL;
+ }
+ /* ooRexx, not VariantClear, must clear this variant. */
+ RexxSend1(RxObject, "!CLEARVARIANT_=", RexxFalse);
+
+ converted = TRUE;
+ break;
+ }
+ /* Let default conversion handle non-nil. */
+ break;
+
+ default :
+ /* Let default conversion handle all other cases. */
+ break;
+ }
+ }
+ }
+ return converted;
+}
+
+/**
+ * Determine, based on the information OLEObject has, if the ooRexx object used
+ * as a parameter in an IDispatch invocation should be an out parameter.
+ *
+ * @param param The parameter to be inspected. If this is an OLEVariant
+ * object, the ooRexx programmer may be overriding what
+ * OLEObject thinks it knows.
+ *
+ * @param pFuncInfo A, possible, pointer to a function information block with
+ * details concerning this parameter.
+ *
+ * @param i The position (index) of the parameter in the method
+ * invocation. This will also be the index of the parameter
+ * in the function information block. Note howerver that it
+ * is possible that the index is not valid for the function
+ * information block.
+ *
+ * @return True if there is enough information to be certain the
+ * paramter is an out parameter, otherwise false.
+ */
+BOOL isOutParam( RexxObject *param, POLEFUNCINFO pFuncInfo, INT i )
+{
+ USHORT paramFlags = PARAMFLAG_NONE;
+ BOOL overridden = FALSE;
+
+ if ( fIsOleVariant(param) )
+ {
+ RexxObject *tmpRxObj = RexxSend0(param, "!_PFLAGS_");
+ if ( tmpRxObj != RexxNil )
+ {
+ paramFlags = (USHORT)_integer(tmpRxObj);
+ overridden = TRUE;
+ }
+ }
+
+ if ( !overridden && pFuncInfo && i < pFuncInfo->iParmCount )
+ paramFlags = pFuncInfo->pusOptFlags[i];
+
+ return ((paramFlags & PARAMFLAG_FOUT) && !(paramFlags & PARAMFLAG_FRETVAL));
+}
+
+/**
+ * Helper function to clear a variant when it may not be safe to pass the
+ * variant to VariantClear.
+ *
+ * Assumes: Pass by reference variants have already been dereferenced and
+ * therefore V_ISBYREF(pVariant) == FALSE.
+ *
+ * @param pVariant The variant to clear.
+ *
+ * @param RxObject If this is an ooRexx OLEVariant object, it contains the flag
+ * signaling whether it is okay to pass the variant to
+ * VariantClear.
+ *
+ * @return VOID
+ */
+VOID handleVariantClear( VARIANT *pVariant, RexxObject *RxObject )
+{
+ if ( ! okayToClear(RxObject) )
+ {
+ /* This reverses work done in Rexx2Variant when the parameter is an
+ * OLEVariant object.
+ */
+
+ switch ( V_VT(pVariant) & VT_TYPEMASK )
+ {
+ case VT_DISPATCH :
+ if ( V_DISPATCH(pVariant) != NULL)
+ ORexxOleFree(V_DISPATCH(pVariant));
+ break;
+
+ case VT_UNKNOWN :
+ if ( V_UNKNOWN(pVariant) != NULL)
+ ORexxOleFree(V_UNKNOWN(pVariant));
+ break;
+
+ default :
+ break;
+ }
+ }
+ else
+ VariantClear(pVariant);
+}
+
+/**
+ * Check if it is okay to use VariantClear.
+ */
+__inline BOOL okayToClear( RexxObject *RxObject )
+{
+ if ( fIsOleVariant(RxObject) )
+ {
+ return (RexxSend0(RxObject, "!CLEARVARIANT_") == RexxTrue);
+ }
+ return TRUE;
+}
+
//******************************************************************************
// Method: OLEObject_Request
//
Modified: interpreter-3.x/trunk/platform/windows/ole/orexxole.cls
===================================================================
--- interpreter-3.x/trunk/platform/windows/ole/orexxole.cls 2007-03-18 18:11:29 UTC (rev 165)
+++ interpreter-3.x/trunk/platform/windows/ole/orexxole.cls 2007-03-18 21:59:38 UTC (rev 166)
@@ -1,12 +1,12 @@
/*----------------------------------------------------------------------------*/
/* */
/* Copyright (c) 1995, 2004 IBM Corporation. All rights reserved. */
-/* Copyright (c) 2005-2006 Rexx Language Association. All rights reserved. */
+/* Copyright (c) 2005-2007 Rexx Language Association. All rights reserved. */
/* */
/* This program and the accompanying materials are made available under */
/* the terms of the Common Public License v1.0 which accompanies this */
/* distribution. A copy is also available at the following address: */
-/* http://www.oorexx.org/license.html */
+/* http://www.oorexx.org/license.html */
/* */
/* Redistribution and use in source and binary forms, with or */
/* without modification, are permitted provided that the following */
@@ -37,7 +37,9 @@
/*----------------------------------------------------------------------------*/
/* */
.OLEObject~!REXXDefined
+.OLEVariant~!REXXDefined
.environment~setentry("OLEOBJECT", .OLEObject)
+.environment~setentry("OLEVARIANT", .OLEVariant)
If Arg(1) = "REXX" Then
Say "OLEObject class setup"
@@ -72,3 +74,65 @@
::METHOD DISPATCH
use arg name
return self~unknown(name, arg(2,'A'))
+
+::CLASS OLEVariant
+::METHOD new class
+ signal on syntax
+
+ if arg(1, 'O') then
+ raise syntax 93.903 array(1) description "A variant value is required to create an OLEVariant."
+ if arg() > 3 then
+ raise syntax 93.902 array(3) description "The only arguments allowed to create an OLEVariant are: value, type, param flags."
+ forward class(super)
+
+syntax:
+ raise propagate
+
+::METHOD INIT EXTERNAL "LIBRARY OREXXOLE OLEVariant_Init"
+
+::METHOD "!VARVALUE_=" EXTERNAL "LIBRARY OREXXOLE OLEVariant_VarValueEquals"
+::METHOD "!VARVALUE_"
+ expose !_VAR_VALUE_
+ return !_VAR_VALUE_
+
+::METHOD "!VARTYPE_=" EXTERNAL "LIBRARY OREXXOLE OLEVariant_VarTypeEquals"
+::METHOD "!VARTYPE_"
+ expose !_VAR_TYPE_STR_
+ return !_VAR_TYPE_STR_
+
+::METHOD "!_VT_"
+ expose !_VAR_TYPE_
+ return !_VAR_TYPE_
+
+::METHOD "!PARAMFLAGS_=" EXTERNAL "LIBRARY OREXXOLE OLEVariant_ParamFlagsEquals"
+::METHOD "!PARAMFLAGS_"
+ expose !_PARAM_FLAGS_STR_
+ return !_PARAM_FLAGS_STR_
+
+::METHOD "!_PFLAGS_"
+ expose !_PARAM_FLAGS_
+ return !_PARAM_FLAGS_
+
+::METHOD "!OLEVARIANT_" ATTRIBUTE
+
+-- !clearVariant_ is an undocumented method for internal use only.
+::METHOD "!CLEARVARIANT_"
+ expose !_CLEAR_VARIANT_
+ return !_CLEAR_VARIANT_
+
+::METHOD "!CLEARVARIANT_="
+ expose !_CLEAR_VARIANT_
+ use arg bool
+ signal on syntax
+
+ if arg(1, 'O') then
+ raise syntax 93.903 array(1) description "!CLEARVARIANT_ must be set to .true or .false."
+ if bool <> .true & bool <> .false then
+ raise syntax 93.914 array(1, "[.true,.false]", bool~string) description "!CLEARVARIANT_ must be set to .true or .false."
+
+ !_CLEAR_VARIANT_ = (bool == .true)
+ return
+
+syntax:
+ raise propagate
+
Modified: interpreter-3.x/trunk/platform/windows/ole/orexxole.def
===================================================================
--- interpreter-3.x/trunk/platform/windows/ole/orexxole.def 2007-03-18 18:11:29 UTC (rev 165)
+++ interpreter-3.x/trunk/platform/windows/ole/orexxole.def 2007-03-18 21:59:38 UTC (rev 166)
@@ -49,6 +49,10 @@
OLEObject_GetKnownMethods
OLEObject_GetKnownEvents
OLEObject_GetObject_Class
+ OLEVariant_Init
+ OLEVariant_VarValueEquals
+ OLEVariant_VarTypeEquals
+ OLEVariant_ParamFlagsEquals
Rexx2Variant
Variant2Rexx
setCreationCallback
Modified: interpreter-3.x/trunk/platform/windows/ole/orexxole.mak
===================================================================
--- interpreter-3.x/trunk/platform/windows/ole/orexxole.mak 2007-03-18 18:11:29 UTC (rev 165)
+++ interpreter-3.x/trunk/platform/windows/ole/orexxole.mak 2007-03-18 21:59:38 UTC (rev 166)
@@ -1,7 +1,7 @@
#/*----------------------------------------------------------------------------*/
#/* */
#/* Copyright (c) 1995, 2004 IBM Corporation. All rights reserved. */
-#/* Copyright (c) 2005-2006 Rexx Language Association. All rights reserved. */
+#/* Copyright (c) 2005-2007 Rexx Language Association. All rights reserved. */
#/* */
#/* This program and the accompanying materials are made available under */
#/* the terms of the Common Public License v1.0 which accompanies this */
@@ -49,7 +49,7 @@
!ERROR Build error, OR_ORYXOLESRC not set
!ENDIF
-OBJS = $(OR_OUTDIR)\orexxole.obj
+OBJS = $(OR_OUTDIR)\orexxole.obj $(OR_OUTDIR)\OLEVariant.obj
CPPOBJS = $(OR_OUTDIR)\events.obj
# Following for OREXXOLE.LIB
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|