+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.
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.
<h2>Synopsis</h2>
<span class="command">package require tcom</span>
- <var>?<span class="option">3.8</span>?</var>
+ <var>?<span class="option">3.9</span>?</var>
<br>
<span class="command">::tcom::ref</span>
<span class="command">createobject</span>
</dt>
<dd>
<p>This command specifies a Tcl command that will be executed when
- events are received from an object. The
- <var>command</var> 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 <var>eventIID</var> parameter to specify the IID
- of another event interface.</p>
+ events are received from an object. The <var>command</var>
+ 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 <var>eventIID</var>
+ 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.</p>
</dd>
<?xml version="1.0"?>
-<!-- $Id: tcom.n.xml,v 1.63 2002/04/12 23:44:50 cthuang Exp $ -->
+<!-- $Id: tcom.n.xml,v 1.65 2002/10/22 22:07:55 cthuang Exp $ -->
<!DOCTYPE refentry PUBLIC "-//OASIS//DTD DocBook XML V4.1.2//EN" "docbookx.dtd">
<refentry id="tcom">
<docinfo>
- <date>$Date: 2002/04/12 23:44:50 $</date>
- <releaseinfo>$Revision: 1.63 $</releaseinfo>
+ <date>$Date: 2002/10/22 22:07:55 $</date>
+ <releaseinfo>$Revision: 1.65 $</releaseinfo>
</docinfo>
<refmeta>
<refentrytitle>tcom</refentrytitle>
<refsynopsisdiv>
<cmdsynopsis>
<command>package require tcom</command>
- <arg><option>3.8</option></arg>
+ <arg><option>3.9</option></arg>
<sbr/>
<command>::tcom::ref</command>
<command>createobject</command>
</term>
<listitem>
<para>This command specifies a Tcl command that will be executed when
- events are received from an object. The
- <parameter>command</parameter> 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 <parameter>eventIID</parameter> parameter to specify the IID
- of another event interface.</para>
+ events are received from an object. The <parameter>command</parameter>
+ 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 <parameter>eventIID</parameter>
+ 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.</para>
</listitem>
</varlistentry>
<varlistentry>
-# $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.
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]
-# $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
switch -- $method {
CreateAccount {
set balance 0
- set name ""
return [::tcom::object create ::Banking::Account accountImpl]
}
-# $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::*
class Engine {
# common HRESULT values
+ common S_FALSE 0x00000001
common E_NOTIMPL 0x80004001
common E_FAIL 0x80004005
common SCRIPTITEM_NOCODE 0x400
# true if logging to debug output enabled
- variable logDebugOn_ 1
+ common logDebugOn_ 1
# SCRIPTSTATE
variable scriptState_
variable slave_
# code to execute
- variable code_ {}
+ public variable code_ {}
# list of names of items which have global members
variable globalMemberItems_ {}
}
# 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"
}
}
}
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 \
}
}
- method sink {sourceName eventName} {
+ method sink {sourceName eventName args} {
if {[info exists eventCode_($sourceName,$eventName)]} {
$slave_ eval $eventCode_($sourceName,$eventName)
}
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
}
method disconnectFromSources {} {
foreach {sourceName source} [array get connectedSources_] {
- ::tcom::unbind $source
+ ::tcom::bind $source {}
unset connectedSources_($sourceName)
}
}
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
}
}
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} {
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
set slave_ [interp create -safe]
} else {
set slave_ [interp create]
+ $slave_ eval rename unknown ::TclScriptEngine::oldUnknown
}
$slave_ alias unknown $this resolveUnknownCommand
--- /dev/null
+# $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"
-# $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]]
-# $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} {
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"
if {$inproc} {
set key "HKEY_CLASSES_ROOT\\CLSID\\$clsid\\InprocServer32"
registry set $key "" $dllPath
- registry set $key "ThreadingModel" "Apartment"
}
if {$local} {
-# $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.
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
-# $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.
proc dumpInterface {obj} {
set interface [::tcom::info interface $obj]
+ puts "interface [$interface name]"
set properties [$interface properties]
foreach property $properties {
-// $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"
// 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;
}
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 {
-// $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 <stdexcept>
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<ClientData>(m_interp));
ComModule::instance().lock();
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 *
TclObject servant,
TclObject destructor)
{
- ComObject *pComObject = new ComObject(
- interfaces,
- interp,
- servant,
- destructor);
- return pComObject;
+ return new ComObject(
+ interfaces,
+ interp,
+ servant,
+ destructor,
+ false);
}
int
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)) {
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);
}
if (pAdapter != 0) {
- *ppvObj = pAdapter;
+ *ppvObj = pAdapter;
addRef();
- return S_OK;
+ return S_OK;
}
*ppvObj = 0;
{
InterlockedDecrement(&m_refCount);
if (m_refCount == 0) {
- delete this;
+ delete this;
return 0;
}
return m_refCount;
// 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.
// 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);
{
#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));
va_arg(pArg, BSTR);
break;
+ case VT_VARIANT:
+ va_arg(pArg, VARIANT);
+ break;
+
default:
va_arg(pArg, int);
}
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.
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.
-// $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
// 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
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,
-// $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"
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(
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);
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;
+}
-// $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
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 &);
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);
-// $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 <sstream>
#include "ThreadLocalStorage.h"
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
class ObjToRepMap
{
- Tcl_HashTable m_hashTable;
+ Tcl_HashTable m_objMap;
static ThreadLocalStorage<ObjToRepMap> ms_tls;
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);
ObjToRepMap::~ObjToRepMap ()
{
- Tcl_DeleteHashTable(&m_hashTable);
+ Tcl_DeleteHashTable(&m_objMap);
}
ObjToRepMap &
{
int isNew;
Tcl_HashEntry *pEntry = Tcl_CreateHashEntry(
- &m_hashTable, reinterpret_cast<char *>(pObj), &isNew);
+ &m_objMap, reinterpret_cast<char *>(pObj), &isNew);
Tcl_SetHashValue(pEntry, pRep);
}
ObjToRepMap::find (Tcl_Obj *pObj)
{
Tcl_HashEntry *pEntry = Tcl_FindHashEntry(
- &m_hashTable, reinterpret_cast<char *>(pObj));
+ &m_objMap, reinterpret_cast<char *>(pObj));
if (pEntry == 0) {
return 0;
}
ObjToRepMap::erase (Tcl_Obj *pObj)
{
Tcl_HashEntry *pEntry = Tcl_FindHashEntry(
- &m_hashTable, reinterpret_cast<char *>(pObj));
+ &m_objMap, reinterpret_cast<char *>(pObj));
if (pEntry != 0) {
Tcl_DeleteHashEntry(pEntry);
}
{
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();
}
}
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);
}
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<InternalRep *>(Tcl_GetHashValue(pEntry));
+ pEntry = pNext;
+ }
+
+ Tcl_DeleteHashTable(&m_handleMap);
}
void
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<char *>(handleStr), &isNew);
+ Tcl_SetHashValue(pEntry, static_cast<ClientData>(pRep));
+ return pEntry;
+}
+
+InternalRep *
+HandleNameToRepMap::find (Tcl_Obj *pHandle) const
+{
+ char *key = Tcl_GetStringFromObj(pHandle, 0);
+ Tcl_HashEntry *pEntry = Tcl_FindHashEntry(
+ const_cast<Tcl_HashTable *>(&m_handleMap), key);
+ if (pEntry == 0) {
+ return 0;
+ }
+ return static_cast<InternalRep *>(Tcl_GetHashValue(pEntry));
+}
+
void
-HandleNameToRepMap::clear ()
+HandleNameToRepMap::erase (Tcl_HashEntry *pNameEntry)
{
- m_map.forEach(Delete());
- m_map.clear();
+ Tcl_DeleteHashEntry(pNameEntry);
}
-// $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 <tcl.h>
#include <string>
#include "tcomApi.h"
-#include "HashTable.h"
#include "Singleton.h"
// This class represents an association from a handle to an application object.
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;
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<InternalRep *> Map;
- Map m_map;
+ Tcl_HashTable m_handleMap;
static void deleteInterpProc(ClientData clientData, Tcl_Interp *interp);
static void exitProc(ClientData clientData);
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
// 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;
-// $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
}
}
+#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.
Tcl_DeleteHashEntry(pEntry);
}
}
+#endif
#endif
-# $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
|
-// $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 <string.h>
#include "ComObject.h"
eventInterfaceDesc,
interp,
servant,
- "");
+ "",
+ true);
// Connect to connection point.
hr = m_pConnectionPoint->Advise(pComObject->unknown(), &m_adviseCookie);
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,
&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;
if (SUCCEEDED(hr)) {
return hr;
}
+
+ if (hr == DISP_E_EXCEPTION) {
+ throwDispatchException(excepInfo);
+ }
}
return invokeDispatch(memberid, dispatchFlags, arguments, pResult);
}
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<void **>(&pUnknown));
-// $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
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
-// $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 <vector>
#ifdef WIN32
#include "Extension.h"
#include "Reference.h"
}
#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<void **>(&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<char *>(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<void **>(&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<void **>(&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<char *>(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<long> 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)) {
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(
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(
break;
case VT_NULL:
- m_pObj = Tcl_NewObj();
+ m_pObj = Extension::newNullObj();
break;
case VT_LPSTR:
#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<void **>(&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,
// Convert to interface pointer.
IUnknown *pUnknown = static_cast<IUnknown *>(
m_pObj->internalRep.otherValuePtr);
- if (addRef) {
+ if (addRef && pUnknown != 0) {
// Must increment reference count of interface pointers returned
// from methods.
pUnknown->AddRef();
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<VARIANT_BOOL *>(pData)[i] =
- value.getBool() ? VARIANT_TRUE : VARIANT_FALSE;
- break;
-
- case VT_R4:
- static_cast<float *>(pData)[i] =
- static_cast<float>(value.getDouble());
- break;
-
- case VT_R8:
- static_cast<double *>(pData)[i] = value.getDouble();
- break;
-
- case VT_BSTR:
- static_cast<BSTR *>(pData)[i] = value.getBSTR();
- break;
-
- case VT_VARIANT:
- {
- VARIANT *pDest = static_cast<VARIANT *>(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<int *>(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<VARIANT_BOOL *>(pData)[i] =
+ value.getBool() ? VARIANT_TRUE : VARIANT_FALSE;
+ break;
+
+ case VT_R4:
+ static_cast<float *>(pData)[i] =
+ static_cast<float>(value.getDouble());
+ break;
+
+ case VT_R8:
+ static_cast<double *>(pData)[i] = value.getDouble();
+ break;
+
+ case VT_BSTR:
+ static_cast<BSTR *>(pData)[i] = value.getBSTR();
+ break;
+
+ case VT_VARIANT:
+ {
+ VARIANT *pDest = static_cast<VARIANT *>(pData) + i;
+ VariantInit(pDest);
+ value.toVariant(pDest, elementType, interp);
+ }
+ break;
+
+ default:
+ static_cast<int *>(pData)[i] = value.getLong();
+ }
+ }
+
+ hr = SafeArrayUnaccessData(psa);
+ if (FAILED(hr)) {
+ _com_issue_error(hr);
+ }
}
V_VT(pDest) = VT_ARRAY | elementType.vartype();
_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<void **>(&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<long> 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<void **>(&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) {
} 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) {
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<const wchar_t *>(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);
}
}
-// $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"
#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,
}
#endif
- Tcl_CreateObjCommand(
- interp, NAMESPACE "outputdebug", outputdebugCmd, 0, 0);
Tcl_CreateObjCommand(
interp, NAMESPACE "getnameditem", getnameditemCmd, 0, 0);
Tcl_CreateObjCommand(
# 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
# 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
interface IActiveScriptParse;
interface IObjectSafety;
};
+
+ [
+ uuid(0A0059C5-E0B0-11D2-942A-00C04F7040AE),
+ helpstring("Dispatch Class")
+ ]
+ coclass Dispatch
+ {
+ [default] interface IDispatch;
+ };
};
-// $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"
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;
}
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);
}
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;
-}
-#define BUILD_NUMBER 13
+#define BUILD_NUMBER 28
+++ /dev/null
-// $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 <stdlib.h>
-#include <string.h>
-#include <comdef.h>
-#include <comutil.h>
-
-// 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
-// $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 <string.h>
naSetFromAny
};
-// Create an NA object.
+// Create a Tcl value representing a missing optional argument.
Tcl_Obj *
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
-// $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 <string.h>
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 (
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;
}
-// $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 <sstream>
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
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__);
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
pExtension->initializeCom();
static char *options[] = {
- "create", "registerfactory", NULL
+ "create", "null", "registerfactory", NULL
};
enum SubCommandEnum {
- CREATE, REGISTER_FACTORY
+ CREATE, OBJECT_NULL, REGISTER_FACTORY
};
int index;
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);
}
-// $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 <sstream>
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(
return false;
}
- if (pSupportErrorInfo->InterfaceSupportsErrorInfo(pInterface->iid())
- != S_OK) {
+ if (pSupportErrorInfo->InterfaceSupportsErrorInfo(iid) != S_OK) {
return false;
}
#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<LPWSTR>(&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') {
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);
SOURCE=.\Uuid.cpp
# End Source File
+# Begin Source File
+
+SOURCE=.\variantCmd.cpp
+# End Source File
# End Group
# Begin Group "Header Files"
--- /dev/null
+// $Id: variantCmd.cpp,v 1.1 2003/05/29 03:33:08 cthuang Exp $
+#include "Extension.h"
+#include <string.h>
+
+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;
+}
-// $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)
--- /dev/null
+# $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
--- /dev/null
+# $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
-# $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.
}
}
- 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
-# $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.
set chart [$charts Add]
$chart -namedarg ChartWizard \
Source $sourceRange \
- Gallery [expr -4102] \
+ Gallery [expr 5] \
PlotBy [expr 1] \
CategoryLabels [expr 1] \
SeriesLabels [expr 0] \
projects / tcom / commitdiff