<xsl:value-of select="artheader/title"/>

This article shows by example how to implement COM objects in - Tcl with the tcom extension. It shows how an object - can be implemented by an [incr Tcl] class or in just plain Tcl. -

The class diagram shows the structure of server objects which implement - two COM interfaces. The IAccount interface defines a Balance property, and - Deposit and Withdraw methods which modify the balance. The Account class - implements the IAccount interface by delegating its operations to the - AccountImpl class, which is written in [incr Tcl] and actually implements - the operations. The IBank interface defines a method to create an account. - Following the same pattern, the Bank class implements the IBank interface by - delegating to the BankImpl class, which provides the actual implementation. -

Write MIDL Specification

The file Banking.idl contains the MIDL - specification for the COM interfaces and classes. The interfaces can be - declared dual because tcom can - implement objects whose operations are invoked through the IDispatch - interface or the virtual function table.

Create Type Library

Run this command to generate a type library file - Banking.tlb from the MIDL specification.

Create Tcl Package

The tcom server implementation depends on the Tcl - package mechanism to provide the code that implements specific COM interfaces. - In this example, we'll create a package named Banking, which provides code - that implements the IBank and IAccount interfaces.

Create a directory for the package by making a subdirectory named - Banking under one of the directories in the - auto_path variable. Create a - pkgIndex.tcl file in the package directory.

Create the following server.itcl file in the package - directory. This file defines [incr Tcl] classes that implement the - IBank and IAccount interfaces.

On line 1, the ::tcom::object create command creates - a COM object that implements the IAccount interface by delegating its - operations to an [incr Tcl] object specified by an [incr Tcl] object handle. - Interface methods are mapped to a method with the same name. Interface - properties are mapped to methods named by prepending _get_ - and _set_ to the property name. When the last reference - to the COM object is released, tcom invokes the - delete object command with the [incr Tcl] object handle as - an additional argument to clean up the [incr Tcl] object.

Line 2 creates a factory for creating instances of the Bank class and - registers the factory with COM. To create a COM object, the factory invokes - a command which returns a handle to an [incr Tcl] object that implements the - operations. In this example, the factory invokes the BankImpl - #auto command which creates a BankImpl [incr Tcl] object and - returns a handle to that object. To clean up when the COM object is - destroyed, tcom invokes the delete - object command with the [incr Tcl] object handle as an additional - argument.

Run these Tcl commands to create entries in the Windows registry - required by COM and the tcom server implementation. -

Implement Client

The client.tcl script implements a simple client. - It gets a reference to an object that implements the bank interface, creates - an account, and performs some operations on the account.

Implement Objects In Plain Tcl

You can implement objects in plain Tcl. The servant command passed to - the ::tcom::object create command can be the name of any - object-style command. Similarly, the factory command passed to the - ::tcom::object registerfactory command can return the - name of any object-style command. The following Tcl script defines the - procedures accountImpl and bankImpl, - which have parameters in the style of a method name followed by any - arguments.

