From: Pat Thoyts Date: Thu, 29 Jan 2009 22:17:50 +0000 (+0000) Subject: import: tcom-3.9 X-Git-Url: https://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=2325035d544f07247f2f8979f59904d6e2faef36;p=tcom import: tcom-3.9 --- diff --git a/CHANGES b/CHANGES index 1ce6379..6edeffe 100644 --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,19 @@ +Version 3.9 +- Fixed defect where eval may trigger premature destruction of handle internal + representation. +- Fixed COM server handling of byref BSTR and VARIANT parameters. +- Fixed invalid pointer error when Visual Studio automation object returns a + VARIANT of type VT_DISPATCH with pointer set to NULL. +- Fixed incorrect type conversion when passing to SAFEARRAY(BYTE) parameter. +- Fixed memory corruption in handling of [out] DECIMAL parameters. +- Fixed Unicode encoding of ::tcom::ref getobject parameter. +- If an error occurs while executing a ::tcom::bind event handler command + then use the bgerror mechanism to report the error. +- Added ::tcom::variant command which creates VARIANT values. +- Added [::tcom::object null] command which returns a token representing a + null IUnknown pointer. +- Added support for two-dimensional SAFEARRAY. + Version 3.8 - Fixed defect which prevented DISPATCH_PROPERTYPUTREF properties from being set. diff --git a/README b/README index e013838..6ff0ac0 100644 --- a/README +++ b/README @@ -14,10 +14,10 @@ directory is C:\Tcl\lib, enter this command at the command prompt: TCL ACTIVE SCRIPT ENGINE -This distribution includes an Active Script engine that's currently in a -pre-alpha stage of development. It implements just enough of the IActiveScript -and IActiveScriptParse interfaces to enable Internet Explorer and Windows -Script Host to run simple scripts. It works with the ActiveTcl binary -distribution from ActiveState. To register the script engine (assuming the -Tcl library directory is C:\Tcl\lib), change the current working directory to +This distribution includes an experimental implementation of a Tcl Active +Script engine. It implements just enough of the IActiveScript and +IActiveScriptParse interfaces to enable Internet Explorer and Windows Script +Host to run simple scripts. It works with the ActiveTcl binary distribution +from ActiveState. To register the script engine (assuming the Tcl library +directory is C:\Tcl\lib), change the current working directory to C:\Tcl\lib\TclScript and run the register.tcl script. diff --git a/doc/docbookx.dtd b/doc/docbookx.dtd deleted file mode 100644 index e69de29..0000000 diff --git a/doc/tcom.n.html b/doc/tcom.n.html index 6913361..518d762 100644 --- a/doc/tcom.n.html +++ b/doc/tcom.n.html @@ -20,7 +20,7 @@

Synopsis

package require tcom - ?3.8? + ?3.9?
::tcom::ref createobject @@ -286,12 +286,13 @@

This command specifies a Tcl command that will be executed when - events are received from an object. The - command will be called with additional - arguments: the event name and the event arguments. By default, the event - interface is the default event source interface of the object's class. - Use the eventIID parameter to specify the IID - of another event interface.

+ events are received from an object. The command + will be called with additional arguments: the event name and the event + arguments. By default, the event interface is the default event source + interface of the object's class. Use the eventIID + parameter to specify the IID of another event interface. If an error + occurs while executing the command then the bgerror mechanism is used to + report the error.