- - $Date: 2002/06/29 15:34:52 $ - $Revision: 1.23 $ - COM Object Implementation in Tcl - + COM Object Implementation in Tcl + + $Date: 2005-04-14 10:01:20 -0400 (Thu, 14 Apr 2005) $ + $Revision: 12 $ + Introduction This article shows by example how to implement COM objects in @@ -36,7 +37,6 @@ implement objects whose operations are invoked through the IDispatch interface or the virtual function table. - import "oaidl.idl"; import "ocidl.idl"; @@ -106,7 +106,6 @@ library Banking Run this command to generate a type library file Banking.tlb from the MIDL specification. - midl Banking.idl @@ -122,7 +121,6 @@ library Banking auto_path variable. Create a pkgIndex.tcl file in the package directory. - package ifneeded Banking 1.0 [list source [file join $dir server.itcl]] @@ -134,7 +132,6 @@ package ifneeded Banking 1.0 [list source [file join $dir server.itcl]] IBank and IAccount interfaces. - package provide Banking 1.0 package require Itcl @@ -196,7 +193,6 @@ class BankImpl { required by COM and the tcom server implementation. - package require tcom ::tcom::server register Banking.tlb @@ -207,7 +203,6 @@ class BankImpl { It gets a reference to an object that implements the bank interface, creates an account, and performs some operations on the account. - package require tcom set bank [::tcom::ref createobject "Banking.Bank"] @@ -230,7 +225,6 @@ puts [$account Balance] which have parameters in the style of a method name followed by any arguments. - package provide Banking 1.0 package require tcom diff --git a/doc/tcom.n.html b/doc/tcom.n.html deleted file mode 100644 index 518d762..0000000 --- a/doc/tcom.n.html +++ /dev/null @@ -1,598 +0,0 @@ - - - -tcom - - - -

Name

tcom -- Access COM objects from Tcl

- - - -

Synopsis

- - package require tcom - ?3.9? -
- ::tcom::ref - createobject - ?-inproc? - ?-local? - ?-remote? - ?-clsid? - progID - ?hostName? -
- ::tcom::ref - getactiveobject - ?-clsid? - progID -
- ::tcom::ref - getobject - pathName -
- ::tcom::ref - equal - handle1 - handle2 -
- handle - ?-method? - method - ?argument ...? -
- handle - -namedarg - method - ?argumentName argumentValue ...? -
- handle - ?-get? - ?-set? - property - ?index ...? - ?value? -
- ::tcom::foreach - varname - collectionHandle - body -
- ::tcom::foreach - varlist - collectionHandle - body -
- ::tcom::bind - handle - command - ?eventIID? -
- ::tcom::unbind - handle -
- ::tcom::na -
- ::tcom::info interface - handle -
- ::tcom::configure - name - ?value? -
- ::tcom::import - typeLibrary - ?namespace? -
- - - -

Description

The tcom package provides commands to access COM - objects through IDispatch and IUnknown derived interfaces.

- - -

Commands

- - ::tcom::ref - createobject - ?-inproc? - ?-local? - ?-remote? - ?-clsid? - progID - ?hostName? - - ::tcom::ref - getactiveobject - ?-clsid? - progID - -

These commands return a handle representing a reference to a COM - object through an interface pointer. The handle can be used as a Tcl - command to invoke operations on the object. In practice, you should store - the handle in a Tcl variable or pass it as an argument to another command. -

References to COM objects are automatically released. If you store - the handle in a local variable, the reference is released when execution - leaves the variable's scope. If you store the handle in a global - variable, you can release the reference by unsetting the variable, setting - the variable to another value, or exiting the Tcl interpreter.

The createobject subcommand creates an instance - of the object. The -inproc option requests the object be - created in the same process. The -local option requests - the object be created in another process on the local machine. The - -remote option requests the object be created on a remote - machine. The progID parameter is the programmatic - identifier of the object class. Use the -clsid option if - you want to specify the class using a class ID instead. The - hostName parameter specifies the machine where you - want to create the object instance.

The getactiveobject subcommand gets a reference - to an already existing object.

- - ::tcom::ref - getobject - pathName - -

This command returns a reference to a COM object from a file. The - pathName parameter is the full path and name of the - file containing the object.

- - ::tcom::ref - equal - handle1 - handle2 - -

This command compares the interface pointers represented by two - handles for COM identity, returning 1 if the interface pointers refer to - the same COM object, or 0 if not.

- - handle - ?-method? - method - ?argument ...? - -

This command invokes a method on the object represented by the - handle. The return value of the method is returned - as a Tcl value. A Tcl error will be raised if the method returns a - failure HRESULT code. Parameters with the [in] attribute are passed by - value. For each parameter with the [out] or [in, out] attributes, pass - the name of a Tcl variable as the argument. After the method returns, the - variables will contain the output values. In some cases where - tcom cannot get information about the object's - interface, you may have to use the -method option to - specify you want to invoke a method.

- - handle - -namedarg - method - ?argumentName argumentValue ...? - -

Use the -namedarg option to invoke a method - with named arguments. This only works with objects that implement - IDispatch. You specify arguments by passing name and value pairs.

- - handle - ?-get? - ?-set? - property - ?index ...? - ?value? - -

This command gets or sets a property of the object represented by - the handle. If you supply a - value argument, this command sets the named - property to the value, otherwise it returns the property value. For - indexed properties, you must specify one or more - index values. The command raises a Tcl error if - you specify an invalid property name or if you try to set a value that - cannot be converted to the property's type. In some cases where - tcom cannot get information about the object's - interface, you may have to use the -get or - -set option to specify you want to get or set a property - respectively.

- - ::tcom::foreach - varname - collectionHandle - body - - ::tcom::foreach - varlist - collectionHandle - body - -

This command implements a loop where the loop variable(s) take on - values from a collection object represented by - collectionHandle. In the simplest case, there - is one loop variable, varname. The - body argument is a Tcl script. For each - element of the collection, the command assigns the contents of the element - to varname, then calls the Tcl interpreter to - execute body.

In the general case, there can be more than one loop variable. - During each iteration of the loop, the variables of - varlist are assigned consecutive elements from - the collection. Each element is used exactly once. The total number of - loop iterations is large enough to use up all the elements from the - collection. On the last iteration, if the collection does not contain - enough elements for each of the loop variables, empty values are used for - the missing elements.

The break and continue - statements may be invoked inside body, with the - same effect as in the for command. The - ::tcom::foreach command returns an empty string.

- - ::tcom::bind - handle - command - ?eventIID? - -

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. If an error - occurs while executing the command then the bgerror mechanism is used to - report the error.

- - ::tcom::unbind - handle - -

This command tears down all event connections to the object that - were set up by the ::tcom::bind command.

- - ::tcom::na - -

Objects that implement the IDispatch interface allow some method - parameters to be optional. This command returns a token representing a - missing optional argument. In practice, you would pass this token as a - method argument in place of a missing optional argument.

- - ::tcom::info interface - handle - -

This command returns a handle representing a description of the - interface exposed by the object. The handle supports the following - commands.

- - interfaceHandle - iid - -: -
This command returns an interface identifier code.
-
- - interfaceHandle - methods - -: -
This command returns a list of method descriptions for methods - defined in the interface. Each method description is a list. The - first element is the member ID. The second element is the return type. - The third element is the method name. The fourth element is a list of - parameter descriptions.
-
- - interfaceHandle - name - -: -
This command returns the interface's name.
-
- - interfaceHandle - properties - -: -
This command returns a list of property descriptions for - properties defined in the interface. Each property description is a - list. The first element is the member ID. The second element is the - property read/write mode. The third element is the property data type. - The fourth element is the property name. If the property is an indexed - property, there is a fifth element which is a list of parameter - descriptions.
-

- - ::tcom::configure - name - ?value? - -

This command sets and retrieves options for the package. If - name is supplied but no - value then the command returns the current - value of the given option. If one or more pairs of - name and value are - supplied, the command sets each of the named options to the corresponding - value; in this case the return value is an empty string.

- - -concurrency - ?concurrencyModel? - -: -
This option sets the concurrency model, which can be - apartmentthreaded or multithreaded. - The default is apartmentthreaded. You must configure - this option before performing any COM operations such as getting a - reference to an object. After a COM operation has been done, changing - this option has no effect.
-

- - -

Importing Type Library Information

- - ::tcom::import - typeLibrary - ?namespace? - -

Use the ::tcom::import command to convert type - information from a type library into Tcl commands to access COM classes and - interfaces. The typeLibrary argument specifies a - type library file. By default, the commands are defined in a namespace named - after the type library, but you may specify another namespace by supplying a - namespace argument. This command returns the - library name stored in the type library file.

- -

Commands

- - class - ?-inproc? - ?-local? - ?-remote? - ?hostName? - -: -
For each class in the type library, - ::tcom::import defines a Tcl command with the same - name as the class. The class command creates an object of the class and - returns a handle representing an interface pointer to the object. The - command accepts an optional hostName argument - to specify the machine where you want to create the object. You can use - the returned handle to invoke methods and access properties of the - object. In practice, you should store this handle in a Tcl variable or - pass it as an argument to a Tcl command.
-
- - interface - handle - -: -
For each interface in the type library, - ::tcom::import defines a Tcl command with the same - name as the interface. The interface command queries the object - represented by handle for an interface pointer - to that specific interface. The command returns a handle representing - the interface pointer. You can use the returned handle to invoke methods - and access properties of the object. In practice, you should store this - handle in a Tcl variable or pass it as an argument to a Tcl - command.
-

- - -

Enumerations

The ::tcom::import command generates a Tcl array - for each enumeration defined in the type library. The array name is the - enumeration name. To get an enumerator value, use an enumerator name as an - index into the array.

- - - -

Tcl Value to VARIANT Mapping

Each Tcl value has two representations. A Tcl value has a string - representation and also has an internal representation that can be - manipulated more efficiently. For example, a Tcl list is represented as an - object that holds the list's string representation as well as an array of - pointers to the objects for each list element. The two representations are a - cache of each other and are computed lazily. That is, each representation is - only computed when necessary, is computed from the other representation, and, - once computed, is saved. In addition, a change in one representation - invalidates the other one. As an example, a Tcl program doing integer - calculations can operate directly on a variable's internal machine integer - representation without having to constantly convert between integers and - strings. Only when it needs a string representing the variable's value, say - to print it, will the program regenerate the string representation from the - integer. The internal representations built into Tcl include boolean, - integer and floating point types.

When invoking COM object methods, tcom tries to - convert each Tcl argument to the parameter type specified by the method - interface. For example, if a method accepts an int - parameter, tcom tries to convert the argument to that - type. If the parameter type is a VARIANT, the conversion has an extra - complication because a VARIANT is designed to hold many different data types. - One approach might be to simply copy the Tcl value's string representation - to a string in the VARIANT, and hope the method's implementation can correctly - interpret the string, but this doesn't work in general because some - implementations expect certain VARIANT types.

Tcom uses the Tcl value's internal representation - type as a hint to choose the resulting VARIANT type.

- Tcl value to VARIANT mapping
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Tcl internal representation VARIANT type
boolean VT_BOOL
int VT_I4
double VT_R8
list one-dimensional array of VT_VARIANT
bytearray one-dimensional array of VT_UI1
other VT_BSTR
-

- -

Invoking Methods With VARIANT Parameters

The internal representation of a Tcl value may become significant when - it is passed to a VARIANT parameter of a method. For example, the standard - interface for COM collections defines the Item method for - getting an element by specifying an index. Many implementations of the - method allow the index to be an integer value (usually based from 1) or a - string key. If the index parameter is a VARIANT, you must account for the - internal representation type of the Tcl argument passed to that - parameter.

-
-# Assume $collection is a handle to a collection.
-set element [$collection Item 1]
-

This command passes a string consisting of the single character "1" - to the Item method. The method may return an error because it can't find an - element with that string key.

-
-set numElements [$collection Count]
-for {set i 1} {$i <= $numElements} {incr i} {  ;# 1
-    set element [$collection Item $i]  ;# 2
-}
-

In line 1, the for command sets the internal - representation of $i to an int type as a side effect of - evaluating the condition expression {$i <= - $numElements}. The command in line 2 passes the integer value in - $i to the Item method, which should succeed if the method - can handle integer index values.

- - - - diff --git a/doc/tcom.n.xml b/doc/tcom.n.xml index 4794bad..c25414a 100644 --- a/doc/tcom.n.xml +++ b/doc/tcom.n.xml @@ -1,11 +1,12 @@ - - + + - - $Date: 2002/10/22 22:07:55 $ - $Revision: 1.65 $ - + + $Date: 2005-04-14 10:01:20 -0400 (Thu, 14 Apr 2005) $ + $Revision: 12 $ + tcom n @@ -17,78 +18,74 @@ package require tcom - + 3.10 - ::tcom::ref - createobject - - - - - progID - hostName + ::tcom::ref createobject + -inproc + -local + -remote + -clsid + progID + hostName - ::tcom::ref - getactiveobject - - progID + ::tcom::ref getactiveobject + -clsid + progID - ::tcom::ref - getobject - pathName + ::tcom::ref getobject + pathName - ::tcom::ref - equal - handle1 - handle2 + ::tcom::ref equal + handle1 + handle2 - handle - - method - argument + handle + -call + method + argument - handle - - method - argumentName argumentValue + handle + -namedarg + method + argumentName argumentValue - handle - - - property - index - value + handle + -get + -set + property + index + value ::tcom::foreach - varname - collectionHandle - body + varname + collectionHandle + body ::tcom::foreach - varlist - collectionHandle - body + varlist + collectionHandle + body ::tcom::bind - handle - command - eventIID + handle + command + eventIID ::tcom::unbind - handle + handle ::tcom::na ::tcom::info interface - handle + handle ::tcom::configure - name - value + name + value ::tcom::import - typeLibrary - namespace + typeLibrary + namespace @@ -103,19 +100,17 @@ - ::tcom::ref - createobject - - - - - progID - hostName + ::tcom::ref createobject + -inproc + -local + -remote + -clsid + progID + hostName - ::tcom::ref - getactiveobject - - progID + ::tcom::ref getactiveobject + -clsid + progID @@ -146,9 +141,8 @@ - ::tcom::ref - getobject - pathName + ::tcom::ref getobject + pathName @@ -160,10 +154,9 @@ - ::tcom::ref - equal - handle1 - handle2 + ::tcom::ref equal + handle1 + handle2 @@ -175,10 +168,10 @@ - handle - - method - argument + handle + -call + method + argument @@ -190,17 +183,19 @@ the name of a Tcl variable as the argument. After the method returns, the variables will contain the output values. In some cases where tcom cannot get information about the object's - interface, you may have to use the option to + interface, you may have to use the option to specify you want to invoke a method. - handle - - method - argumentName argumentValue + handle + -namedarg + method + + argumentName argumentValue + @@ -212,12 +207,12 @@ - handle - - - property - index - value + handle + -get + -set + property + index + value @@ -239,14 +234,14 @@ ::tcom::foreach - varname - collectionHandle - body + varname + collectionHandle + body ::tcom::foreach - varlist - collectionHandle - body + varlist + collectionHandle + body @@ -276,9 +271,9 @@ ::tcom::bind - handle - command - eventIID + handle + command + eventIID @@ -296,7 +291,7 @@ ::tcom::unbind - handle + handle @@ -321,7 +316,7 @@ ::tcom::info interface - handle + handle @@ -332,7 +327,7 @@ - interfaceHandle + interfaceHandle iid @@ -343,7 +338,7 @@ - interfaceHandle + interfaceHandle methods @@ -358,7 +353,7 @@ - interfaceHandle + interfaceHandle name @@ -369,7 +364,7 @@ - interfaceHandle + interfaceHandle properties @@ -390,8 +385,8 @@ ::tcom::configure - name - value + name + value @@ -406,8 +401,8 @@ - - concurrencyModel + -concurrency + concurrencyModel @@ -428,8 +423,8 @@ Importing Type Library Information ::tcom::import - typeLibrary - namespace + typeLibrary + namespace Use the ::tcom::import command to convert type information from a type library into Tcl commands to access COM classes and @@ -444,11 +439,11 @@ - class - - - - hostName + class + -inproc + -local + -remote + hostName @@ -466,8 +461,8 @@ - interface - handle + interface + handle @@ -569,7 +564,6 @@ internal representation type of the Tcl argument passed to that parameter. - # Assume $collection is a handle to a collection. set element [$collection Item 1] @@ -577,7 +571,6 @@ set element [$collection Item 1] to the Item method. The method may return an error because it can't find an element with that string key. - set numElements [$collection Count] for {set i 1} {$i <= $numElements} {incr i} { ;# 1 set element [$collection Item $i] ;# 2 diff --git a/doc/xslt.tcl b/doc/xslt.tcl index 6969985..f28e4dc 100644 --- a/doc/xslt.tcl +++ b/doc/xslt.tcl @@ -1,4 +1,4 @@ -# $Id: xslt.tcl,v 1.2 2002/09/05 22:10:25 cthuang Exp $ +# $Id: xslt.tcl 7 2005-02-24 05:18:47Z cthuang $ # # Run an XML document through an XSLT processor. @@ -12,6 +12,7 @@ package require tcom set domProgId "Msxml2.DOMDocument" set source [::tcom::ref createobject $domProgId] +$source async 0 $source preserveWhiteSpace 1 $source validateOnParse 0 $source resolveExternals 0 @@ -26,6 +27,7 @@ if {![$source load $sourceUrl]} { } set xslt [::tcom::ref createobject $domProgId] +$xslt async 0 $xslt preserveWhiteSpace 1 $xslt validateOnParse 0 set xsltUrl [lindex $argv 1] @@ -39,7 +41,7 @@ if {![$xslt load $xsltUrl]} { } regsub {]*>} [$source transformNode $xslt] \ - {} \ + {} \ resultHtml set out [open [lindex $argv 2] "w"] diff --git a/lib/Banking/Banking.tlb b/lib/Banking/Banking.tlb deleted file mode 100644 index 83694de..0000000 Binary files a/lib/Banking/Banking.tlb and /dev/null differ diff --git a/lib/Banking/pkgIndex.tcl b/lib/Banking/pkgIndex.tcl index 1c3601c..8aafe65 100644 --- a/lib/Banking/pkgIndex.tcl +++ b/lib/Banking/pkgIndex.tcl @@ -1,2 +1,2 @@ -# $Id: pkgIndex.tcl,v 1.3 2001/07/04 03:36:16 cthuang Exp $ +# $Id: pkgIndex.tcl 5 2005-02-16 14:57:24Z cthuang $ package ifneeded Banking 1.0 [list source [file join $dir server.tcl]] diff --git a/lib/Banking/server.itcl b/lib/Banking/server.itcl index 7b9540d..ae628a1 100644 --- a/lib/Banking/server.itcl +++ b/lib/Banking/server.itcl @@ -1,4 +1,4 @@ -# $Id: server.itcl,v 1.7 2002/06/29 15:34:52 cthuang Exp $ +# $Id: server.itcl 5 2005-02-16 14:57:24Z cthuang $ package provide Banking 1.0 package require Itcl diff --git a/lib/Banking/server.tcl b/lib/Banking/server.tcl index f31894f..bc72ff7 100644 --- a/lib/Banking/server.tcl +++ b/lib/Banking/server.tcl @@ -1,4 +1,4 @@ -# $Id: server.tcl,v 1.4 2003/03/07 00:03:00 cthuang Exp $ +# $Id: server.tcl 5 2005-02-16 14:57:24Z cthuang $ package provide Banking 1.0 package require tcom diff --git a/lib/TclScript/TclScript.dll b/lib/TclScript/TclScript.dll index a214bbd..db25d4d 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 1d6f287..5b50389 100644 --- a/lib/TclScript/TclScript.itcl +++ b/lib/TclScript/TclScript.itcl @@ -1,4 +1,4 @@ -# $Id: TclScript.itcl,v 1.6 2003/11/08 17:38:09 cthuang Exp $ +# $Id: TclScript.itcl 5 2005-02-16 14:57:24Z cthuang $ package require Itcl namespace import itcl::* diff --git a/lib/TclScript/TclScript.tlb b/lib/TclScript/TclScript.tlb index 871d694..d17a1ba 100644 Binary files a/lib/TclScript/TclScript.tlb and b/lib/TclScript/TclScript.tlb differ diff --git a/lib/TclScript/pkgIndex.tcl b/lib/TclScript/pkgIndex.tcl index 74d19b9..efb1c13 100644 --- a/lib/TclScript/pkgIndex.tcl +++ b/lib/TclScript/pkgIndex.tcl @@ -1,3 +1,3 @@ -# $Id: pkgIndex.tcl,v 1.2 2002/03/30 18:49:10 cthuang Exp $ +# $Id: pkgIndex.tcl 5 2005-02-16 14:57:24Z cthuang $ package ifneeded TclScript 1.0 \ [list load [file join $dir TclScript.dll]]\n[list source [file join $dir TclScript.itcl]] diff --git a/lib/TclScript/register.tcl b/lib/TclScript/register.tcl index 807ee29..8b8e033 100644 --- a/lib/TclScript/register.tcl +++ b/lib/TclScript/register.tcl @@ -1,4 +1,4 @@ -# $Id: register.tcl,v 1.3 2002/03/20 23:52:35 cthuang Exp $ +# $Id: register.tcl 5 2005-02-16 14:57:24Z cthuang $ # # This script registers the Tcl Active Scripting engine. diff --git a/lib/TclScript/unregister.tcl b/lib/TclScript/unregister.tcl index 906114a..9e7695b 100644 --- a/lib/TclScript/unregister.tcl +++ b/lib/TclScript/unregister.tcl @@ -1,4 +1,4 @@ -# $Id: unregister.tcl,v 1.1 2003/03/20 00:12:14 cthuang Exp $ +# $Id: unregister.tcl 5 2005-02-16 14:57:24Z cthuang $ # # This script unregisters the Tcl Active Scripting engine. diff --git a/lib/tcom/pkgIndex.tcl b/lib/tcom/pkgIndex.tcl index aa90f9b..27a04a8 100644 --- a/lib/tcom/pkgIndex.tcl +++ b/lib/tcom/pkgIndex.tcl @@ -1,3 +1,3 @@ -# $Id: pkgIndex.tcl,v 1.16 2003/04/17 03:17:30 cthuang Exp $ +# $Id: pkgIndex.tcl 5 2005-02-16 14:57:24Z cthuang $ 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 3c68901..9f60aa0 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 58eaab4..6ae6e43 100644 --- a/lib/tcom/tcom.tcl +++ b/lib/tcom/tcom.tcl @@ -1,4 +1,4 @@ -# $Id: tcom.tcl,v 1.17 2003/04/02 22:46:51 cthuang Exp $ +# $Id: tcom.tcl 5 2005-02-16 14:57:24Z cthuang $ namespace eval ::tcom { # Tear down all event connections to the object. diff --git a/lib/tcom/tcominproc.dll b/lib/tcom/tcominproc.dll index 519a611..95fcfca 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 42df14c..e83568b 100644 Binary files a/lib/tcom/tcomlocal.exe and b/lib/tcom/tcomlocal.exe differ diff --git a/src/ActiveScriptError.cpp b/src/ActiveScriptError.cpp index fe219b3..e71a002 100644 --- a/src/ActiveScriptError.cpp +++ b/src/ActiveScriptError.cpp @@ -1,4 +1,4 @@ -// $Id: ActiveScriptError.cpp,v 1.1 2002/03/30 18:49:53 cthuang Exp $ +// $Id: ActiveScriptError.cpp 5 2005-02-16 14:57:24Z cthuang $ #include "ActiveScriptError.h" STDMETHODIMP diff --git a/src/ActiveScriptError.h b/src/ActiveScriptError.h index 38c542f..9c1723c 100644 --- a/src/ActiveScriptError.h +++ b/src/ActiveScriptError.h @@ -1,4 +1,4 @@ -// $Id: ActiveScriptError.h,v 1.2 2002/04/12 02:55:27 cthuang Exp $ +// $Id: ActiveScriptError.h 5 2005-02-16 14:57:24Z cthuang $ #ifndef ACTIVESCRIPTERROR_H #define ACTIVESCRIPTERROR_H diff --git a/src/Arguments.cpp b/src/Arguments.cpp index b92e4a7..73a055b 100644 --- a/src/Arguments.cpp +++ b/src/Arguments.cpp @@ -1,4 +1,4 @@ -// $Id: Arguments.cpp,v 1.35 2003/03/15 01:32:09 cthuang Exp $ +// $Id: Arguments.cpp 5 2005-02-16 14:57:24Z cthuang $ #include "Arguments.h" #include "Extension.h" #include "TclObject.h" @@ -45,13 +45,23 @@ TypedArguments::initArgument ( // For out parameters, set a pointer to where the out value // will be stored. - if (vt == VT_INT) { + switch (vt) { + case VT_INT: // IDispatch::Invoke returns DISP_E_TYPEMISMATCH on // VT_INT | VT_BYREF parameters. vt = VT_I4; - } else if (vt == VT_USERDEFINED) { + break; + + case VT_UINT: + // IDispatch::Invoke returns DISP_E_TYPEMISMATCH on + // VT_UINT | VT_BYREF parameters. + vt = VT_UI4; + break; + + case VT_USERDEFINED: // Assume user defined types derive from IUnknown. vt = VT_UNKNOWN; + break; } if (vt == VT_SAFEARRAY) { @@ -81,7 +91,7 @@ TypedArguments::initArgument ( // If the argument is an interface pointer, increment its reference // count because the _variant_t destructor will release it. - value.toVariant( + value.toNativeValue( &m_outValues[argIndex], parameter.type(), interp, true); } else { if (vt == VT_UNKNOWN) { @@ -103,7 +113,8 @@ TypedArguments::initArgument ( } else { // If the argument is an interface pointer, increment its reference // count because the _variant_t destructor will release it. - argument.toVariant(&m_args[argIndex], parameter.type(), interp, true); + argument.toNativeValue( + &m_args[argIndex], parameter.type(), interp, true); } return TCL_OK; @@ -149,21 +160,22 @@ PositionalArguments::initialize ( } if (method.vararg() && inputCount > 0) { - m_args = new _variant_t[inputCount]; + m_args = new NativeValue[inputCount]; // Convert the arguments actually provided. int inputIndex = 0; int argIndex = inputCount - 1; for (; inputIndex < inputCount; ++inputIndex, --argIndex) { TclObject value(objv[inputIndex]); - value.toVariant(&m_args[argIndex], Type::variant(), interp, true); + value.toNativeValue( + &m_args[argIndex], Type::variant(), interp, true); } paramCount = inputCount; } else if (paramCount > 0) { - m_args = new _variant_t[paramCount]; - m_outValues = new _variant_t[paramCount]; + m_args = new NativeValue[paramCount]; + m_outValues = new NativeValue[paramCount]; int j = paramCount - 1; Method::Parameters::const_iterator p = parameters.begin(); @@ -186,7 +198,7 @@ PositionalArguments::initialize ( if (dispatchFlags == DISPATCH_PROPERTYPUT || dispatchFlags == DISPATCH_PROPERTYPUTREF) { TclObject value = objv[i]; - value.toVariant(&m_args[j], method.type(), interp, true); + value.toNativeValue(&m_args[j], method.type(), interp, true); } } @@ -244,8 +256,8 @@ NamedArguments::initialize ( int cArgs = objc / 2; if (cArgs > 0) { - m_args = new _variant_t[cArgs]; - m_outValues = new _variant_t[cArgs]; + m_args = new NativeValue[cArgs]; + m_outValues = new NativeValue[cArgs]; m_namedDispids = new DISPID[cArgs]; int j = cArgs - 1; @@ -284,7 +296,7 @@ UntypedArguments::initialize ( WORD dispatchFlags) { if (objc > 0) { - m_args = new _variant_t[objc]; + m_args = new NativeValue[objc]; int j = objc - 1; for (int i = 0; i < objc; ++i, --j) { @@ -292,7 +304,7 @@ UntypedArguments::initialize ( // If the argument is an interface pointer, increment its reference // count because the _variant_t destructor will release it. - value.toVariant(&m_args[j], Type::variant(), interp, true); + value.toNativeValue(&m_args[j], Type::variant(), interp, true); } } diff --git a/src/Arguments.h b/src/Arguments.h index 50e57f9..fbbea6e 100644 --- a/src/Arguments.h +++ b/src/Arguments.h @@ -1,8 +1,9 @@ -// $Id: Arguments.h,v 1.8 2001/10/13 17:56:14 Administrator Exp $ +// $Id: Arguments.h 5 2005-02-16 14:57:24Z cthuang $ #ifndef ARGUMENTS_H #define ARGUMENTS_H #include "TypeInfo.h" +#include "NativeValue.h" class Arguments { @@ -10,7 +11,7 @@ protected: DISPPARAMS m_dispParams; // argument values - _variant_t *m_args; + NativeValue *m_args; Arguments(); @@ -29,7 +30,7 @@ class TypedArguments: public Arguments { protected: // used to hold values returned from out parameters - _variant_t *m_outValues; + NativeValue *m_outValues; TypedArguments(); diff --git a/src/ComModule.cpp b/src/ComModule.cpp index 9ff5224..f4b18ad 100644 --- a/src/ComModule.cpp +++ b/src/ComModule.cpp @@ -1,4 +1,4 @@ -// $Id: ComModule.cpp,v 1.15 2002/05/31 04:03:06 cthuang Exp $ +// $Id: ComModule.cpp 5 2005-02-16 14:57:24Z cthuang $ #pragma warning(disable: 4786) #include "ComObjectFactory.h" #include "ComModule.h" diff --git a/src/ComModule.h b/src/ComModule.h index 21816f4..8a7abed 100644 --- a/src/ComModule.h +++ b/src/ComModule.h @@ -1,4 +1,4 @@ -// $Id: ComModule.h,v 1.13 2002/04/13 03:53:56 cthuang Exp $ +// $Id: ComModule.h 5 2005-02-16 14:57:24Z cthuang $ #ifndef COMMODULE_H #define COMMODULE_H diff --git a/src/ComObject.cpp b/src/ComObject.cpp index beb4e9b..89e693e 100644 --- a/src/ComObject.cpp +++ b/src/ComObject.cpp @@ -1,9 +1,12 @@ -// $Id: ComObject.cpp,v 1.41 2003/04/04 23:55:04 cthuang Exp $ +// $Id: ComObject.cpp 13 2005-04-18 12:24:14Z cthuang $ #pragma warning(disable: 4786) #include "ComObject.h" #include #include "ComModule.h" +#include "DispatchAdapter.h" +#ifdef TCOM_VTBL_SERVER #include "InterfaceAdapter.h" +#endif #include "Reference.h" #include "Extension.h" @@ -76,10 +79,16 @@ ComObject::registerActiveObject (REFCLSID clsid) m_registeredActiveObject = true; } -InterfaceAdapter * +void * ComObject::implementInterface (const Interface &interfaceDesc) { - InterfaceAdapter *pAdapter = new InterfaceAdapter(*this, interfaceDesc); + void *pAdapter = +#ifdef TCOM_VTBL_SERVER + new InterfaceAdapter(*this, interfaceDesc); +#else + new DispatchAdapter(*this, interfaceDesc); +#endif + m_iidToAdapterMap.insert(interfaceDesc.iid(), pAdapter); return pAdapter; } @@ -203,7 +212,7 @@ ComObject::queryInterface (REFIID iid, void **ppvObj) if (IsEqualIID(iid, IID_IDispatch)) { // Expose the operations of the default interface through IDispatch. if (m_pDispatch == 0) { - m_pDispatch = new InterfaceAdapter(*this, m_defaultInterface, true); + m_pDispatch = new DispatchAdapter(*this, m_defaultInterface); } *ppvObj = m_pDispatch; addRef(); @@ -216,7 +225,7 @@ ComObject::queryInterface (REFIID iid, void **ppvObj) return S_OK; } - InterfaceAdapter *pAdapter = m_iidToAdapterMap.find(iid); + void *pAdapter = m_iidToAdapterMap.find(iid); if (pAdapter == 0) { const Interface *pInterface = m_supportedInterfaceMap.find(iid); if (pInterface != 0) { @@ -364,14 +373,22 @@ putOutVariant (Tcl_Interp *interp, } break; + case VT_SAFEARRAY: + if (*V_ARRAYREF(pDest) != 0) { + SafeArrayDestroy(*V_ARRAYREF(pDest)); + } + *V_ARRAYREF(pDest) = + tclObject.getSafeArray(type.elementType(), interp); + break; + default: *V_I4REF(pDest) = tclObject.getLong(); } } HRESULT -ComObject::invoke (InterfaceAdapter *pAdapter, - DISPID dispid, +ComObject::invoke (const Method &method, + bool isProperty, REFIID /*riid*/, LCID /*lcid*/, WORD wFlags, @@ -380,11 +397,6 @@ ComObject::invoke (InterfaceAdapter *pAdapter, EXCEPINFO *pExcepInfo, UINT *pArgErr) { - // Get the method description for method being invoked. - const Method *pMethod = pAdapter->findDispatchMethod(dispid); - if (pMethod == 0) { - return DISP_E_MEMBERNOTFOUND; - } HRESULT hresult; @@ -394,15 +406,14 @@ ComObject::invoke (InterfaceAdapter *pAdapter, // Get the method or property to invoke on the servant. std::string operation; - if ((wFlags & DISPATCH_PROPERTYGET) != 0 - && pAdapter->isProperty(dispid)) { - operation = getPrefix + pMethod->name(); + if ((wFlags & DISPATCH_PROPERTYGET) != 0 && isProperty) { + operation = getPrefix + method.name(); } else if (wFlags & (DISPATCH_PROPERTYPUT | DISPATCH_PROPERTYPUTREF)) { - operation = setPrefix + pMethod->name(); + operation = setPrefix + method.name(); } else if (wFlags & DISPATCH_METHOD) { - operation = pMethod->name(); + operation = method.name(); } else { return DISP_E_MEMBERNOTFOUND; @@ -420,7 +431,7 @@ ComObject::invoke (InterfaceAdapter *pAdapter, // Convert arguments to Tcl values. // TODO: Should handle named arguments differently than positional // arguments. - const Method::Parameters ¶meters = pMethod->parameters(); + const Method::Parameters ¶meters = method.parameters(); int argIndex = pDispParams->cArgs - 1; Method::Parameters::const_iterator pParam; @@ -440,7 +451,7 @@ ComObject::invoke (InterfaceAdapter *pAdapter, if (wFlags & (DISPATCH_PROPERTYPUT | DISPATCH_PROPERTYPUTREF)) { VARIANT *pArg = &(pDispParams->rgvarg[argIndex]); try { - TclObject value(pArg, pMethod->type(), m_interp); + TclObject value(pArg, method.type(), m_interp); script.lappend(value); } catch (_com_error &) { @@ -474,27 +485,24 @@ ComObject::invoke (InterfaceAdapter *pAdapter, argIndex = pDispParams->cArgs - 1; for (pParam = parameters.begin(); pParam != parameters.end(); ++pParam, --argIndex) { - if (pParam->flags() & PARAMFLAG_FOUT) { + VARIANT *pArg = &(pDispParams->rgvarg[argIndex]); + if ((pParam->flags() & PARAMFLAG_FOUT) && (V_VT(pArg) & VT_BYREF)) { // Get name of Tcl variable that holds out value. TclObject varName = getOutVariableName(*pParam); // Copy variable value to out argument. TclObject value; if (getVariable(varName, value) == TCL_OK) { - putOutVariant( - m_interp, - &pDispParams->rgvarg[argIndex], - value, - pParam->type()); + putOutVariant(m_interp, pArg, value, pParam->type()); } } } // Convert return value. - if (pReturnValue != 0 && pMethod->type().vartype() != VT_VOID) { + if (pReturnValue != 0 && method.type().vartype() != VT_VOID) { // Must increment reference count of interface pointers returned // from methods. - result.toVariant(pReturnValue, pMethod->type(), m_interp, true); + result.toVariant(pReturnValue, method.type(), m_interp, true); } } catch (_com_error &e) { @@ -504,6 +512,8 @@ ComObject::invoke (InterfaceAdapter *pAdapter, return hresult; } +#ifdef TCOM_VTBL_SERVER + // Convert the native value that the va_list points to into a Tcl object. // Returns a va_list pointing to the next argument. @@ -584,6 +594,13 @@ convertNativeToTclObject (va_list pArg, interp); break; + case VT_SAFEARRAY: + tclObject = TclObject( + byRef ? *va_arg(pArg, SAFEARRAY **) : va_arg(pArg, SAFEARRAY *), + type, + interp); + break; + default: tclObject = Tcl_NewLongObj( byRef ? *va_arg(pArg, int *) : va_arg(pArg, int)); @@ -703,6 +720,11 @@ putArgument (va_list pArg, } break; + case VT_SAFEARRAY: + *static_cast(pDest) = + tclObject.getSafeArray(type.elementType(), interp); + break; + default: *static_cast(pDest) = tclObject.getLong(); } @@ -870,3 +892,5 @@ invokeComObjectFunction (volatile HRESULT hresult, va_end(pArg); } + +#endif diff --git a/src/ComObject.h b/src/ComObject.h index 3868e2f..386d132 100644 --- a/src/ComObject.h +++ b/src/ComObject.h @@ -1,4 +1,4 @@ -// $Id: ComObject.h,v 1.15 2002/10/22 22:07:55 cthuang Exp $ +// $Id: ComObject.h 13 2005-04-18 12:24:14Z cthuang $ #ifndef COMOBJECT_H #define COMOBJECT_H @@ -49,17 +49,17 @@ class TCOM_API ComObject SupportedInterfaceMap m_supportedInterfaceMap; // collection of implemented interface adapters - typedef HashTable IidToAdapterMap; + typedef HashTable IidToAdapterMap; IidToAdapterMap m_iidToAdapterMap; // implements default interface - InterfaceAdapter *m_pDefaultAdapter; + void *m_pDefaultAdapter; // implements ISupportErrorInfo SupportErrorInfo m_supportErrorInfo; // implements IDispatch - InterfaceAdapter *m_pDispatch; + void *m_pDispatch; // token returned from RegisterActiveObject unsigned long m_activeObjectHandle; @@ -81,7 +81,7 @@ class TCOM_API ComObject void operator=(const ComObject &); // not implemented // Create an adapter which implements the specified interface. - InterfaceAdapter *implementInterface(const Interface &interfaceDesc); + void *implementInterface(const Interface &interfaceDesc); // Convert IDispatch argument to Tcl value. TclObject getArgument(VARIANT *pArg, const Parameter ¶m); @@ -136,15 +136,15 @@ public: // IDispatch implementation HRESULT invoke( - InterfaceAdapter *pThis, - DISPID dispidMember, - REFIID riid, + const Method &method, + bool isProperty, + REFIID iid, LCID lcid, WORD wFlags, - DISPPARAMS *pdispparams, - VARIANT *pvarResult, - EXCEPINFO *pexcepinfo, - UINT *puArgErr); + DISPPARAMS *pDispParams, + VARIANT *pReturnValue, + EXCEPINFO *pExcepInfo, + UINT *pArgErr); }; #endif diff --git a/src/ComObjectFactory.cpp b/src/ComObjectFactory.cpp index 8176be5..710f261 100644 --- a/src/ComObjectFactory.cpp +++ b/src/ComObjectFactory.cpp @@ -1,4 +1,4 @@ -// $Id: ComObjectFactory.cpp,v 1.17 2002/05/31 04:03:06 cthuang Exp $ +// $Id: ComObjectFactory.cpp 5 2005-02-16 14:57:24Z cthuang $ #pragma warning(disable: 4786) #include "ComModule.h" #include "ComObject.h" diff --git a/src/ComObjectFactory.h b/src/ComObjectFactory.h index 6bf8e14..6726813 100644 --- a/src/ComObjectFactory.h +++ b/src/ComObjectFactory.h @@ -1,4 +1,4 @@ -// $Id: ComObjectFactory.h,v 1.11 2002/04/13 03:53:56 cthuang Exp $ +// $Id: ComObjectFactory.h 5 2005-02-16 14:57:24Z cthuang $ #ifndef COMOBJECTFACTORY_H #define COMOBJECTFACTORY_H diff --git a/src/DispatchAdapter.cpp b/src/DispatchAdapter.cpp new file mode 100644 index 0000000..9459c7f --- /dev/null +++ b/src/DispatchAdapter.cpp @@ -0,0 +1,84 @@ +// $Id: DispatchAdapter.cpp 14 2005-04-18 14:14:12Z cthuang $ +#pragma warning(disable: 4786) +#include "DispatchAdapter.h" +#include +#include "ComObject.h" +#include "Reference.h" +#include "Extension.h" + +// Implement IUnknown methods + +STDMETHODIMP +DispatchAdapter::QueryInterface (REFIID iid, void **ppvObj) +{ + return m_dispatchImpl.object().queryInterface(iid, ppvObj); +} + +STDMETHODIMP_(ULONG) +DispatchAdapter::AddRef () +{ + return m_dispatchImpl.object().addRef(); +} + +STDMETHODIMP_(ULONG) +DispatchAdapter::Release () +{ + return m_dispatchImpl.object().release(); +} + +// Implement IDispatch methods + +STDMETHODIMP +DispatchAdapter::GetTypeInfoCount (UINT *pCount) +{ + *pCount = 1; + return S_OK; +} + +STDMETHODIMP +DispatchAdapter::GetTypeInfo (UINT index, LCID, ITypeInfo **ppTypeInfo) +{ + if (index != 0) { + *ppTypeInfo = 0; + return DISP_E_BADINDEX; + } + + ITypeInfo *pTypeInfo = m_dispatchImpl.typeInfo(); + pTypeInfo->AddRef(); + *ppTypeInfo = pTypeInfo; + return S_OK; +} + +STDMETHODIMP +DispatchAdapter::GetIDsOfNames ( + REFIID, + OLECHAR **rgszNames, + UINT cNames, + LCID, + DISPID *rgDispId) +{ + ITypeInfo *pTypeInfo = m_dispatchImpl.typeInfo(); + return pTypeInfo->GetIDsOfNames(rgszNames, cNames, rgDispId); +} + +STDMETHODIMP +DispatchAdapter::Invoke ( + DISPID dispid, + REFIID iid, + LCID lcid, + WORD wFlags, + DISPPARAMS *pDispParams, + VARIANT *pReturnValue, + EXCEPINFO *pExcepInfo, + UINT *pArgErr) +{ + return m_dispatchImpl.invoke( + dispid, + iid, + lcid, + wFlags, + pDispParams, + pReturnValue, + pExcepInfo, + pArgErr); +} diff --git a/src/DispatchAdapter.h b/src/DispatchAdapter.h new file mode 100644 index 0000000..f09544a --- /dev/null +++ b/src/DispatchAdapter.h @@ -0,0 +1,52 @@ +// $Id: DispatchAdapter.h 14 2005-04-18 14:14:12Z cthuang $ +#ifndef DISPATCHADAPTER_H +#define DISPATCHADAPTER_H + +#include "tcomApi.h" +#include "DispatchImpl.h" + +// This class implements an IDispatch interface and delegates the operations to +// the ComObject class. + +class TCOM_API DispatchAdapter: public IDispatch +{ + // provides IDispatch implementation + DispatchImpl m_dispatchImpl; + + // not implemented + DispatchAdapter(const DispatchAdapter &); + void operator=(const DispatchAdapter &); + +public: + DispatchAdapter ( + ComObject &object, + const Interface &interfaceDesc): + m_dispatchImpl(object, interfaceDesc) + { } + + // IUnknown functions + STDMETHODIMP QueryInterface(REFIID iid, void **ppvObj); + STDMETHODIMP_(ULONG) AddRef(); + STDMETHODIMP_(ULONG) Release(); + + // IDispatch functions + STDMETHODIMP GetTypeInfoCount(UINT *pctinfo); + STDMETHODIMP GetTypeInfo(UINT itinfo, LCID lcid, ITypeInfo **pptinfo); + STDMETHODIMP GetIDsOfNames( + REFIID iid, + OLECHAR **rgszNames, + UINT cNames, + LCID lcid, + DISPID *rgdispid); + STDMETHODIMP Invoke( + DISPID dispidMember, + REFIID iid, + LCID lcid, + WORD flags, + DISPPARAMS *pParams, + VARIANT *pResult, + EXCEPINFO *pExcepInfo, + UINT *pArgErr); +}; + +#endif diff --git a/src/DispatchImpl.cpp b/src/DispatchImpl.cpp new file mode 100644 index 0000000..02f544b --- /dev/null +++ b/src/DispatchImpl.cpp @@ -0,0 +1,66 @@ +// $Id: DispatchImpl.cpp 14 2005-04-18 14:14:12Z cthuang $ +#pragma warning(disable: 4786) +#include "DispatchImpl.h" +#include +#include "ComObject.h" + +DispatchImpl::DispatchImpl ( + ComObject &object, + const Interface &interfaceDesc): + m_object(object), + m_interface(interfaceDesc) +{ + // Initialize dispatch member ID to method description map. + const Interface::Methods &methods = m_interface.methods(); + for (Interface::Methods::const_iterator pMethod = methods.begin(); + pMethod != methods.end(); ++pMethod) { + m_dispIdToMethodMap.insert(DispIdToMethodMap::value_type( + pMethod->memberid(), &(*pMethod))); + } + + // Initialize set of property dispatch member ID's. + const Interface::Properties &properties = m_interface.properties(); + for (Interface::Properties::const_iterator pProp = properties.begin(); + pProp != properties.end(); ++pProp) { + m_propertyDispIds.insert(pProp->memberid()); + } +} + +const Method * +DispatchImpl::findDispatchMethod (DISPID dispid) +{ + DispIdToMethodMap::const_iterator p = m_dispIdToMethodMap.find(dispid); + if (p == m_dispIdToMethodMap.end()) { + return 0; + } + return p->second; +} + +HRESULT +DispatchImpl::invoke ( + DISPID dispid, + REFIID iid, + LCID lcid, + WORD wFlags, + DISPPARAMS *pDispParams, + VARIANT *pReturnValue, + EXCEPINFO *pExcepInfo, + UINT *pArgErr) +{ + // Get the method description for method being invoked. + const Method *pMethod = findDispatchMethod(dispid); + if (pMethod == 0) { + return DISP_E_MEMBERNOTFOUND; + } + + return m_object.invoke( + *pMethod, + isProperty(dispid), + iid, + lcid, + wFlags, + pDispParams, + pReturnValue, + pExcepInfo, + pArgErr); +} diff --git a/src/DispatchImpl.h b/src/DispatchImpl.h new file mode 100644 index 0000000..275d436 --- /dev/null +++ b/src/DispatchImpl.h @@ -0,0 +1,67 @@ +// $Id: DispatchImpl.h 14 2005-04-18 14:14:12Z cthuang $ +#ifndef DISPATCHIMPL_H +#define DISPATCHIMPL_H + +#include +#include +#include "tcomApi.h" +#include "TypeInfo.h" + +class TCOM_API ComObject; + +// This class implements an IDispatch interface and delegates the operations to +// the ComObject class. + +class TCOM_API DispatchImpl +{ + // delegate operations to this object + ComObject &m_object; + + // description of the interface to implement + const Interface &m_interface; + + // dispatch member ID to method description map + typedef std::map DispIdToMethodMap; + DispIdToMethodMap m_dispIdToMethodMap; + + // dispatch member ID's which are actually properties + typedef std::set DispIdSet; + DispIdSet m_propertyDispIds; + + // not implemented + DispatchImpl(const DispatchImpl &); + void operator=(const DispatchImpl &); + + // Get dispatch method description. + const Method *findDispatchMethod(DISPID dispid); + + // Return true if the dispatch member ID identifies a property. + bool isProperty (DISPID dispid) const + { return m_propertyDispIds.count(dispid) != 0; } + +public: + DispatchImpl( + ComObject &object, + const Interface &interfaceDesc); + + // Get object for delegating operations. + ComObject &object () const + { return m_object; } + + // Get ITypeInfo for the interface that is implemented. + ITypeInfo *typeInfo () const + { return m_interface.typeInfo(); } + + // Implement IDispatch::Invoke function. + HRESULT invoke( + DISPID dispidMember, + REFIID iid, + LCID lcid, + WORD flags, + DISPPARAMS *pParams, + VARIANT *pResult, + EXCEPINFO *pExcepInfo, + UINT *pArgErr); +}; + +#endif diff --git a/src/Extension.cpp b/src/Extension.cpp index 85d4abe..01c2037 100644 --- a/src/Extension.cpp +++ b/src/Extension.cpp @@ -1,4 +1,4 @@ -// $Id: Extension.cpp,v 1.3 2003/04/02 22:46:51 cthuang Exp $ +// $Id: Extension.cpp 5 2005-02-16 14:57:24Z cthuang $ #pragma warning(disable: 4786) #include "Extension.h" #include "ComModule.h" diff --git a/src/Extension.h b/src/Extension.h index 7eb7116..a354e98 100644 --- a/src/Extension.h +++ b/src/Extension.h @@ -1,4 +1,4 @@ -// $Id: Extension.h,v 1.5 2003/04/02 22:46:51 cthuang Exp $ +// $Id: Extension.h 5 2005-02-16 14:57:24Z cthuang $ #ifndef EXTENSION_H #define EXTENSION_H diff --git a/src/HandleSupport.cpp b/src/HandleSupport.cpp index d4d75df..a1a5d52 100644 --- a/src/HandleSupport.cpp +++ b/src/HandleSupport.cpp @@ -1,4 +1,4 @@ -// $Id: HandleSupport.cpp,v 1.19 2003/07/17 22:33:31 cthuang Exp $ +// $Id: HandleSupport.cpp 5 2005-02-16 14:57:24Z cthuang $ #include "HandleSupport.h" #include #include "ThreadLocalStorage.h" diff --git a/src/HandleSupport.h b/src/HandleSupport.h index d96a1fb..d3a8d2d 100644 --- a/src/HandleSupport.h +++ b/src/HandleSupport.h @@ -1,4 +1,4 @@ -// $Id: HandleSupport.h,v 1.29 2003/07/17 22:33:31 cthuang Exp $ +// $Id: HandleSupport.h 5 2005-02-16 14:57:24Z cthuang $ #ifndef HANDLESUPPORT_H #define HANDLESUPPORT_H diff --git a/src/HashTable.h b/src/HashTable.h index 120b029..25f6949 100644 --- a/src/HashTable.h +++ b/src/HashTable.h @@ -1,4 +1,4 @@ -// $Id: HashTable.h,v 1.22 2003/07/17 22:33:31 cthuang Exp $ +// $Id: HashTable.h 5 2005-02-16 14:57:24Z cthuang $ #ifndef HASHTABLE_H #define HASHTABLE_H diff --git a/src/InterfaceAdapter.cpp b/src/InterfaceAdapter.cpp index f1117e3..1b644f2 100644 --- a/src/InterfaceAdapter.cpp +++ b/src/InterfaceAdapter.cpp @@ -1,43 +1,28 @@ -// $Id: InterfaceAdapter.cpp,v 1.3 2002/02/27 01:58:45 cthuang Exp $ +// $Id: InterfaceAdapter.cpp 16 2005-04-19 14:47:52Z cthuang $ +#ifdef TCOM_VTBL_SERVER + #pragma warning(disable: 4786) -#include "ComObject.h" #include "InterfaceAdapter.h" +#include "ComObject.h" InterfaceAdapter::InterfaceAdapter ( ComObject &object, const Interface &interfaceDesc, bool forceDispatch): - m_object(object), - m_interface(interfaceDesc) + m_dispatchImpl(object, interfaceDesc) { // Initialize virtual function index to method description map. - const Interface::Methods &methods = m_interface.methods(); + const Interface::Methods &methods = interfaceDesc.methods(); for (Interface::Methods::const_iterator p = methods.begin(); p != methods.end(); ++p) { m_vtblIndexToMethodMap.insert(VtblIndexToMethodMap::value_type( p->vtblIndex(), &(*p))); } - if (m_interface.dispatchable() || forceDispatch) { - m_pVtbl = dispatchVtbl; - - // Initialize dispatch member ID to method description map. - const Interface::Methods &methods = m_interface.methods(); - for (Interface::Methods::const_iterator pMethod = methods.begin(); - pMethod != methods.end(); ++pMethod) { - m_dispIdToMethodMap.insert(DispIdToMethodMap::value_type( - pMethod->memberid(), &(*pMethod))); - } - - // Initialize set of property dispatch member ID's. - const Interface::Properties &properties = m_interface.properties(); - for (Interface::Properties::const_iterator pProp = properties.begin(); - pProp != properties.end(); ++pProp) { - m_propertyDispIds.insert(pProp->memberid()); - } - + if (interfaceDesc.dispatchable() || forceDispatch) { + m_pVtbl = dualVtbl; } else { - m_pVtbl = unknownVtbl; + m_pVtbl = customVtbl; } } @@ -52,35 +37,25 @@ InterfaceAdapter::findComMethod (int funcIndex) return p->second; } -const Method * -InterfaceAdapter::findDispatchMethod (DISPID dispid) -{ - DispIdToMethodMap::const_iterator p = m_dispIdToMethodMap.find(dispid); - if (p == m_dispIdToMethodMap.end()) { - return 0; - } - return p->second; -} - // Implement IUnknown methods STDMETHODIMP InterfaceAdapter::QueryInterface ( InterfaceAdapter *pThis, REFIID iid, void **ppvObj) { - return pThis->m_object.queryInterface(iid, ppvObj); + return pThis->m_dispatchImpl.object().queryInterface(iid, ppvObj); } STDMETHODIMP_(ULONG) InterfaceAdapter::AddRef (InterfaceAdapter *pThis) { - return pThis->m_object.addRef(); + return pThis->m_dispatchImpl.object().addRef(); } STDMETHODIMP_(ULONG) InterfaceAdapter::Release (InterfaceAdapter *pThis) { - return pThis->m_object.release(); + return pThis->m_dispatchImpl.object().release(); } // Implement IDispatch methods @@ -101,7 +76,7 @@ InterfaceAdapter::GetTypeInfo ( return DISP_E_BADINDEX; } - ITypeInfo *pTypeInfo = pThis->m_interface.typeInfo(); + ITypeInfo *pTypeInfo = pThis->m_dispatchImpl.typeInfo(); pTypeInfo->AddRef(); *ppTypeInfo = pTypeInfo; return S_OK; @@ -116,7 +91,7 @@ InterfaceAdapter::GetIDsOfNames ( LCID, DISPID *rgDispId) { - ITypeInfo *pTypeInfo = pThis->m_interface.typeInfo(); + ITypeInfo *pTypeInfo = pThis->m_dispatchImpl.typeInfo(); return pTypeInfo->GetIDsOfNames(rgszNames, cNames, rgDispId); } @@ -132,8 +107,7 @@ InterfaceAdapter::Invoke ( EXCEPINFO *pExcepInfo, UINT *pArgErr) { - return pThis->m_object.invoke( - pThis, + return pThis->m_dispatchImpl.invoke( dispid, iid, lcid, @@ -143,3 +117,5 @@ InterfaceAdapter::Invoke ( pExcepInfo, pArgErr); } + +#endif diff --git a/src/InterfaceAdapter.h b/src/InterfaceAdapter.h index 19bc8e0..6d6b330 100644 --- a/src/InterfaceAdapter.h +++ b/src/InterfaceAdapter.h @@ -1,11 +1,11 @@ -// $Id: InterfaceAdapter.h,v 1.3 2002/02/27 01:58:45 cthuang Exp $ +// $Id: InterfaceAdapter.h 16 2005-04-19 14:47:52Z cthuang $ #ifndef INTERFACEADAPTER_H #define INTERFACEADAPTER_H #include #include #include "tcomApi.h" -#include "TypeInfo.h" +#include "DispatchImpl.h" class TCOM_API ComObject; @@ -22,31 +22,21 @@ class TCOM_API InterfaceAdapter const void *m_pVtbl; // delegate operations to this object - ComObject &m_object; - - // description of the interface to implement - const Interface &m_interface; + DispatchImpl m_dispatchImpl; // virtual function index to method description map typedef std::map VtblIndexToMethodMap; VtblIndexToMethodMap m_vtblIndexToMethodMap; - // dispatch member ID to method description map - typedef std::map DispIdToMethodMap; - DispIdToMethodMap m_dispIdToMethodMap; - - // dispatch member ID's which are actually properties - typedef std::set DispIdSet; - DispIdSet m_propertyDispIds; - - // virtual function table for IUnknown derived interfaces - static const void *unknownVtbl[]; + // virtual function table for custom (IUnknown derived) interfaces + static const void *customVtbl[]; - // virtual function table for IDispatch derived interfaces - static const void *dispatchVtbl[]; + // virtual function table for dual (IDispatch derived) interfaces + static const void *dualVtbl[]; - InterfaceAdapter(const InterfaceAdapter &); // not implemented - void operator=(const InterfaceAdapter &); // not implemented + // not implemented + InterfaceAdapter(const InterfaceAdapter &); + void operator=(const InterfaceAdapter &); public: InterfaceAdapter( @@ -56,18 +46,11 @@ public: // Get delegate object. ComObject &object () const - { return m_object; } + { return m_dispatchImpl.object(); } // Get COM method description. const Method *findComMethod(int funcIndex); - // Get dispatch method description. - const Method *findDispatchMethod(DISPID dispid); - - // Return true if the dispatch member ID identifies a property. - bool isProperty (DISPID dispid) const - { return m_propertyDispIds.count(dispid) != 0; } - // IUnknown implementation static STDMETHODIMP QueryInterface( InterfaceAdapter *pThis, REFIID iid, void **ppvObj); diff --git a/src/InterfaceAdapterVtbl.cpp b/src/InterfaceAdapterVtbl.cpp index 896f36d..8ab5ce5 100644 --- a/src/InterfaceAdapterVtbl.cpp +++ b/src/InterfaceAdapterVtbl.cpp @@ -1,4 +1,6 @@ -// $Id: InterfaceAdapterVtbl.cpp,v 1.3 2001/10/13 17:56:14 Administrator Exp $ +// $Id: InterfaceAdapterVtbl.cpp 16 2005-04-19 14:47:52Z cthuang $ +#ifdef TCOM_VTBL_SERVER + #pragma warning(disable: 4786) #include "InterfaceAdapter.h" #include "ComObject.h" @@ -1076,7 +1078,7 @@ FUNCTION_ENTRY_POINT(1021) FUNCTION_ENTRY_POINT(1022) FUNCTION_ENTRY_POINT(1023) -const void *InterfaceAdapter::unknownVtbl[] = { +const void *InterfaceAdapter::customVtbl[] = { InterfaceAdapter::QueryInterface, InterfaceAdapter::AddRef, InterfaceAdapter::Release, @@ -2103,7 +2105,7 @@ const void *InterfaceAdapter::unknownVtbl[] = { function_1023 }; -const void *InterfaceAdapter::dispatchVtbl[] = { +const void *InterfaceAdapter::dualVtbl[] = { InterfaceAdapter::QueryInterface, InterfaceAdapter::AddRef, InterfaceAdapter::Release, @@ -3129,3 +3131,5 @@ const void *InterfaceAdapter::dispatchVtbl[] = { function_1022, function_1023 }; + +#endif diff --git a/src/Makefile b/src/Makefile index 9c9c309..5d9375e 100644 --- a/src/Makefile +++ b/src/Makefile @@ -1,4 +1,4 @@ -# $Id: Makefile,v 1.12 2003/07/24 22:46:35 cthuang Exp $ +# $Id: Makefile 5 2005-02-16 14:57:24Z cthuang $ debug: tclsh &&| diff --git a/src/NativeValue.cpp b/src/NativeValue.cpp new file mode 100644 index 0000000..b171e9a --- /dev/null +++ b/src/NativeValue.cpp @@ -0,0 +1,12 @@ +// $Id: NativeValue.cpp 5 2005-02-16 14:57:24Z cthuang $ +#include "NativeValue.h" + +void +NativeValue::fixInvalidVariantType () +{ + if (vt == VT_I8 || vt == VT_UI8) { + // 64-bit integers are not valid VARIANT types. Change the VARIANT + // type to something valid so VariantClear does not return an error. + vt = VT_EMPTY; + } +} diff --git a/src/NativeValue.h b/src/NativeValue.h new file mode 100644 index 0000000..8e8df33 --- /dev/null +++ b/src/NativeValue.h @@ -0,0 +1,25 @@ +// $Id: NativeValue.h 5 2005-02-16 14:57:24Z cthuang $ +#ifndef NATIVEVALUE_H +#define NATIVEVALUE_H + +#include + +// This is a value in the native machine format. + +class NativeValue: public _variant_t +{ +public: + NativeValue () + { } + + ~NativeValue () + { fixInvalidVariantType(); } + + NativeValue &operator= (const _variant_t &rhs) + { _variant_t::operator=(rhs); return *this; } + + // Change the variant type if it is invalid. + void fixInvalidVariantType(); +}; + +#endif diff --git a/src/Reference.cpp b/src/Reference.cpp index 9a7f448..3e21047 100644 --- a/src/Reference.cpp +++ b/src/Reference.cpp @@ -1,4 +1,4 @@ -// $Id: Reference.cpp,v 1.73 2003/11/06 15:29:01 cthuang Exp $ +// $Id: Reference.cpp 5 2005-02-16 14:57:24Z cthuang $ #pragma warning(disable: 4786) #include #include "ComObject.h" @@ -231,6 +231,8 @@ Reference::invokeDispatch ( if (hr == DISP_E_EXCEPTION) { throwDispatchException(excepInfo); + } else if (hr == DISP_E_TYPEMISMATCH || hr == DISP_E_PARAMNOTFOUND) { + throw InvokeException(hr, pParams->cArgs - argErr); } return hr; @@ -264,6 +266,8 @@ Reference::invoke (MEMBERID memberid, if (hr == DISP_E_EXCEPTION) { throwDispatchException(excepInfo); + } else if (hr == DISP_E_TYPEMISMATCH || hr == DISP_E_PARAMNOTFOUND) { + throw InvokeException(hr, arguments.dispParams()->cArgs - argErr); } } diff --git a/src/Reference.h b/src/Reference.h index fc46931..003b8f1 100644 --- a/src/Reference.h +++ b/src/Reference.h @@ -1,4 +1,4 @@ -// $Id: Reference.h,v 1.42 2003/11/06 15:29:01 cthuang Exp $ +// $Id: Reference.h 5 2005-02-16 14:57:24Z cthuang $ #ifndef REFERENCE_H #define REFERENCE_H @@ -29,6 +29,26 @@ public: { return m_description; } }; +// Throw this exception when invoke returns error about an argument. + +class InvokeException +{ + HRESULT m_hresult; + unsigned m_argIndex; + +public: + InvokeException (HRESULT hresult, unsigned argIndex): + m_hresult(hresult), + m_argIndex(argIndex) + { } + + HRESULT hresult () const + { return m_hresult; } + + unsigned argIndex () const + { return m_argIndex; } +}; + // This class holds an interface pointer and the interface description needed // to invoke methods on it. diff --git a/src/RegistryKey.cpp b/src/RegistryKey.cpp index 4a9f3be..02aeb7a 100644 --- a/src/RegistryKey.cpp +++ b/src/RegistryKey.cpp @@ -1,4 +1,4 @@ -// $Id: RegistryKey.cpp,v 1.6 2001/11/28 16:10:57 cthuang Exp $ +// $Id: RegistryKey.cpp 5 2005-02-16 14:57:24Z cthuang $ #include "RegistryKey.h" void diff --git a/src/RegistryKey.h b/src/RegistryKey.h index e1b06da..819ae6d 100644 --- a/src/RegistryKey.h +++ b/src/RegistryKey.h @@ -1,4 +1,4 @@ -// $Id: RegistryKey.h,v 1.5 2001/11/28 16:10:57 cthuang Exp $ +// $Id: RegistryKey.h 5 2005-02-16 14:57:24Z cthuang $ #ifndef REGISTRYKEY_H #define REGISTRYKEY_H diff --git a/src/Singleton.h b/src/Singleton.h index 7a6543a..078d93d 100644 --- a/src/Singleton.h +++ b/src/Singleton.h @@ -1,4 +1,4 @@ -// $Id: Singleton.h,v 1.9 2002/04/13 03:53:56 cthuang Exp $ +// $Id: Singleton.h 5 2005-02-16 14:57:24Z cthuang $ #ifndef SINGLETON_H #define SINGLETON_H diff --git a/src/SupportErrorInfo.cpp b/src/SupportErrorInfo.cpp index e2dd645..a8e132c 100644 --- a/src/SupportErrorInfo.cpp +++ b/src/SupportErrorInfo.cpp @@ -1,4 +1,4 @@ -// $Id: SupportErrorInfo.cpp,v 1.3 2001/07/17 02:24:08 cthuang Exp $ +// $Id: SupportErrorInfo.cpp 5 2005-02-16 14:57:24Z cthuang $ #include "ComObject.h" #include "SupportErrorInfo.h" diff --git a/src/SupportErrorInfo.h b/src/SupportErrorInfo.h index 40d94b5..806049f 100644 --- a/src/SupportErrorInfo.h +++ b/src/SupportErrorInfo.h @@ -1,4 +1,4 @@ -// $Id: SupportErrorInfo.h,v 1.3 2001/07/17 02:24:08 cthuang Exp $ +// $Id: SupportErrorInfo.h 5 2005-02-16 14:57:24Z cthuang $ #ifndef SUPPORTERRORINFO_H #define SUPPORTERRORINFO_H diff --git a/src/TclInterp.cpp b/src/TclInterp.cpp index 0a2f93a..6e9aa0d 100644 --- a/src/TclInterp.cpp +++ b/src/TclInterp.cpp @@ -1,4 +1,4 @@ -// $Id: TclInterp.cpp,v 1.12 2002/04/13 03:53:56 cthuang Exp $ +// $Id: TclInterp.cpp 5 2005-02-16 14:57:24Z cthuang $ #include #include "RegistryKey.h" #include "TclObject.h" diff --git a/src/TclInterp.h b/src/TclInterp.h index bbfa522..350695c 100644 --- a/src/TclInterp.h +++ b/src/TclInterp.h @@ -1,4 +1,4 @@ -// $Id: TclInterp.h,v 1.8 2002/04/13 03:53:56 cthuang Exp $ +// $Id: TclInterp.h 5 2005-02-16 14:57:24Z cthuang $ #ifndef TCLINTERP_H #define TCLINTERP_H diff --git a/src/TclModule.cpp b/src/TclModule.cpp index 3a4f05c..7c85136 100644 --- a/src/TclModule.cpp +++ b/src/TclModule.cpp @@ -1,4 +1,4 @@ -// $Id: TclModule.cpp,v 1.5 2002/04/13 03:53:56 cthuang Exp $ +// $Id: TclModule.cpp 5 2005-02-16 14:57:24Z cthuang $ #pragma warning(disable: 4786) #include "TclObject.h" #include "TclModule.h" diff --git a/src/TclModule.h b/src/TclModule.h index af95d6b..3709765 100644 --- a/src/TclModule.h +++ b/src/TclModule.h @@ -1,4 +1,4 @@ -// $Id: TclModule.h,v 1.4 2002/04/13 03:53:56 cthuang Exp $ +// $Id: TclModule.h 5 2005-02-16 14:57:24Z cthuang $ #ifndef TCLMODULE_H #define TCLMODULE_H diff --git a/src/TclObject.cpp b/src/TclObject.cpp index 8c24d8a..2a924b6 100644 --- a/src/TclObject.cpp +++ b/src/TclObject.cpp @@ -1,4 +1,4 @@ -// $Id: TclObject.cpp,v 1.35 2003/05/12 23:30:43 cthuang Exp $ +// $Id: TclObject.cpp 18 2005-05-03 00:40:40Z cthuang $ #include "TclObject.h" #include #ifdef WIN32 @@ -158,7 +158,7 @@ TclObject::lappend (Tcl_Obj *pElement) static Tcl_Obj * convertFromSafeArray ( SAFEARRAY *psa, - VARTYPE vt, + VARTYPE elementType, unsigned dim, long *pIndices, const Type &type, @@ -185,14 +185,14 @@ convertFromSafeArray ( 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_Obj *pElement = convertFromSafeArray( + psa, elementType, dim + 1, pIndices, type, interp); Tcl_ListObjAppendElement(interp, pResult, pElement); } return pResult; } - if (vt == VT_UI1 && SafeArrayGetDim(psa) == 1) { + if (elementType == VT_UI1 && SafeArrayGetDim(psa) == 1) { unsigned char *pData; hr = SafeArrayAccessData(psa, reinterpret_cast(&pData)); if (FAILED(hr)) { @@ -218,14 +218,14 @@ convertFromSafeArray ( // Create list of Tcl values. pResult = Tcl_NewListObj(0, 0); for (long i = lowerBound; i <= upperBound; ++i) { - _variant_t elementVar; + NativeValue elementVar; pIndices[dim - 1] = i; - if (vt == VT_VARIANT) { + if (elementType == VT_VARIANT) { hr = SafeArrayGetElement(psa, pIndices, &elementVar); } else { // I hope the element can be contained in a VARIANT. - V_VT(&elementVar) = vt; + V_VT(&elementVar) = elementType; hr = SafeArrayGetElement(psa, pIndices, &elementVar.punkVal); } if (FAILED(hr)) { @@ -284,8 +284,8 @@ fillSafeArray ( } else { for (int i = 0; i < numElements; ++i) { TclObject element(pElements[i]); - _variant_t elementVar; - element.toVariant(&elementVar, Type::variant(), interp, addRef); + NativeValue elementVar; + element.toNativeValue(&elementVar, Type::variant(), interp, addRef); pIndices[dim1] = i; hr = SafeArrayPutElement(psa, pIndices, &elementVar); @@ -296,15 +296,28 @@ fillSafeArray ( } } +static Tcl_Obj * +convertFromUnknown (IUnknown *pUnknown, REFIID iid, Tcl_Interp *interp) +{ + if (pUnknown == 0) { + return Tcl_NewObj(); + } + + const Interface *pInterface = InterfaceManager::instance().find(iid); + return Extension::referenceHandles.newObj( + interp, + Reference::newReference(pUnknown, pInterface)); +} + 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; + if (V_ISARRAY(pSrc)) { + SAFEARRAY *psa = V_ISBYREF(pSrc) ? *V_ARRAYREF(pSrc) : V_ARRAY(pSrc); + VARTYPE elementType = V_VT(pSrc) & VT_TYPEMASK; unsigned numDimensions = SafeArrayGetDim(psa); std::vector indices(numDimensions); m_pObj = convertFromSafeArray( - psa, vt, 1, &indices[0], type, interp); + psa, elementType, 1, &indices[0], type, interp); } else if (vtMissing == pSrc) { m_pObj = Extension::newNaObj(); @@ -315,6 +328,10 @@ TclObject::TclObject (VARIANT *pSrc, const Type &type, Tcl_Interp *interp) m_pObj = Tcl_NewBooleanObj(V_BOOL(pSrc)); break; + case VT_ERROR: + m_pObj = Tcl_NewLongObj(V_ERROR(pSrc)); + break; + case VT_I1: case VT_UI1: m_pObj = Tcl_NewLongObj(V_I1(pSrc)); @@ -332,6 +349,13 @@ TclObject::TclObject (VARIANT *pSrc, const Type &type, Tcl_Interp *interp) m_pObj = Tcl_NewLongObj(V_I4(pSrc)); break; +#ifdef V_I8 + case VT_I8: + case VT_UI8: + m_pObj = Tcl_NewWideIntObj(V_I8(pSrc)); + break; +#endif + case VT_R4: m_pObj = Tcl_NewDoubleObj(V_R4(pSrc)); break; @@ -342,27 +366,25 @@ 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( - interp, - Reference::newReference(V_DISPATCH(pSrc), pInterface)); - } + m_pObj = convertFromUnknown(V_DISPATCH(pSrc), type.iid(), interp); + break; + + case VT_DISPATCH | VT_BYREF: + m_pObj = convertFromUnknown( + (V_DISPATCHREF(pSrc) != 0) ? *V_DISPATCHREF(pSrc) : 0, + type.iid(), + 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( - interp, - Reference::newReference(V_UNKNOWN(pSrc), pInterface)); - } + m_pObj = convertFromUnknown(V_UNKNOWN(pSrc), type.iid(), interp); + break; + + case VT_UNKNOWN | VT_BYREF: + m_pObj = convertFromUnknown( + (V_UNKNOWNREF(pSrc) != 0) ? *V_UNKNOWNREF(pSrc) : 0, + type.iid(), + interp); break; case VT_NULL: @@ -392,6 +414,10 @@ TclObject::TclObject (VARIANT *pSrc, const Type &type, Tcl_Interp *interp) m_pObj = Tcl_NewStringObj( const_cast(uuid.toString().c_str()), -1); } else { + if (V_VT(pSrc) == (VT_VARIANT | VT_BYREF)) { + pSrc = V_VARIANTREF(pSrc); + } + _bstr_t str(pSrc); #if TCL_MINOR_VERSION >= 2 // Uses Unicode function introduced in Tcl 8.2. @@ -408,6 +434,33 @@ TclObject::TclObject (VARIANT *pSrc, const Type &type, Tcl_Interp *interp) Tcl_IncrRefCount(m_pObj); } +TclObject::TclObject (const _bstr_t &src) +{ + if (src.length() > 0) { +#if TCL_MINOR_VERSION >= 2 + // Uses Unicode functions introduced in Tcl 8.2. + m_pObj = Tcl_NewUnicodeObj(src, -1); +#else + m_pObj = Tcl_NewStringObj(src, -1); +#endif + } else { + m_pObj = Tcl_NewObj(); + } + + Tcl_IncrRefCount(m_pObj); +} + +TclObject::TclObject ( + SAFEARRAY *psa, const Type &type, Tcl_Interp *interp) +{ + unsigned numDimensions = SafeArrayGetDim(psa); + std::vector indices(numDimensions); + m_pObj = convertFromSafeArray( + psa, type.elementType().vartype(), 1, &indices[0], type, interp); + + Tcl_IncrRefCount(m_pObj); +} + BSTR TclObject::getBSTR () const { @@ -453,6 +506,83 @@ newByteSafeArray (Tcl_Obj *pObj) } #endif +SAFEARRAY * +TclObject::getSafeArray (const Type &elementType, Tcl_Interp *interp) const +{ + SAFEARRAY *psa; + + 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); + } + + 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); + } + + 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_I2: + case VT_UI2: + static_cast(pData)[i] = value.getLong(); + 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); + } + } + + return psa; +} + void TclObject::toVariant (VARIANT *pDest, const Type &type, @@ -493,75 +623,10 @@ TclObject::toVariant (VARIANT *pDest, V_UNKNOWN(pDest) = pUnknown; } else if (vt == VT_SAFEARRAY) { - SAFEARRAY *psa; - const Type &elementType = type.elementType(); - - 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); - } - - 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); - } - - 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); - } - } + const Type &elementType = type.elementType(); V_VT(pDest) = VT_ARRAY | elementType.vartype(); - V_ARRAY(pDest) = psa; + V_ARRAY(pDest) = getSafeArray(elementType, interp); } else if (m_pObj->typePtr == TclTypes::listType()) { // Convert Tcl list to array of VARIANT. @@ -678,4 +743,26 @@ TclObject::toVariant (VARIANT *pDest, } } + +void +TclObject::toNativeValue (NativeValue *pDest, + const Type &type, + Tcl_Interp *interp, + bool addRef) +{ +#ifdef V_I8 + VARTYPE vt = type.vartype(); + if (vt == VT_I8 || vt == VT_UI8) { + pDest->fixInvalidVariantType(); + VariantClear(pDest); + V_VT(pDest) = vt; + Tcl_GetWideIntFromObj(interp, m_pObj, &V_I8(pDest)); + return; + } +#endif + + pDest->fixInvalidVariantType(); + toVariant(pDest, type, interp, addRef); +} + #endif diff --git a/src/TclObject.h b/src/TclObject.h index 9a71502..35c3cb2 100644 --- a/src/TclObject.h +++ b/src/TclObject.h @@ -1,9 +1,10 @@ -// $Id: TclObject.h,v 1.12 2002/04/12 02:55:28 cthuang Exp $ +// $Id: TclObject.h 16 2005-04-19 14:47:52Z cthuang $ #ifndef TCLOBJECT_H #define TCLOBJECT_H #ifdef WIN32 #include "TypeInfo.h" +#include "NativeValue.h" #endif #include #include @@ -101,12 +102,21 @@ public: TclObject &lappend(Tcl_Obj *pElement); #ifdef WIN32 - // Construct Tcl object from VARIANT value. + // Construct Tcl object from native machine value. TclObject( - VARIANT *pSrc, // VARIANT value to convert from + VARIANT *pSrc, // value to convert from const Type &type, // expected type for interface pointers Tcl_Interp *interp); + // Construct Tcl object from _bstr_t. + TclObject(const _bstr_t &src); + + // Construct Tcl object from SAFEARRAY. + TclObject( + SAFEARRAY *psa, // value to convert from + const Type &type, // array type + Tcl_Interp *interp); + // Convert Tcl object to VARIANT value. void toVariant( VARIANT *pDest, // converted value put here @@ -114,9 +124,20 @@ public: Tcl_Interp *interp, bool addRef=false); // call AddRef on interface pointer + // Convert Tcl object to native machine value. + void toNativeValue( + NativeValue *pDest, // converted value put here + const Type &type, // desired data type + Tcl_Interp *interp, + bool addRef=false); // call AddRef on interface pointer + // Get BSTR representation. Caller is responsible for freeing the // returned BSTR. BSTR getBSTR() const; + + // Get SAFEARRAY representation. Caller is responsible for freeing the + // returned array. + SAFEARRAY *getSafeArray(const Type &elementType, Tcl_Interp *interp) const; #endif }; diff --git a/src/TclScript.cpp b/src/TclScript.cpp index df52143..1f43bf1 100644 --- a/src/TclScript.cpp +++ b/src/TclScript.cpp @@ -1,4 +1,4 @@ -// $Id: TclScript.cpp,v 1.12 2003/04/02 22:46:51 cthuang Exp $ +// $Id: TclScript.cpp 5 2005-02-16 14:57:24Z cthuang $ #include "ActiveScriptError.h" #include "Reference.h" #include "TypeInfo.h" diff --git a/src/TclScriptVersion.rc b/src/TclScriptVersion.rc index 914a688..7208227 100644 --- a/src/TclScriptVersion.rc +++ b/src/TclScriptVersion.rc @@ -1,4 +1,4 @@ -// $Id: TclScriptVersion.rc,v 1.3 2002/04/27 18:15:24 cthuang Exp $ +// $Id: TclScriptVersion.rc 5 2005-02-16 14:57:24Z cthuang $ #include #include "version.h" #include "buildNumber.h" diff --git a/src/ThreadLocalStorage.h b/src/ThreadLocalStorage.h index 71770d1..804dc95 100644 --- a/src/ThreadLocalStorage.h +++ b/src/ThreadLocalStorage.h @@ -1,4 +1,4 @@ -// $Id: ThreadLocalStorage.h,v 1.1 2002/04/20 15:43:57 cthuang Exp $ +// $Id: ThreadLocalStorage.h 5 2005-02-16 14:57:24Z cthuang $ #ifndef THREADLOCALSTORAGE_H #define THREADLOCALSTORAGE_H diff --git a/src/TypeInfo.cpp b/src/TypeInfo.cpp index 39b5fda..04775ed 100644 --- a/src/TypeInfo.cpp +++ b/src/TypeInfo.cpp @@ -1,4 +1,4 @@ -// $Id: TypeInfo.cpp,v 1.58 2002/04/20 06:11:32 cthuang Exp $ +// $Id: TypeInfo.cpp 5 2005-02-16 14:57:24Z cthuang $ #pragma warning(disable: 4786) #include #include @@ -35,7 +35,7 @@ static VarTypeStringAssoc varTypeStringAssocs[] = { { VT_DATE, "DATE" }, { VT_BSTR, "BSTR" }, { VT_DISPATCH, "DISPATCH" }, - { VT_ERROR, "ERROR" }, + { VT_ERROR, "SCODE" }, { VT_BOOL, "BOOL" }, { VT_VARIANT, "VARIANT" }, { VT_UNKNOWN, "UNKNOWN" }, diff --git a/src/TypeInfo.h b/src/TypeInfo.h index 2794e1a..1dd13a2 100644 --- a/src/TypeInfo.h +++ b/src/TypeInfo.h @@ -1,4 +1,4 @@ -// $Id: TypeInfo.h,v 1.41 2002/04/20 06:11:32 cthuang Exp $ +// $Id: TypeInfo.h 5 2005-02-16 14:57:24Z cthuang $ #ifndef TYPEINFO_H #define TYPEINFO_H diff --git a/src/TypeLib.cpp b/src/TypeLib.cpp index 37f4591..8bc99ae 100644 --- a/src/TypeLib.cpp +++ b/src/TypeLib.cpp @@ -1,4 +1,4 @@ -// $Id: TypeLib.cpp,v 1.29 2002/03/09 16:40:24 cthuang Exp $ +// $Id: TypeLib.cpp 9 2005-04-07 14:14:37Z cthuang $ #pragma warning(disable: 4786) #include #include "RegistryKey.h" @@ -148,7 +148,7 @@ TypeLib::loadByLibid (const std::string &libidStr, const std::string &version) ITypeLibPtr pTypeLib; HRESULT hr = LoadRegTypeLib( - libid, majorVersion, minorVersion, LOCALE_USER_DEFAULT, &pTypeLib); + libid, majorVersion, minorVersion, LOCALE_NEUTRAL, &pTypeLib); if (FAILED(hr)) { _com_issue_error(hr); } diff --git a/src/TypeLib.h b/src/TypeLib.h index 8d989a1..417f4a3 100644 --- a/src/TypeLib.h +++ b/src/TypeLib.h @@ -1,4 +1,4 @@ -// $Id: TypeLib.h,v 1.21 2002/03/09 16:40:24 cthuang Exp $ +// $Id: TypeLib.h 5 2005-02-16 14:57:24Z cthuang $ #ifndef TYPELIB_H #define TYPELIB_H diff --git a/src/Uuid.cpp b/src/Uuid.cpp index a45e740..cbc0782 100644 --- a/src/Uuid.cpp +++ b/src/Uuid.cpp @@ -1,4 +1,4 @@ -// $Id: Uuid.cpp,v 1.2 2000/04/20 18:37:40 chuang Exp $ +// $Id: Uuid.cpp 5 2005-02-16 14:57:24Z cthuang $ #include "Uuid.h" std::string diff --git a/src/Uuid.h b/src/Uuid.h index ab01674..6aa1d21 100644 --- a/src/Uuid.h +++ b/src/Uuid.h @@ -1,4 +1,4 @@ -// $Id: Uuid.h,v 1.3 2000/04/28 19:37:53 chuang Exp $ +// $Id: Uuid.h 5 2005-02-16 14:57:24Z cthuang $ #ifndef UUID_H #define UUID_H diff --git a/src/bindCmd.cpp b/src/bindCmd.cpp index 7b0c253..80b80fa 100644 --- a/src/bindCmd.cpp +++ b/src/bindCmd.cpp @@ -1,4 +1,4 @@ -// $Id: bindCmd.cpp,v 1.53 2003/04/02 22:46:51 cthuang Exp $ +// $Id: bindCmd.cpp 13 2005-04-18 12:24:14Z cthuang $ #pragma warning(disable: 4786) #include "Extension.h" #include "Reference.h" diff --git a/src/buildNumber.h b/src/buildNumber.h index 7fe11cc..e5f4509 100644 --- a/src/buildNumber.h +++ b/src/buildNumber.h @@ -1 +1 @@ -#define BUILD_NUMBER 28 +#define BUILD_NUMBER 33 diff --git a/src/configureCmd.cpp b/src/configureCmd.cpp index 7e8ee1c..633e33d 100644 --- a/src/configureCmd.cpp +++ b/src/configureCmd.cpp @@ -1,4 +1,4 @@ -// $Id: configureCmd.cpp,v 1.7 2002/04/13 03:53:57 cthuang Exp $ +// $Id: configureCmd.cpp 5 2005-02-16 14:57:24Z cthuang $ #pragma warning(disable: 4786) #include "Extension.h" diff --git a/src/dllmain.cpp b/src/dllmain.cpp index 537d1c1..a88805f 100644 --- a/src/dllmain.cpp +++ b/src/dllmain.cpp @@ -1,4 +1,4 @@ -// $Id: dllmain.cpp,v 1.16 2002/07/14 18:42:57 cthuang Exp $ +// $Id: dllmain.cpp 5 2005-02-16 14:57:24Z cthuang $ #pragma warning(disable: 4786) #include "Uuid.h" #include "HandleSupport.h" diff --git a/src/dllserver.dsp b/src/dllserver.dsp index 34ad259..eb1662c 100644 --- a/src/dllserver.dsp +++ b/src/dllserver.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" /mktyplib203 /win32 # ADD BASE RSC /l 0x409 /d "NDEBUG" @@ -69,7 +69,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" /mktyplib203 /win32 # ADD BASE RSC /l 0x409 /d "_DEBUG" diff --git a/src/dllserverVersion.rc b/src/dllserverVersion.rc index 484be11..1de70de 100644 --- a/src/dllserverVersion.rc +++ b/src/dllserverVersion.rc @@ -1,4 +1,4 @@ -// $Id: dllserverVersion.rc,v 1.5 2002/04/27 18:15:24 cthuang Exp $ +// $Id: dllserverVersion.rc 5 2005-02-16 14:57:24Z cthuang $ #include #include "version.h" #include "buildNumber.h" diff --git a/src/exemain.cpp b/src/exemain.cpp index abd3919..0dee0b8 100644 --- a/src/exemain.cpp +++ b/src/exemain.cpp @@ -1,4 +1,4 @@ -// $Id: exemain.cpp,v 1.12 2002/07/14 18:42:57 cthuang Exp $ +// $Id: exemain.cpp 5 2005-02-16 14:57:24Z cthuang $ #pragma warning(disable: 4786) #include "TclModule.h" #include "tclRunTime.h" diff --git a/src/exeserverVersion.rc b/src/exeserverVersion.rc index 711106b..78753ce 100644 --- a/src/exeserverVersion.rc +++ b/src/exeserverVersion.rc @@ -1,4 +1,4 @@ -// $Id: exeserverVersion.rc,v 1.5 2002/04/27 18:15:24 cthuang Exp $ +// $Id: exeserverVersion.rc 5 2005-02-16 14:57:24Z cthuang $ #include #include "version.h" #include "buildNumber.h" diff --git a/src/foreachCmd.cpp b/src/foreachCmd.cpp index d61e3bb..f6e5758 100644 --- a/src/foreachCmd.cpp +++ b/src/foreachCmd.cpp @@ -1,4 +1,4 @@ -// $Id: foreachCmd.cpp,v 1.10 2002/05/31 04:03:06 cthuang Exp $ +// $Id: foreachCmd.cpp 5 2005-02-16 14:57:24Z cthuang $ #include "Extension.h" #include #include "Reference.h" diff --git a/src/importCmd.cpp b/src/importCmd.cpp index 2682c14..b3d5c8b 100644 --- a/src/importCmd.cpp +++ b/src/importCmd.cpp @@ -1,4 +1,4 @@ -// $Id: importCmd.cpp,v 1.26 2002/05/31 04:03:06 cthuang Exp $ +// $Id: importCmd.cpp 5 2005-02-16 14:57:24Z cthuang $ #pragma warning(disable: 4786) #include "Extension.h" #include diff --git a/src/infoCmd.cpp b/src/infoCmd.cpp index 2a3dffd..ac6fb14 100644 --- a/src/infoCmd.cpp +++ b/src/infoCmd.cpp @@ -1,4 +1,4 @@ -// $Id: infoCmd.cpp,v 1.31 2002/04/13 03:53:57 cthuang Exp $ +// $Id: infoCmd.cpp 5 2005-02-16 14:57:24Z cthuang $ #include "Extension.h" #include "TclObject.h" #include "Reference.h" diff --git a/src/main.cpp b/src/main.cpp index 160c515..eff5738 100644 --- a/src/main.cpp +++ b/src/main.cpp @@ -1,4 +1,4 @@ -// $Id: main.cpp,v 1.70 2002/07/14 18:42:57 cthuang Exp $ +// $Id: main.cpp 5 2005-02-16 14:57:24Z cthuang $ #pragma warning(disable: 4786) #include "ComModule.h" #include "Extension.h" diff --git a/src/mutex.h b/src/mutex.h index 3ee1f72..2e132a8 100644 --- a/src/mutex.h +++ b/src/mutex.h @@ -1,4 +1,4 @@ -// $Id: mutex.h,v 1.7 2002/04/13 03:53:57 cthuang Exp $ +// $Id: mutex.h 5 2005-02-16 14:57:24Z cthuang $ #ifndef MUTEX_H #define MUTEX_H diff --git a/src/naCmd.cpp b/src/naCmd.cpp index 8cc47b0..3283907 100644 --- a/src/naCmd.cpp +++ b/src/naCmd.cpp @@ -1,4 +1,4 @@ -// $Id: naCmd.cpp,v 1.7 2003/03/07 00:17:30 cthuang Exp $ +// $Id: naCmd.cpp 5 2005-02-16 14:57:24Z cthuang $ #include "Extension.h" #include diff --git a/src/nullCmd.cpp b/src/nullCmd.cpp index 28e669e..d268a20 100644 --- a/src/nullCmd.cpp +++ b/src/nullCmd.cpp @@ -1,4 +1,4 @@ -// $Id: nullCmd.cpp,v 1.10 2003/03/07 00:17:30 cthuang Exp $ +// $Id: nullCmd.cpp 5 2005-02-16 14:57:24Z cthuang $ #include "Extension.h" #include diff --git a/src/objectCmd.cpp b/src/objectCmd.cpp index 5dc9560..ca49314 100644 --- a/src/objectCmd.cpp +++ b/src/objectCmd.cpp @@ -1,4 +1,4 @@ -// $Id: objectCmd.cpp,v 1.31 2003/03/07 00:24:04 cthuang Exp $ +// $Id: objectCmd.cpp 5 2005-02-16 14:57:24Z cthuang $ #pragma warning(disable: 4786) #include "Extension.h" #include diff --git a/src/refCmd.cpp b/src/refCmd.cpp index eac808d..a21daef 100644 --- a/src/refCmd.cpp +++ b/src/refCmd.cpp @@ -1,4 +1,4 @@ -// $Id: refCmd.cpp,v 1.46 2003/11/06 15:29:01 cthuang Exp $ +// $Id: refCmd.cpp 16 2005-04-19 14:47:52Z cthuang $ #pragma warning(disable: 4786) #include "Extension.h" #include @@ -10,6 +10,8 @@ static int referenceObjCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); HandleSupport Extension::referenceHandles(referenceObjCmd); +static const char unknownErrorDescription[] = "Unknown error"; + // Check if the object implements ISupportErrorInfo. If it does, get the // error information. Return true if successful. @@ -36,6 +38,59 @@ getErrorInfo (Reference *pReference, IErrorInfo **ppErrorInfo) return GetErrorInfo(0, ppErrorInfo) == S_OK; } +// Get description text for an HRESULT. + +static Tcl_Obj * +formatMessage (HRESULT hresult) +{ +#if TCL_MINOR_VERSION >= 2 + // Uses Unicode functions introduced in Tcl 8.2. + wchar_t *pMessage; + DWORD nLen = FormatMessageW( + FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM, + NULL, + hresult, + 0, + reinterpret_cast(&pMessage), + 0, + NULL); +#else + char *pMessage; + DWORD nLen = FormatMessageA( + FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM, + NULL, + hresult, + 0, + reinterpret_cast(&pMessage), + 0, + NULL); +#endif + + Tcl_Obj *pDescription; + if (nLen > 0) { + if (nLen > 1 && pMessage[nLen - 1] == '\n') { + --nLen; + if (nLen > 1 && pMessage[nLen - 1] == '\r') { + --nLen; + } + } + pMessage[nLen] = '\0'; + + +#if TCL_MINOR_VERSION >= 2 + // Uses Unicode functions introduced in Tcl 8.2. + pDescription = Tcl_NewUnicodeObj(pMessage, nLen); +#else + pDescription = Tcl_NewStringObj(pMessage, nLen); +#endif + } else { + pDescription = Tcl_NewStringObj(unknownErrorDescription, -1); + } + LocalFree(pMessage); + + return pDescription; +} + // Set the Tcl errorCode variable and the Tcl interpreter result. // Returns TCL_ERROR. @@ -43,7 +98,7 @@ static int setErrorCodeAndResult ( Tcl_Interp *interp, HRESULT hresult, - const _bstr_t &description, + Tcl_Obj *pDescription, const char *file, int line) { @@ -60,13 +115,8 @@ setErrorCodeAndResult ( result.lappend(hrObj); // Append description. - const wchar_t *pWide = static_cast(description); - if (pWide == 0) { - pWide = L"Unknown error"; - } - TclObject descriptionObj(pWide); - errorCode.lappend(descriptionObj); - result.lappend(descriptionObj); + errorCode.lappend(pDescription); + result.lappend(pDescription); #ifndef NDEBUG // Append file and line number. @@ -81,45 +131,29 @@ setErrorCodeAndResult ( return TCL_ERROR; } +static int +setErrorCodeAndResult ( + Tcl_Interp *interp, + HRESULT hresult, + const _bstr_t &description, + const char *file, + int line) +{ + TclObject descriptionObj; + int length; + Tcl_GetStringFromObj(descriptionObj, &length); + if (length == 0) { + descriptionObj = Tcl_NewStringObj(unknownErrorDescription, -1); + } + return setErrorCodeAndResult(interp, hresult, descriptionObj, file, line); +} + int Extension::setComErrorResult ( Tcl_Interp *interp, _com_error &e, const char *file, int line) { - // Get description. - _bstr_t description; - -#if TCL_MINOR_VERSION >= 2 - // Uses Unicode functions introduced in Tcl 8.2. - wchar_t *pMessage; - DWORD nLen = FormatMessageW( - FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM, - NULL, - e.Error(), - 0, - reinterpret_cast(&pMessage), - 0, - NULL); - - if (nLen > 0) { - if (nLen > 1 && pMessage[nLen - 1] == '\n') { - --nLen; - if (nLen > 1 && pMessage[nLen - 1] == '\r') { - --nLen; - } - } - pMessage[nLen] = '\0'; - - description = _bstr_t(pMessage); - } else { - // FormatMessageW doesn't seem to work on Windows 95/98. - description = _bstr_t(e.ErrorMessage()); - } - LocalFree(pMessage); -#else - description = _bstr_t(e.ErrorMessage()); -#endif - - return setErrorCodeAndResult(interp, e.Error(), description, file, line); + return setErrorCodeAndResult( + interp, e.Error(), formatMessage(e.Error()), file, line); } // Invoke a method or property. @@ -135,7 +169,7 @@ invoke (Tcl_Interp *interp, WORD dispatchFlags) { // Set up return value. - _variant_t returnValue; + NativeValue returnValue; VARIANT *pReturnValue = (pMethod->type().vartype() == VT_VOID) ? 0 : &returnValue; @@ -286,7 +320,7 @@ invokeWithoutInterfaceDesc ( } // Set up return value. - _variant_t varReturnValue; + NativeValue varReturnValue; VARIANT *pReturnValue = (dispatchFlags & DISPATCH_PROPERTYPUT) ? 0 : &varReturnValue; @@ -339,10 +373,10 @@ referenceObjCmd ( int i = 1; for (; i < objc; ++i) { static char *options[] = { - "-get", "-method", "-namedarg", "-set", NULL + "-call", "-get", "-method", "-namedarg", "-set", NULL }; enum OptionEnum { - OPTION_GET, OPTION_METHOD, OPTION_NAMEDARG, OPTION_SET + OPTION_CALL, OPTION_GET, OPTION_METHOD, OPTION_NAMEDARG, OPTION_SET }; int index; @@ -352,12 +386,13 @@ referenceObjCmd ( } switch (index) { - case OPTION_GET: - dispatchFlags = DISPATCH_PROPERTYGET; - break; + case OPTION_CALL: case OPTION_METHOD: dispatchFlags = DISPATCH_METHOD; break; + case OPTION_GET: + dispatchFlags = DISPATCH_PROPERTYGET; + break; case OPTION_NAMEDARG: namedArgOpt = true; break; @@ -460,6 +495,18 @@ referenceObjCmd ( result = setErrorCodeAndResult( interp, e.scode(), e.description(), __FILE__, __LINE__); } + catch (InvokeException &e) { + std::ostringstream argOut; + argOut << "Argument " << e.argIndex() << ": "; + TclObject descriptionObj(argOut.str()); + + TclObject messageObj(formatMessage(e.hresult())); + Tcl_AppendObjToObj(descriptionObj, messageObj); + + result = setErrorCodeAndResult( + interp, e.hresult(), descriptionObj, __FILE__, __LINE__); + } + return result; } diff --git a/src/shortPathNameCmd.cpp b/src/shortPathNameCmd.cpp index a885e22..f0e5fe8 100644 --- a/src/shortPathNameCmd.cpp +++ b/src/shortPathNameCmd.cpp @@ -1,4 +1,4 @@ -// $Id: shortPathNameCmd.cpp,v 1.3 2002/04/13 03:53:57 cthuang Exp $ +// $Id: shortPathNameCmd.cpp 5 2005-02-16 14:57:24Z cthuang $ #include "Extension.h" #define WIN32_LEAN_AND_MEAN #include diff --git a/src/tclRunTime.h b/src/tclRunTime.h index 4c89f3c..3bac0cb 100644 --- a/src/tclRunTime.h +++ b/src/tclRunTime.h @@ -1,4 +1,4 @@ -// $Id: tclRunTime.h,v 1.1 2002/07/15 04:03:54 cthuang Exp $ +// $Id: tclRunTime.h 5 2005-02-16 14:57:24Z cthuang $ #ifndef TCLRUNTIME_H #define TCLRUNTIME_H diff --git a/src/tcom.dsp b/src/tcom.dsp index b05665d..e7cc1ee 100644 --- a/src/tcom.dsp +++ b/src/tcom.dsp @@ -45,7 +45,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 "TCOM_EXPORTS" /YX /FD /c -# ADD CPP /nologo /MD /W3 /GX /Zi /Od /I "\tcl\include" /D "NDEBUG" /D "_WIN32_DCOM" /D "WIN32" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "TCOM_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_DCOM" /D "WIN32" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "TCOM_EXPORTS" /D "TCOM_VTBL_SERVER" /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" /mktyplib203 /win32 # ADD BASE RSC /l 0x409 /d "NDEBUG" @@ -71,7 +71,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 "TCOM_EXPORTS" /YX /FD /GZ /c -# ADD CPP /nologo /MDd /W3 /Gm /GX /Zi /Od /I "\tcl\include" /D "_DEBUG" /D "_WIN32_DCOM" /D "WIN32" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "TCOM_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_DCOM" /D "WIN32" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "TCOM_EXPORTS" /D "TCOM_VTBL_SERVER" /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" /mktyplib203 /win32 # ADD BASE RSC /l 0x409 /d "_DEBUG" @@ -98,7 +98,7 @@ LINK32=link.exe # PROP Ignore_Export_Lib 0 # PROP Target_Dir "" # ADD BASE CPP /nologo /MT /W3 /GX /O2 /I "e:\tcl\include" /D "NDEBUG" /D "WIN32" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "TCOM_EXPORTS" /D "_WIN32_DCOM" /YX /FD /c -# ADD CPP /nologo /MD /W3 /GX /Zi /O2 /I "\tcl\include" /D "NDEBUG" /D "WIN32" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "TCOM_EXPORTS" /D "TCL_THREADS" /D "USE_TCL_STUBS" /D "USE_NON_CONST" /YX /FD /c +# ADD CPP /nologo /MD /W3 /GX /Zi /O2 /I "\tcl\include" /D "NDEBUG" /D "WIN32" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "TCOM_EXPORTS" /D "TCOM_VTBL_SERVER" /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" /mktyplib203 /win32 # ADD BASE RSC /l 0x409 /d "NDEBUG" @@ -125,7 +125,7 @@ LINK32=link.exe # PROP Ignore_Export_Lib 0 # PROP Target_Dir "" # ADD BASE CPP /nologo /MTd /W3 /Gm /GX /ZI /Od /I "c:\tcl\include" /D "_DEBUG" /D "WIN32" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "TCOM_EXPORTS" /D "_WIN32_DCOM" /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 "TCOM_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 "TCOM_EXPORTS" /D "TCOM_VTBL_SERVER" /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" /mktyplib203 /win32 # ADD BASE RSC /l 0x409 /d "_DEBUG" @@ -174,6 +174,14 @@ SOURCE=.\configureCmd.cpp # End Source File # Begin Source File +SOURCE=.\DispatchAdapter.cpp +# End Source File +# Begin Source File + +SOURCE=.\DispatchImpl.cpp +# End Source File +# Begin Source File + SOURCE=.\Extension.cpp # End Source File # Begin Source File @@ -210,6 +218,10 @@ SOURCE=.\naCmd.cpp # End Source File # Begin Source File +SOURCE=.\NativeValue.cpp +# End Source File +# Begin Source File + SOURCE=.\nullCmd.cpp # End Source File # Begin Source File @@ -286,6 +298,14 @@ SOURCE=.\ComObjectFactory.h # End Source File # Begin Source File +SOURCE=.\DispatchAdapter.h +# End Source File +# Begin Source File + +SOURCE=.\DispatchImpl.h +# End Source File +# Begin Source File + SOURCE=.\Extension.h # End Source File # Begin Source File @@ -306,6 +326,10 @@ SOURCE=.\mutex.h # End Source File # Begin Source File +SOURCE=.\NativeValue.h +# End Source File +# Begin Source File + SOURCE=.\Reference.h # End Source File # Begin Source File diff --git a/src/tcomApi.h b/src/tcomApi.h index 1cdd220..9f00bec 100644 --- a/src/tcomApi.h +++ b/src/tcomApi.h @@ -1,4 +1,4 @@ -// $Id: tcomApi.h,v 1.1 2000/04/22 21:39:36 chuang Exp $ +// $Id: tcomApi.h 5 2005-02-16 14:57:24Z cthuang $ #ifndef TCOMAPI_H #define TCOMAPI_H diff --git a/src/tcomVersion.rc b/src/tcomVersion.rc index 12e742b..9480528 100644 --- a/src/tcomVersion.rc +++ b/src/tcomVersion.rc @@ -1,4 +1,4 @@ -// $Id: tcomVersion.rc,v 1.5 2002/04/27 18:15:24 cthuang Exp $ +// $Id: tcomVersion.rc 5 2005-02-16 14:57:24Z cthuang $ #include #include "version.h" #include "buildNumber.h" diff --git a/src/typelibCmd.cpp b/src/typelibCmd.cpp index b5da966..58d00e0 100644 --- a/src/typelibCmd.cpp +++ b/src/typelibCmd.cpp @@ -1,4 +1,4 @@ -// $Id: typelibCmd.cpp,v 1.29 2002/04/13 03:53:57 cthuang Exp $ +// $Id: typelibCmd.cpp 5 2005-02-16 14:57:24Z cthuang $ #pragma warning(disable: 4786) #include "Extension.h" #include "TypeLib.h" diff --git a/src/variantCmd.cpp b/src/variantCmd.cpp index 51e5214..cbad50e 100644 --- a/src/variantCmd.cpp +++ b/src/variantCmd.cpp @@ -1,4 +1,4 @@ -// $Id: variantCmd.cpp,v 1.1 2003/05/29 03:33:08 cthuang Exp $ +// $Id: variantCmd.cpp 5 2005-02-16 14:57:24Z cthuang $ #include "Extension.h" #include diff --git a/src/version.h b/src/version.h index 5e98760..361a705 100644 --- a/src/version.h +++ b/src/version.h @@ -1,9 +1,9 @@ -// $Id: version.h,v 1.4 2002/10/01 21:51:32 cthuang Exp $ +// $Id: version.h 5 2005-02-16 14:57:24Z cthuang $ #ifndef VERSION_H #define VERSION_H #define PACKAGE_MAJOR_VERSION 3 -#define PACKAGE_MINOR_VERSION 9 +#define PACKAGE_MINOR_VERSION 10 #define MAKE_VERSION_STRING0(MAJOR,MINOR) #MAJOR "." #MINOR #define MAKE_VERSION_STRING(MAJOR,MINOR) MAKE_VERSION_STRING0(MAJOR,MINOR) diff --git a/tests/all.tcl b/tests/all.tcl index b2d4f9e..c25e0c3 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -1,4 +1,4 @@ -# $Id: all.tcl,v 1.1 2002/03/16 04:53:17 cthuang Exp $ +# $Id: all.tcl 5 2005-02-16 14:57:24Z cthuang $ # # This file contains a top-level script to run all of the tests. diff --git a/tests/array.test b/tests/array.test index 8a8f49b..d0f5c50 100644 --- a/tests/array.test +++ b/tests/array.test @@ -1,6 +1,6 @@ -# $Id: array.test,v 1.1 2003/05/12 23:31:03 cthuang Exp $ +# $Id: array.test 5 2005-02-16 14:57:24Z cthuang $ # -# This file contains tests for the passing arrays +# This file contains tests for passing arrays. if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/eval.test b/tests/eval.test index e55972b..c2ed8f8 100644 --- a/tests/eval.test +++ b/tests/eval.test @@ -1,6 +1,6 @@ -# $Id: eval.test,v 1.2 2003/04/02 22:57:35 cthuang Exp $ +# $Id: eval.test 5 2005-02-16 14:57:24Z cthuang $ # -# This file contains tests the robustness of handles under eval. +# This file tests the robustness of handles under eval. if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/foreach.test b/tests/foreach.test index f2935bf..6791a78 100644 --- a/tests/foreach.test +++ b/tests/foreach.test @@ -1,4 +1,4 @@ -# $Id: foreach.test,v 1.2 2003/03/07 00:01:40 cthuang Exp $ +# $Id: foreach.test 5 2005-02-16 14:57:24Z cthuang $ # # This file contains tests for the ::tcom::foreach command. diff --git a/tests/namedarg.test b/tests/namedarg.test index 21f718f..e3fa96f 100644 --- a/tests/namedarg.test +++ b/tests/namedarg.test @@ -1,4 +1,4 @@ -# $Id: namedarg.test,v 1.2 2003/04/02 22:57:35 cthuang Exp $ +# $Id: namedarg.test 5 2005-02-16 14:57:24Z cthuang $ # # This file contains tests invoking methods through IDispatch with named # arguments. diff --git a/tests/ref.test b/tests/ref.test index bf28e22..2b43a8e 100644 --- a/tests/ref.test +++ b/tests/ref.test @@ -1,4 +1,4 @@ -# $Id: ref.test,v 1.2 2002/06/29 15:44:21 cthuang Exp $ +# $Id: ref.test 13 2005-04-18 12:24:14Z cthuang $ # # This file contains tests for the ::tcom::ref command. @@ -34,7 +34,9 @@ test createobject-1.2 {::tcom::ref createobject, Banking example server} { package require tcom set bank [::tcom::ref createobject "Banking.Bank"] +# set bank [::tcom::ref querydispatch $bank] set account [$bank CreateAccount] +# set account [::tcom::ref querydispatch $account] $account Deposit 30 $account Withdraw 20 $account Balance

Tcl internal representation	VARIANT type
boolean	VT_BOOL
int	VT_I4
double	VT_R8
list	one-dimensional array of VT_VARIANT
bytearray	one-dimensional array of VT_UI1
other	VT_BSTR

COM Object Implementation in Tcl

Introduction

Write MIDL Specification

Create Type Library

Create Tcl Package

Register Server

Implement Client

Implement Objects In Plain Tcl

Name

Synopsis

Description

Commands

Importing Type Library Information

Commands

Enumerations

Tcl Value to VARIANT Mapping

Invoking Methods With VARIANT Parameters