diff --git a/doc/tcom.n.xml b/doc/tcom.n.xml index f5c20e4..4794bad 100644 --- a/doc/tcom.n.xml +++ b/doc/tcom.n.xml @@ -1,10 +1,10 @@ - + - $Date: 2002/04/12 23:44:50 $ - $Revision: 1.63 $ + $Date: 2002/10/22 22:07:55 $ + $Revision: 1.65 $ tcom @@ -17,7 +17,7 @@ package require tcom - + ::tcom::ref createobject @@ -283,12 +283,13 @@ This command specifies a Tcl command that will be executed when - events are received from an object. The - command will be called with additional - arguments: the event name and the event arguments. By default, the event - interface is the default event source interface of the object's class. - Use the eventIID parameter to specify the IID - of another event interface. + events are received from an object. The command + will be called with additional arguments: the event name and the event + arguments. By default, the event interface is the default event source + interface of the object's class. Use the eventIID + parameter to specify the IID of another event interface. If an error + occurs while executing the command then the bgerror mechanism is used to + report the error. diff --git a/doc/xslt.tcl b/doc/xslt.tcl index 4df74fa..6969985 100644 --- a/doc/xslt.tcl +++ b/doc/xslt.tcl @@ -1,4 +1,4 @@ -# $Id: xslt.tcl,v 1.1 2002/04/17 22:07:57 cthuang Exp $ +# $Id: xslt.tcl,v 1.2 2002/09/05 22:10:25 cthuang Exp $ # # Run an XML document through an XSLT processor. @@ -14,6 +14,7 @@ set domProgId "Msxml2.DOMDocument" set source [::tcom::ref createobject $domProgId] $source preserveWhiteSpace 1 $source validateOnParse 0 +$source resolveExternals 0 set sourceUrl [lindex $argv 0] if {![$source load $sourceUrl]} { set parseError [$source parseError] diff --git a/lib/Banking/server.tcl b/lib/Banking/server.tcl index 520e669..f31894f 100644 --- a/lib/Banking/server.tcl +++ b/lib/Banking/server.tcl @@ -1,4 +1,4 @@ -# $Id: server.tcl,v 1.3 2002/06/29 15:34:52 cthuang Exp $ +# $Id: server.tcl,v 1.4 2003/03/07 00:03:00 cthuang Exp $ package provide Banking 1.0 package require tcom @@ -34,7 +34,6 @@ proc bankImpl {method args} { switch -- $method { CreateAccount { set balance 0 - set name "" return [::tcom::object create ::Banking::Account accountImpl] } diff --git a/lib/TclScript/TclScript.dll b/lib/TclScript/TclScript.dll index 81409ac..a214bbd 100644 Binary files a/lib/TclScript/TclScript.dll and b/lib/TclScript/TclScript.dll differ diff --git a/lib/TclScript/TclScript.itcl b/lib/TclScript/TclScript.itcl index 40c93a3..1d6f287 100644 --- a/lib/TclScript/TclScript.itcl +++ b/lib/TclScript/TclScript.itcl @@ -1,4 +1,4 @@ -# $Id: TclScript.itcl,v 1.2 2002/04/20 06:11:32 cthuang Exp $ +# $Id: TclScript.itcl,v 1.6 2003/11/08 17:38:09 cthuang Exp $ package require Itcl namespace import itcl::* @@ -8,6 +8,7 @@ package require tcom class Engine { # common HRESULT values + common S_FALSE 0x00000001 common E_NOTIMPL 0x80004001 common E_FAIL 0x80004005 @@ -39,7 +40,7 @@ class Engine { common SCRIPTITEM_NOCODE 0x400 # true if logging to debug output enabled - variable logDebugOn_ 1 + common logDebugOn_ 1 # SCRIPTSTATE variable scriptState_ @@ -51,7 +52,7 @@ class Engine { variable slave_ # code to execute - variable code_ {} + public variable code_ {} # list of names of items which have global members variable globalMemberItems_ {} @@ -103,12 +104,14 @@ class Engine { } # Fall back to original unknown. - eval unknown $args + if {![$slave_ issafe]} { + $slave_ eval ::TclScriptEngine::oldUnknown $args + } } method log {msg} { if {$logDebugOn_} { - ::TclScriptEngine::outputdebug $msg + ::tcom::outputdebug "$this $msg" } } @@ -144,9 +147,15 @@ class Engine { } method changeScriptState {newState} { + log "changeScriptState $scriptStateDesc($scriptState_) $scriptStateDesc($newState)" + set scriptState_ $newState if {[info exists scriptSite_]} { - $scriptSite_ OnStateChange $newState + if {[catch { + $scriptSite_ OnStateChange $newState + }]} { + log $::errorInfo + } } switch -- $newState \ @@ -156,7 +165,7 @@ class Engine { } } - method sink {sourceName eventName} { + method sink {sourceName eventName args} { if {[info exists eventCode_($sourceName,$eventName)]} { $slave_ eval $eventCode_($sourceName,$eventName) } @@ -171,10 +180,7 @@ class Engine { set source [::TclScriptEngine::getnameditem \ $scriptSite_ $itemName $subItemName] - set sinkProcName ::${sourceName}_sink - proc $sinkProcName {eventName args} \ - "$this sink $sourceName \$eventName" - ::tcom::bind $source $sinkProcName + ::tcom::bind $source "$this sink $sourceName" set connectedSources_($sourceName) $source } @@ -183,7 +189,7 @@ class Engine { method disconnectFromSources {} { foreach {sourceName source} [array get connectedSources_] { - ::tcom::unbind $source + ::tcom::bind $source {} unset connectedSources_($sourceName) } } @@ -261,12 +267,11 @@ class Engine { set unknown [::TclScriptEngine::getnameditem $scriptSite_ $name] - if {($flags & $SCRIPTITEM_GLOBALMEMBERS) != 0} { + if {$flags & $SCRIPTITEM_GLOBALMEMBERS} { lappend globalMemberItems_ $name } - if {($flags & $SCRIPTITEM_ISVISIBLE) != 0} { - log "IActiveScript::AddNamedItem createItemCommand" + if {$flags & $SCRIPTITEM_ISVISIBLE} { createItemCommand $name $unknown } } @@ -279,8 +284,16 @@ class Engine { method GetScriptDispatch {itemName ppDispatch} { log "IActiveScript::GetScriptDispatch $itemName" upvar $ppDispatch pDispatch + + if {[string length $itemName] == 0} { + set pDispatch [::tcom::object create ::TclScript::Dispatch \ + [namespace current]::$this] + return + } + set pDispatch 0 - errorNotImpl + set messageText "Not implemented" + error $messageText {} [list COM $S_FALSE $messageText] } method GetCurrentScriptThreadID {pScriptThreadId} { @@ -310,8 +323,13 @@ class Engine { method Clone {ppScript} { log "IActiveScript::Clone" upvar $ppScript pScript - set pScript 0 - errorNotImpl + + set engine [Engine #auto] + $engine configure -code_ $code_ + $engine InitNew + + set pScript [::tcom::object create ::TclScript::Engine \ + [namespace current]::$engine {delete object}] } # IActiveScriptParse implementation @@ -323,6 +341,7 @@ class Engine { set slave_ [interp create -safe] } else { set slave_ [interp create] + $slave_ eval rename unknown ::TclScriptEngine::oldUnknown } $slave_ alias unknown $this resolveUnknownCommand diff --git a/lib/TclScript/TclScript.tlb b/lib/TclScript/TclScript.tlb index af23937..871d694 100644 Binary files a/lib/TclScript/TclScript.tlb and b/lib/TclScript/TclScript.tlb differ diff --git a/lib/TclScript/unregister.tcl b/lib/TclScript/unregister.tcl new file mode 100644 index 0000000..906114a --- /dev/null +++ b/lib/TclScript/unregister.tcl @@ -0,0 +1,13 @@ +# $Id: unregister.tcl,v 1.1 2003/03/20 00:12:14 cthuang Exp $ +# +# This script unregisters the Tcl Active Scripting engine. + +package require registry +package require tcom + + set typeLibFile "TclScript.tlb" + ::tcom::server unregister $typeLibFile + + registry delete "HKEY_CLASSES_ROOT\\TclScript" + registry delete "HKEY_CLASSES_ROOT\\.tcls" + registry delete "HKEY_CLASSES_ROOT\\TclScriptFile" diff --git a/lib/tcom/pkgIndex.tcl b/lib/tcom/pkgIndex.tcl index bbfa714..aa90f9b 100644 --- a/lib/tcom/pkgIndex.tcl +++ b/lib/tcom/pkgIndex.tcl @@ -1,3 +1,3 @@ -# $Id: pkgIndex.tcl,v 1.15 2002/02/26 23:10:47 cthuang Exp $ -package ifneeded tcom 3.8 \ +# $Id: pkgIndex.tcl,v 1.16 2003/04/17 03:17:30 cthuang Exp $ +package ifneeded tcom 3.9 \ [list load [file join $dir tcom.dll]]\n[list source [file join $dir tcom.tcl]] diff --git a/lib/tcom/tcom.dll b/lib/tcom/tcom.dll index c543121..3c68901 100644 Binary files a/lib/tcom/tcom.dll and b/lib/tcom/tcom.dll differ diff --git a/lib/tcom/tcom.tcl b/lib/tcom/tcom.tcl index 2044e33..58eaab4 100644 --- a/lib/tcom/tcom.tcl +++ b/lib/tcom/tcom.tcl @@ -1,6 +1,11 @@ -# $Id: tcom.tcl,v 1.14 2002/03/30 16:24:11 cthuang Exp $ +# $Id: tcom.tcl,v 1.17 2003/04/02 22:46:51 cthuang Exp $ namespace eval ::tcom { + # Tear down all event connections to the object. + proc unbind {handle} { + ::tcom::bind $handle {} + } + # Look for the file in the directories in the package load path. # Return the full path of the file. proc search_auto_path {fileSpec} { @@ -44,6 +49,7 @@ namespace eval ::tcom { set key "HKEY_CLASSES_ROOT\\$verIndependentProgId" registry set $key "" "$className Class" registry set "$key\\CLSID" "" $clsid + registry set "$key\\CurVer" "" $progId set key "HKEY_CLASSES_ROOT\\CLSID\\$clsid" registry set $key "" "$className Class" @@ -55,7 +61,6 @@ namespace eval ::tcom { if {$inproc} { set key "HKEY_CLASSES_ROOT\\CLSID\\$clsid\\InprocServer32" registry set $key "" $dllPath - registry set $key "ThreadingModel" "Apartment" } if {$local} { diff --git a/lib/tcom/tcominproc.dll b/lib/tcom/tcominproc.dll index ddedbfe..519a611 100644 Binary files a/lib/tcom/tcominproc.dll and b/lib/tcom/tcominproc.dll differ diff --git a/lib/tcom/tcomlocal.exe b/lib/tcom/tcomlocal.exe index f718268..42df14c 100644 Binary files a/lib/tcom/tcomlocal.exe and b/lib/tcom/tcomlocal.exe differ diff --git a/samples/chart.tcl b/samples/chart.tcl index cb34c09..fbfd15f 100644 --- a/samples/chart.tcl +++ b/samples/chart.tcl @@ -1,4 +1,4 @@ -# $Id: chart.tcl,v 1.1 2001/08/18 00:35:52 cthuang Exp $ +# $Id: chart.tcl,v 1.5 2004/02/26 18:07:38 cthuang Exp $ # # This example controls Excel. It performs the following steps. # - Start Excel application. @@ -16,28 +16,16 @@ set workbook [$workbooks Add] set worksheets [$workbook Worksheets] set worksheet [$worksheets Item [expr 1]] -set cells [$worksheet Cells] -$cells Item 1 A "North" -$cells Item 1 B "South" -$cells Item 1 C "East" -$cells Item 1 D "West" -$cells Item 2 A 5.2 -$cells Item 2 B 10.0 -$cells Item 2 C 8.0 -$cells Item 2 D 20.0 +set data [list \ + [list "North" "South" "East" "West"] \ + [list 5.2 10.0 8.0 20.0] \ +] set sourceRange [$worksheet Range "A1" "D2"] +$sourceRange Value $data set charts [$workbook Charts] set chart [$charts Add] -$chart ChartWizard \ - $sourceRange \ - [expr -4102] \ - [expr 7] \ - [expr 1] \ - [expr 1] \ - [expr 0] \ - 0 \ - "Sales Percentages" +$chart ChartWizard $sourceRange 5 [::tcom::na] 1 1 0 0 "Sales Percentages" # Prevent Excel from prompting to save the document on close. $workbook Saved 1 diff --git a/samples/excel.tcl b/samples/excel.tcl index 4bc3031..b00459e 100644 --- a/samples/excel.tcl +++ b/samples/excel.tcl @@ -1,4 +1,4 @@ -# $Id: excel.tcl,v 1.9 2001/06/30 18:42:58 cthuang Exp $ +# $Id: excel.tcl,v 1.10 2002/09/27 22:11:03 cthuang Exp $ # # This example controls Excel. It performs the following steps. # - Start Excel application. @@ -13,6 +13,7 @@ package require tcom proc dumpInterface {obj} { set interface [::tcom::info interface $obj] + puts "interface [$interface name]" set properties [$interface properties] foreach property $properties { diff --git a/src/Arguments.cpp b/src/Arguments.cpp index 4ed82a7..b92e4a7 100644 --- a/src/Arguments.cpp +++ b/src/Arguments.cpp @@ -1,4 +1,4 @@ -// $Id: Arguments.cpp,v 1.33 2002/07/09 04:10:08 cthuang Exp $ +// $Id: Arguments.cpp,v 1.35 2003/03/15 01:32:09 cthuang Exp $ #include "Arguments.h" #include "Extension.h" #include "TclObject.h" @@ -45,7 +45,11 @@ TypedArguments::initArgument ( // For out parameters, set a pointer to where the out value // will be stored. - if (vt == VT_USERDEFINED) { + if (vt == VT_INT) { + // IDispatch::Invoke returns DISP_E_TYPEMISMATCH on + // VT_INT | VT_BYREF parameters. + vt = VT_I4; + } else if (vt == VT_USERDEFINED) { // Assume user defined types derive from IUnknown. vt = VT_UNKNOWN; } @@ -57,7 +61,7 @@ TypedArguments::initArgument ( m_args[argIndex].vt = VT_BYREF | vt; } - if (vt == VT_VARIANT) { + if (vt == VT_VARIANT || vt == VT_DECIMAL) { // Set a pointer to out variant. m_args[argIndex].byref = &m_outValues[argIndex]; } else { diff --git a/src/ComObject.cpp b/src/ComObject.cpp index e0fc187..beb4e9b 100644 --- a/src/ComObject.cpp +++ b/src/ComObject.cpp @@ -1,4 +1,4 @@ -// $Id: ComObject.cpp,v 1.37 2002/05/31 04:03:06 cthuang Exp $ +// $Id: ComObject.cpp,v 1.41 2003/04/04 23:55:04 cthuang Exp $ #pragma warning(disable: 4786) #include "ComObject.h" #include @@ -16,14 +16,17 @@ static const char setPrefix[] = "_set_"; ComObject::ComObject (const Class::Interfaces &interfaces, Tcl_Interp *interp, TclObject servant, - TclObject destructor): + TclObject destructor, + bool isSink): m_refCount(0), m_defaultInterface(*(interfaces.front())), m_interp(interp), m_servant(servant), m_destructor(destructor), m_supportErrorInfo(*this), - m_pDispatch(0) + m_pDispatch(0), + m_registeredActiveObject(false), + m_isSink(isSink) { // Tcl_Preserve(reinterpret_cast(m_interp)); ComModule::instance().lock(); @@ -86,16 +89,18 @@ ComObject::newInstance ( const Interface &defaultInterface, Tcl_Interp *interp, TclObject servant, - TclObject destructor) + TclObject destructor, + bool isSink) { Class::Interfaces interfaces; interfaces.push_back(&defaultInterface); return new ComObject( - interfaces, - interp, - servant, - destructor); + interfaces, + interp, + servant, + destructor, + isSink); } ComObject * @@ -105,12 +110,12 @@ ComObject::newInstance ( TclObject servant, TclObject destructor) { - ComObject *pComObject = new ComObject( - interfaces, - interp, - servant, - destructor); - return pComObject; + return new ComObject( + interfaces, + interp, + servant, + destructor, + false); } int @@ -190,9 +195,9 @@ HRESULT ComObject::queryInterface (REFIID iid, void **ppvObj) { if (IsEqualIID(iid, IID_IUnknown)) { - *ppvObj = m_pDefaultAdapter; + *ppvObj = m_pDefaultAdapter; addRef(); - return S_OK; + return S_OK; } if (IsEqualIID(iid, IID_IDispatch)) { @@ -200,15 +205,15 @@ ComObject::queryInterface (REFIID iid, void **ppvObj) if (m_pDispatch == 0) { m_pDispatch = new InterfaceAdapter(*this, m_defaultInterface, true); } - *ppvObj = m_pDispatch; + *ppvObj = m_pDispatch; addRef(); - return S_OK; + return S_OK; } if (IsEqualIID(iid, IID_ISupportErrorInfo)) { - *ppvObj = &m_supportErrorInfo; + *ppvObj = &m_supportErrorInfo; addRef(); - return S_OK; + return S_OK; } InterfaceAdapter *pAdapter = m_iidToAdapterMap.find(iid); @@ -220,9 +225,9 @@ ComObject::queryInterface (REFIID iid, void **ppvObj) } if (pAdapter != 0) { - *ppvObj = pAdapter; + *ppvObj = pAdapter; addRef(); - return S_OK; + return S_OK; } *ppvObj = 0; @@ -241,7 +246,7 @@ ComObject::release () { InterlockedDecrement(&m_refCount); if (m_refCount == 0) { - delete this; + delete this; return 0; } return m_refCount; @@ -447,13 +452,22 @@ ComObject::invoke (InterfaceAdapter *pAdapter, // Execute the Tcl script. TclObject result; int completionCode = eval(script, &result); - if (completionCode != TCL_OK) { - fillExcepInfo( - pExcepInfo, - hresultFromErrorCode(), - m_servant.c_str(), - result.c_str()); - return DISP_E_EXCEPTION; + if (completionCode == TCL_OK) { + hresult = S_OK; + } else { + if (m_isSink) { + Tcl_BackgroundError(m_interp); + } + + hresult = hresultFromErrorCode(); + if (FAILED(hresult)) { + fillExcepInfo( + pExcepInfo, + hresult, + m_servant.c_str(), + result.c_str()); + hresult = DISP_E_EXCEPTION; + } } // Copy values to out arguments. @@ -482,8 +496,6 @@ ComObject::invoke (InterfaceAdapter *pAdapter, // from methods. result.toVariant(pReturnValue, pMethod->type(), m_interp, true); } - - hresult = S_OK; } catch (_com_error &e) { fillExcepInfo(pExcepInfo, e.Error(), m_servant.c_str(), 0); @@ -549,19 +561,29 @@ convertNativeToTclObject (va_list pArg, { #if TCL_MINOR_VERSION >= 2 // Uses Unicode function introduced in Tcl 8.2. - Tcl_UniChar *pUnicode = va_arg(pArg, Tcl_UniChar *); + Tcl_UniChar *pUnicode = byRef ? + *va_arg(pArg, Tcl_UniChar **) : va_arg(pArg, Tcl_UniChar *); if (pUnicode != 0) { tclObject = Tcl_NewUnicodeObj(pUnicode, -1); } else { tclObject = Tcl_NewObj(); } #else - _bstr_t str(va_arg(pArg, wchar_t *)); + wchar_t *pUnicode = byRef ? + *va_arg(pArg, wchar_t **) : va_arg(pArg, wchar_t *); + _bstr_t str(pUnicode); tclObject = Tcl_NewStringObj(str, -1); #endif } break; + case VT_VARIANT: + tclObject = TclObject( + byRef ? va_arg(pArg, VARIANT *) : &va_arg(pArg, VARIANT), + type, + interp); + break; + default: tclObject = Tcl_NewLongObj( byRef ? *va_arg(pArg, int *) : va_arg(pArg, int)); @@ -711,6 +733,10 @@ nextArgument (va_list pArg, const Type &type) va_arg(pArg, BSTR); break; + case VT_VARIANT: + va_arg(pArg, VARIANT); + break; + default: va_arg(pArg, int); } @@ -752,10 +778,10 @@ setErrorInfo (const char *source, const char *description) void __cdecl invokeComObjectFunction (volatile HRESULT hresult, volatile DWORD pArgEnd, - DWORD /*ebp*/, - DWORD funcIndex, - DWORD /*retAddr*/, - InterfaceAdapter *pAdapter, + DWORD /*ebp*/, + DWORD funcIndex, + DWORD /*retAddr*/, + InterfaceAdapter *pAdapter, ...) { // Get the method description for method being invoked. @@ -812,7 +838,9 @@ invokeComObjectFunction (volatile HRESULT hresult, hresult = S_OK; } else { hresult = object.hresultFromErrorCode(); - setErrorInfo(object.m_servant.c_str(), result.c_str()); + if (FAILED(hresult)) { + setErrorInfo(object.m_servant.c_str(), result.c_str()); + } } // Copy values to out arguments. diff --git a/src/ComObject.h b/src/ComObject.h index 1d71c0a..3868e2f 100644 --- a/src/ComObject.h +++ b/src/ComObject.h @@ -1,4 +1,4 @@ -// $Id: ComObject.h,v 1.14 2002/04/13 03:53:56 cthuang Exp $ +// $Id: ComObject.h,v 1.15 2002/10/22 22:07:55 cthuang Exp $ #ifndef COMOBJECT_H #define COMOBJECT_H @@ -67,12 +67,16 @@ class TCOM_API ComObject // true if object registered in running object table bool m_registeredActiveObject; + // true if object is an event sink + bool m_isSink; + // Do not allow others to create or copy instances of this class. ComObject( const Class::Interfaces &interfaces, Tcl_Interp *interp, TclObject servant, - TclObject destructor); + TclObject destructor, + bool isSink); ComObject(const ComObject &); // not implemented void operator=(const ComObject &); // not implemented @@ -91,7 +95,8 @@ public: const Interface &defaultInterface, Tcl_Interp *interp, TclObject servant, - TclObject destructor); + TclObject destructor, + bool isSink = false); static ComObject *newInstance( const Class::Interfaces &interfaces, Tcl_Interp *interp, diff --git a/src/Extension.cpp b/src/Extension.cpp index ab53fba..85d4abe 100644 --- a/src/Extension.cpp +++ b/src/Extension.cpp @@ -1,4 +1,4 @@ -// $Id: Extension.cpp,v 1.1 2002/06/29 15:40:32 cthuang Exp $ +// $Id: Extension.cpp,v 1.3 2003/04/02 22:46:51 cthuang Exp $ #pragma warning(disable: 4786) #include "Extension.h" #include "ComModule.h" @@ -35,6 +35,8 @@ Extension::Extension (Tcl_Interp *interp): interp, PACKAGE_NAMESPACE "null", nullCmd, 0, 0); Tcl_CreateObjCommand( interp, PACKAGE_NAMESPACE "object", objectCmd, this, 0); + Tcl_CreateObjCommand( + interp, PACKAGE_NAMESPACE "outputdebug", outputdebugCmd, this, 0); Tcl_CreateObjCommand( interp, PACKAGE_NAMESPACE "property", propertyCmd, 0, 0); Tcl_CreateObjCommand( @@ -46,7 +48,7 @@ Extension::Extension (Tcl_Interp *interp): Tcl_CreateObjCommand( interp, PACKAGE_NAMESPACE "typeof", typeofCmd, 0, 0); Tcl_CreateObjCommand( - interp, PACKAGE_NAMESPACE "unbind", unbindCmd, 0, 0); + interp, PACKAGE_NAMESPACE "variant", variantCmd, 0, 0); Tcl_CallWhenDeleted(interp, interpDeleteProc, this); Tcl_CreateExitHandler(exitProc, this); @@ -97,3 +99,30 @@ Extension::typeofCmd ( Tcl_SetResult(interp, name, TCL_STATIC); return TCL_OK; } + +// This Tcl command outputs a string to the debug stream. + +int +Extension::outputdebugCmd ( + ClientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "message"); + return TCL_ERROR; + } + + Tcl_Obj *pMessage = objv[1]; + Tcl_Obj *pWithNewLine = + Tcl_IsShared(pMessage) ? Tcl_DuplicateObj(pMessage) : pMessage; + + Tcl_AppendToObj(pWithNewLine, "\n", 1); + OutputDebugString(Tcl_GetStringFromObj(pWithNewLine, 0)); + + if (Tcl_IsShared(pMessage)) { + Tcl_DecrRefCount(pWithNewLine); + } + return TCL_OK; +} diff --git a/src/Extension.h b/src/Extension.h index de47b6c..7eb7116 100644 --- a/src/Extension.h +++ b/src/Extension.h @@ -1,4 +1,4 @@ -// $Id: Extension.h,v 1.1 2002/06/29 15:40:32 cthuang Exp $ +// $Id: Extension.h,v 1.5 2003/04/02 22:46:51 cthuang Exp $ #ifndef EXTENSION_H #define EXTENSION_H @@ -47,12 +47,13 @@ class TCOM_API Extension static int naCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); static int nullCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); static int objectCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); + static int outputdebugCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); static int propertyCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); static int refCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); static int shortPathNameCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); static int typelibCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); static int typeofCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); - static int unbindCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); + static int variantCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); // not implemented Extension(const Extension &); @@ -84,10 +85,17 @@ public: static Tcl_ObjType naType; static Tcl_ObjType nullType; static Tcl_ObjType unknownPointerType; + static Tcl_ObjType variantType; // Create a Tcl value representing a missing optional argument. static Tcl_Obj *newNaObj(); + // Create a Tcl value representing a SQL-style null. + static Tcl_Obj *newNullObj(); + + // Create a Tcl value representing a VARIANT. + static Tcl_Obj *newVariantObj(_variant_t *pVar); + // Set the Tcl result to a description of the COM error and return TCL_ERROR. static int setComErrorResult( Tcl_Interp *interp, _com_error &e, const char *file, int line); diff --git a/src/HandleSupport.cpp b/src/HandleSupport.cpp index 2795dcf..d4d75df 100644 --- a/src/HandleSupport.cpp +++ b/src/HandleSupport.cpp @@ -1,4 +1,4 @@ -// $Id: HandleSupport.cpp,v 1.15 2002/05/31 04:03:06 cthuang Exp $ +// $Id: HandleSupport.cpp,v 1.19 2003/07/17 22:33:31 cthuang Exp $ #include "HandleSupport.h" #include #include "ThreadLocalStorage.h" @@ -20,13 +20,16 @@ InternalRep::InternalRep ( objClientData, 0); - HandleNameToRepMap::instance(interp)->insert(handleName.c_str(), this); + m_pNameEntry = HandleNameToRepMap::instance(interp)->insert( + handleName.c_str(), this); } InternalRep::~InternalRep () { - HandleNameToRepMap::instance(m_interp)->erase(name().c_str()); - Tcl_DeleteCommandFromToken(m_interp, m_command); + HandleNameToRepMap::erase(m_pNameEntry); + if (!Tcl_InterpDeleted(m_interp)) { + Tcl_DeleteCommandFromToken(m_interp, m_command); + } } std::string @@ -58,7 +61,7 @@ InternalRep::decrHandleCount () class ObjToRepMap { - Tcl_HashTable m_hashTable; + Tcl_HashTable m_objMap; static ThreadLocalStorage ms_tls; @@ -89,7 +92,7 @@ ObjToRepMap::exitProc (ClientData clientData) ObjToRepMap::ObjToRepMap () { - Tcl_InitHashTable(&m_hashTable, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&m_objMap, TCL_ONE_WORD_KEYS); #ifdef TCL_THREADS Tcl_CreateThreadExitHandler(exitProc, this); @@ -100,7 +103,7 @@ ObjToRepMap::ObjToRepMap () ObjToRepMap::~ObjToRepMap () { - Tcl_DeleteHashTable(&m_hashTable); + Tcl_DeleteHashTable(&m_objMap); } ObjToRepMap & @@ -114,7 +117,7 @@ ObjToRepMap::insert (Tcl_Obj *pObj, InternalRep *pRep) { int isNew; Tcl_HashEntry *pEntry = Tcl_CreateHashEntry( - &m_hashTable, reinterpret_cast(pObj), &isNew); + &m_objMap, reinterpret_cast(pObj), &isNew); Tcl_SetHashValue(pEntry, pRep); } @@ -122,7 +125,7 @@ InternalRep * ObjToRepMap::find (Tcl_Obj *pObj) { Tcl_HashEntry *pEntry = Tcl_FindHashEntry( - &m_hashTable, reinterpret_cast(pObj)); + &m_objMap, reinterpret_cast(pObj)); if (pEntry == 0) { return 0; } @@ -133,7 +136,7 @@ void ObjToRepMap::erase (Tcl_Obj *pObj) { Tcl_HashEntry *pEntry = Tcl_FindHashEntry( - &m_hashTable, reinterpret_cast(pObj)); + &m_objMap, reinterpret_cast(pObj)); if (pEntry != 0) { Tcl_DeleteHashEntry(pEntry); } @@ -176,8 +179,9 @@ CmdNameType::freeInternalRep (Tcl_Obj *pObj) { if (pObj->refCount == 0) { InternalRep *pRep = ObjToRepMap::instance().find(pObj); - if (pRep != 0 && pRep->decrHandleCount() == 0) { + if (pRep != 0) { ObjToRepMap::instance().erase(pObj); + pRep->decrHandleCount(); } } @@ -236,6 +240,8 @@ static char ASSOC_KEY[] = "tcomHandles"; HandleNameToRepMap::HandleNameToRepMap (Tcl_Interp *interp): m_interp(interp) { + Tcl_InitHashTable(&m_handleMap, TCL_STRING_KEYS); + Tcl_SetAssocData(interp, ASSOC_KEY, deleteInterpProc, this); Tcl_CreateExitHandler(exitProc, this); } @@ -243,7 +249,15 @@ HandleNameToRepMap::HandleNameToRepMap (Tcl_Interp *interp): HandleNameToRepMap::~HandleNameToRepMap () { // Clean up any left over objects. - clear(); + Tcl_HashSearch search; + Tcl_HashEntry *pEntry = Tcl_FirstHashEntry(&m_handleMap, &search); + while (pEntry != 0) { + Tcl_HashEntry *pNext = Tcl_NextHashEntry(&search); + delete static_cast(Tcl_GetHashValue(pEntry)); + pEntry = pNext; + } + + Tcl_DeleteHashTable(&m_handleMap); } void @@ -268,9 +282,30 @@ HandleNameToRepMap::instance (Tcl_Interp *interp) Tcl_GetAssocData(interp, ASSOC_KEY, 0)); } +Tcl_HashEntry * +HandleNameToRepMap::insert (const char *handleStr, InternalRep *pRep) +{ + int isNew; + Tcl_HashEntry *pEntry = Tcl_CreateHashEntry( + &m_handleMap, const_cast(handleStr), &isNew); + Tcl_SetHashValue(pEntry, static_cast(pRep)); + return pEntry; +} + +InternalRep * +HandleNameToRepMap::find (Tcl_Obj *pHandle) const +{ + char *key = Tcl_GetStringFromObj(pHandle, 0); + Tcl_HashEntry *pEntry = Tcl_FindHashEntry( + const_cast(&m_handleMap), key); + if (pEntry == 0) { + return 0; + } + return static_cast(Tcl_GetHashValue(pEntry)); +} + void -HandleNameToRepMap::clear () +HandleNameToRepMap::erase (Tcl_HashEntry *pNameEntry) { - m_map.forEach(Delete()); - m_map.clear(); + Tcl_DeleteHashEntry(pNameEntry); } diff --git a/src/HandleSupport.h b/src/HandleSupport.h index 51ad6c0..d96a1fb 100644 --- a/src/HandleSupport.h +++ b/src/HandleSupport.h @@ -1,11 +1,10 @@ -// $Id: HandleSupport.h,v 1.27 2002/04/17 21:43:07 cthuang Exp $ +// $Id: HandleSupport.h,v 1.29 2003/07/17 22:33:31 cthuang Exp $ #ifndef HANDLESUPPORT_H #define HANDLESUPPORT_H #include #include #include "tcomApi.h" -#include "HashTable.h" #include "Singleton.h" // This class represents an association from a handle to an application object. @@ -17,6 +16,7 @@ protected: Tcl_Interp *m_interp; Tcl_Command m_command; ClientData m_clientData; + Tcl_HashEntry *m_pNameEntry; // number of Tcl_Obj instances that are handles to this object long m_handleCount; @@ -94,16 +94,16 @@ public: Tcl_Obj *newObj(Tcl_Interp *interp, InternalRep *pRep); }; -// Maps handle name to internal representation. There's an instance of this -// class associated with each Tcl interpreter that loads the extension. +// Maps string representation of handle to internal representation. There's an +// instance of this class associated with each Tcl interpreter that loads the +// extension. class TCOM_API HandleNameToRepMap { Tcl_Interp *m_interp; // handle string representation to internal representation map - typedef StringHashTable Map; - Map m_map; + Tcl_HashTable m_handleMap; static void deleteInterpProc(ClientData clientData, Tcl_Interp *interp); static void exitProc(ClientData clientData); @@ -117,19 +117,13 @@ public: static HandleNameToRepMap *instance(Tcl_Interp *interp); // Insert handle to object mapping. - void insert (const char *handleStr, InternalRep *pRep) - { m_map.insert(handleStr, pRep); } + Tcl_HashEntry *insert(const char *handleStr, InternalRep *pRep); // Get the object represented by the handle. - InternalRep *find (Tcl_Obj *pHandle) const - { return m_map.find(Tcl_GetStringFromObj(pHandle, 0)); } + InternalRep *find(Tcl_Obj *pHandle) const; // Remove handle to object mapping. - void erase (const char *handleStr) - { m_map.erase(handleStr); } - - // Clean all handles. - void clear(); + static void erase(Tcl_HashEntry *pNameEntry); }; // This class provides functions to map handles to objects of a specific @@ -150,10 +144,6 @@ public: // ownership of the application object and is responsible for deleting it. Tcl_Obj *newObj(Tcl_Interp *interp, AppType *pAppObject); - // Get count of matching elements. - size_t count (Tcl_Interp *interp, Tcl_Obj *pHandle) const - { return HandleNameToRepMap::instance(interp)->count(pHandle); } - // Get the application object represented by the handle. If the handle // is invalid, return 0. AppType *find(Tcl_Interp *interp, Tcl_Obj *pHandle) const; diff --git a/src/HashTable.h b/src/HashTable.h index 8b1d3d3..120b029 100644 --- a/src/HashTable.h +++ b/src/HashTable.h @@ -1,4 +1,4 @@ -// $Id: HashTable.h,v 1.21 2002/04/13 03:53:56 cthuang Exp $ +// $Id: HashTable.h,v 1.22 2003/07/17 22:33:31 cthuang Exp $ #ifndef HASHTABLE_H #define HASHTABLE_H @@ -118,6 +118,7 @@ HashTable::erase (const K &key) } } +#if 0 // This class wraps a Tcl hash table that uses null-terminated strings as keys. // The mapped type is assumed to be a pointer type. @@ -172,5 +173,6 @@ StringHashTable::erase (const char *key) Tcl_DeleteHashEntry(pEntry); } } +#endif #endif diff --git a/src/Makefile b/src/Makefile index 9ce33e0..9c9c309 100644 --- a/src/Makefile +++ b/src/Makefile @@ -1,21 +1,27 @@ -# $Id: Makefile,v 1.10 2002/05/31 04:03:06 cthuang Exp $ +# $Id: Makefile,v 1.12 2003/07/24 22:46:35 cthuang Exp $ debug: tclsh &&| set libDir [file join [info library] "../tcom"] +file copy -force ../lib/tcom/pkgIndex.tcl $libDir +file copy -force ../lib/tcom/tcom.tcl $libDir file copy -force Debug/tcom.dll $libDir file copy -force dllserver_Debug/tcominproc.dll $libDir file copy -force exeserver_Debug/tcomlocal.exe $libDir set libDir [file join [info library] "../TclScript"] file copy -force TclScript_Debug/TclScript.dll $libDir +file copy -force TclScript_Debug/TclScript.tlb $libDir | release: tclsh &&| set libDir [file join [info library] "../tcom"] +file copy -force ../lib/tcom/pkgIndex.tcl $libDir +file copy -force ../lib/tcom/tcom.tcl $libDir file copy -force Release/tcom.dll $libDir file copy -force dllserver_Release/tcominproc.dll $libDir file copy -force exeserver_Release/tcomlocal.exe $libDir set libDir [file join [info library] "../TclScript"] file copy -force TclScript_Release/TclScript.dll $libDir +file copy -force TclScript_Release/TclScript.tlb $libDir | diff --git a/src/Reference.cpp b/src/Reference.cpp index 49e9a79..9a7f448 100644 --- a/src/Reference.cpp +++ b/src/Reference.cpp @@ -1,4 +1,4 @@ -// $Id: Reference.cpp,v 1.69 2002/06/28 00:53:46 cthuang Exp $ +// $Id: Reference.cpp,v 1.73 2003/11/06 15:29:01 cthuang Exp $ #pragma warning(disable: 4786) #include #include "ComObject.h" @@ -35,7 +35,8 @@ Reference::Connection::Connection (Tcl_Interp *interp, eventInterfaceDesc, interp, servant, - ""); + "", + true); // Connect to connection point. hr = m_pConnectionPoint->Advise(pComObject->unknown(), &m_adviseCookie); @@ -159,6 +160,21 @@ Reference::operator== (const Reference &rhs) const return result; } +static void +throwDispatchException (EXCEPINFO &excepInfo) +{ + // Clean up exception information strings. + _bstr_t source(excepInfo.bstrSource, false); + _bstr_t description(excepInfo.bstrDescription, false); + _bstr_t helpFile(excepInfo.bstrHelpFile, false); + + HRESULT hr = excepInfo.scode; + if (hr == 0) { + hr = _com_error::WCodeToHRESULT(excepInfo.wCode); + } + throw DispatchException(hr, description); +} + HRESULT Reference::invokeDispatch ( MEMBERID memberid, @@ -214,16 +230,7 @@ Reference::invokeDispatch ( &argErr); if (hr == DISP_E_EXCEPTION) { - // Clean up exception information strings. - _bstr_t source(excepInfo.bstrSource, false); - _bstr_t description(excepInfo.bstrDescription, false); - _bstr_t helpFile(excepInfo.bstrHelpFile, false); - - hr = excepInfo.scode; - if (hr == 0) { - hr = _com_error::WCodeToHRESULT(excepInfo.wCode); - } - throw DispatchException(hr, description); + throwDispatchException(excepInfo); } return hr; @@ -254,6 +261,10 @@ Reference::invoke (MEMBERID memberid, if (SUCCEEDED(hr)) { return hr; } + + if (hr == DISP_E_EXCEPTION) { + throwDispatchException(excepInfo); + } } return invokeDispatch(memberid, dispatchFlags, arguments, pResult); @@ -518,11 +529,11 @@ Reference::getActiveObject (const char *progId) } Reference * -Reference::getObject (const char *displayName) +Reference::getObject (const wchar_t *displayName) { IUnknown *pUnknown; HRESULT hr = CoGetObject( - _bstr_t(displayName), + displayName, NULL, IID_IUnknown, reinterpret_cast(&pUnknown)); diff --git a/src/Reference.h b/src/Reference.h index 5c423d5..fc46931 100644 --- a/src/Reference.h +++ b/src/Reference.h @@ -1,4 +1,4 @@ -// $Id: Reference.h,v 1.41 2002/06/12 02:14:08 cthuang Exp $ +// $Id: Reference.h,v 1.42 2003/11/06 15:29:01 cthuang Exp $ #ifndef REFERENCE_H #define REFERENCE_H @@ -132,7 +132,7 @@ public: static Reference *getActiveObject(const char *progId); // Get an object using CoGetObject and construct a reference. - static Reference *getObject(const char *displayName); + static Reference *getObject(const wchar_t *displayName); // Get raw interface pointer. IUnknown *unknown () const diff --git a/src/TclObject.cpp b/src/TclObject.cpp index dc164f7..8c24d8a 100644 --- a/src/TclObject.cpp +++ b/src/TclObject.cpp @@ -1,5 +1,6 @@ -// $Id: TclObject.cpp,v 1.29 2002/05/31 04:03:06 cthuang Exp $ +// $Id: TclObject.cpp,v 1.35 2003/05/12 23:30:43 cthuang Exp $ #include "TclObject.h" +#include #ifdef WIN32 #include "Extension.h" #include "Reference.h" @@ -152,112 +153,161 @@ TclObject::lappend (Tcl_Obj *pElement) } #ifdef WIN32 +// Convert SAFEARRAY to a Tcl value. -TclObject::TclObject (VARIANT *pSrc, const Type &type, Tcl_Interp *interp) +static Tcl_Obj * +convertFromSafeArray ( + SAFEARRAY *psa, + VARTYPE vt, + unsigned dim, + long *pIndices, + const Type &type, + Tcl_Interp *interp) { HRESULT hr; - if (V_VT(pSrc) & VT_ARRAY) { - // We can handle only one-dimensional arrays. - SAFEARRAY *psa = V_ARRAY(pSrc); - if (SafeArrayGetDim(psa) != 1) { - _com_issue_error(E_INVALIDARG); + // Get index range. + long lowerBound; + hr = SafeArrayGetLBound(psa, dim, &lowerBound); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + long upperBound; + hr = SafeArrayGetUBound(psa, dim, &upperBound); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + Tcl_Obj *pResult; + if (dim < SafeArrayGetDim(psa)) { + // Create list of list for multi-dimensional array. + pResult = Tcl_NewListObj(0, 0); + for (long i = lowerBound; i <= upperBound; ++i) { + pIndices[dim - 1] = i; + Tcl_Obj *pElement = + convertFromSafeArray(psa, vt, dim + 1, pIndices, type, interp); + Tcl_ListObjAppendElement(interp, pResult, pElement); } + return pResult; + } - // Get index range. - long lowerBound; - hr = SafeArrayGetLBound(psa, 1, &lowerBound); + if (vt == VT_UI1 && SafeArrayGetDim(psa) == 1) { + unsigned char *pData; + hr = SafeArrayAccessData(psa, reinterpret_cast(&pData)); if (FAILED(hr)) { _com_issue_error(hr); } - long upperBound; - hr = SafeArrayGetUBound(psa, 1, &upperBound); + long length = upperBound - lowerBound + 1; + pResult = +#if TCL_MINOR_VERSION >= 1 + // Convert array of bytes to Tcl byte array. + Tcl_NewByteArrayObj(pData, length); +#else + // Convert array of bytes to Tcl string. + Tcl_NewStringObj(reinterpret_cast(pData), length); +#endif + + hr = SafeArrayUnaccessData(psa); if (FAILED(hr)) { _com_issue_error(hr); } - // Get element type. - VARTYPE vt = V_VT(pSrc) & VT_TYPEMASK; + } else { + // Create list of Tcl values. + pResult = Tcl_NewListObj(0, 0); + for (long i = lowerBound; i <= upperBound; ++i) { + _variant_t elementVar; + + pIndices[dim - 1] = i; + if (vt == VT_VARIANT) { + hr = SafeArrayGetElement(psa, pIndices, &elementVar); + } else { + // I hope the element can be contained in a VARIANT. + V_VT(&elementVar) = vt; + hr = SafeArrayGetElement(psa, pIndices, &elementVar.punkVal); + } + if (FAILED(hr)) { + _com_issue_error(hr); + } - switch (vt) { - case VT_UNKNOWN: - case VT_DISPATCH: - // Convert array of IUnknown to Tcl list of interface pointer - // handles. - { - IUnknown **pData; - hr = SafeArrayAccessData( - psa, reinterpret_cast(&pData)); - if (FAILED(hr)) { - _com_issue_error(hr); - } + TclObject element(&elementVar, type, interp); + Tcl_ListObjAppendElement(interp, pResult, element); + } + } - m_pObj = Tcl_NewListObj(0, 0); - for (long i = lowerBound; i <= upperBound; ++i) { - Tcl_Obj *pElement = - Extension::referenceHandles.newObj( - interp, Reference::newReference(pData[i])); - Tcl_ListObjAppendElement(interp, m_pObj, pElement); - } + return pResult; +} - hr = SafeArrayUnaccessData(psa); - if (FAILED(hr)) { - _com_issue_error(hr); - } - } - break; +// Fill SAFEARRAY from Tcl list. - case VT_UI1: - { - unsigned char *pData; - hr = SafeArrayAccessData( - psa, reinterpret_cast(&pData)); - if (FAILED(hr)) { - _com_issue_error(hr); - } +static void +fillSafeArray ( + Tcl_Obj *pList, + SAFEARRAY *psa, + unsigned dim, + long *pIndices, + Tcl_Interp *interp, + bool addRef) +{ + HRESULT hr; - long length = upperBound - lowerBound + 1; - m_pObj = -#if TCL_MINOR_VERSION >= 1 - // Convert array of bytes to Tcl byte array. - Tcl_NewByteArrayObj(pData, length); -#else - // Convert array of bytes to Tcl string. - Tcl_NewStringObj(reinterpret_cast(pData), length); -#endif + // Get index range. + long lowerBound; + hr = SafeArrayGetLBound(psa, dim, &lowerBound); + if (FAILED(hr)) { + _com_issue_error(hr); + } - hr = SafeArrayUnaccessData(psa); - if (FAILED(hr)) { - _com_issue_error(hr); - } - } - break; + long upperBound; + hr = SafeArrayGetUBound(psa, dim, &upperBound); + if (FAILED(hr)) { + _com_issue_error(hr); + } - default: - // Convert array of other types to Tcl list of objects. - { - m_pObj = Tcl_NewListObj(0, 0); - for (long i = lowerBound; i <= upperBound; ++i) { - _variant_t elementVar; - - if (vt == VT_VARIANT) { - hr = SafeArrayGetElement(psa, &i, &elementVar); - } else { - // I hope the element can be contained in a VARIANT. - V_VT(&elementVar) = vt; - hr = SafeArrayGetElement( - psa, &i, &elementVar.punkVal); - } - if (FAILED(hr)) { - _com_issue_error(hr); - } + int numElements; + Tcl_Obj **pElements; + if (Tcl_ListObjGetElements(interp, pList, &numElements, &pElements) + != TCL_OK) { + _com_issue_error(E_INVALIDARG); + } - TclObject element(&elementVar, type, interp); - Tcl_ListObjAppendElement(interp, m_pObj, element); - } + unsigned dim1 = dim - 1; + if (dim < SafeArrayGetDim(psa)) { + // Create list of list for multi-dimensional array. + for (int i = 0; i < numElements; ++i) { + pIndices[dim1] = i; + fillSafeArray(pElements[i], psa, dim + 1, pIndices, interp, addRef); + } + + } else { + for (int i = 0; i < numElements; ++i) { + TclObject element(pElements[i]); + _variant_t elementVar; + element.toVariant(&elementVar, Type::variant(), interp, addRef); + + pIndices[dim1] = i; + hr = SafeArrayPutElement(psa, pIndices, &elementVar); + if (FAILED(hr)) { + _com_issue_error(hr); } } + } +} + +TclObject::TclObject (VARIANT *pSrc, const Type &type, Tcl_Interp *interp) +{ + if (V_VT(pSrc) & VT_ARRAY) { + SAFEARRAY *psa = V_ARRAY(pSrc); + VARTYPE vt = V_VT(pSrc) & VT_TYPEMASK; + unsigned numDimensions = SafeArrayGetDim(psa); + std::vector indices(numDimensions); + m_pObj = convertFromSafeArray( + psa, vt, 1, &indices[0], type, interp); + + } else if (vtMissing == pSrc) { + m_pObj = Extension::newNaObj(); } else { switch (V_VT(pSrc)) { @@ -292,7 +342,9 @@ TclObject::TclObject (VARIANT *pSrc, const Type &type, Tcl_Interp *interp) break; case VT_DISPATCH: - { + if (V_DISPATCH(pSrc) == 0) { + m_pObj = Tcl_NewObj(); + } else { const Interface *pInterface = InterfaceManager::instance().find(type.iid()); m_pObj = Extension::referenceHandles.newObj( @@ -302,7 +354,9 @@ TclObject::TclObject (VARIANT *pSrc, const Type &type, Tcl_Interp *interp) break; case VT_UNKNOWN: - { + if (V_UNKNOWN(pSrc) == 0) { + m_pObj = Tcl_NewObj(); + } else { const Interface *pInterface = InterfaceManager::instance().find(type.iid()); m_pObj = Extension::referenceHandles.newObj( @@ -312,7 +366,7 @@ TclObject::TclObject (VARIANT *pSrc, const Type &type, Tcl_Interp *interp) break; case VT_NULL: - m_pObj = Tcl_NewObj(); + m_pObj = Extension::newNullObj(); break; case VT_LPSTR: @@ -366,6 +420,39 @@ TclObject::getBSTR () const #endif } +#if TCL_MINOR_VERSION >= 1 +// Convert Tcl byte array to SAFEARRAY of bytes. + +static SAFEARRAY * +newByteSafeArray (Tcl_Obj *pObj) +{ + int length; + unsigned char *pSrc = Tcl_GetByteArrayFromObj(pObj, &length); + + SAFEARRAY *psa = SafeArrayCreateVector(VT_UI1, 0, length); + if (psa == 0) { + _com_issue_error(E_OUTOFMEMORY); + } + + unsigned char *pDest; + HRESULT hr; + hr = SafeArrayAccessData( + psa, reinterpret_cast(&pDest)); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + memcpy(pDest, pSrc, length); + + hr = SafeArrayUnaccessData(psa); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + return psa; +} +#endif + void TclObject::toVariant (VARIANT *pDest, const Type &type, @@ -397,7 +484,7 @@ TclObject::toVariant (VARIANT *pDest, // Convert to interface pointer. IUnknown *pUnknown = static_cast( m_pObj->internalRep.otherValuePtr); - if (addRef) { + if (addRef && pUnknown != 0) { // Must increment reference count of interface pointers returned // from methods. pUnknown->AddRef(); @@ -406,66 +493,71 @@ TclObject::toVariant (VARIANT *pDest, V_UNKNOWN(pDest) = pUnknown; } else if (vt == VT_SAFEARRAY) { - // Convert Tcl list to SAFEARRAY. - int numElements; - Tcl_Obj **pElements; - if (Tcl_ListObjGetElements(interp, m_pObj, &numElements, &pElements) - != TCL_OK) { - _com_issue_error(E_INVALIDARG); - } - + SAFEARRAY *psa; const Type &elementType = type.elementType(); - SAFEARRAY *psa = - SafeArrayCreateVector(elementType.vartype(), 0, numElements); - if (psa == 0) { - _com_issue_error(E_OUTOFMEMORY); - } - void *pData; - HRESULT hr; - hr = SafeArrayAccessData(psa, &pData); - if (FAILED(hr)) { - _com_issue_error(hr); - } + if (elementType.vartype() == VT_UI1) { + psa = newByteSafeArray(m_pObj); + } else { + // Convert Tcl list to SAFEARRAY. + int numElements; + Tcl_Obj **pElements; + if (Tcl_ListObjGetElements(interp, m_pObj, &numElements, &pElements) + != TCL_OK) { + _com_issue_error(E_INVALIDARG); + } - for (int i = 0; i < numElements; ++i) { - TclObject value(pElements[i]); - - switch (elementType.vartype()) { - case VT_BOOL: - static_cast(pData)[i] = - value.getBool() ? VARIANT_TRUE : VARIANT_FALSE; - break; - - case VT_R4: - static_cast(pData)[i] = - static_cast(value.getDouble()); - break; - - case VT_R8: - static_cast(pData)[i] = value.getDouble(); - break; - - case VT_BSTR: - static_cast(pData)[i] = value.getBSTR(); - break; - - case VT_VARIANT: - { - VARIANT *pDest = static_cast(pData) + i; - VariantInit(pDest); - value.toVariant(pDest, elementType, interp); - } - break; + psa = SafeArrayCreateVector(elementType.vartype(), 0, numElements); + if (psa == 0) { + _com_issue_error(E_OUTOFMEMORY); + } - default: - static_cast(pData)[i] = value.getLong(); + void *pData; + HRESULT hr; + hr = SafeArrayAccessData(psa, &pData); + if (FAILED(hr)) { + _com_issue_error(hr); } - } - hr = SafeArrayUnaccessData(psa); - if (FAILED(hr)) { - _com_issue_error(hr); + for (int i = 0; i < numElements; ++i) { + TclObject value(pElements[i]); + + switch (elementType.vartype()) { + case VT_BOOL: + static_cast(pData)[i] = + value.getBool() ? VARIANT_TRUE : VARIANT_FALSE; + break; + + case VT_R4: + static_cast(pData)[i] = + static_cast(value.getDouble()); + break; + + case VT_R8: + static_cast(pData)[i] = value.getDouble(); + break; + + case VT_BSTR: + static_cast(pData)[i] = value.getBSTR(); + break; + + case VT_VARIANT: + { + VARIANT *pDest = static_cast(pData) + i; + VariantInit(pDest); + value.toVariant(pDest, elementType, interp); + } + break; + + default: + static_cast(pData)[i] = value.getLong(); + } + } + + hr = SafeArrayUnaccessData(psa); + if (FAILED(hr)) { + _com_issue_error(hr); + } } V_VT(pDest) = VT_ARRAY | elementType.vartype(); @@ -480,60 +572,41 @@ TclObject::toVariant (VARIANT *pDest, _com_issue_error(E_INVALIDARG); } - SAFEARRAY *psa = SafeArrayCreateVector(VT_VARIANT, 0, numElements); - if (psa == 0) { - _com_issue_error(E_OUTOFMEMORY); - } + SAFEARRAYBOUND bounds[2]; + bounds[0].cElements = numElements; + bounds[0].lLbound = 0; - VARIANT *pData; - HRESULT hr; - hr = SafeArrayAccessData(psa, reinterpret_cast(&pData)); - if (FAILED(hr)) { - _com_issue_error(hr); - } + unsigned numDimensions; - for (int i = 0; i < numElements; ++i) { - TclObject value(pElements[i]); - VariantInit(&pData[i]); - value.toVariant(&pData[i], Type::variant(), interp, addRef); - } + // Check if the first element of the list is a list. + if (numElements > 0 && pElements[0]->typePtr == TclTypes::listType()) { + int colSize; + Tcl_Obj **pCol; + if (Tcl_ListObjGetElements(interp, pElements[0], &colSize, &pCol) + != TCL_OK) { + _com_issue_error(E_INVALIDARG); + } - hr = SafeArrayUnaccessData(psa); - if (FAILED(hr)) { - _com_issue_error(hr); + bounds[1].cElements = colSize; + bounds[1].lLbound = 0; + numDimensions = 2; + } else { + numDimensions = 1; } + SAFEARRAY *psa = SafeArrayCreate(VT_VARIANT, numDimensions, bounds); + std::vector indices(numDimensions); + fillSafeArray(m_pObj, psa, 1, &indices[0], interp, addRef); + V_VT(pDest) = VT_ARRAY | VT_VARIANT; V_ARRAY(pDest) = psa; #if TCL_MINOR_VERSION >= 1 } else if (m_pObj->typePtr == TclTypes::byteArrayType()) { - // Convert Tcl byte array to array of bytes. - int length; - unsigned char *pBytes = Tcl_GetByteArrayFromObj(m_pObj, &length); - - SAFEARRAY *psa = SafeArrayCreateVector(VT_UI1, 0, length); - if (psa == 0) { - _com_issue_error(E_OUTOFMEMORY); - } - - unsigned char *pDestData; - HRESULT hr; - hr = SafeArrayAccessData( - psa, reinterpret_cast(&pDestData)); - if (FAILED(hr)) { - _com_issue_error(hr); - } - - memcpy(pDestData, pBytes, length); - - hr = SafeArrayUnaccessData(psa); - if (FAILED(hr)) { - _com_issue_error(hr); - } + // Convert Tcl byte array to SAFEARRAY of bytes. V_VT(pDest) = VT_ARRAY | VT_UI1; - V_ARRAY(pDest) = psa; + V_ARRAY(pDest) = newByteSafeArray(m_pObj); #endif } else if (m_pObj->typePtr == &Extension::naType) { @@ -543,6 +616,11 @@ TclObject::toVariant (VARIANT *pDest, } else if (m_pObj->typePtr == &Extension::nullType) { V_VT(pDest) = VT_NULL; + } else if (m_pObj->typePtr == &Extension::variantType) { + VariantCopy( + pDest, + static_cast<_variant_t *>(m_pObj->internalRep.otherValuePtr)); + } else if (m_pObj->typePtr == TclTypes::intType()) { long value; if (Tcl_GetLongFromObj(interp, m_pObj, &value) != TCL_OK) { @@ -584,26 +662,19 @@ TclObject::toVariant (VARIANT *pDest, V_BOOL(pDest) = getBool() ? VARIANT_TRUE : VARIANT_FALSE; } else { -#if TCL_MINOR_VERSION >= 2 - // Uses Unicode function introduced in Tcl 8.2. - const wchar_t *pStringRep = - reinterpret_cast(Tcl_GetUnicode(m_pObj)); -#else - const char *pStringRep = Tcl_GetStringFromObj(m_pObj, 0); -#endif - _variant_t var(pStringRep); + V_VT(pDest) = VT_BSTR; + V_BSTR(pDest) = getBSTR(); // If trying to convert from a string to a date, // we need to convert to a double (VT_R8) first. if (vt == VT_DATE) { - var.ChangeType(VT_R8); + VariantChangeType(pDest, pDest, 0, VT_R8); } // Try to convert from a string representation. if (vt != VT_VARIANT && vt != VT_USERDEFINED && vt != VT_LPWSTR) { - var.ChangeType(vt); + VariantChangeType(pDest, pDest, 0, vt); } - VariantCopy(pDest, &var); } } diff --git a/src/TclScript.cpp b/src/TclScript.cpp index 71954c6..df52143 100644 --- a/src/TclScript.cpp +++ b/src/TclScript.cpp @@ -1,4 +1,4 @@ -// $Id: TclScript.cpp,v 1.10 2002/07/14 18:42:57 cthuang Exp $ +// $Id: TclScript.cpp,v 1.12 2003/04/02 22:46:51 cthuang Exp $ #include "ActiveScriptError.h" #include "Reference.h" #include "TypeInfo.h" @@ -9,29 +9,6 @@ #define ENGINE_PACKAGE_NAME "TclScript" #define ENGINE_PACKAGE_VERSION "1.0" -static int -outputdebugCmd ( - ClientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *CONST objv[]) -{ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "message"); - return TCL_ERROR; - } - - Tcl_Obj *pMessage = objv[1]; - if (Tcl_IsShared(pMessage)) { - pMessage = Tcl_DuplicateObj(pMessage); - } - Tcl_IncrRefCount(pMessage); - Tcl_AppendToObj(pMessage, "\n", 1); - OutputDebugString(Tcl_GetStringFromObj(pMessage, 0)); - Tcl_DecrRefCount(pMessage); - return TCL_OK; -} - static int getnameditemCmd ( ClientData, @@ -206,8 +183,6 @@ Tclscript_Init (Tcl_Interp *interp) } #endif - Tcl_CreateObjCommand( - interp, NAMESPACE "outputdebug", outputdebugCmd, 0, 0); Tcl_CreateObjCommand( interp, NAMESPACE "getnameditem", getnameditemCmd, 0, 0); Tcl_CreateObjCommand( diff --git a/src/TclScript.dsp b/src/TclScript.dsp index 12f542d..ec02430 100644 --- a/src/TclScript.dsp +++ b/src/TclScript.dsp @@ -43,7 +43,7 @@ RSC=rc.exe # PROP Ignore_Export_Lib 0 # PROP Target_Dir "" # ADD BASE CPP /nologo /MT /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "DLLSERVER_EXPORTS" /YX /FD /c -# ADD CPP /nologo /MD /W3 /GX /Zi /Od /I "\tcl\include" /D "NDEBUG" /D "WIN32" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "DLLSERVER_EXPORTS" /D "TCL_THREADS" /D "USE_TCL_STUBS" /D "USE_NON_CONST" /YX /FD /c +# ADD CPP /nologo /MD /W3 /GX /Zi /Od /I "\tcl\include" /D "NDEBUG" /D "WIN32" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "TCL_THREADS" /D "USE_TCL_STUBS" /D "USE_NON_CONST" /YX /FD /c # ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32 # ADD MTL /nologo /D "NDEBUG" /win32 # SUBTRACT MTL /mktyplib203 @@ -70,7 +70,7 @@ LINK32=link.exe # PROP Ignore_Export_Lib 0 # PROP Target_Dir "" # ADD BASE CPP /nologo /MTd /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "DLLSERVER_EXPORTS" /YX /FD /GZ /c -# ADD CPP /nologo /MDd /W3 /Gm /GX /Zi /Od /I "\tcl\include" /D "_DEBUG" /D "WIN32" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "DLLSERVER_EXPORTS" /D "TCL_THREADS" /D "USE_TCL_STUBS" /D "USE_NON_CONST" /YX /FD /GZ /c +# ADD CPP /nologo /MDd /W3 /Gm /GX /Zi /Od /I "\tcl\include" /D "_DEBUG" /D "WIN32" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "TCL_THREADS" /D "USE_TCL_STUBS" /D "USE_NON_CONST" /YX /FD /GZ /c # ADD BASE MTL /nologo /D "_DEBUG" /mktyplib203 /win32 # ADD MTL /nologo /D "_DEBUG" /win32 # SUBTRACT MTL /mktyplib203 diff --git a/src/TclScript.idl b/src/TclScript.idl index 1dbdf31..2ea365a 100644 --- a/src/TclScript.idl +++ b/src/TclScript.idl @@ -24,4 +24,13 @@ library TclScript interface IActiveScriptParse; interface IObjectSafety; }; + + [ + uuid(0A0059C5-E0B0-11D2-942A-00C04F7040AE), + helpstring("Dispatch Class") + ] + coclass Dispatch + { + [default] interface IDispatch; + }; }; diff --git a/src/bindCmd.cpp b/src/bindCmd.cpp index a336015..7b0c253 100644 --- a/src/bindCmd.cpp +++ b/src/bindCmd.cpp @@ -1,4 +1,4 @@ -// $Id: bindCmd.cpp,v 1.52 2002/04/13 03:53:56 cthuang Exp $ +// $Id: bindCmd.cpp,v 1.53 2003/04/02 22:46:51 cthuang Exp $ #pragma warning(disable: 4786) #include "Extension.h" #include "Reference.h" @@ -175,7 +175,7 @@ Extension::bindCmd ( Tcl_Obj *CONST objv[]) { if (objc < 3 || objc > 4) { - Tcl_WrongNumArgs(interp, 1, objv, "object sinkCommand ?eventIID?"); + Tcl_WrongNumArgs(interp, 1, objv, "handle sinkCommand ?eventIID?"); return TCL_ERROR; } @@ -187,6 +187,19 @@ Extension::bindCmd ( return TCL_ERROR; } + int servantLength; + Tcl_GetStringFromObj(objv[2], &servantLength); + if (servantLength == 0) { + try { + // Tear down all event connections to the object. + pReference->unadvise(); + } + catch (_com_error &e) { + return setComErrorResult(interp, e, __FILE__, __LINE__); + } + return TCL_OK; + } + TclObject servant(objv[2]); char *eventIIDStr = (objc < 4) ? 0 : Tcl_GetStringFromObj(objv[3], 0); @@ -205,34 +218,3 @@ Extension::bindCmd ( } return TCL_OK; } - -// This Tcl command tears down all event connections to the object. - -int -Extension::unbindCmd ( - ClientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *CONST objv[]) -{ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "object"); - return TCL_ERROR; - } - - Reference *pReference = referenceHandles.find(interp, objv[1]); - if (pReference == 0) { - const char *arg = Tcl_GetStringFromObj(objv[1], 0); - Tcl_AppendResult( - interp, "invalid interface pointer handle ", arg, NULL); - return TCL_ERROR; - } - - try { - pReference->unadvise(); - } - catch (_com_error &e) { - return setComErrorResult(interp, e, __FILE__, __LINE__); - } - return TCL_OK; -} diff --git a/src/buildNumber.h b/src/buildNumber.h index dd59692..7fe11cc 100644 --- a/src/buildNumber.h +++ b/src/buildNumber.h @@ -1 +1 @@ -#define BUILD_NUMBER 13 +#define BUILD_NUMBER 28 diff --git a/src/comsupp.cpp b/src/comsupp.cpp deleted file mode 100644 index a4128f5..0000000 --- a/src/comsupp.cpp +++ /dev/null @@ -1,60 +0,0 @@ -// $Id: comsupp.cpp,v 1.2 2001/07/12 04:09:58 cthuang Exp $ -// -// These functions are defined in comsupp.lib but Borland C++ does not include -// that library in its distribution, so we implement them here when compiling -// with Borland C++. -#include -#include -#include -#include - -// This value represents a missing optional parameter. -_variant_t vtMissing(DISP_E_PARAMNOTFOUND, VT_ERROR); - -// COM error handling routine - -void __stdcall -_com_issue_error (HRESULT hr) throw(_com_error) -{ - throw _com_error(hr); -} - -namespace _com_util { - -// Convert char * to BSTR - -BSTR __stdcall -ConvertStringToBSTR (const char* pSrc) throw(_com_error) -{ - if (pSrc == 0) { - return SysAllocString(0); - } - - // Guess the number of wide characters needed. - size_t destLen = strlen(pSrc) + 1; - wchar_t *pDest = new wchar_t[destLen]; - mbstowcs(pDest, pSrc, destLen); - BSTR result = SysAllocString(pDest); - delete[] pDest; - return result; -} - -// Convert BSTR to char * - -char* __stdcall -ConvertBSTRToString (BSTR pSrc) throw(_com_error) -{ - if (pSrc == 0) { - char *pDest = new char[1]; - *pDest = '\0'; - return pDest; - } - - // Guess the number of bytes needed. - size_t destLen = wcslen(pSrc) * 3 + 1; - char *pDest = new char[destLen]; - wcstombs(pDest, pSrc, destLen); - return pDest; -} - -} //namespace diff --git a/src/naCmd.cpp b/src/naCmd.cpp index 2b6f4d1..8cc47b0 100644 --- a/src/naCmd.cpp +++ b/src/naCmd.cpp @@ -1,4 +1,4 @@ -// $Id: naCmd.cpp,v 1.6 2002/04/27 18:15:24 cthuang Exp $ +// $Id: naCmd.cpp,v 1.7 2003/03/07 00:17:30 cthuang Exp $ #include "Extension.h" #include @@ -34,7 +34,7 @@ Tcl_ObjType Extension::naType = { naSetFromAny }; -// Create an NA object. +// Create a Tcl value representing a missing optional argument. Tcl_Obj * Extension::newNaObj () @@ -45,7 +45,7 @@ Extension::newNaObj () return pObj; } -// This Tcl command returns an object used to represent a missing optional +// This Tcl command returns a Tcl value representing a missing optional // argument. int diff --git a/src/nullCmd.cpp b/src/nullCmd.cpp index 91fc3aa..28e669e 100644 --- a/src/nullCmd.cpp +++ b/src/nullCmd.cpp @@ -1,4 +1,4 @@ -// $Id: nullCmd.cpp,v 1.9 2002/04/27 18:15:24 cthuang Exp $ +// $Id: nullCmd.cpp,v 1.10 2003/03/07 00:17:30 cthuang Exp $ #include "Extension.h" #include @@ -34,8 +34,19 @@ Tcl_ObjType Extension::nullType = { nullSetFromAny }; -// This Tcl command returns a null object which be used to pass a null pointer -// argument. +// Create a Tcl value representing a null value in SQL operations. + +Tcl_Obj * +Extension::newNullObj () +{ + Tcl_Obj *pObj = Tcl_NewObj(); + Tcl_InvalidateStringRep(pObj); + pObj->typePtr = &nullType; + return pObj; +} + +// This Tcl command returns a Tcl value representing a null value in SQL +// operations. int Extension::nullCmd ( @@ -49,10 +60,6 @@ Extension::nullCmd ( return TCL_ERROR; } - Tcl_Obj *pObj = Tcl_NewObj(); - Tcl_InvalidateStringRep(pObj); - pObj->typePtr = &nullType; - - Tcl_SetObjResult(interp, pObj); + Tcl_SetObjResult(interp, newNullObj()); return TCL_OK; } diff --git a/src/objectCmd.cpp b/src/objectCmd.cpp index 9f2c010..5dc9560 100644 --- a/src/objectCmd.cpp +++ b/src/objectCmd.cpp @@ -1,4 +1,4 @@ -// $Id: objectCmd.cpp,v 1.30 2002/04/27 18:15:24 cthuang Exp $ +// $Id: objectCmd.cpp,v 1.31 2003/03/07 00:24:04 cthuang Exp $ #pragma warning(disable: 4786) #include "Extension.h" #include @@ -140,6 +140,16 @@ findInterface (Tcl_Interp *interp, Tcl_Obj *pName) return pInterface; } +static Tcl_Obj * +newUnknownPointer (IUnknown *pUnknown) +{ + Tcl_Obj *pObj = Tcl_NewObj(); + Tcl_InvalidateStringRep(pObj); + pObj->typePtr = &Extension::unknownPointerType; + pObj->internalRep.otherValuePtr = pUnknown; + return pObj; +} + // This Tcl command creates a COM object. static int @@ -234,12 +244,7 @@ objectCreateCmd ( destructor); } - Tcl_Obj *pObj = Tcl_NewObj(); - Tcl_InvalidateStringRep(pObj); - pObj->typePtr = &Extension::unknownPointerType; - pObj->internalRep.otherValuePtr = pComObject->unknown(); - - Tcl_SetObjResult(interp, pObj); + Tcl_SetObjResult(interp, newUnknownPointer(pComObject->unknown())); } catch (_com_error &e) { return Extension::setComErrorResult(interp, e, __FILE__, __LINE__); @@ -247,6 +252,27 @@ objectCreateCmd ( return TCL_OK; } +// This Tcl command creates a null IUnknown pointer. + +static int +objectNullCmd ( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs( + interp, + 2, + objv, + NULL); + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, newUnknownPointer(0)); + return TCL_OK; +} + // This Tcl command provides operations for creating COM objects. int @@ -266,10 +292,10 @@ Extension::objectCmd ( pExtension->initializeCom(); static char *options[] = { - "create", "registerfactory", NULL + "create", "null", "registerfactory", NULL }; enum SubCommandEnum { - CREATE, REGISTER_FACTORY + CREATE, OBJECT_NULL, REGISTER_FACTORY }; int index; @@ -281,6 +307,8 @@ Extension::objectCmd ( switch (index) { case CREATE: return objectCreateCmd(interp, objc, objv); + case OBJECT_NULL: + return objectNullCmd(interp, objc, objv); case REGISTER_FACTORY: return objectRegisterFactoryCmd(interp, objc, objv); } diff --git a/src/refCmd.cpp b/src/refCmd.cpp index 6b4e641..eac808d 100644 --- a/src/refCmd.cpp +++ b/src/refCmd.cpp @@ -1,4 +1,4 @@ -// $Id: refCmd.cpp,v 1.43 2002/06/12 02:14:08 cthuang Exp $ +// $Id: refCmd.cpp,v 1.46 2003/11/06 15:29:01 cthuang Exp $ #pragma warning(disable: 4786) #include "Extension.h" #include @@ -17,9 +17,10 @@ static bool getErrorInfo (Reference *pReference, IErrorInfo **ppErrorInfo) { const Interface *pInterface = pReference->interfaceDesc(); - if (pInterface == 0) { - return false; - } + + // The .NET Framework uses GUID_NULL to identify the interface which + // raised the error. + const IID &iid = (pInterface == 0) ? GUID_NULL : pInterface->iid(); ISupportErrorInfoPtr pSupportErrorInfo; HRESULT hr = pReference->unknown()->QueryInterface( @@ -28,8 +29,7 @@ getErrorInfo (Reference *pReference, IErrorInfo **ppErrorInfo) return false; } - if (pSupportErrorInfo->InterfaceSupportsErrorInfo(pInterface->iid()) - != S_OK) { + if (pSupportErrorInfo->InterfaceSupportsErrorInfo(iid) != S_OK) { return false; } @@ -90,18 +90,17 @@ Extension::setComErrorResult ( #if TCL_MINOR_VERSION >= 2 // Uses Unicode functions introduced in Tcl 8.2. - wchar_t *pMessage = 0; - FormatMessageW( + wchar_t *pMessage; + DWORD nLen = FormatMessageW( FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM, NULL, e.Error(), - MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), + 0, reinterpret_cast(&pMessage), 0, NULL); - if (pMessage != 0) { - int nLen = wcslen(pMessage); + if (nLen > 0) { if (nLen > 1 && pMessage[nLen - 1] == '\n') { --nLen; if (nLen > 1 && pMessage[nLen - 1] == '\r') { @@ -477,7 +476,11 @@ getObjectCmd ( return TCL_ERROR; } - char *monikerName = Tcl_GetStringFromObj(objv[2], 0); +#if TCL_MINOR_VERSION >= 2 + const wchar_t *monikerName = Tcl_GetUnicode(objv[2]); +#else + _bstr_t monikerName(Tcl_GetStringFromObj(objv[2], 0)); +#endif try { Reference *pReference = Reference::getObject(monikerName); diff --git a/src/tcom.dsp b/src/tcom.dsp index 1672759..b05665d 100644 --- a/src/tcom.dsp +++ b/src/tcom.dsp @@ -260,6 +260,10 @@ SOURCE=.\typelibCmd.cpp SOURCE=.\Uuid.cpp # End Source File +# Begin Source File + +SOURCE=.\variantCmd.cpp +# End Source File # End Group # Begin Group "Header Files" diff --git a/src/variantCmd.cpp b/src/variantCmd.cpp new file mode 100644 index 0000000..51e5214 --- /dev/null +++ b/src/variantCmd.cpp @@ -0,0 +1,151 @@ +// $Id: variantCmd.cpp,v 1.1 2003/05/29 03:33:08 cthuang Exp $ +#include "Extension.h" +#include + +static void +variantFreeInternalRep (Tcl_Obj *pObj) +{ + delete static_cast<_variant_t *>(pObj->internalRep.otherValuePtr); +} + +static void +variantDuplicateInternalRep (Tcl_Obj *pSrc, Tcl_Obj *pDup) +{ + pDup->typePtr = &Extension::variantType; + pDup->internalRep.otherValuePtr = new _variant_t( + static_cast<_variant_t *>(pSrc->internalRep.otherValuePtr)); +} + +static void +variantUpdateString (Tcl_Obj *pObj) +{ + try { + _bstr_t bstr( + static_cast<_variant_t *>(pObj->internalRep.otherValuePtr)); + const char *stringRep = bstr; + pObj->length = strlen(stringRep); + pObj->bytes = Tcl_Alloc(pObj->length + 1); + strcpy(pObj->bytes, stringRep); + } + catch (_com_error &) { + pObj->length = 0; + pObj->bytes = Tcl_Alloc(1); + pObj->bytes[0] = '\0'; + } +} + +static int +variantSetFromAny (Tcl_Interp *interp, Tcl_Obj *pObj) +{ + const char *stringRep = Tcl_GetStringFromObj(pObj, 0); + + Tcl_ObjType *pOldType = pObj->typePtr; + if (pOldType != NULL && pOldType->freeIntRepProc != NULL) { + pOldType->freeIntRepProc(pObj); + } + + pObj->typePtr = &Extension::variantType; + pObj->internalRep.otherValuePtr = new _variant_t(stringRep); + return TCL_OK; +} + +Tcl_ObjType Extension::variantType = { + PACKAGE_NAMESPACE "VARIANT", + variantFreeInternalRep, + variantDuplicateInternalRep, + variantUpdateString, + variantSetFromAny +}; + +// Create a Tcl value representing a VARIANT. + +Tcl_Obj * +Extension::newVariantObj (_variant_t *pVar) +{ + Tcl_Obj *pObj = Tcl_NewObj(); + Tcl_InvalidateStringRep(pObj); + pObj->typePtr = &variantType; + pObj->internalRep.otherValuePtr = pVar; + return pObj; +} + +// This Tcl command returns a Tcl value representing a VARIANT. + +int +Extension::variantCmd ( + ClientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "type ?value?"); + return TCL_ERROR; + } + + static char *types[] = { + "empty", + "null", + "i2", + "i4", + "r4", + "r8", + "cy", + "date", + "bstr", + "dispatch", + "error", + "bool", + "variant", + "unknown", + "decimal", + "record", + "i1", + "ui1", + "ui2", + "ui4", + "i8", // VT_I8 and VT_UI8 actually are not valid VARIANT types. + "ui8", + "int", + "uint", + NULL + }; + + int vt; + if (Tcl_GetIndexFromObj(NULL, objv[1], types, "type", 0, &vt) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[1], &vt) != TCL_OK) { + return TCL_ERROR; + } + } + + _variant_t *pVar = new _variant_t; + switch (vt) { + case VT_DISPATCH: + V_VT(pVar) = vt; + V_DISPATCH(pVar) = 0; + break; + + case VT_UNKNOWN: + V_VT(pVar) = vt; + V_UNKNOWN(pVar) = 0; + break; + } + + try { + if (objc == 3) { + *pVar = Tcl_GetStringFromObj(objv[2], 0); + } + + if (vt == VT_DATE) { + pVar->ChangeType(VT_R8); + } + + pVar->ChangeType(vt); + } + catch (_com_error &e) { + return setComErrorResult(interp, e, __FILE__, __LINE__); + } + + Tcl_SetObjResult(interp, newVariantObj(pVar)); + return TCL_OK; +} diff --git a/src/version.h b/src/version.h index 090cd68..5e98760 100644 --- a/src/version.h +++ b/src/version.h @@ -1,9 +1,9 @@ -// $Id: version.h,v 1.3 2002/04/27 18:15:24 cthuang Exp $ +// $Id: version.h,v 1.4 2002/10/01 21:51:32 cthuang Exp $ #ifndef VERSION_H #define VERSION_H #define PACKAGE_MAJOR_VERSION 3 -#define PACKAGE_MINOR_VERSION 8 +#define PACKAGE_MINOR_VERSION 9 #define MAKE_VERSION_STRING0(MAJOR,MINOR) #MAJOR "." #MINOR #define MAKE_VERSION_STRING(MAJOR,MINOR) MAKE_VERSION_STRING0(MAJOR,MINOR) diff --git a/tests/array.test b/tests/array.test new file mode 100644 index 0000000..8a8f49b --- /dev/null +++ b/tests/array.test @@ -0,0 +1,53 @@ +# $Id: array.test,v 1.1 2003/05/12 23:31:03 cthuang Exp $ +# +# This file contains tests for the passing arrays + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +test array-1.1 {one-dimensional array} { + package require tcom + + set application [::tcom::ref createobject "Excel.Application"] + $application Visible 1 + + set workbooks [$application Workbooks] + set workbook [$workbooks Add] + set worksheets [$workbook Worksheets] + set worksheet [$worksheets Item [expr 1]] + + set range [$worksheet Range "A1" "C1"] + $range Value [list 1 2 3] + set value [$range Value] + + $workbook Saved 1 + $application Quit + + set value +} {{1.0 2.0 3.0}} + +test array-1.2 {two-dimensional array} { + package require tcom + + set application [::tcom::ref createobject "Excel.Application"] + $application Visible 1 + + set workbooks [$application Workbooks] + set workbook [$workbooks Add] + set worksheets [$workbook Worksheets] + set worksheet [$worksheets Item [expr 1]] + + set range [$worksheet Range "A1" "C2"] + $range Value [list [list 1 2 3] [list 4 5 6]] + set value [$range Value] + + $workbook Saved 1 + $application Quit + + set value +} {{1.0 2.0 3.0} {4.0 5.0 6.0}} + +::tcltest::cleanupTests +return diff --git a/tests/eval.test b/tests/eval.test new file mode 100644 index 0000000..e55972b --- /dev/null +++ b/tests/eval.test @@ -0,0 +1,35 @@ +# $Id: eval.test,v 1.2 2003/04/02 22:57:35 cthuang Exp $ +# +# This file contains tests the robustness of handles under eval. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +test eval-1.1 {eval} { + package require tcom + + for {set i 1} {$i <= 9} {incr i} { + proc testEval$i {} { + } + } + + proc testEval {n} { + set application [::tcom::ref createobject "Excel.Application"] + eval $application Visible 0 + + for {set i 1} {$i <= $n} {incr i} { + eval testEval$i + } + + $application Visible 0 + } + + for {set i 1} {$i <= 9} {incr i} { + testEval $i + } +} {} + +::tcltest::cleanupTests +return diff --git a/tests/foreach.test b/tests/foreach.test index 55ea329..f2935bf 100644 --- a/tests/foreach.test +++ b/tests/foreach.test @@ -1,4 +1,4 @@ -# $Id: foreach.test,v 1.1 2002/03/16 04:53:17 cthuang Exp $ +# $Id: foreach.test,v 1.2 2003/03/07 00:01:40 cthuang Exp $ # # This file contains tests for the ::tcom::foreach command. @@ -26,17 +26,17 @@ test foreach-1.1 {::tcom::foreach} { } } - set cellCount 0 + set addresses {} set range [$worksheet Range "A1:C3"] ::tcom::foreach cell $range { - incr cellCount + lappend addresses [$cell Address] } $workbook Saved 1 $application Quit - set cellCount -} {9} + set addresses +} {{$A$1} {$B$1} {$C$1} {$A$2} {$B$2} {$C$2} {$A$3} {$B$3} {$C$3}} ::tcltest::cleanupTests return diff --git a/tests/namedarg.test b/tests/namedarg.test index 6b461d6..21f718f 100644 --- a/tests/namedarg.test +++ b/tests/namedarg.test @@ -1,4 +1,4 @@ -# $Id: namedarg.test,v 1.1 2002/06/21 02:38:50 cthuang Exp $ +# $Id: namedarg.test,v 1.2 2003/04/02 22:57:35 cthuang Exp $ # # This file contains tests invoking methods through IDispatch with named # arguments. @@ -34,7 +34,7 @@ test namedarg-1.1 {named arguments, ChartWizard} { set chart [$charts Add] $chart -namedarg ChartWizard \ Source $sourceRange \ - Gallery [expr -4102] \ + Gallery [expr 5] \ PlotBy [expr 1] \ CategoryLabels [expr 1] \ SeriesLabels [expr 0] \