From: Pat Thoyts Date: Thu, 29 Jan 2009 22:14:13 +0000 (+0000) Subject: import: tcom-3.8 import X-Git-Url: https://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=4a0f25c8f11962620f22bc613607a4ab06d1c082;p=tcom import: tcom-3.8 import --- 4a0f25c8f11962620f22bc613607a4ab06d1c082 diff --git a/CHANGES b/CHANGES new file mode 100644 index 0000000..1ce6379 --- /dev/null +++ b/CHANGES @@ -0,0 +1,217 @@ +Version 3.8 +- Fixed defect which prevented DISPATCH_PROPERTYPUTREF properties from being + set. +- Fixed defect which incorrectly decremented reference count of interface + pointers passed as method arguments. +- Fixed defect where only one argument was passed to methods marked with the + [vararg] attribute. +- Fixed defect with handling of [out] SAFEARRAY parameters. +- Implemented work around for access violation when ::tcom::import command + was used with Excel. +- Implemented work around for incorrect IDispatch implementation in Microsoft + Word. + +Version 3.7 +- Fixed access violation in ::tcom::foreach command. + +Version 3.6 +- Prevent race conditions when local server registers multiple class objects. +- Added work around for bogus type information returned from IDispatch + implemented by AutoDispatch in Microsoft .NET Framework. + +Version 3.5 +- Fixed defect where the code tried to invoke operations on pure dispatch + interfaces by calling through the virtual function table. + +Version 3.4 +- Added -inproc, -local and -remote options to "::tcom::ref createobject" + command. +- Fixed access violation when IDispatch objects return a null error + description. +- The "::tcom::object create" and "::tcom::object registerfactory" commands + accept the -registeractive option which registers the created COM object in + the running object table. +- Added -inproc and -local options to "::tcom::server register" command. + +Version 3.3 +- The "::tcom::ref getobject" command now gets a reference to a COM object + specified by a moniker name. Added the "::tcom::ref getactiveobject" + command which gets a reference to an existing COM object specified by a + programmatic ID. +- Added -method, -get and -set options for invoking operations on IDispatch + interfaces. +- Fixed defect where passing an interface pointer as an argument to a COM + method caused Release to be called too many times on the interface pointer. + +Version 3.2 +- Fixed defect where ::tcom::foreach command called Release one too many times + on the interface pointer to the collection object. +- The "::tcom::object create" command can now accept a list of imported + interface names to implement. + +Version 3.1 +- Fixed access violation when formatting COM error message. +- Add clean up code to restore original Tcl cmdName type, so wish will not hang + on exit. + +Version 3.0 +- Handles now automatically released. Removed "::tcom::release" command. +- Added "::tcom::foreach" command which iterates through the elements of a + COM collection. + +Version 2.8 +- Provide work around for dual interface objects that don't implement IDispatch + correctly (such as Visual Studio). Now references created by class commands + generated by the ::tcom::import command will try to invoke operations through + the virtual function table before trying through IDispatch. +- Fixed defect where only the last connection point is unadvised and released + when more than one event sink is bound to an object reference. +- Added "::tcom::ref equal" command which test handles for COM identity. +- Added "::tcom::unbind" command which disconnects event sinks. +- VARIANT dates (VT_DATE) are now converted to Tcl double values. + +Version 2.7 +- Added support for one-dimensional SAFEARRAYs of primitive data types as + method arguments. + +Version 2.6 +- Fixed type mismatch error when invoking methods with an [out] IDispatch + parameter. +- Fixed bug where tcom server methods invoked through the virtual function + table kept a reference to input COM interface pointer arguments. +- Fixed bug where Tcl error result formatting did not provide text + descriptions of COM error codes on Windows 95. + +Version 2.5 +- Fixed bug where [out, retval] parameters were not treated as method return + values. +- Fixed bug where property put functions could not be implemented because + descriptions for those functions were discarded. + +Version 2.4 +- COM objects now run as in-process and local servers using the Tcl package + mechanism to load object implementations. Added the ::tcom::server command + to register and unregister servers. +- The ::tcom::object create command now optionally specifies a Tcl command to + execute when the object is destroyed. +- Removed the -register option from the ::tcom::object create command. Now use + the ::tcom::object registerfactory command to register a class factory. +- Deprecated -property option, which is now silently ignored. MIDL should + never allow a property and method to have the same name. + +Version 2.3 +- Fixed illegal memory access bug when importing type libraries. +- Fixed bug where strings passed in BSTR arguments were not converted from + UTF-8. + +Version 2.2 +- Fixed bug where duplication method descriptions were stored when traversing + inherited interfaces. +- Catch invalid callee error when a type library says that an object implements + a dual interface when it actually doesn't. + +Version 2.1 +- Fixed bug where the ::tcom::import command did not read TKIND_DISPATCH type + information. +- Fixed bug where parameters that were pointer types were treated as out + parameters when they should have been in parameters. + +Version 2.0 +- The ::tcom::bind command now binds a Tcl command to events generated by an + object. Use the ::tcom::ref command now to create a reference to an object. +- The default concurrency model on Windows NT is now apartment threaded. + Use the ::tcom::configure command to set the concurrency model. +- The ::tcom::import command now returns the library name stored in the type + library file. + +Version 1.11 +- Fixed type mismatch error when calling an IDispatch method that returns + a VARIANT of type VT_NULL. +- Convert boolean Tcl internal representation to VARIANT boolean type. +- Can now access properties of IDispatch implementations that describe their + properties using the variable descriptions instead of the function + descriptions in their type information. +- The object created by the ::tcom::object command now processes named + arguments passed to its Invoke method by converting them into a Tcl list of + argument names and values. + +Version 1.10 +- Fixed empty Tcl error message returned upon attempt to read a non-existent + variable when passing an [in,out] argument. +- Fixed bug where the reference count of COM objects created by the + ::tcom::object command can never be decremented to 0. +- Fixed passing of missing optional arguments. +- Added ismissing subcommand to ::tcom::na command. This checks if an object + is a missing argument token. + +Version 1.9 +- The life cycle of handle objects can be managed by multiple Tcl interpreters. +- Now convert Tcl int and long object types to VARIANT integer type when + passing arguments. This enables the use of integer values to index into + collections. +- Replaced tlib2tcl.tcl script with ::tcom::import command. + +Version 1.8 + +- Added -getobject option to ::tcom::bind command to get a reference to an + existing object. +- Removed static initialization of C++ objects to allow the extension to use + Tcl stubs. + +Version 1.7 + +- Now you don't have to specify all the arguments when calling an object method. + A VARIANT value denoting a missing value will be passed in place of the + missing arguments. +- The ::tcom::bind command and class commands generated by tlib2tcl now accept + the -withevents option to allow Tcl scripting of event sinks. +- Fixed the IDispatch server implementation to follow the correct memory + management rules for events posted on the Tcl event queue. +- If the type information for the interface is available, the type + information will be attached to interface pointers returned from methods. + +Version 1.6 + +- Added ::tcom::object command that allows IDispatch interfaces to be + implemented in Tcl. +- The ::tcom::bind command now accepts the -clsid option for specifying a + class by CLSID instead of programmatic ID. +- The tlib2tcl utility now puts the UUID of interfaces and classes into an + array named __uuidof indexed by their name. +- Fixed COM interface pointer leak that occurred when a method returned an + interface pointer. +- Made the code thread safe. + +Version 1.5 + +- Added ::tcom::dispatch and ::tcom::na commands. +- Added sample Tcl script which shows how to create a spreadsheet by taking + control of Excel. + +Version 1.4 + +- Replaced "$interfaceInfo method" command with "$interfaceInfo methods" which + returns a list of method descriptions. +- The tlib2tcl utility now generates Tcl code that requires the type library + file at run time. +- Support Tcl 8.1 features: + - A Tcl byte array argument passed to an interface method is converted to a + one dimensional SAFEARRAY of bytes (VT_UI1). + +Version 1.3 + +- Enhanced tlib2tcl to also generate Tcl arrays for enumerations defined in + the type library. +- Class commands initialized object references with interface descriptions but + the references discarded them on a createInstance. +- Now uninitialize COM when the Tcl interpreter is deleted. + +Version 1.2 + +- Now allow property access using object reference command. +- Fixed array of VARIANT to Tcl list conversion. + +Version 1.1 + +- The tlib2tcl utility was outputing "VOID" types as "unknown". +- Added tcom95.dll which does not use Windows NT specific COM features. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..59f5603 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +This software is copyrighted by Chin Huang and other parties. The +following terms apply to all files associated with the software unless +explicitly disclaimed in individual files. + +The authors hereby grant permission to use, copy, modify, distribute, +and license this software and its documentation for any purpose, provided +that existing copyright notices are retained in all copies and that this +notice is included verbatim in any distributions. No written agreement, +license, or royalty fee is required for any of the authorized uses. +Modifications to this software may be copyrighted by their authors +and need not follow the licensing terms described here, provided that +the new terms are clearly indicated on the first page of each file where +they apply. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. diff --git a/README b/README new file mode 100644 index 0000000..e013838 --- /dev/null +++ b/README @@ -0,0 +1,23 @@ +Tcom is a Windows-specific Tcl extension that provides commands to access and +implement COM objects. This extension enables client-side and server-side +scripting of COM objects through IDispatch and IUnknown derived interfaces. + +INSTALLATION + +This distribution includes compiled libraries that can be loaded by the binary +release of Tcl/Tk 8.2 or later for Windows. Copy the contents of the lib +directory to the Tcl library directory. For example, if the Tcl library +directory is C:\Tcl\lib, enter this command at the command prompt: + + xcopy lib C:\Tcl\lib /s + + +TCL ACTIVE SCRIPT ENGINE + +This distribution includes an Active Script engine that's currently in a +pre-alpha stage of development. It implements just enough of the IActiveScript +and IActiveScriptParse interfaces to enable Internet Explorer and Windows +Script Host to run simple scripts. It works with the ActiveTcl binary +distribution from ActiveState. To register the script engine (assuming the +Tcl library directory is C:\Tcl\lib), change the current working directory to +C:\Tcl\lib\TclScript and run the register.tcl script. diff --git a/doc/Makefile b/doc/Makefile new file mode 100644 index 0000000..40f59cf --- /dev/null +++ b/doc/Makefile @@ -0,0 +1,9 @@ +# $Id: Makefile,v 1.6 2002/04/17 22:07:57 cthuang Exp $ + +all: tcom.n.html server.html + +tcom.n.html: tcom.n.xml xslt.tcl refentry2html.xsl + tclsh xslt.tcl tcom.n.xml refentry2html.xsl $@ + +server.html: server.xml xslt.tcl article2html.xsl + tclsh xslt.tcl server.xml article2html.xsl $@ diff --git a/doc/article2html.xsl b/doc/article2html.xsl new file mode 100644 index 0000000..06c72ad --- /dev/null +++ b/doc/article2html.xsl @@ -0,0 +1,143 @@ + + + + + + + + + <xsl:value-of select="artheader/title"/> + + + +

+ + + + + + + + + + + + + + + + ? + + + + ... + + + + ? + + + + + + + + + + + + + +

+ + + + + + + +
+ + + +
+ +
+ + + + + + + +
+ + + +
+ + + +

+ + + + + + + + + + + + 
+    
+
+ + + + 
+    
+
+ + + + + + + +
+ + + + + + + + + + + + + < + + > + + </ + + > + + + + diff --git a/doc/bankingClassDiagram.png b/doc/bankingClassDiagram.png new file mode 100644 index 0000000..831f3a3 Binary files /dev/null and b/doc/bankingClassDiagram.png differ diff --git a/doc/docbookx.dtd b/doc/docbookx.dtd new file mode 100644 index 0000000..e69de29 diff --git a/doc/refentry2html.xsl b/doc/refentry2html.xsl new file mode 100644 index 0000000..324d286 --- /dev/null +++ b/doc/refentry2html.xsl @@ -0,0 +1,173 @@ + + + + + + + + + <xsl:value-of select="refnamediv/refname"/> + + + +

Name

+

--

+ + + + + + + + + + + + +

Synopsis

+ + + + + + + + + + + + ? + + + + ... + + + + ? + + + + + + + + + + + + + +

+ + + + + + + +

+ + + + + + + +
+ + + +
+ +
+ + + + + + + +
+ + + +
+ + + +

+ + + + + + + + + + + +
+ +
+ + + +
+ + + + + +
+ + + + + + + + + + + + + + + + + + + + + + + + 
+    
+
+ + + + + < + + > + + </ + + > + + + + diff --git a/doc/server.html b/doc/server.html new file mode 100644 index 0000000..d4f1386 --- /dev/null +++ b/doc/server.html @@ -0,0 +1,291 @@ + + + +COM Object Implementation in Tcl + + + +

COM Object Implementation in Tcl

+ + +

Introduction

+

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.

+ 
+
+import "oaidl.idl";
+import "ocidl.idl";
+
+        [
+                object,
+                uuid(0A0059C4-E0B0-11D2-942A-00C04F7040AB),
+                dual,
+                helpstring("IAccount Interface"),
+                pointer_default(unique)
+        ]
+        interface IAccount: IDispatch
+        {
+                [id(1), propget, helpstring("property Balance")]
+                HRESULT Balance([out, retval] long *pValue);
+
+                [id(2), helpstring("method Deposit")]
+                HRESULT Deposit([in] long amount);
+
+                [id(3), helpstring("method Withdraw")]
+                HRESULT Withdraw([in] long amount);
+        };
+
+        [
+                object,
+                uuid(0A0059C4-E0B0-11D2-942A-00C04F7040AC),
+                dual,
+                helpstring("IBank Interface"),
+                pointer_default(unique)
+        ]
+        interface IBank: IDispatch
+        {
+                [id(1), helpstring("method CreateAccount")]
+                HRESULT CreateAccount([out, retval] IAccount **pAccount);
+        };
+
+[
+        uuid(0A0059B8-E0B0-11D2-942A-00C04F7040AB),
+        version(1.0),
+        helpstring("Banking 1.0 Type Library")
+]
+library Banking
+{
+        importlib("stdole32.tlb");
+
+        [
+                uuid(0A0059C5-E0B0-11D2-942A-00C04F7040AB),
+                helpstring("Account Class")
+        ]
+        coclass Account
+        {
+                [default] interface IAccount;
+        };
+
+        [
+                uuid(0A0059C5-E0B0-11D2-942A-00C04F7040AC),
+                helpstring("Bank Class")
+        ]
+        coclass Bank
+        {
+                [default] interface IBank;
+        };
+};
+
+ + +

Create Type Library

+

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

+ 
+
+midl Banking.idl
+
+ + +

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.

+
+
+package ifneeded Banking 1.0 [list source [file join $dir server.itcl]]
+
+ +

Copy the Banking.tlb type library file into 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.

+ + 
+
+package provide Banking 1.0
+
+package require Itcl
+namespace import ::itcl::*
+
+package require tcom
+::tcom::import [file join [file dirname [info script]] Banking.tlb]
+
+class AccountImpl {
+    private variable balance 0
+
+    public method _get_Balance {} {
+        return $balance
+    }
+
+    public method Deposit {amount} {
+        set balance [expr $balance + $amount]
+    }
+
+    public method Withdraw {amount} {
+        set balance [expr $balance - $amount]
+    }
+}
+
+class BankImpl {
+    public method CreateAccount {} {
+        set accountImpl [AccountImpl #auto]
+        return [::tcom::object create ::Banking::Account \
+            [code $accountImpl] {delete object}]                                ;# 1
+    }
+}
+
+::tcom::object registerfactory ::Banking::Bank {BankImpl #auto} {delete object} ;# 2
+
+ +

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.

+ + +

Register Server

+

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

+ 
+
+package require tcom
+::tcom::server register Banking.tlb
+
+ + +

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.

+ 
+
+package require tcom
+
+set bank [::tcom::ref createobject "Banking.Bank"]
+set account [$bank CreateAccount]
+puts [$account Balance]
+$account Deposit 20
+puts [$account Balance]
+$account Withdraw 10
+puts [$account Balance]
+
+ + +

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.

+ 
+
+package provide Banking 1.0
+
+package require tcom
+::tcom::import [file join [file dirname [info script]] Banking.tlb]
+
+proc accountImpl {method args} {
+    global balance
+
+    switch -- $method {
+        _get_Balance {
+            return $balance
+        }
+
+        Deposit {
+            set amount [lindex $args 0]
+            set balance [expr $balance + $amount]
+        }
+
+        Withdraw {
+            set amount [lindex $args 0]
+            set balance [expr $balance - $amount]
+        }
+        
+        default {
+            error "unknown method $method $args"
+        }
+    }
+}
+
+proc bankImpl {method args} {
+    global balance
+
+    switch -- $method {
+        CreateAccount {
+            set balance 0
+            return [::tcom::object create ::Banking::Account accountImpl]
+        }
+        
+        default {
+            error "unknown method $method $args"
+        }
+    }
+}
+
+::tcom::object registerfactory ::Banking::Bank {list bankImpl}
+
+ + + diff --git a/doc/server.xml b/doc/server.xml new file mode 100644 index 0000000..fec1814 --- /dev/null +++ b/doc/server.xml @@ -0,0 +1,281 @@ + + + +
+ + $Date: 2002/06/29 15:34:52 $ + $Revision: 1.23 $ + COM Object Implementation in Tcl + + + Introduction + 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. + + +import "oaidl.idl"; +import "ocidl.idl"; + + [ + object, + uuid(0A0059C4-E0B0-11D2-942A-00C04F7040AB), + dual, + helpstring("IAccount Interface"), + pointer_default(unique) + ] + interface IAccount: IDispatch + { + [id(1), propget, helpstring("property Balance")] + HRESULT Balance([out, retval] long *pValue); + + [id(2), helpstring("method Deposit")] + HRESULT Deposit([in] long amount); + + [id(3), helpstring("method Withdraw")] + HRESULT Withdraw([in] long amount); + }; + + [ + object, + uuid(0A0059C4-E0B0-11D2-942A-00C04F7040AC), + dual, + helpstring("IBank Interface"), + pointer_default(unique) + ] + interface IBank: IDispatch + { + [id(1), helpstring("method CreateAccount")] + HRESULT CreateAccount([out, retval] IAccount **pAccount); + }; + +[ + uuid(0A0059B8-E0B0-11D2-942A-00C04F7040AB), + version(1.0), + helpstring("Banking 1.0 Type Library") +] +library Banking +{ + importlib("stdole32.tlb"); + + [ + uuid(0A0059C5-E0B0-11D2-942A-00C04F7040AB), + helpstring("Account Class") + ] + coclass Account + { + [default] interface IAccount; + }; + + [ + uuid(0A0059C5-E0B0-11D2-942A-00C04F7040AC), + helpstring("Bank Class") + ] + coclass Bank + { + [default] interface IBank; + }; +}; + + + + Create Type Library + Run this command to generate a type library file + Banking.tlb from the MIDL specification. + + +midl Banking.idl + + + + 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. + + +package ifneeded Banking 1.0 [list source [file join $dir server.itcl]] + + + Copy the Banking.tlb type library file into 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. + + + +package provide Banking 1.0 + +package require Itcl +namespace import ::itcl::* + +package require tcom +::tcom::import [file join [file dirname [info script]] Banking.tlb] + +class AccountImpl { + private variable balance 0 + + public method _get_Balance {} { + return $balance + } + + public method Deposit {amount} { + set balance [expr $balance + $amount] + } + + public method Withdraw {amount} { + set balance [expr $balance - $amount] + } +} + +class BankImpl { + public method CreateAccount {} { + set accountImpl [AccountImpl #auto] + return [::tcom::object create ::Banking::Account \ + [code $accountImpl] {delete object}] ;# 1 + } +} + +::tcom::object registerfactory ::Banking::Bank {BankImpl #auto} {delete object} ;# 2 + + + 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. + + + Register Server + Run these Tcl commands to create entries in the Windows registry + required by COM and the tcom server implementation. + + + +package require tcom +::tcom::server register Banking.tlb + + + + 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. + + +package require tcom + +set bank [::tcom::ref createobject "Banking.Bank"] +set account [$bank CreateAccount] +puts [$account Balance] +$account Deposit 20 +puts [$account Balance] +$account Withdraw 10 +puts [$account Balance] + + + + 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. + + +package provide Banking 1.0 + +package require tcom +::tcom::import [file join [file dirname [info script]] Banking.tlb] + +proc accountImpl {method args} { + global balance + + switch -- $method { + _get_Balance { + return $balance + } + + Deposit { + set amount [lindex $args 0] + set balance [expr $balance + $amount] + } + + Withdraw { + set amount [lindex $args 0] + set balance [expr $balance - $amount] + } + + default { + error "unknown method $method $args" + } + } +} + +proc bankImpl {method args} { + global balance + + switch -- $method { + CreateAccount { + set balance 0 + return [::tcom::object create ::Banking::Account accountImpl] + } + + default { + error "unknown method $method $args" + } + } +} + +::tcom::object registerfactory ::Banking::Bank {list bankImpl} + + +
diff --git a/doc/tcom.n.html b/doc/tcom.n.html new file mode 100644 index 0000000..6913361 --- /dev/null +++ b/doc/tcom.n.html @@ -0,0 +1,597 @@ + + + +tcom + + + +

Name

+

tcom -- Access COM objects from Tcl

+ + + +

Synopsis

+ + package require tcom + ?3.8? +
+ ::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.

+
+ + +
+ + ::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 representationVARIANT type
booleanVT_BOOL
intVT_I4
doubleVT_R8
listone-dimensional array of VT_VARIANT
bytearrayone-dimensional array of VT_UI1
otherVT_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 new file mode 100644 index 0000000..f5c20e4 --- /dev/null +++ b/doc/tcom.n.xml @@ -0,0 +1,593 @@ + + + + + + $Date: 2002/04/12 23:44:50 $ + $Revision: 1.63 $ + + + tcom + n + + + tcom + Access COM objects from Tcl + + + + package require tcom + + + ::tcom::ref + createobject + + + + + progID + hostName + + ::tcom::ref + getactiveobject + + progID + + ::tcom::ref + getobject + pathName + + ::tcom::ref + equal + handle1 + handle2 + + handle + + method + argument + + handle + + method + argumentName argumentValue + + handle + + + 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 + + + + + progID + hostName + + ::tcom::ref + getactiveobject + + 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 option requests the object be + created in the same process. The option requests + the object be created in another process on the local machine. The + option requests the object be created on a remote + machine. The progID parameter is the programmatic + identifier of the object class. Use the 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 + 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 option to + specify you want to invoke a method. + + + + + + handle + + method + argumentName argumentValue + + + + Use the 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 + + + 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 or + 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. + + + + + + ::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. + + + + + + concurrencyModel + + + + This option sets the concurrency model, which can be + or . + The default is . 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 + + + + 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/xslt.tcl b/doc/xslt.tcl new file mode 100644 index 0000000..4df74fa --- /dev/null +++ b/doc/xslt.tcl @@ -0,0 +1,47 @@ +# $Id: xslt.tcl,v 1.1 2002/04/17 22:07:57 cthuang Exp $ +# +# Run an XML document through an XSLT processor. + +if {$argc != 3} { + puts "usage: $argv0 inputFile xsltFile outputFile" + exit 1 +} + +package require tcom + +set domProgId "Msxml2.DOMDocument" + +set source [::tcom::ref createobject $domProgId] +$source preserveWhiteSpace 1 +$source validateOnParse 0 +set sourceUrl [lindex $argv 0] +if {![$source load $sourceUrl]} { + set parseError [$source parseError] + puts [format "%x" [$parseError errorCode]] + puts [$parseError reason] + puts [$parseError srcText] + puts [$parseError url] + exit 1 +} + +set xslt [::tcom::ref createobject $domProgId] +$xslt preserveWhiteSpace 1 +$xslt validateOnParse 0 +set xsltUrl [lindex $argv 1] +if {![$xslt load $xsltUrl]} { + set parseError [$xslt parseError] + puts [format "%x" [$parseError errorCode]] + puts [$parseError reason] + puts [$parseError srcText] + puts [$parseError url] + exit 1 +} + +regsub {]*>} [$source transformNode $xslt] \ + {} \ + resultHtml + +set out [open [lindex $argv 2] "w"] +fconfigure $out -translation binary +puts -nonewline $out $resultHtml +close $out diff --git a/lib/Banking/Banking.tlb b/lib/Banking/Banking.tlb new file mode 100644 index 0000000..83694de Binary files /dev/null and b/lib/Banking/Banking.tlb differ diff --git a/lib/Banking/pkgIndex.tcl b/lib/Banking/pkgIndex.tcl new file mode 100644 index 0000000..1c3601c --- /dev/null +++ b/lib/Banking/pkgIndex.tcl @@ -0,0 +1,2 @@ +# $Id: pkgIndex.tcl,v 1.3 2001/07/04 03:36:16 cthuang Exp $ +package ifneeded Banking 1.0 [list source [file join $dir server.tcl]] diff --git a/lib/Banking/server.itcl b/lib/Banking/server.itcl new file mode 100644 index 0000000..7b9540d --- /dev/null +++ b/lib/Banking/server.itcl @@ -0,0 +1,34 @@ +# $Id: server.itcl,v 1.7 2002/06/29 15:34:52 cthuang Exp $ +package provide Banking 1.0 + +package require Itcl +namespace import ::itcl::* + +package require tcom +::tcom::import [file join [file dirname [info script]] Banking.tlb] + +class AccountImpl { + private variable balance 0 + + public method _get_Balance {} { + return $balance + } + + public method Deposit {amount} { + set balance [expr $balance + $amount] + } + + public method Withdraw {amount} { + set balance [expr $balance - $amount] + } +} + +class BankImpl { + public method CreateAccount {} { + set accountImpl [AccountImpl #auto] + return [::tcom::object create ::Banking::Account \ + [code $accountImpl] {delete object}] + } +} + +::tcom::object registerfactory ::Banking::Bank {BankImpl #auto} {delete object} diff --git a/lib/Banking/server.tcl b/lib/Banking/server.tcl new file mode 100644 index 0000000..520e669 --- /dev/null +++ b/lib/Banking/server.tcl @@ -0,0 +1,47 @@ +# $Id: server.tcl,v 1.3 2002/06/29 15:34:52 cthuang Exp $ +package provide Banking 1.0 + +package require tcom +::tcom::import [file join [file dirname [info script]] Banking.tlb] + +proc accountImpl {method args} { + global balance + + switch -- $method { + _get_Balance { + return $balance + } + + Deposit { + set amount [lindex $args 0] + set balance [expr $balance + $amount] + } + + Withdraw { + set amount [lindex $args 0] + set balance [expr $balance - $amount] + } + + default { + error "unknown method $method $args" + } + } +} + +proc bankImpl {method args} { + global balance + + switch -- $method { + CreateAccount { + set balance 0 + set name "" + return [::tcom::object create ::Banking::Account accountImpl] + } + + default { + error "unknown method $method $args" + } + } +} + +::tcom::object registerfactory ::Banking::Bank {list bankImpl} diff --git a/lib/TclScript/TclScript.dll b/lib/TclScript/TclScript.dll new file mode 100644 index 0000000..81409ac Binary files /dev/null and b/lib/TclScript/TclScript.dll differ diff --git a/lib/TclScript/TclScript.itcl b/lib/TclScript/TclScript.itcl new file mode 100644 index 0000000..40c93a3 --- /dev/null +++ b/lib/TclScript/TclScript.itcl @@ -0,0 +1,422 @@ +# $Id: TclScript.itcl,v 1.2 2002/04/20 06:11:32 cthuang Exp $ + +package require Itcl +namespace import itcl::* + +package require tcom +::tcom::import [file join [file dirname [info script]] TclScript.tlb] + +class Engine { + # common HRESULT values + common E_NOTIMPL 0x80004001 + common E_FAIL 0x80004005 + + # engine states + common SCRIPTSTATE_UNINITIALIZED 0 + common SCRIPTSTATE_INITIALIZED 5 + common SCRIPTSTATE_STARTED 1 + common SCRIPTSTATE_CONNECTED 2 + common SCRIPTSTATE_DISCONNECTED 3 + common SCRIPTSTATE_CLOSED 4 + + # map script state code to description + common scriptStateDesc + array set scriptStateDesc { + 0 SCRIPTSTATE_UNINITIALIZED + 5 SCRIPTSTATE_INITIALIZED + 1 SCRIPTSTATE_STARTED + 2 SCRIPTSTATE_CONNECTED + 3 SCRIPTSTATE_DISCONNECTED + 4 SCRIPTSTATE_CLOSED + } + + # flags passed into AddNamedItem method + common SCRIPTITEM_ISVISIBLE 2 + common SCRIPTITEM_ISSOURCE 4 + common SCRIPTITEM_GLOBALMEMBERS 8 + common SCRIPTITEM_ISPERSISTENT 0x40 + common SCRIPTITEM_CODEONLY 0x200 + common SCRIPTITEM_NOCODE 0x400 + + # true if logging to debug output enabled + variable logDebugOn_ 1 + + # SCRIPTSTATE + variable scriptState_ + + # IActiveScriptSite + variable scriptSite_ + + # slave interpreter used to execute scripts + variable slave_ + + # code to execute + variable code_ {} + + # list of names of items which have global members + variable globalMemberItems_ {} + + # list of names of item commands added to the Tcl interpreter + variable itemCommands_ {} + + # array of scripts to execute for each event + variable eventCode_ + array set eventCode_ {} + + # array of item and sub-item names of event sources + variable eventSources_ + array set eventSources_ {} + + # array of connected event sources + variable connectedSources_ + array set connectedSources_ {} + + constructor {} { + set scriptState_ $SCRIPTSTATE_UNINITIALIZED + + log "Engine::constructor" + } + + destructor { + log "Engine::destructor" + } + + method createItemCommand {itemName unknown} { + log "createItemCommand $itemName $unknown" + + $slave_ alias ::$itemName $unknown + lappend itemCommands_ $itemName + } + + method resolveUnknownCommand {args} { + log "resolveUnknownCommand $args" + + # See if any named items have a sub-item with that name. + set subItemName [lindex $args 0] + foreach itemName $globalMemberItems_ { + set obj [::TclScriptEngine::getnameditem \ + $scriptSite_ $itemName $subItemName] + if {[string equal [::tcom::typeof $obj] cmdName]} { + createItemCommand $subItemName $obj + return [eval $obj [lrange $args 1 end]] + } + } + + # Fall back to original unknown. + eval unknown $args + } + + method log {msg} { + if {$logDebugOn_} { + ::TclScriptEngine::outputdebug $msg + } + } + + method dumpInterface {obj} { + set interface [::tcom::info interface $obj] + log "interface [$interface name]" + + set properties [$interface properties] + foreach property $properties { + log "property $property" + } + + set methods [$interface methods] + foreach method $methods { + log "method [lrange $method 0 2] \{" + set parameters [lindex $method 3] + foreach parameter $parameters { + log " \{$parameter\}" + } + log "\}" + } + } + + method evaluateCode {code} { + $scriptSite_ OnEnterScript + if {[catch {$slave_ eval $code} result]} { + log $::errorInfo + set error [::TclScriptEngine::activescripterror \ + $E_FAIL TclScript $result 0 0 $::errorInfo] + $scriptSite_ OnScriptError $error + } + $scriptSite_ OnLeaveScript + } + + method changeScriptState {newState} { + set scriptState_ $newState + if {[info exists scriptSite_]} { + $scriptSite_ OnStateChange $newState + } + + switch -- $newState \ + $SCRIPTSTATE_STARTED { + evaluateCode $code_ + set code_ {} + } + } + + method sink {sourceName eventName} { + if {[info exists eventCode_($sourceName,$eventName)]} { + $slave_ eval $eventCode_($sourceName,$eventName) + } + } + + method connectToSources {} { + foreach sourceName [array names eventSources_] { + # Check if the source is already connected to a sink. + if {![info exists connectedSources_($sourceName)]} { + set itemName [lindex $eventSources_($sourceName) 0] + set subItemName [lindex $eventSources_($sourceName) 1] + set source [::TclScriptEngine::getnameditem \ + $scriptSite_ $itemName $subItemName] + + set sinkProcName ::${sourceName}_sink + proc $sinkProcName {eventName args} \ + "$this sink $sourceName \$eventName" + ::tcom::bind $source $sinkProcName + + set connectedSources_($sourceName) $source + } + } + } + + method disconnectFromSources {} { + foreach {sourceName source} [array get connectedSources_] { + ::tcom::unbind $source + unset connectedSources_($sourceName) + } + } + + # Raise not implemented error. + method errorNotImpl {} { + set messageText "Not implemented" + error $messageText {} [list COM $E_NOTIMPL $messageText] + } + + # IActiveScript implementation + + method SetScriptSite {site} { + log "IActiveScript::SetScriptSite $site" + + set scriptSite_ $site + } + + method GetScriptSite {iid ppvObject} { + log "IActiveScript::GetScriptSite $iid" + + upvar $ppvObject pvObject + set pvObject $scriptSite_ + } + + method SetScriptState {newState} { + log "IActiveScript::SetScriptState $scriptStateDesc($newState)" + + switch -- $newState \ + $SCRIPTSTATE_STARTED { + if {$scriptState_ != $SCRIPTSTATE_INITIALIZED} { + error "must be in INITIALIZED state to go to STARTED state" + } + } \ + $SCRIPTSTATE_CONNECTED { + connectToSources + } \ + $SCRIPTSTATE_DISCONNECTED { + disconnectFromSources + } + + if {$newState != $scriptState_} { + changeScriptState $newState + } + } + + method GetScriptState {pState} { + log "IActiveScript::GetScriptState" + + upvar $pState state + set state $scriptState_ + } + + method Close {} { + log "IActiveScript::Close" + + changeScriptState $SCRIPTSTATE_CLOSED + + # Clear object references. + foreach itemName $itemCommands_ { + log "delete command $itemName" + $slave_ alias ::$itemName {} + } + + set eventSources_ {} + set scriptSite_ {} + unset scriptSite_ + + interp delete $slave_ + log "IActiveScript::Close done" + } + + method AddNamedItem {name flags} { + log "IActiveScript::AddNamedItem $name $flags" + + set unknown [::TclScriptEngine::getnameditem $scriptSite_ $name] + + if {($flags & $SCRIPTITEM_GLOBALMEMBERS) != 0} { + lappend globalMemberItems_ $name + } + + if {($flags & $SCRIPTITEM_ISVISIBLE) != 0} { + log "IActiveScript::AddNamedItem createItemCommand" + createItemCommand $name $unknown + } + } + + method AddTypeLib {libid major minor flags} { + log "IActiveScript::AddTypeLib" + errorNotImpl + } + + method GetScriptDispatch {itemName ppDispatch} { + log "IActiveScript::GetScriptDispatch $itemName" + upvar $ppDispatch pDispatch + set pDispatch 0 + errorNotImpl + } + + method GetCurrentScriptThreadID {pScriptThreadId} { + log "IActiveScript::GetCurrentScriptThreadID" + upvar $pScriptThreadId scriptThreadId + set scriptThreadId 0 + errorNotImpl + } + + method GetScriptThreadID {win32ThreadId pScriptThreadId} { + log "IActiveScript::GetScriptThreadID" + upvar $pScriptThreadId scriptThreadId + set scriptThreadId 0 + errorNotImpl + } + + method GetScriptThreadState {scriptThreadId pScriptThreadState} { + log "IActiveScript::GetScriptThreadState" + errorNotImpl + } + + method InterruptScriptThread {scriptThreadId excepInfo flags} { + log "IActiveScript::InterruptScriptThread" + errorNotImpl + } + + method Clone {ppScript} { + log "IActiveScript::Clone" + upvar $ppScript pScript + set pScript 0 + errorNotImpl + } + + # IActiveScriptParse implementation + + method InitNew {} { + log "IActiveScriptParse::InitNew" + + if {$safetyOptions & $INTERFACESAFE_FOR_UNTRUSTED_DATA} { + set slave_ [interp create -safe] + } else { + set slave_ [interp create] + } + $slave_ alias unknown $this resolveUnknownCommand + + changeScriptState $SCRIPTSTATE_INITIALIZED + } + + method AddScriptlet { + defaultName code itemName subItemName eventName delimiter + sourceContextCookie startingLineNumber flags pName pExcepInfo + } { + log "IActiveScriptParse::AddScriptlet $defaultName" + log "code $code" + log "itemName $itemName" + log "subItemName $subItemName" + log "eventName $eventName" + + set sourceName $itemName + if {[string length $subItemName] > 0} { + append sourceName _ $subItemName + } + + set eventSources_($sourceName) [list $itemName $subItemName] + set eventCode_($sourceName,$eventName) $code + connectToSources + + upvar $pName name + set name $sourceName + } + + method ParseScriptText { + code itemName pContext delimiter + sourceContextCookie startingLineNumber flags pVarResult pExcepInfo + } { + set code [string map { \r\n \n } $code] + log "IActiveScriptParse::ParseScriptText $code" + log "itemName $itemName" + log "flags $flags" + + switch -- $scriptState_ \ + $SCRIPTSTATE_INITIALIZED { + append code_ $code + } \ + $SCRIPTSTATE_STARTED - \ + $SCRIPTSTATE_CONNECTED - \ + $SCRIPTSTATE_DISCONNECTED { + evaluateCode $code + } \ + default { + error "invalid script state $scriptState_" + } + } + + # IObjectSafety implementation + + # option flags + common INTERFACESAFE_FOR_UNTRUSTED_CALLER 1 + common INTERFACESAFE_FOR_UNTRUSTED_DATA 2 + common INTERFACE_USES_DISPEX 4 + common INTERFACE_USES_SECURITY_MANAGER 8 + + # Internet Explorer seems to insist we say we support all the options + # even though we refuse to accept some. + common SUPPORTED_SAFETY_OPTIONS [expr \ + $INTERFACESAFE_FOR_UNTRUSTED_CALLER | \ + $INTERFACESAFE_FOR_UNTRUSTED_DATA | \ + $INTERFACE_USES_DISPEX | \ + $INTERFACE_USES_SECURITY_MANAGER] + + # currently set safety options + variable safetyOptions 0 + + method GetInterfaceSafetyOptions {iid pSupportedOptions pEnabledOptions} { + log "GetInterfaceSafetyOptions $iid" + + upvar $pSupportedOptions supportedOptions + upvar $pEnabledOptions enabledOptions + set supportedOptions $SUPPORTED_SAFETY_OPTIONS + set enabledOptions $safetyOptions + } + + method SetInterfaceSafetyOptions {iid optionSetMask enabledOptions} { + log "SetInterfaceSafetyOptions $iid $optionSetMask $enabledOptions" + + # Check optionSetMask for options we don't support. + if {$optionSetMask & ~$SUPPORTED_SAFETY_OPTIONS} { + error "tried to set unsupported option" + } + + set safetyOptions [expr ($safetyOptions & ~$optionSetMask) | \ + ($enabledOptions & $optionSetMask)] + + log "safetyOptions $safetyOptions" + } +} + +::tcom::object registerfactory ::TclScript::Engine \ + {Engine #auto} {delete object} diff --git a/lib/TclScript/TclScript.tlb b/lib/TclScript/TclScript.tlb new file mode 100644 index 0000000..af23937 Binary files /dev/null and b/lib/TclScript/TclScript.tlb differ diff --git a/lib/TclScript/pkgIndex.tcl b/lib/TclScript/pkgIndex.tcl new file mode 100644 index 0000000..74d19b9 --- /dev/null +++ b/lib/TclScript/pkgIndex.tcl @@ -0,0 +1,3 @@ +# $Id: pkgIndex.tcl,v 1.2 2002/03/30 18:49:10 cthuang Exp $ +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 new file mode 100644 index 0000000..807ee29 --- /dev/null +++ b/lib/TclScript/register.tcl @@ -0,0 +1,34 @@ +# $Id: register.tcl,v 1.3 2002/03/20 23:52:35 cthuang Exp $ +# +# This script registers the Tcl Active Scripting engine. + +package require registry +package require tcom + + set typeLibFile "TclScript.tlb" + ::tcom::server register -inproc $typeLibFile + + set typeLib [::tcom::typelib load $typeLibFile] + set classInfo [$typeLib class "Engine"] + set clsid "{[string toupper [lindex $classInfo 0]]}" + set progId "TclScript" + + set key "HKEY_CLASSES_ROOT\\CLSID\\$clsid" + registry set "$key\\ProgID" "" $progId + registry set "$key\\OLEScript" + + set key "HKEY_CLASSES_ROOT\\CLSID\\$clsid\\Implemented Categories" + registry set "$key\\{F0B7A1A1-9847-11CF-8F20-00805F2CD064}" + registry set "$key\\{F0B7A1A2-9847-11CF-8F20-00805F2CD064}" + + set key "HKEY_CLASSES_ROOT\\$progId" + registry set $key "" "Tcl Script Language" + registry set "$key\\CLSID" "" $clsid + registry set "$key\\OLEScript" + + set key "HKEY_CLASSES_ROOT\\.tcls" + registry set $key "" "TclScriptFile" + + set key "HKEY_CLASSES_ROOT\\TclScriptFile" + registry set $key "" "Tcl Script File" + registry set "$key\\ScriptEngine" "" $progId diff --git a/lib/tcom/pkgIndex.tcl b/lib/tcom/pkgIndex.tcl new file mode 100644 index 0000000..bbfa714 --- /dev/null +++ b/lib/tcom/pkgIndex.tcl @@ -0,0 +1,3 @@ +# $Id: pkgIndex.tcl,v 1.15 2002/02/26 23:10:47 cthuang Exp $ +package ifneeded tcom 3.8 \ +[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 new file mode 100644 index 0000000..c543121 Binary files /dev/null and b/lib/tcom/tcom.dll differ diff --git a/lib/tcom/tcom.tcl b/lib/tcom/tcom.tcl new file mode 100644 index 0000000..2044e33 --- /dev/null +++ b/lib/tcom/tcom.tcl @@ -0,0 +1,152 @@ +# $Id: tcom.tcl,v 1.14 2002/03/30 16:24:11 cthuang Exp $ + +namespace eval ::tcom { + # Look for the file in the directories in the package load path. + # Return the full path of the file. + proc search_auto_path {fileSpec} { + global auto_path + + ::foreach dir [set auto_path] { + set filePath [file join $dir $fileSpec] + if {[file exists $filePath]} { + return [file nativename $filePath] + } + } + error "cannot find $fileSpec" + } + + # Get full path to Tcl interpreter DLL. + proc tclDllPath {} { + set parts [file split [::info library]] + set n [expr [llength $parts] - 3] + set rootDir [eval file join [lrange $parts 0 $n]] + set version [string map {. {}} [::info tclversion]] + return [file nativename [file join $rootDir "bin" "tcl$version.dll"]] + } + + # Insert registry entries for the class. + proc registerClass { + typeLibName typeLibId version className clsid inproc local + } { + set dllPath [search_auto_path "tcom/tcominproc.dll"] + set exePath [search_auto_path "tcom/tcomlocal.exe"] + if {[string first " " $exePath] > 0} { + # Must not have space character in local server path name. + set exePath [::tcom::shortPathName $exePath] + } + set verIndependentProgId "$typeLibName.$className" + set progId "$verIndependentProgId.1" + + set key "HKEY_CLASSES_ROOT\\$progId" + registry set $key "" "$className Class" + registry set "$key\\CLSID" "" $clsid + + set key "HKEY_CLASSES_ROOT\\$verIndependentProgId" + registry set $key "" "$className Class" + registry set "$key\\CLSID" "" $clsid + + set key "HKEY_CLASSES_ROOT\\CLSID\\$clsid" + registry set $key "" "$className Class" + registry set "$key\\ProgID" "" $progId + registry set "$key\\VersionIndependentProgID" "" $verIndependentProgId + registry set "$key\\TypeLib" "" $typeLibId + registry set "$key\\Version" "" $version + + if {$inproc} { + set key "HKEY_CLASSES_ROOT\\CLSID\\$clsid\\InprocServer32" + registry set $key "" $dllPath + registry set $key "ThreadingModel" "Apartment" + } + + if {$local} { + set key "HKEY_CLASSES_ROOT\\CLSID\\$clsid\\LocalServer32" + registry set $key "" "$exePath $clsid" + } + + set key "HKEY_CLASSES_ROOT\\CLSID\\$clsid\\tcom" + registry set $key "Script" "package require $typeLibName" + registry set $key "TclDLL" [tclDllPath] + } + + # Remove registry entries for the class. + proc unregisterClass {typeLibName className clsid} { + set verIndependentProgId "$typeLibName.$className" + set progId "$verIndependentProgId.1" + + registry delete "HKEY_CLASSES_ROOT\\$progId" + registry delete "HKEY_CLASSES_ROOT\\$verIndependentProgId" + registry delete "HKEY_CLASSES_ROOT\\CLSID\\$clsid" + } + + # Register or unregister servers for classes defined in a type library. + proc server {subCommand args} { + package require registry + + set inproc 1 + set local 1 + + set argc [llength $args] + for {set i 0} {$i < $argc} {incr i} { + set endOfOptions 0 + switch -- [lindex $args $i] { + -inproc { + set inproc 1 + set local 0 + } + -local { + set inproc 0 + set local 1 + } + default { + set endOfOptions 1 + } + } + if {$endOfOptions} { + break + } + } + + if {$i >= $argc} { + error "wrong # args: usage: ::tcom::server register|unregister typeLibFile ?class ...?" + } + + set typeLibFile [lindex $args $i] + incr i + + switch -- $subCommand { + register { + ::tcom::typelib register $typeLibFile + set registerOpt 1 + } + unregister { + ::tcom::typelib unregister $typeLibFile + set registerOpt 0 + } + default { + error "bad option $option: must be register or unregsiter" + } + } + + set typeLib [::tcom::typelib load $typeLibFile] + set typeLibName [$typeLib name] + set typeLibId "{[string toupper [$typeLib libid]]}" + set typeLibVersion [$typeLib version] + + if {$i < $argc} { + set classes [lrange $args $i end] + } else { + set classes [$typeLib class] + } + + ::foreach className $classes { + set classInfo [$typeLib class $className] + set clsid "{[string toupper [lindex $classInfo 0]]}" + if {$registerOpt} { + registerClass $typeLibName $typeLibId $typeLibVersion \ + $className $clsid $inproc $local + } else { + unregisterClass $typeLibName $className $clsid + } + } + } +} diff --git a/lib/tcom/tcominproc.dll b/lib/tcom/tcominproc.dll new file mode 100644 index 0000000..ddedbfe Binary files /dev/null and b/lib/tcom/tcominproc.dll differ diff --git a/lib/tcom/tcomlocal.exe b/lib/tcom/tcomlocal.exe new file mode 100644 index 0000000..f718268 Binary files /dev/null and b/lib/tcom/tcomlocal.exe differ diff --git a/samples/Banking/Banking.idl b/samples/Banking/Banking.idl new file mode 100644 index 0000000..71e35a0 --- /dev/null +++ b/samples/Banking/Banking.idl @@ -0,0 +1,62 @@ +import "oaidl.idl"; +import "ocidl.idl"; + + [ + object, + uuid(0A0059C4-E0B0-11D2-942A-00C04F7040AB), + dual, + helpstring("IAccount Interface"), + pointer_default(unique) + ] + interface IAccount: IDispatch + { + [id(1), propget, helpstring("property Balance")] + HRESULT Balance([out, retval] long *pValue); + + [id(2), helpstring("method Deposit")] + HRESULT Deposit([in] long amount); + + [id(3), helpstring("method Withdraw")] + HRESULT Withdraw([in] long amount); + }; + + [ + object, + uuid(0A0059C4-E0B0-11D2-942A-00C04F7040AC), + dual, + helpstring("IBank Interface"), + pointer_default(unique) + ] + interface IBank: IDispatch + { + [id(1), helpstring("method CreateAccount")] + HRESULT CreateAccount([out, retval] IAccount **ppAccount); + }; + +[ + uuid(0A0059B8-E0B0-11D2-942A-00C04F7040AB), + version(1.0), + helpstring("Banking 1.0 Type Library") +] +library Banking +{ + importlib("stdole32.tlb"); + + [ + uuid(0A0059C5-E0B0-11D2-942A-00C04F7040AB), + helpstring("Account Class") + ] + coclass Account + { + [default] interface IAccount; + }; + + [ + uuid(0A0059C5-E0B0-11D2-942A-00C04F7040AC), + helpstring("Bank Class") + ] + coclass Bank + { + [default] interface IBank; + }; +}; diff --git a/samples/Banking/client.tcl b/samples/Banking/client.tcl new file mode 100644 index 0000000..0f975e6 --- /dev/null +++ b/samples/Banking/client.tcl @@ -0,0 +1,9 @@ +package require tcom + +set bank [::tcom::ref createobject "Banking.Bank"] +set account [$bank CreateAccount] +puts [$account Balance] +$account Deposit 20 +puts [$account Balance] +$account Withdraw 10 +puts [$account Balance] diff --git a/samples/chart.tcl b/samples/chart.tcl new file mode 100644 index 0000000..cb34c09 --- /dev/null +++ b/samples/chart.tcl @@ -0,0 +1,43 @@ +# $Id: chart.tcl,v 1.1 2001/08/18 00:35:52 cthuang Exp $ +# +# This example controls Excel. It performs the following steps. +# - Start Excel application. +# - Create a new workbook. +# - Put values into some cells. +# - Create a chart. + +package require tcom + +set application [::tcom::ref createobject "Excel.Application"] +$application Visible 1 + +set workbooks [$application Workbooks] +set workbook [$workbooks Add] +set worksheets [$workbook Worksheets] +set worksheet [$worksheets Item [expr 1]] + +set cells [$worksheet Cells] +$cells Item 1 A "North" +$cells Item 1 B "South" +$cells Item 1 C "East" +$cells Item 1 D "West" +$cells Item 2 A 5.2 +$cells Item 2 B 10.0 +$cells Item 2 C 8.0 +$cells Item 2 D 20.0 +set sourceRange [$worksheet Range "A1" "D2"] + +set charts [$workbook Charts] +set chart [$charts Add] +$chart ChartWizard \ + $sourceRange \ + [expr -4102] \ + [expr 7] \ + [expr 1] \ + [expr 1] \ + [expr 0] \ + 0 \ + "Sales Percentages" + +# Prevent Excel from prompting to save the document on close. +$workbook Saved 1 diff --git a/samples/events.tcl b/samples/events.tcl new file mode 100644 index 0000000..32e02d3 --- /dev/null +++ b/samples/events.tcl @@ -0,0 +1,20 @@ +# $Id: events.tcl,v 1.2 2001/06/30 18:42:58 cthuang Exp $ + +package require tcom + +proc sink {method args} { + puts "event $method $args" +} + +proc doUpdate {comment} { + puts "invoked $comment" + update +} + +set application [::tcom::ref createobject "InternetExplorer.Application"] +::tcom::bind $application sink + +$application Visible 1 +doUpdate "Visible" +$application Quit +doUpdate "Quit" diff --git a/samples/excel.tcl b/samples/excel.tcl new file mode 100644 index 0000000..4bc3031 --- /dev/null +++ b/samples/excel.tcl @@ -0,0 +1,50 @@ +# $Id: excel.tcl,v 1.9 2001/06/30 18:42:58 cthuang Exp $ +# +# This example controls Excel. It performs the following steps. +# - Start Excel application. +# - Create a new workbook. +# - Put values into some cells. +# - Save the workbook to a file. +# - Exit Excel application. + +package require tcom + +# Print the properties and methods exposed by the object. + +proc dumpInterface {obj} { + set interface [::tcom::info interface $obj] + + set properties [$interface properties] + foreach property $properties { + puts "property $property" + } + + set methods [$interface methods] + foreach method $methods { + puts "method [lrange $method 0 2] \{" + set parameters [lindex $method 3] + foreach parameter $parameters { + puts " \{$parameter\}" + } + puts "\}" + } +} + +set application [::tcom::ref createobject "Excel.Application"] +$application Visible 1 + +set workbooks [$application Workbooks] +set workbook [$workbooks Add] +set worksheets [$workbook Worksheets] +set worksheet [$worksheets Item [expr 1]] + +set cells [$worksheet Cells] +set i 0 +foreach row {1 2 3} { + foreach column {A B C} { + $cells Item $row $column [incr i] + } +} + +$workbook SaveAs {c:\tst.xls} +$application Quit diff --git a/samples/sendkeys.tcl b/samples/sendkeys.tcl new file mode 100644 index 0000000..e2705ab --- /dev/null +++ b/samples/sendkeys.tcl @@ -0,0 +1,13 @@ +# $Id: sendkeys.tcl,v 1.3 2001/06/30 18:42:58 cthuang Exp $ +# +# This example demonstrates how to send keys to Windows applications. +# It requires Windows Script Host 2.0 installed on the system. + +package require tcom + +set wshShell [::tcom::ref createobject "WScript.Shell"] +set taskId [$wshShell Run "notepad.exe"] +$wshShell AppActivate $taskId +after 500 +$wshShell SendKeys "The quick brown fox jumped\n" +$wshShell SendKeys "{TAB}over the lazy dog." diff --git a/src/ActiveScriptError.cpp b/src/ActiveScriptError.cpp new file mode 100644 index 0000000..fe219b3 --- /dev/null +++ b/src/ActiveScriptError.cpp @@ -0,0 +1,66 @@ +// $Id: ActiveScriptError.cpp,v 1.1 2002/03/30 18:49:53 cthuang Exp $ +#include "ActiveScriptError.h" + +STDMETHODIMP +ActiveScriptError::QueryInterface (REFIID iid, void **ppvObj) +{ + if (IsEqualIID(iid, IID_IUnknown) + || IsEqualIID(iid, IID_IActiveScriptError)) { + *ppvObj = this; + AddRef(); + return S_OK; + } + + *ppvObj = 0; + return E_NOINTERFACE; +} + +STDMETHODIMP_(ULONG) +ActiveScriptError::AddRef () +{ + InterlockedIncrement(&m_refCount); + return m_refCount; +} + +STDMETHODIMP_(ULONG) +ActiveScriptError::Release () +{ + InterlockedDecrement(&m_refCount); + if (m_refCount == 0) { + delete this; + return 0; + } + return m_refCount; +} + +STDMETHODIMP +ActiveScriptError::GetExceptionInfo (EXCEPINFO *pExcepInfo) +{ + if (pExcepInfo == 0) { + return E_POINTER; + } + + memset(pExcepInfo, 0, sizeof(EXCEPINFO)); + + pExcepInfo->scode = m_hresult; + pExcepInfo->bstrSource = SysAllocString(m_source); + pExcepInfo->bstrDescription = SysAllocString(m_description); + return S_OK; +} + +STDMETHODIMP +ActiveScriptError::GetSourcePosition ( + DWORD *pSourceContext, ULONG *pLineNumber, LONG *pCharacterPosition) +{ + *pSourceContext = 0; + *pLineNumber = m_lineNumber; + *pCharacterPosition = m_characterPosition; + return S_OK; +} + +STDMETHODIMP +ActiveScriptError::GetSourceLineText (BSTR *pSourceLineText) +{ + *pSourceLineText = SysAllocString(m_sourceLineText); + return S_OK; +} diff --git a/src/ActiveScriptError.h b/src/ActiveScriptError.h new file mode 100644 index 0000000..38c542f --- /dev/null +++ b/src/ActiveScriptError.h @@ -0,0 +1,49 @@ +// $Id: ActiveScriptError.h,v 1.2 2002/04/12 02:55:27 cthuang Exp $ +#ifndef ACTIVESCRIPTERROR_H +#define ACTIVESCRIPTERROR_H + +#include +#include + +// This class implements IActiveScriptError. + +class ActiveScriptError: public IActiveScriptError +{ + long m_refCount; + HRESULT m_hresult; + _bstr_t m_source; + _bstr_t m_description; + ULONG m_lineNumber; + long m_characterPosition; + _bstr_t m_sourceLineText; + +public: + ActiveScriptError ( + HRESULT hresult, + const char *source, + const char *description, + ULONG lineNumber, + long characterPosition, + const char *sourceLineText): + m_refCount(0), + m_hresult(hresult), + m_source(source), + m_description(description), + m_lineNumber(lineNumber), + m_characterPosition(characterPosition), + m_sourceLineText(sourceLineText) + { } + + // IUnknown implementation + STDMETHODIMP QueryInterface(REFIID iid, void **ppvObj); + STDMETHODIMP_(ULONG) AddRef(); + STDMETHODIMP_(ULONG) Release(); + + // IActiveScriptError implementation + STDMETHODIMP GetExceptionInfo(EXCEPINFO *pExcepInfo); + STDMETHODIMP GetSourcePosition( + DWORD *pSourceContext, ULONG *pLineNumber, LONG *pCharacterPosition); + STDMETHODIMP GetSourceLineText(BSTR *pSourceLineText); +}; + +#endif diff --git a/src/Arguments.cpp b/src/Arguments.cpp new file mode 100644 index 0000000..4ed82a7 --- /dev/null +++ b/src/Arguments.cpp @@ -0,0 +1,308 @@ +// $Id: Arguments.cpp,v 1.33 2002/07/09 04:10:08 cthuang Exp $ +#include "Arguments.h" +#include "Extension.h" +#include "TclObject.h" + +Arguments::Arguments (): + m_args(0) +{ + m_dispParams.rgvarg = NULL; + m_dispParams.rgdispidNamedArgs = NULL; + m_dispParams.cArgs = 0; + m_dispParams.cNamedArgs = 0; +} + +Arguments::~Arguments () +{ + delete[] m_args; +} + + +TypedArguments::TypedArguments (): + m_outValues(0) +{ } + +TypedArguments::~TypedArguments () +{ + delete[] m_outValues; +} + +int +TypedArguments::initArgument ( + Tcl_Interp *interp, + Tcl_Obj *pObj, + int argIndex, + const Parameter ¶meter) +{ + TclObject argument(pObj); + VARTYPE vt = parameter.type().vartype(); + + if (pObj->typePtr == &Extension::naType) { + // This variant indicates a missing optional argument. + m_args[argIndex] = vtMissing; + + } else if (parameter.flags() & PARAMFLAG_FOUT) { + // For out parameters, set a pointer to where the out value + // will be stored. + + if (vt == VT_USERDEFINED) { + // Assume user defined types derive from IUnknown. + vt = VT_UNKNOWN; + } + + if (vt == VT_SAFEARRAY) { + m_args[argIndex].vt = VT_BYREF | VT_ARRAY | + parameter.type().elementType().vartype(); + } else { + m_args[argIndex].vt = VT_BYREF | vt; + } + + if (vt == VT_VARIANT) { + // Set a pointer to out variant. + m_args[argIndex].byref = &m_outValues[argIndex]; + } else { + // Set a pointer to variant data value. + m_args[argIndex].byref = &m_outValues[argIndex].byref; + } + + if (parameter.flags() & PARAMFLAG_FIN) { + // Set the value for an in/out parameter. + Tcl_Obj *pValue = Tcl_ObjGetVar2( + interp, pObj, NULL, TCL_LEAVE_ERR_MSG); + if (pValue == 0) { + return TCL_ERROR; + } + + TclObject value(pValue); + + // If the argument is an interface pointer, increment its reference + // count because the _variant_t destructor will release it. + value.toVariant( + &m_outValues[argIndex], parameter.type(), interp, true); + } else { + if (vt == VT_UNKNOWN) { + m_outValues[argIndex].vt = vt; + m_outValues[argIndex].punkVal = NULL; + } else if (vt == VT_DISPATCH) { + m_outValues[argIndex].vt = vt; + m_outValues[argIndex].pdispVal = NULL; + } else if (vt == VT_SAFEARRAY) { + VARTYPE elementType = parameter.type().elementType().vartype(); + m_outValues[argIndex].vt = VT_ARRAY | elementType; + m_outValues[argIndex].parray = + SafeArrayCreateVector(elementType, 0, 1); + } else if (vt != VT_VARIANT) { + m_outValues[argIndex].ChangeType(vt); + } + } + + } 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); + } + + return TCL_OK; +} + +void +TypedArguments::storeOutValues ( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[], + const Method::Parameters ¶meters) +{ + if (objc > 0) { + int j = objc - 1; + Method::Parameters::const_iterator p = parameters.begin(); + for (int i = 0; i < objc && p != parameters.end(); ++i, --j, ++p) { + if (p->flags() & PARAMFLAG_FOUT) { + TclObject value(&m_outValues[j], p->type(), interp); + Tcl_ObjSetVar2( + interp, objv[i], NULL, value, TCL_LEAVE_ERR_MSG); + } + } + } +} + + +int +PositionalArguments::initialize ( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[], + const Method &method, + WORD dispatchFlags) +{ + const Method::Parameters ¶meters = method.parameters(); + + int paramCount = parameters.size(); + int inputCount = objc; + if (dispatchFlags == DISPATCH_PROPERTYPUT + || dispatchFlags == DISPATCH_PROPERTYPUTREF) { + paramCount = objc; + --inputCount; + } + + if (method.vararg() && inputCount > 0) { + m_args = new _variant_t[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); + } + + paramCount = inputCount; + + } else if (paramCount > 0) { + m_args = new _variant_t[paramCount]; + m_outValues = new _variant_t[paramCount]; + + int j = paramCount - 1; + Method::Parameters::const_iterator p = parameters.begin(); + + // Convert the arguments actually provided. + int i = 0; + for (; i < inputCount; ++i, --j, ++p) { + int result = initArgument(interp, objv[i], j, *p); + if (result != TCL_OK) { + return result; + } + } + + // Fill in missing arguments. + for (; p != parameters.end(); ++p, --j) { + m_args[j] = vtMissing; + } + + // Convert argument for property put operations. + if (dispatchFlags == DISPATCH_PROPERTYPUT + || dispatchFlags == DISPATCH_PROPERTYPUTREF) { + TclObject value = objv[i]; + value.toVariant(&m_args[j], method.type(), interp, true); + } + } + + m_dispParams.rgvarg = m_args; + m_dispParams.cArgs = paramCount; + + if (dispatchFlags == DISPATCH_PROPERTYPUT + || dispatchFlags == DISPATCH_PROPERTYPUTREF) { + // Property puts have a named argument that represents the value being + // assigned to the property. + static DISPID mydispid = DISPID_PROPERTYPUT; + m_dispParams.rgdispidNamedArgs = &mydispid; + m_dispParams.cNamedArgs = 1; + } + + return TCL_OK; +} + + +NamedArguments::~NamedArguments () +{ + delete[] m_namedDispids; +} + +Method::Parameters::const_iterator +NamedArguments::findParameter (const Method::Parameters ¶meters, + const std::string &name, + DISPID &dispid) +{ + int i = 0; + Method::Parameters::const_iterator p = parameters.begin(); + for (; p != parameters.end(); ++p, ++i) { + if (p->name() == name) { + dispid = i; + break; + } + } + return p; +} + +int +NamedArguments::initialize ( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[], + const Method &method, + WORD /*dispatchFlags*/) +{ + const Method::Parameters ¶meters = method.parameters(); + + if (objc % 2 != 0) { + Tcl_AppendResult(interp, "name value pairs required", NULL); + return TCL_ERROR; + } + + int cArgs = objc / 2; + if (cArgs > 0) { + m_args = new _variant_t[cArgs]; + m_outValues = new _variant_t[cArgs]; + m_namedDispids = new DISPID[cArgs]; + + int j = cArgs - 1; + for (int i = 0; i < objc; i += 2, --j) { + char *name = Tcl_GetStringFromObj(objv[i], 0); + Method::Parameters::const_iterator p = findParameter( + parameters, + name, + m_namedDispids[j]); + if (p == parameters.end()) { + Tcl_AppendResult(interp, "unknown parameter ", name, NULL); + return TCL_ERROR; + } + + int result = initArgument(interp, objv[i+1], j, *p); + if (result != TCL_OK) { + return result; + } + } + } + + m_dispParams.rgvarg = m_args; + m_dispParams.rgdispidNamedArgs = m_namedDispids; + m_dispParams.cArgs = cArgs; + m_dispParams.cNamedArgs = cArgs; + + return TCL_OK; +} + + +int +UntypedArguments::initialize ( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[], + WORD dispatchFlags) +{ + if (objc > 0) { + m_args = new _variant_t[objc]; + + int j = objc - 1; + for (int i = 0; i < objc; ++i, --j) { + TclObject value(objv[i]); + + // 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); + } + } + + m_dispParams.rgvarg = m_args; + m_dispParams.cArgs = objc; + + if (dispatchFlags == DISPATCH_PROPERTYPUT + || dispatchFlags == DISPATCH_PROPERTYPUTREF) { + // Property puts have a named argument that represents the value being + // assigned to the property. + static DISPID mydispid = DISPID_PROPERTYPUT; + m_dispParams.rgdispidNamedArgs = &mydispid; + m_dispParams.cNamedArgs = 1; + } + + return TCL_OK; +} diff --git a/src/Arguments.h b/src/Arguments.h new file mode 100644 index 0000000..50e57f9 --- /dev/null +++ b/src/Arguments.h @@ -0,0 +1,124 @@ +// $Id: Arguments.h,v 1.8 2001/10/13 17:56:14 Administrator Exp $ +#ifndef ARGUMENTS_H +#define ARGUMENTS_H + +#include "TypeInfo.h" + +class Arguments +{ +protected: + DISPPARAMS m_dispParams; + + // argument values + _variant_t *m_args; + + Arguments(); + +public: + virtual ~Arguments(); + + // Get arguments in the format required by the Invoke function. + DISPPARAMS *dispParams () const + { return const_cast(&m_dispParams); } +}; + +// This abstract class represents the arguments passed in and out of a method +// for the case where we know the types of the parameters. + +class TypedArguments: public Arguments +{ +protected: + // used to hold values returned from out parameters + _variant_t *m_outValues; + + TypedArguments(); + + // Initialize a single argument. + int initArgument( + Tcl_Interp *interp, + Tcl_Obj *obj, + int argIndex, + const Parameter ¶meter); + +public: + virtual ~TypedArguments(); + + // Ready arguments for method invocation. + // Returns a Tcl completion code. + virtual int initialize( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[], + const Method &method, + WORD dispatchFlags) = 0; + + // Put the values returned from out parameters into Tcl variables. + void storeOutValues( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[], + const Method::Parameters ¶meters); +}; + +// This class represents arguments specified by their position in an argument +// list. + +class PositionalArguments: public TypedArguments +{ +public: + // Ready arguments for method invocation. + // Returns a Tcl completion code. + virtual int initialize( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[], + const Method &method, + WORD dispatchFlags); +}; + +// This class represents arguments specified by name. + +class NamedArguments: public TypedArguments +{ + // Search the parameter list for the named parameter. + static Method::Parameters::const_iterator findParameter( + const Method::Parameters ¶meters, + const std::string &name, + DISPID &dispid); + + // IDs of named arguments + DISPID *m_namedDispids; + +public: + NamedArguments (): + m_namedDispids(0) + { } + + ~NamedArguments(); + + // Ready arguments for method invocation. + // Returns a Tcl completion code. + virtual int initialize( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[], + const Method &method, + WORD dispatchFlags); +}; + +// This class represents the arguments passed into a method +// for the case where we don't know the types of the parameters. + +class UntypedArguments: public Arguments +{ +public: + // Ready arguments for method invocation. + // Returns a Tcl result code. + int initialize( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[], + WORD dispatchFlags); +}; + +#endif diff --git a/src/ComModule.cpp b/src/ComModule.cpp new file mode 100644 index 0000000..9ff5224 --- /dev/null +++ b/src/ComModule.cpp @@ -0,0 +1,108 @@ +// $Id: ComModule.cpp,v 1.15 2002/05/31 04:03:06 cthuang Exp $ +#pragma warning(disable: 4786) +#include "ComObjectFactory.h" +#include "ComModule.h" + +// This is the default module for event sink objects. + +class DefaultModule: public ComModule +{ +public: + DefaultModule () + { } + + ~DefaultModule () + { revokeFactories(); } +}; + + +ComModule *ComModule::ms_pInstance; + +Mutex ComModule::ms_singletonMutex; + +ComModule & +ComModule::instance () +{ + if (ms_pInstance == 0) { + LOCK_MUTEX(ms_singletonMutex) + static DefaultModule module; + } + return *ms_pInstance; +} + +// This exit handler uninitializes COM. + +static void +exitProc (ClientData) +{ + CoUninitialize(); +} + +void +ComModule::initializeCom (DWORD coinitFlags) +{ +#ifdef _WIN32_DCOM + CoInitializeEx(NULL, coinitFlags); +#else + CoInitialize(NULL); +#endif + +#ifdef TCL_THREADS + Tcl_CreateThreadExitHandler(exitProc, 0); +#else + Tcl_CreateExitHandler(exitProc, 0); +#endif +} + +DWORD +ComModule::regclsFlags () const +{ + return REGCLS_MULTIPLEUSE; +} + +void +ComModule::lock () +{ + InterlockedIncrement(&m_lockCount); +} + +long +ComModule::unlock () +{ + InterlockedDecrement(&m_lockCount); + return m_lockCount; +} + +void +ComModule::registerFactory (REFCLSID clsid, + ComObjectFactory *pFactory) +{ + pFactory->registerFactory(clsid, regclsFlags()); + + Uuid classId(clsid); + m_clsidToFactoryMap.insert(ClsidToFactoryMap::value_type( + classId, pFactory)); + pFactory->AddRef(); +} + +IClassFactory * +ComModule::find (REFCLSID clsid) +{ + Uuid classId(clsid); + ClsidToFactoryMap::iterator p = m_clsidToFactoryMap.find(classId); + if (p != m_clsidToFactoryMap.end()) { + return p->second; + } + return 0; +} + +void +ComModule::revokeFactories () +{ + ClsidToFactoryMap::iterator p = m_clsidToFactoryMap.begin(); + for (; p != m_clsidToFactoryMap.end(); ++p) { + p->second->Release(); + } + + m_clsidToFactoryMap.clear(); +} diff --git a/src/ComModule.h b/src/ComModule.h new file mode 100644 index 0000000..21816f4 --- /dev/null +++ b/src/ComModule.h @@ -0,0 +1,69 @@ +// $Id: ComModule.h,v 1.13 2002/04/13 03:53:56 cthuang Exp $ +#ifndef COMMODULE_H +#define COMMODULE_H + +#include +#include +#include "tcomApi.h" +#include "Uuid.h" +#include "mutex.h" + +class ComObjectFactory; + +// This class manages the life cycle of a COM server. + +class TCOM_API ComModule +{ + // used to track when the server can exit + long m_lockCount; + + // This maps a CLSID to a class factory. + typedef std::map ClsidToFactoryMap; + ClsidToFactoryMap m_clsidToFactoryMap; + + // singleton instance + static ComModule *ms_pInstance; + + // used to synchonize construction of singleton instance + static Mutex ms_singletonMutex; + + // Do not allow others to create and copy instances of this class. + ComModule(const ComModule &); // not implemented + void operator=(const ComModule &); // not implemented + +protected: + ComModule (): + m_lockCount(0) + { ms_pInstance = this; } + + // Get class object registration flags. + virtual DWORD regclsFlags() const; + +public: + // Get singleton instance. + static ComModule &instance(); + + // Initialize COM for the current thread. + virtual void initializeCom(DWORD coinitFlags); + + // Get lock count. + long lockCount () const + { return m_lockCount; } + + // Increment lock count. + virtual void lock(); + + // Decrement lock count. + virtual long unlock(); + + // Register a class factory. + void registerFactory(REFCLSID clsid, ComObjectFactory *pFactory); + + // Search for a class factory by CLSID. + IClassFactory *find(REFCLSID clsid); + + // Revoke all class factories. + void revokeFactories(); +}; + +#endif diff --git a/src/ComObject.cpp b/src/ComObject.cpp new file mode 100644 index 0000000..e0fc187 --- /dev/null +++ b/src/ComObject.cpp @@ -0,0 +1,844 @@ +// $Id: ComObject.cpp,v 1.37 2002/05/31 04:03:06 cthuang Exp $ +#pragma warning(disable: 4786) +#include "ComObject.h" +#include +#include "ComModule.h" +#include "InterfaceAdapter.h" +#include "Reference.h" +#include "Extension.h" + +// prefix prepended to operation name for property get +static const char getPrefix[] = "_get_"; + +// prefix prepended to operation name for property put +static const char setPrefix[] = "_set_"; + +ComObject::ComObject (const Class::Interfaces &interfaces, + Tcl_Interp *interp, + TclObject servant, + TclObject destructor): + m_refCount(0), + m_defaultInterface(*(interfaces.front())), + m_interp(interp), + m_servant(servant), + m_destructor(destructor), + m_supportErrorInfo(*this), + m_pDispatch(0) +{ +// Tcl_Preserve(reinterpret_cast(m_interp)); + ComModule::instance().lock(); + + for (Class::Interfaces::const_iterator p = interfaces.begin(); + p != interfaces.end(); ++p) { + const Interface *pInterface = *p; + m_supportedInterfaceMap.insert( + pInterface->iid(), const_cast(pInterface)); + } + + m_pDefaultAdapter = implementInterface(m_defaultInterface); +} + +ComObject::~ComObject () +{ + if (m_registeredActiveObject) { + // TODO: This call may return an error but I don't want to throw an + // exception from a destructor. + RevokeActiveObject(m_activeObjectHandle, 0); + } + + m_iidToAdapterMap.forEach(Delete()); + delete m_pDispatch; + + // Execute destructor Tcl command if defined. + int length; + Tcl_GetStringFromObj(m_destructor, &length); + if (length > 0) { + TclObject script(m_destructor); + script.lappend(m_servant); + eval(script); + } + + ComModule::instance().unlock(); +// Tcl_Release(reinterpret_cast(m_interp)); +} + +void +ComObject::registerActiveObject (REFCLSID clsid) +{ + HRESULT hr = RegisterActiveObject( + unknown(), clsid, ACTIVEOBJECT_WEAK, &m_activeObjectHandle); + if (FAILED(hr)) { + _com_issue_error(hr); + } + m_registeredActiveObject = true; +} + +InterfaceAdapter * +ComObject::implementInterface (const Interface &interfaceDesc) +{ + InterfaceAdapter *pAdapter = new InterfaceAdapter(*this, interfaceDesc); + m_iidToAdapterMap.insert(interfaceDesc.iid(), pAdapter); + return pAdapter; +} + +ComObject * +ComObject::newInstance ( + const Interface &defaultInterface, + Tcl_Interp *interp, + TclObject servant, + TclObject destructor) +{ + Class::Interfaces interfaces; + interfaces.push_back(&defaultInterface); + + return new ComObject( + interfaces, + interp, + servant, + destructor); +} + +ComObject * +ComObject::newInstance ( + const Class::Interfaces &interfaces, + Tcl_Interp *interp, + TclObject servant, + TclObject destructor) +{ + ComObject *pComObject = new ComObject( + interfaces, + interp, + servant, + destructor); + return pComObject; +} + +int +ComObject::eval (TclObject script, TclObject *pResult) +{ + int completionCode = +#if TCL_MINOR_VERSION >= 1 + Tcl_EvalObjEx(m_interp, script, TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL); +#else + Tcl_GlobalEvalObj(m_interp, script); +#endif + + if (pResult != 0) { + *pResult = Tcl_GetObjResult(m_interp); + } + return completionCode; +} + +int +ComObject::getVariable (TclObject name, TclObject &value) const +{ + Tcl_Obj *pValue = Tcl_ObjGetVar2(m_interp, name, 0, TCL_LEAVE_ERR_MSG); + if (pValue == 0) { + return TCL_ERROR; + } + value = pValue; + return TCL_OK; +} + +int +ComObject::setVariable (TclObject name, TclObject value) +{ + Tcl_Obj *pValue = + Tcl_ObjSetVar2(m_interp, name, 0, value, TCL_LEAVE_ERR_MSG); + return (pValue == 0) ? TCL_ERROR : TCL_OK; +} + +HRESULT +ComObject::hresultFromErrorCode () const +{ +#if TCL_MINOR_VERSION >= 1 + Tcl_Obj *pErrorCode = + Tcl_GetVar2Ex(m_interp, "::errorCode", 0, TCL_LEAVE_ERR_MSG); +#else + TclObject errorCodeVarName("::errorCode"); + Tcl_Obj *pErrorCode = + Tcl_ObjGetVar2(m_interp, errorCodeVarName, 0, TCL_LEAVE_ERR_MSG); +#endif + + if (pErrorCode == 0) { + return E_UNEXPECTED; + } + + Tcl_Obj *pErrorClass; + if (Tcl_ListObjIndex(m_interp, pErrorCode, 0, &pErrorClass) != TCL_OK) { + return E_UNEXPECTED; + } + if (strcmp(Tcl_GetStringFromObj(pErrorClass, 0), "COM") != 0) { + return E_UNEXPECTED; + } + + Tcl_Obj *pHresult; + if (Tcl_ListObjIndex(m_interp, pErrorCode, 1, &pHresult) != TCL_OK) { + return E_UNEXPECTED; + } + + HRESULT hr; + if (Tcl_GetLongFromObj(m_interp, pHresult, &hr) != TCL_OK) { + return E_UNEXPECTED; + } + return hr; +} + +// Implement IUnknown methods + +HRESULT +ComObject::queryInterface (REFIID iid, void **ppvObj) +{ + if (IsEqualIID(iid, IID_IUnknown)) { + *ppvObj = m_pDefaultAdapter; + addRef(); + return S_OK; + } + + 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); + } + *ppvObj = m_pDispatch; + addRef(); + return S_OK; + } + + if (IsEqualIID(iid, IID_ISupportErrorInfo)) { + *ppvObj = &m_supportErrorInfo; + addRef(); + return S_OK; + } + + InterfaceAdapter *pAdapter = m_iidToAdapterMap.find(iid); + if (pAdapter == 0) { + const Interface *pInterface = m_supportedInterfaceMap.find(iid); + if (pInterface != 0) { + pAdapter = implementInterface(*pInterface); + } + } + + if (pAdapter != 0) { + *ppvObj = pAdapter; + addRef(); + return S_OK; + } + + *ppvObj = 0; + return E_NOINTERFACE; +} + +ULONG +ComObject::addRef () +{ + InterlockedIncrement(&m_refCount); + return m_refCount; +} + +ULONG +ComObject::release () +{ + InterlockedDecrement(&m_refCount); + if (m_refCount == 0) { + delete this; + return 0; + } + return m_refCount; +} + +// Generate a name for a Tcl variable used to hold an argument out value. + +static TclObject +getOutVariableName (const Parameter ¶m) +{ + return TclObject(PACKAGE_NAMESPACE "arg_" + param.name()); +} + +// Convert IDispatch argument to Tcl value. + +TclObject +ComObject::getArgument (VARIANT *pArg, const Parameter ¶m) +{ + if (vtMissing == pArg) { + return Extension::newNaObj(); + + } else if (param.flags() & PARAMFLAG_FOUT) { + // Get name of Tcl variable to hold out value. + TclObject varName = getOutVariableName(param); + + if (param.flags() & PARAMFLAG_FIN) { + // For in/out parameters, set the Tcl variable to the input value. + TclObject value(pArg, param.type(), m_interp); + setVariable(varName, value); + } + return varName; + + } else { + return TclObject(pArg, param.type(), m_interp); + } +} + +// Fill exception information structure. + +static void +fillExcepInfo (EXCEPINFO *pExcepInfo, + HRESULT hresult, + const char *source, + const char *description) +{ + if (pExcepInfo != 0) { + memset(pExcepInfo, 0, sizeof(EXCEPINFO)); + pExcepInfo->scode = hresult; + + _bstr_t bstrSource(source); + pExcepInfo->bstrSource = SysAllocString(bstrSource); + + if (description != 0) { + _bstr_t bstrDescription(description); + pExcepInfo->bstrDescription = SysAllocString(bstrDescription); + } + } +} + +static void +putOutVariant (Tcl_Interp *interp, + VARIANT *pDest, + TclObject &tclObject, + const Type &type) +{ + switch (type.vartype()) { + case VT_BOOL: + *V_BOOLREF(pDest) = tclObject.getBool() ? VARIANT_TRUE : VARIANT_FALSE; + break; + + case VT_R4: + *V_R4REF(pDest) = static_cast(tclObject.getDouble()); + break; + + case VT_R8: + *V_R8REF(pDest) = tclObject.getDouble(); + break; + + case VT_DISPATCH: + case VT_UNKNOWN: + case VT_USERDEFINED: + { + IUnknown *pUnknown; + + Tcl_Obj *pObj = tclObject; + if (pObj->typePtr == &Extension::unknownPointerType) { + pUnknown = + static_cast(pObj->internalRep.otherValuePtr); + } else { + Reference *pRef = Extension::referenceHandles.find( + interp, tclObject); + pUnknown = (pRef == 0) ? 0 : pRef->unknown(); + } + + *V_UNKNOWNREF(pDest) = pUnknown; + + // The COM rules say we must increment the reference count of + // interface pointers returned from methods. + if (pUnknown != 0) { + pUnknown->AddRef(); + } + } + break; + + case VT_BSTR: + *V_BSTRREF(pDest) = tclObject.getBSTR(); + break; + + case VT_VARIANT: + { + // Must increment reference count of interface pointers returned + // from methods. + tclObject.toVariant( + V_VARIANTREF(pDest), Type::variant(), interp, true); + } + break; + + default: + *V_I4REF(pDest) = tclObject.getLong(); + } +} + +HRESULT +ComObject::invoke (InterfaceAdapter *pAdapter, + DISPID dispid, + REFIID /*riid*/, + LCID /*lcid*/, + WORD wFlags, + DISPPARAMS *pDispParams, + VARIANT *pReturnValue, + 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; + + try { + // Construct Tcl script to invoke operation on the servant. + TclObject script(m_servant); + + // 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(); + + } else if (wFlags & (DISPATCH_PROPERTYPUT | DISPATCH_PROPERTYPUTREF)) { + operation = setPrefix + pMethod->name(); + + } else if (wFlags & DISPATCH_METHOD) { + operation = pMethod->name(); + + } else { + return DISP_E_MEMBERNOTFOUND; + } + + script.lappend( + Tcl_NewStringObj(const_cast(operation.c_str()), -1)); + + // Set the argument error pointer in case we need to use it. + UINT argErr; + if (pArgErr == 0) { + pArgErr = &argErr; + } + + // Convert arguments to Tcl values. + // TODO: Should handle named arguments differently than positional + // arguments. + const Method::Parameters ¶meters = pMethod->parameters(); + + int argIndex = pDispParams->cArgs - 1; + Method::Parameters::const_iterator pParam; + for (pParam = parameters.begin(); pParam != parameters.end(); + ++pParam, --argIndex) { + // Append argument value. + VARIANT *pArg = &(pDispParams->rgvarg[argIndex]); + try { + script.lappend(getArgument(pArg, *pParam)); + } + catch (_com_error &) { + *pArgErr = argIndex; + throw; + } + } + + if (wFlags & (DISPATCH_PROPERTYPUT | DISPATCH_PROPERTYPUTREF)) { + VARIANT *pArg = &(pDispParams->rgvarg[argIndex]); + try { + TclObject value(pArg, pMethod->type(), m_interp); + script.lappend(value); + } + catch (_com_error &) { + *pArgErr = argIndex; + throw; + } + } + + // Execute the Tcl script. + TclObject result; + int completionCode = eval(script, &result); + if (completionCode != TCL_OK) { + fillExcepInfo( + pExcepInfo, + hresultFromErrorCode(), + m_servant.c_str(), + result.c_str()); + return DISP_E_EXCEPTION; + } + + // Copy values to out arguments. + argIndex = pDispParams->cArgs - 1; + for (pParam = parameters.begin(); pParam != parameters.end(); + ++pParam, --argIndex) { + if (pParam->flags() & PARAMFLAG_FOUT) { + // 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()); + } + } + } + + // Convert return value. + if (pReturnValue != 0 && pMethod->type().vartype() != VT_VOID) { + // Must increment reference count of interface pointers returned + // from methods. + result.toVariant(pReturnValue, pMethod->type(), m_interp, true); + } + + hresult = S_OK; + } + catch (_com_error &e) { + fillExcepInfo(pExcepInfo, e.Error(), m_servant.c_str(), 0); + hresult = DISP_E_EXCEPTION; + } + return hresult; +} + +// Convert the native value that the va_list points to into a Tcl object. +// Returns a va_list pointing to the next argument. + +static va_list +convertNativeToTclObject (va_list pArg, + Tcl_Interp *interp, + TclObject &tclObject, + const Type &type, + bool byRef=false) +{ + switch (type.vartype()) { + case VT_BOOL: + tclObject = Tcl_NewBooleanObj( + byRef ? *va_arg(pArg, VARIANT_BOOL *) : va_arg(pArg, VARIANT_BOOL)); + break; + + case VT_DATE: + case VT_R4: + case VT_R8: + tclObject = Tcl_NewDoubleObj( + byRef ? *va_arg(pArg, double *) : va_arg(pArg, double)); + break; + + case VT_USERDEFINED: + if (type.name() == "GUID") { + UUID *pUuid = va_arg(pArg, UUID *); + Uuid uuid(*pUuid); + tclObject = Tcl_NewStringObj( + const_cast(uuid.toString().c_str()), -1); + break; + } + // Fall through + + case VT_DISPATCH: + case VT_UNKNOWN: + { + IUnknown *pUnknown = va_arg(pArg, IUnknown *); + if (pUnknown == 0) { + tclObject = Tcl_NewObj(); + } else { + const Interface *pInterface = + InterfaceManager::instance().find(type.iid()); + tclObject = Extension::referenceHandles.newObj( + interp, Reference::newReference(pUnknown, pInterface)); + } + } + break; + + case VT_NULL: + tclObject = Tcl_NewObj(); + break; + + case VT_LPWSTR: + case VT_BSTR: + { +#if TCL_MINOR_VERSION >= 2 + // Uses Unicode function introduced in Tcl 8.2. + Tcl_UniChar *pUnicode = va_arg(pArg, Tcl_UniChar *); + if (pUnicode != 0) { + tclObject = Tcl_NewUnicodeObj(pUnicode, -1); + } else { + tclObject = Tcl_NewObj(); + } +#else + _bstr_t str(va_arg(pArg, wchar_t *)); + tclObject = Tcl_NewStringObj(str, -1); +#endif + } + break; + + default: + tclObject = Tcl_NewLongObj( + byRef ? *va_arg(pArg, int *) : va_arg(pArg, int)); + } + + return pArg; +} + +// Convert the native value that the va_list points to into a Tcl value. +// Returns a va_list pointing to the next argument. + +va_list +ComObject::getArgument ( + va_list pArg, const Parameter ¶m, TclObject &dest) +{ + if (param.flags() & PARAMFLAG_FOUT) { + // Get name of Tcl variable to hold out value. + TclObject varName = getOutVariableName(param); + + if (param.flags() & PARAMFLAG_FIN) { + // For in/out parameters, set the Tcl variable to the input value. + TclObject value; + pArg = convertNativeToTclObject( + pArg, m_interp, value, param.type(), true); + setVariable(varName, value); + } else { + // Advance to next argument. + va_arg(pArg, void *); + } + dest = varName; + return pArg; + + } else { + return convertNativeToTclObject( + pArg, m_interp, dest, param.type()); + } +} + +// Convert Tcl value to native value and store it at the address the va_list +// points to. +// Returns a va_list pointing to the next argument. + +static va_list +putArgument (va_list pArg, + Tcl_Interp *interp, + TclObject tclObject, + const Type &type) +{ + void *pDest = va_arg(pArg, void *); + if (pDest == 0) { + return pArg; + } + + switch (type.vartype()) { + case VT_BOOL: + *static_cast(pDest) = + tclObject.getBool() ? VARIANT_TRUE : VARIANT_FALSE; + break; + + case VT_R4: + *static_cast(pDest) = + static_cast(tclObject.getDouble()); + break; + + case VT_R8: + *static_cast(pDest) = tclObject.getDouble(); + break; + + case VT_USERDEFINED: + if (type.name() == "GUID") { + char *uuidStr = const_cast(tclObject.c_str()); + UUID uuid; + UuidFromString(reinterpret_cast(uuidStr), &uuid); + *static_cast(pDest) = uuid; + break; + } + // Fall through + + case VT_DISPATCH: + case VT_UNKNOWN: + { + IUnknown *pUnknown; + + Tcl_Obj *pObj = tclObject; + if (pObj->typePtr == &Extension::unknownPointerType) { + pUnknown = + static_cast(pObj->internalRep.otherValuePtr); + } else { + Reference *pRef = Extension::referenceHandles.find( + interp, tclObject); + pUnknown = (pRef == 0) ? 0 : pRef->unknown(); + } + + *static_cast(pDest) = pUnknown; + + // The COM rules say we must increment the reference count of + // interface pointers returned from methods. + if (pUnknown != 0) { + pUnknown->AddRef(); + } + } + break; + + case VT_BSTR: + *static_cast(pDest) = tclObject.getBSTR(); + break; + + case VT_VARIANT: + { + // Must increment reference count of interface pointers returned + // from methods. + tclObject.toVariant( + static_cast(pDest), + Type::variant(), + interp, + true); + } + break; + + default: + *static_cast(pDest) = tclObject.getLong(); + } + + return pArg; +} + +// Advance the va_list to the next argument. +// Returns a va_list pointing to the next argument. + +static va_list +nextArgument (va_list pArg, const Type &type) +{ + switch (type.vartype()) { + case VT_R4: + case VT_R8: + case VT_DATE: + va_arg(pArg, double); + break; + + case VT_DISPATCH: + case VT_UNKNOWN: + case VT_USERDEFINED: + va_arg(pArg, IUnknown *); + break; + + case VT_BSTR: + va_arg(pArg, BSTR); + break; + + default: + va_arg(pArg, int); + } + + return pArg; +} + +// Set error info. + +static void +setErrorInfo (const char *source, const char *description) +{ + HRESULT hr; + + ICreateErrorInfoPtr pCreateErrorInfo; + hr = CreateErrorInfo(&pCreateErrorInfo); + if (FAILED(hr)) { + return; + } + + _bstr_t sourceBstr(source); + pCreateErrorInfo->SetSource(sourceBstr); + + _bstr_t descriptionBstr(description); + pCreateErrorInfo->SetDescription(descriptionBstr); + + IErrorInfoPtr pErrorInfo; + hr = pCreateErrorInfo->QueryInterface( + IID_IErrorInfo, reinterpret_cast(&pErrorInfo)); + if (SUCCEEDED(hr)) { + SetErrorInfo(0, pErrorInfo); + } +} + +// Note that this function is called in an odd way to avoid copying the +// arguments onto the stack (for efficiency and simplicity in the calling +// code). This is why the call is explicitly declared __cdecl. + +void __cdecl +invokeComObjectFunction (volatile HRESULT hresult, + volatile DWORD pArgEnd, + DWORD /*ebp*/, + DWORD funcIndex, + DWORD /*retAddr*/, + InterfaceAdapter *pAdapter, + ...) +{ + // Get the method description for method being invoked. + const Method *pMethod = pAdapter->findComMethod(funcIndex); + if (pMethod == 0) { + // If we don't have a method description, we don't know how many bytes + // the arguments take on the stack. + throw std::runtime_error("unknown virtual function index"); + } + + ComObject &object = pAdapter->object(); + + // Construct Tcl script to invoke operation on the servant. + TclObject script(object.m_servant); + + std::string operation; + switch (pMethod->invokeKind()) { + case INVOKE_PROPERTYGET: + operation = getPrefix + pMethod->name(); + break; + case INVOKE_PROPERTYPUT: + case INVOKE_PROPERTYPUTREF: + operation = setPrefix + pMethod->name(); + break; + default: + operation = pMethod->name(); + } + script.lappend( + Tcl_NewStringObj(const_cast(operation.c_str()), -1)); + + // Convert arguments to Tcl values. + va_list pArg; + va_start(pArg, pAdapter); + const Method::Parameters ¶meters = pMethod->parameters(); + Method::Parameters::const_iterator pParam = parameters.begin(); + for (; pParam != parameters.end(); ++pParam) { + // Append argument value. + TclObject argument; + pArg = object.getArgument(pArg, *pParam, argument); + script.lappend(argument); + } + + // Set end of arguments pointer. + if (pMethod->type().vartype() != VT_VOID) { + va_arg(pArg, void *); + } + pArgEnd = reinterpret_cast(pArg); + va_end(pArg); + + // Execute the Tcl script. + TclObject result; + int completionCode = object.eval(script, &result); + if (completionCode == TCL_OK) { + hresult = S_OK; + } else { + hresult = object.hresultFromErrorCode(); + setErrorInfo(object.m_servant.c_str(), result.c_str()); + } + + // Copy values to out arguments. + va_start(pArg, pAdapter); + pParam = parameters.begin(); + for (; pParam != parameters.end(); ++pParam) { + if (pParam->flags() & PARAMFLAG_FOUT) { + // Get name of Tcl variable that holds out value. + TclObject varName = getOutVariableName(*pParam); + + // Copy variable value to out argument. + TclObject value; + if (object.getVariable(varName, value) == TCL_OK) { + pArg = putArgument( + pArg, object.m_interp, value, pParam->type()); + continue; + } + } + + pArg = nextArgument(pArg, pParam->type()); + } + + // Convert return value. + if (pMethod->type().vartype() != VT_VOID) { + putArgument(pArg, object.m_interp, result, pMethod->type()); + } + + va_end(pArg); +} diff --git a/src/ComObject.h b/src/ComObject.h new file mode 100644 index 0000000..1d71c0a --- /dev/null +++ b/src/ComObject.h @@ -0,0 +1,145 @@ +// $Id: ComObject.h,v 1.14 2002/04/13 03:53:56 cthuang Exp $ +#ifndef COMOBJECT_H +#define COMOBJECT_H + +#include +#include "tcomApi.h" +#include "HashTable.h" +#include "TclObject.h" +#include "TypeInfo.h" +#include "SupportErrorInfo.h" + +class TCOM_API InterfaceAdapter; + +// This class represents a COM object. +// The COM object methods are implemented by executing a Tcl command. + +class TCOM_API ComObject +{ + // Implement method invocation through virtual function table call. + friend void __cdecl invokeComObjectFunction( + volatile HRESULT hresult, + volatile DWORD pArgEnd, + DWORD ebp, + DWORD funcIndex, + DWORD retAddr, + InterfaceAdapter *pThis, + ...); + + // count of references to this object + long m_refCount; + + // description of default interface + const Interface &m_defaultInterface; + + // TODO: Directly accessing the Tcl interpreter means the object must run + // in a single threaded apartment to comply with Tcl's threading rules. + + // interpreter used to execute Tcl command + Tcl_Interp *m_interp; + + // Tcl command executed to implement methods + TclObject m_servant; + + // Tcl command executed when this COM object is destroyed + TclObject m_destructor; + + // collection of interfaces this object can implement + typedef HashTable SupportedInterfaceMap; + SupportedInterfaceMap m_supportedInterfaceMap; + + // collection of implemented interface adapters + typedef HashTable IidToAdapterMap; + IidToAdapterMap m_iidToAdapterMap; + + // implements default interface + InterfaceAdapter *m_pDefaultAdapter; + + // implements ISupportErrorInfo + SupportErrorInfo m_supportErrorInfo; + + // implements IDispatch + InterfaceAdapter *m_pDispatch; + + // token returned from RegisterActiveObject + unsigned long m_activeObjectHandle; + + // true if object registered in running object table + bool m_registeredActiveObject; + + // Do not allow others to create or copy instances of this class. + ComObject( + const Class::Interfaces &interfaces, + Tcl_Interp *interp, + TclObject servant, + TclObject destructor); + ComObject(const ComObject &); // not implemented + void operator=(const ComObject &); // not implemented + + // Create an adapter which implements the specified interface. + InterfaceAdapter *implementInterface(const Interface &interfaceDesc); + + // Convert IDispatch argument to Tcl value. + TclObject getArgument(VARIANT *pArg, const Parameter ¶m); + + // Convert the native value that the va_list points to into a Tcl value. + // Returns a va_list pointing to the next argument. + va_list getArgument(va_list pArg, const Parameter ¶m, TclObject &dest); + +public: + static ComObject *newInstance( + const Interface &defaultInterface, + Tcl_Interp *interp, + TclObject servant, + TclObject destructor); + static ComObject *newInstance( + const Class::Interfaces &interfaces, + Tcl_Interp *interp, + TclObject servant, + TclObject destructor); + ~ComObject(); + + // Register object in running object table. + void registerActiveObject(REFCLSID clsid); + + // Return true if the interface is implemented. + bool implemented (REFIID iid) const + { return m_iidToAdapterMap.find(iid) != 0; } + + // Get IUnknown pointer to default interface. + IUnknown *unknown () const + { return reinterpret_cast(m_pDefaultAdapter); } + + // Execute Tcl script. Returns Tcl completion code. + int eval(TclObject script, TclObject *pResult=0); + + // Get Tcl variable. Returns Tcl completion code. + int getVariable(TclObject name, TclObject &value) const; + + // Set Tcl variable. Returns Tcl completion code. + int setVariable(TclObject name, TclObject value); + + // If the first element of the Tcl errorCode variable is "COM", convert + // second element to an HRESULT. Return E_UNEXPECTED if errorCode does + // not contain a recognizable value. + HRESULT hresultFromErrorCode() const; + + // IUnknown implementation + HRESULT queryInterface(REFIID riid, void **ppvObj); + ULONG addRef(); + ULONG release(); + + // IDispatch implementation + HRESULT invoke( + InterfaceAdapter *pThis, + DISPID dispidMember, + REFIID riid, + LCID lcid, + WORD wFlags, + DISPPARAMS *pdispparams, + VARIANT *pvarResult, + EXCEPINFO *pexcepinfo, + UINT *puArgErr); +}; + +#endif diff --git a/src/ComObjectFactory.cpp b/src/ComObjectFactory.cpp new file mode 100644 index 0000000..8176be5 --- /dev/null +++ b/src/ComObjectFactory.cpp @@ -0,0 +1,179 @@ +// $Id: ComObjectFactory.cpp,v 1.17 2002/05/31 04:03:06 cthuang Exp $ +#pragma warning(disable: 4786) +#include "ComModule.h" +#include "ComObject.h" +#include "ComObjectFactory.h" + +ComObjectFactory::ComObjectFactory (const Class::Interfaces &interfaces, + Tcl_Interp *interp, + TclObject constructor, + TclObject destructor, + bool registerActiveObject): + m_refCount(0), + m_interfaces(interfaces), + m_interp(interp), + m_constructor(constructor), + m_destructor(destructor), + m_registerActiveObject(registerActiveObject), + m_registeredFactory(false) +{ } + +ComObjectFactory::~ComObjectFactory () +{ + if (m_registeredFactory) { + // TODO: This call can return an error but I don't want to throw an + // exception from a destructor. + CoRevokeClassObject(m_classObjectHandle); + } +} + +void +ComObjectFactory::registerFactory (REFCLSID clsid, DWORD regclsFlags) +{ + m_clsid = clsid; + + HRESULT hr = CoRegisterClassObject( + clsid, + this, + CLSCTX_SERVER, + regclsFlags, + &m_classObjectHandle); + if (FAILED(hr)) { + _com_issue_error(hr); + } + m_registeredFactory = true; +} + +STDMETHODIMP +ComObjectFactory::QueryInterface (REFIID iid, void **ppvObj) +{ + if (IsEqualIID(iid, IID_IClassFactory) || IsEqualIID(iid, IID_IUnknown)) { + *ppvObj = this; + AddRef(); + return S_OK; + } + + *ppvObj = 0; + return E_NOINTERFACE; +} + +STDMETHODIMP_(ULONG) +ComObjectFactory::AddRef () +{ + InterlockedIncrement(&m_refCount); + return m_refCount; +} + +STDMETHODIMP_(ULONG) +ComObjectFactory::Release () +{ + InterlockedDecrement(&m_refCount); + if (m_refCount == 0) { + delete this; + return 0; + } + return m_refCount; +} + +int +ComObjectFactory::eval (TclObject script, TclObject *pResult) +{ + int completionCode = +#if TCL_MINOR_VERSION >= 1 + Tcl_EvalObjEx(m_interp, script, TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL); +#else + Tcl_GlobalEvalObj(m_interp, script); +#endif + + if (pResult != 0) { + *pResult = Tcl_GetObjResult(m_interp); + } + return completionCode; +} + +STDMETHODIMP +ComObjectFactory::CreateInstance (IUnknown *pOuter, REFIID iid, void **ppvObj) +{ + // We don't support aggregation. + if (pOuter != 0) { + *ppvObj = 0; + return CLASS_E_NOAGGREGATION; + } + + // Execute Tcl script to create a servant. The script should return the + // name of a Tcl command which implements the object's operations. + TclObject servant; + int completionCode = eval(m_constructor, &servant); + if (completionCode != TCL_OK) { + *ppvObj = 0; + return E_UNEXPECTED; + } + + // Create a COM object and tie its implementation to the servant. + ComObject *pComObject = ComObject::newInstance( + m_interfaces, + m_interp, + servant, + m_destructor); + + if (m_registerActiveObject) { + pComObject->registerActiveObject(m_clsid); + } + + return pComObject->unknown()->QueryInterface(iid, ppvObj); +} + +STDMETHODIMP +ComObjectFactory::LockServer (BOOL lock) +{ + if (lock) { + ComModule::instance().lock(); + } else { + ComModule::instance().unlock(); + } + return S_OK; +} + + +SingletonObjectFactory::SingletonObjectFactory ( + const Class::Interfaces &interfaces, + Tcl_Interp *interp, + TclObject constructor, + TclObject destructor, + bool registerActiveObject): + ComObjectFactory( + interfaces, + interp, + constructor, + destructor, + registerActiveObject), + m_pInstance(0) +{ } + +SingletonObjectFactory::~SingletonObjectFactory () +{ + if (m_pInstance != 0) { + m_pInstance->Release(); + } +} + +STDMETHODIMP +SingletonObjectFactory::CreateInstance (IUnknown *pOuter, + REFIID iid, + void **ppvObj) +{ + if (m_pInstance == 0) { + LOCK_MUTEX(m_mutex) + if (m_pInstance == 0) { + HRESULT hr = ComObjectFactory::CreateInstance( + pOuter, + iid, + reinterpret_cast(&m_pInstance)); + if (FAILED(hr)) { + return hr; + } + } + } + + return m_pInstance->QueryInterface(iid, ppvObj); +} diff --git a/src/ComObjectFactory.h b/src/ComObjectFactory.h new file mode 100644 index 0000000..6bf8e14 --- /dev/null +++ b/src/ComObjectFactory.h @@ -0,0 +1,96 @@ +// $Id: ComObjectFactory.h,v 1.11 2002/04/13 03:53:56 cthuang Exp $ +#ifndef COMOBJECTFACTORY_H +#define COMOBJECTFACTORY_H + +#include "tcomApi.h" +#include "mutex.h" +#include "TclObject.h" +#include "TypeInfo.h" + +// This is a factory of COM objects. + +class TCOM_API ComObjectFactory: public IClassFactory +{ + // reference count of the factory + long m_refCount; + + // interfaces to implement + const Class::Interfaces &m_interfaces; + + // TODO: Directly accessing the Tcl interpreter means the object must run + // in a single threaded apartment to comply with Tcl's threading rules. + + // Tcl interpreter used to execute Tcl commands + Tcl_Interp *m_interp; + + // Tcl command executed to create a servant + TclObject m_constructor; + + // Tcl command executed to destroy servant + TclObject m_destructor; + + // handle of registered class object + unsigned long m_classObjectHandle; + + // CLSID used to register active object + CLSID m_clsid; + + // true if created objects should be registered in running object table + bool m_registerActiveObject; + + // true if object factory was registered + bool m_registeredFactory; + + // Execute Tcl script. Returns Tcl completion code. + int eval(TclObject script, TclObject *pResult=0); + + // Do not allow others to copy instances of this class. + ComObjectFactory(const ComObjectFactory &); // not implemented + void operator=(const ComObjectFactory &); // not implemented + +public: + ComObjectFactory( + const Class::Interfaces &interfaces, + Tcl_Interp *interp, + TclObject constructor, + TclObject destructor, + bool registerActiveObject); + virtual ~ComObjectFactory(); + + // Register factory. + void registerFactory(REFCLSID clsid, DWORD regclsFlags); + + // IUnknown methods + STDMETHOD(QueryInterface)(REFIID riid, void **ppvObj); + STDMETHOD_(ULONG, AddRef)(); + STDMETHOD_(ULONG, Release)(); + + // IClassFactory methods + STDMETHOD(CreateInstance)(IUnknown *pOuter, REFIID riid, void **ppvObj); + STDMETHOD(LockServer)(BOOL fLock); +}; + +// This factory always returns the same instance. + +class TCOM_API SingletonObjectFactory: public ComObjectFactory +{ + // singleton instance returned from factory + IUnknown *m_pInstance; + + // used to synchronize construction of singleton instance + Mutex m_mutex; + +public: + SingletonObjectFactory( + const Class::Interfaces &interfaces, + Tcl_Interp *interp, + TclObject constructor, + TclObject destructor, + bool registerActiveObject); + ~SingletonObjectFactory(); + + // Override create function. + STDMETHOD(CreateInstance)(IUnknown *pOuter, REFIID riid, void **ppvObj); +}; + +#endif diff --git a/src/Extension.cpp b/src/Extension.cpp new file mode 100644 index 0000000..ab53fba --- /dev/null +++ b/src/Extension.cpp @@ -0,0 +1,99 @@ +// $Id: Extension.cpp,v 1.1 2002/06/29 15:40:32 cthuang Exp $ +#pragma warning(disable: 4786) +#include "Extension.h" +#include "ComModule.h" + +Extension::Extension (Tcl_Interp *interp): + m_interp(interp), + m_comInitialized(false) +{ + // Register new internal representation types. + Tcl_RegisterObjType(&naType); + Tcl_RegisterObjType(&nullType); + Tcl_RegisterObjType(&unknownPointerType); + + // Create additional commands. + Tcl_CreateObjCommand( + interp, PACKAGE_NAMESPACE "bind", bindCmd, 0, 0); + Tcl_CreateObjCommand( + interp, PACKAGE_NAMESPACE "class", classCmd, 0, 0); + Tcl_CreateObjCommand( + interp, PACKAGE_NAMESPACE "configure", configureCmd, this, 0); + Tcl_CreateObjCommand( + interp, PACKAGE_NAMESPACE "foreach", foreachCmd, 0, 0); + Tcl_CreateObjCommand( + interp, PACKAGE_NAMESPACE "import", importCmd, this, 0); + Tcl_CreateObjCommand( + interp, PACKAGE_NAMESPACE "info", infoCmd, 0, 0); + Tcl_CreateObjCommand( + interp, PACKAGE_NAMESPACE "interface", interfaceCmd, 0, 0); + Tcl_CreateObjCommand( + interp, PACKAGE_NAMESPACE "method", methodCmd, 0, 0); + Tcl_CreateObjCommand( + interp, PACKAGE_NAMESPACE "na", naCmd, 0, 0); + Tcl_CreateObjCommand( + interp, PACKAGE_NAMESPACE "null", nullCmd, 0, 0); + Tcl_CreateObjCommand( + interp, PACKAGE_NAMESPACE "object", objectCmd, this, 0); + Tcl_CreateObjCommand( + interp, PACKAGE_NAMESPACE "property", propertyCmd, 0, 0); + Tcl_CreateObjCommand( + interp, PACKAGE_NAMESPACE "ref", refCmd, this, 0); + Tcl_CreateObjCommand( + interp, PACKAGE_NAMESPACE "shortPathName", shortPathNameCmd, 0, 0); + Tcl_CreateObjCommand( + interp, PACKAGE_NAMESPACE "typelib", typelibCmd, 0, 0); + Tcl_CreateObjCommand( + interp, PACKAGE_NAMESPACE "typeof", typeofCmd, 0, 0); + Tcl_CreateObjCommand( + interp, PACKAGE_NAMESPACE "unbind", unbindCmd, 0, 0); + + Tcl_CallWhenDeleted(interp, interpDeleteProc, this); + Tcl_CreateExitHandler(exitProc, this); +} + +void +Extension::interpDeleteProc (ClientData clientData, Tcl_Interp *) +{ + Tcl_DeleteExitHandler(exitProc, clientData); + delete static_cast(clientData); +} + +void +Extension::exitProc (ClientData clientData) +{ + Extension *pExtension = + static_cast(clientData); + Tcl_DontCallWhenDeleted(pExtension->m_interp, interpDeleteProc, clientData); + delete pExtension; +} + +void +Extension::initializeCom () +{ + if (!m_comInitialized) { + ComModule::instance().initializeCom(m_coinitFlags); + m_comInitialized = true; + } +} + +// This Tcl command returns the name of the argument's internal +// representation type. + +int +Extension::typeofCmd ( + ClientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "value"); + return TCL_ERROR; + } + + Tcl_ObjType *pType = objv[1]->typePtr; + char *name = (pType == 0) ? "NULL" : pType->name; + Tcl_SetResult(interp, name, TCL_STATIC); + return TCL_OK; +} diff --git a/src/Extension.h b/src/Extension.h new file mode 100644 index 0000000..de47b6c --- /dev/null +++ b/src/Extension.h @@ -0,0 +1,103 @@ +// $Id: Extension.h,v 1.1 2002/06/29 15:40:32 cthuang Exp $ +#ifndef EXTENSION_H +#define EXTENSION_H + +#include +#include +#include "tcomApi.h" +#include "HandleSupport.h" + +// package name +#define PACKAGE_NAME "tcom" + +// namespace where the package defines new commands +#define PACKAGE_NAMESPACE "::tcom::" + +class Class; +class Interface; +class InterfaceHolder; +class Reference; +class TypeLib; + +// This class implements the commands and state of an extension loaded into a +// Tcl interpreter. + +class TCOM_API Extension +{ + // interpreter associated with this object + Tcl_Interp *m_interp; + + // flags used to initialize COM + DWORD m_coinitFlags; + + // true if COM was initialized + bool m_comInitialized; + + static void interpDeleteProc(ClientData clientData, Tcl_Interp *interp); + static void exitProc(ClientData clientData); + + static int bindCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); + static int classCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); + static int configureCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); + static int foreachCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); + static int importCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); + static int infoCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); + static int interfaceCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); + static int methodCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); + static int naCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); + static int nullCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); + static int objectCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); + static int propertyCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); + static int refCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); + static int shortPathNameCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); + static int typelibCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); + static int typeofCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); + static int unbindCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); + + // not implemented + Extension(const Extension &); + void operator=(const Extension &); + + ~Extension () + { } + +public: + Extension(Tcl_Interp *interp); + + // Set the concurrency model to be used by the current thread. + void concurrencyModel (DWORD flags) + { m_coinitFlags = flags; } + + // Get the concurrency model to be used by the current thread. + DWORD concurrencyModel () const + { return m_coinitFlags; } + + // Initialize COM if not already initialized. + void initializeCom(); + + // handle support objects + static HandleSupport interfaceHolderHandles; + static HandleSupport referenceHandles; + static HandleSupport typeLibHandles; + + // new Tcl internal representation types + static Tcl_ObjType naType; + static Tcl_ObjType nullType; + static Tcl_ObjType unknownPointerType; + + // Create a Tcl value representing a missing optional argument. + static Tcl_Obj *newNaObj(); + + // Set the Tcl result to a description of the COM error and return TCL_ERROR. + static int setComErrorResult( + Tcl_Interp *interp, _com_error &e, const char *file, int line); + + // Find class description by name. + static const Class *findClassByCmdName(Tcl_Interp *interp, Tcl_Obj *pName); + + // Find interface description by name. + static const Interface *findInterfaceByCmdName( + Tcl_Interp *interp, Tcl_Obj *pName); +}; + +#endif diff --git a/src/HandleSupport.cpp b/src/HandleSupport.cpp new file mode 100644 index 0000000..2795dcf --- /dev/null +++ b/src/HandleSupport.cpp @@ -0,0 +1,276 @@ +// $Id: HandleSupport.cpp,v 1.15 2002/05/31 04:03:06 cthuang Exp $ +#include "HandleSupport.h" +#include +#include "ThreadLocalStorage.h" + +InternalRep::InternalRep ( + Tcl_Interp *interp, + Tcl_ObjCmdProc *pCmdProc, + ClientData objClientData): + m_interp(interp), + m_clientData(objClientData), + m_handleCount(0) +{ + std::string handleName(name()); + + m_command = Tcl_CreateObjCommand( + m_interp, + const_cast(handleName.c_str()), + pCmdProc, + objClientData, + 0); + + HandleNameToRepMap::instance(interp)->insert(handleName.c_str(), this); +} + +InternalRep::~InternalRep () +{ + HandleNameToRepMap::instance(m_interp)->erase(name().c_str()); + Tcl_DeleteCommandFromToken(m_interp, m_command); +} + +std::string +InternalRep::name () const +{ + std::ostringstream oss; + oss << "::tcom::handle0x" << std::hex << this; + return oss.str(); +} + +void +InternalRep::incrHandleCount () +{ + ++m_handleCount; +} + +long +InternalRep::decrHandleCount () +{ + if (--m_handleCount == 0) { + delete this; + return 0; + } + return m_handleCount; +} + + +// This maps Tcl_Obj pointers to an internal representation. + +class ObjToRepMap +{ + Tcl_HashTable m_hashTable; + + static ThreadLocalStorage ms_tls; + + static void exitProc(ClientData); + + // not implemented + ObjToRepMap(const ObjToRepMap &); + void operator=(const ObjToRepMap &); + + ~ObjToRepMap(); + +public: + ObjToRepMap(); + static ObjToRepMap &instance(); + + void insert(Tcl_Obj *pObj, InternalRep *pRep); + InternalRep *find(Tcl_Obj *pObj); + void erase(Tcl_Obj *pObj); +}; + +ThreadLocalStorage ObjToRepMap::ms_tls; + +void +ObjToRepMap::exitProc (ClientData clientData) +{ + delete static_cast(clientData); +} + +ObjToRepMap::ObjToRepMap () +{ + Tcl_InitHashTable(&m_hashTable, TCL_ONE_WORD_KEYS); + +#ifdef TCL_THREADS + Tcl_CreateThreadExitHandler(exitProc, this); +#else + Tcl_CreateExitHandler(exitProc, 0); +#endif +} + +ObjToRepMap::~ObjToRepMap () +{ + Tcl_DeleteHashTable(&m_hashTable); +} + +ObjToRepMap & +ObjToRepMap::instance () +{ + return ms_tls.instance(); +} + +void +ObjToRepMap::insert (Tcl_Obj *pObj, InternalRep *pRep) +{ + int isNew; + Tcl_HashEntry *pEntry = Tcl_CreateHashEntry( + &m_hashTable, reinterpret_cast(pObj), &isNew); + Tcl_SetHashValue(pEntry, pRep); +} + +InternalRep * +ObjToRepMap::find (Tcl_Obj *pObj) +{ + Tcl_HashEntry *pEntry = Tcl_FindHashEntry( + &m_hashTable, reinterpret_cast(pObj)); + if (pEntry == 0) { + return 0; + } + return static_cast(Tcl_GetHashValue(pEntry)); +} + +void +ObjToRepMap::erase (Tcl_Obj *pObj) +{ + Tcl_HashEntry *pEntry = Tcl_FindHashEntry( + &m_hashTable, reinterpret_cast(pObj)); + if (pEntry != 0) { + Tcl_DeleteHashEntry(pEntry); + } +} + + +Tcl_ObjType *CmdNameType::ms_pCmdNameType; +Tcl_ObjType CmdNameType::ms_oldCmdNameType; + +Singleton CmdNameType::ms_singleton; + +CmdNameType & +CmdNameType::instance () +{ + return ms_singleton.instance(); +} + +CmdNameType::CmdNameType () +{ + // Hijack Tcl's cmdName type. + ms_pCmdNameType = Tcl_GetObjType("cmdName"); + ms_oldCmdNameType = *ms_pCmdNameType; + ms_pCmdNameType->freeIntRepProc = freeInternalRep; + ms_pCmdNameType->dupIntRepProc = dupInternalRep; + ms_pCmdNameType->updateStringProc = updateString; + ms_pCmdNameType->setFromAnyProc = setFromAny; +} + +CmdNameType::~CmdNameType () +{ + // Restore original cmdName type. + ms_pCmdNameType->freeIntRepProc = ms_oldCmdNameType.freeIntRepProc; + ms_pCmdNameType->dupIntRepProc = ms_oldCmdNameType.dupIntRepProc; + ms_pCmdNameType->updateStringProc = ms_oldCmdNameType.updateStringProc; + ms_pCmdNameType->setFromAnyProc = ms_oldCmdNameType.setFromAnyProc; +} + +void +CmdNameType::freeInternalRep (Tcl_Obj *pObj) +{ + if (pObj->refCount == 0) { + InternalRep *pRep = ObjToRepMap::instance().find(pObj); + if (pRep != 0 && pRep->decrHandleCount() == 0) { + ObjToRepMap::instance().erase(pObj); + } + } + + ms_oldCmdNameType.freeIntRepProc(pObj); +} + +void +CmdNameType::dupInternalRep (Tcl_Obj *pSrc, Tcl_Obj *pDup) +{ + // TODO: An object is duplicated if it is about to be modified. We cannot + // allow modifications on a handle. + + ms_oldCmdNameType.dupIntRepProc(pSrc, pDup); +} + +// This should never be called because the string representation should already +// be valid. + +void +CmdNameType::updateString (Tcl_Obj *pObj) +{ + ms_oldCmdNameType.updateStringProc(pObj); +} + +int +CmdNameType::setFromAny (Tcl_Interp *interp, Tcl_Obj *pObj) +{ + // Check if the string represents an existing handle. + HandleNameToRepMap *pHandleNameToRepMap = + HandleNameToRepMap::instance(interp); + if (pHandleNameToRepMap != 0) { + InternalRep *pRep = pHandleNameToRepMap->find(pObj); + if (pRep != 0) { + if (ObjToRepMap::instance().find(pObj) == 0) { + ObjToRepMap::instance().insert(pObj, pRep); + pRep->incrHandleCount(); + } + } + } + + return ms_oldCmdNameType.setFromAnyProc(interp, pObj); +} + +Tcl_Obj * +CmdNameType::newObj (Tcl_Interp *interp, InternalRep *pRep) +{ + Tcl_Obj *pObj = Tcl_NewStringObj( + const_cast(pRep->name().c_str()), -1); + Tcl_ConvertToType(interp, pObj, ms_pCmdNameType); + return pObj; +} + + +static char ASSOC_KEY[] = "tcomHandles"; + +HandleNameToRepMap::HandleNameToRepMap (Tcl_Interp *interp): + m_interp(interp) +{ + Tcl_SetAssocData(interp, ASSOC_KEY, deleteInterpProc, this); + Tcl_CreateExitHandler(exitProc, this); +} + +HandleNameToRepMap::~HandleNameToRepMap () +{ + // Clean up any left over objects. + clear(); +} + +void +HandleNameToRepMap::deleteInterpProc (ClientData clientData, Tcl_Interp *) +{ + Tcl_DeleteExitHandler(exitProc, clientData); + delete static_cast(clientData); +} + +void +HandleNameToRepMap::exitProc (ClientData clientData) +{ + HandleNameToRepMap *pHandleNameToRepMap = + static_cast(clientData); + Tcl_DeleteAssocData(pHandleNameToRepMap->m_interp, ASSOC_KEY); +} + +HandleNameToRepMap * +HandleNameToRepMap::instance (Tcl_Interp *interp) +{ + return static_cast( + Tcl_GetAssocData(interp, ASSOC_KEY, 0)); +} + +void +HandleNameToRepMap::clear () +{ + m_map.forEach(Delete()); + m_map.clear(); +} diff --git a/src/HandleSupport.h b/src/HandleSupport.h new file mode 100644 index 0000000..51ad6c0 --- /dev/null +++ b/src/HandleSupport.h @@ -0,0 +1,182 @@ +// $Id: HandleSupport.h,v 1.27 2002/04/17 21:43:07 cthuang Exp $ +#ifndef HANDLESUPPORT_H +#define HANDLESUPPORT_H + +#include +#include +#include "tcomApi.h" +#include "HashTable.h" +#include "Singleton.h" + +// This class represents an association from a handle to an application object. +// A handle maps to an object of this class. + +class TCOM_API InternalRep +{ +protected: + Tcl_Interp *m_interp; + Tcl_Command m_command; + ClientData m_clientData; + + // number of Tcl_Obj instances that are handles to this object + long m_handleCount; + +public: + InternalRep( + Tcl_Interp *interp, + Tcl_ObjCmdProc *pCmdProc, + ClientData clientData); + virtual ~InternalRep(); + + // Get handle name. + std::string name() const; + + // Get pointer to the application object. + ClientData clientData () const + { return m_clientData; } + + void incrHandleCount(); + long decrHandleCount(); +}; + +// This class extends InternalRep to associate with a specific application +// object class. The class takes ownership of the passed in application object +// and is responsible for deleting it. + +template +class AppInternalRep: public InternalRep +{ +public: + AppInternalRep ( + Tcl_Interp *interp, + Tcl_ObjCmdProc *pCmdProc, + AppType *pAppObject): + InternalRep(interp, pCmdProc, pAppObject) + { } + + virtual ~AppInternalRep(); +}; + +template +AppInternalRep::~AppInternalRep () +{ + delete reinterpret_cast(clientData()); +} + +// Handles are instances of Tcl's cmdName type which this class hijacks in +// order to map handles to application objects. + +class TCOM_API CmdNameType +{ + // pointer to Tcl cmdName type + static Tcl_ObjType *ms_pCmdNameType; + + // saved Tcl cmdName type + static Tcl_ObjType ms_oldCmdNameType; + + // Tcl type functions + static void freeInternalRep(Tcl_Obj *pObj); + static void dupInternalRep(Tcl_Obj *pSrc, Tcl_Obj *pDup); + static void updateString(Tcl_Obj *pObj); + static int setFromAny(Tcl_Interp *interp, Tcl_Obj *pObj); + + friend class Singleton; + static Singleton ms_singleton; + + CmdNameType(); + ~CmdNameType(); + +public: + // Get instance of this class. + static CmdNameType &instance(); + + // Create handle. + Tcl_Obj *newObj(Tcl_Interp *interp, InternalRep *pRep); +}; + +// Maps handle name to internal representation. There's an instance of this +// class associated with each Tcl interpreter that loads the extension. + +class TCOM_API HandleNameToRepMap +{ + Tcl_Interp *m_interp; + + // handle string representation to internal representation map + typedef StringHashTable Map; + Map m_map; + + static void deleteInterpProc(ClientData clientData, Tcl_Interp *interp); + static void exitProc(ClientData clientData); + + ~HandleNameToRepMap(); + +public: + HandleNameToRepMap(Tcl_Interp *interp); + + // Get instance associated with the Tcl interpreter. + static HandleNameToRepMap *instance(Tcl_Interp *interp); + + // Insert handle to object mapping. + void insert (const char *handleStr, InternalRep *pRep) + { m_map.insert(handleStr, pRep); } + + // Get the object represented by the handle. + InternalRep *find (Tcl_Obj *pHandle) const + { return m_map.find(Tcl_GetStringFromObj(pHandle, 0)); } + + // Remove handle to object mapping. + void erase (const char *handleStr) + { m_map.erase(handleStr); } + + // Clean all handles. + void clear(); +}; + +// This class provides functions to map handles to objects of a specific +// application class. + +template +class HandleSupport +{ + // Tcl command that implements the operations of the object + Tcl_ObjCmdProc *m_pCmdProc; + +public: + HandleSupport (Tcl_ObjCmdProc *pCmdProc): + m_pCmdProc(pCmdProc) + { } + + // Create a handle and associate it with an application object. Takes + // ownership of the application object and is responsible for deleting it. + Tcl_Obj *newObj(Tcl_Interp *interp, AppType *pAppObject); + + // Get count of matching elements. + size_t count (Tcl_Interp *interp, Tcl_Obj *pHandle) const + { return HandleNameToRepMap::instance(interp)->count(pHandle); } + + // Get the application object represented by the handle. If the handle + // is invalid, return 0. + AppType *find(Tcl_Interp *interp, Tcl_Obj *pHandle) const; +}; + +template +Tcl_Obj * +HandleSupport::newObj (Tcl_Interp *interp, AppType *pAppObject) +{ + AppInternalRep *pRep = new AppInternalRep( + interp, m_pCmdProc, pAppObject); + return CmdNameType::instance().newObj(interp, pRep); +} + +template +AppType * +HandleSupport::find (Tcl_Interp *interp, Tcl_Obj *pObj) const +{ + InternalRep *pRep = HandleNameToRepMap::instance(interp)->find(pObj); + if (pRep == 0) { + return 0; + } + return reinterpret_cast(pRep->clientData()); +} + +#endif diff --git a/src/HashTable.h b/src/HashTable.h new file mode 100644 index 0000000..8b1d3d3 --- /dev/null +++ b/src/HashTable.h @@ -0,0 +1,176 @@ +// $Id: HashTable.h,v 1.21 2002/04/13 03:53:56 cthuang Exp $ +#ifndef HASHTABLE_H +#define HASHTABLE_H + +#include + +// Function object that invokes delete on its argument + +struct Delete +{ + template + void operator() (T p) const + { delete p; } +}; + +// This is a base class used to implement hash tables. + +template +class BasicHashTable +{ +protected: + Tcl_HashTable m_hashTable; + +public: + BasicHashTable (int keyType) + { Tcl_InitHashTable(&m_hashTable, keyType); } + + ~BasicHashTable () + { Tcl_DeleteHashTable(&m_hashTable); } + + // Remove all elements. + void clear(); + + // Call function on all data elements. + template + void forEach (F f) + { + Tcl_HashSearch search; + Tcl_HashEntry *pEntry = Tcl_FirstHashEntry(&m_hashTable, &search); + while (pEntry != 0) { + Tcl_HashEntry *pNext = Tcl_NextHashEntry(&search); + f(reinterpret_cast(Tcl_GetHashValue(pEntry))); + pEntry = pNext; + } + } +}; + +template +void +BasicHashTable::clear () +{ + Tcl_HashSearch search; + Tcl_HashEntry *pEntry = Tcl_FirstHashEntry(&m_hashTable, &search); + while (pEntry != 0) { + Tcl_HashEntry *pNext = Tcl_NextHashEntry(&search); + Tcl_DeleteHashEntry(pEntry); + pEntry = pNext; + } +} + +// This class wraps a Tcl hash table that uses structures as keys. The mapped +// type is assumed to be a pointer type. + +template +class HashTable: public BasicHashTable +{ +public: + typedef K key_type; + typedef D mapped_type; + + HashTable (): BasicHashTable(sizeof(K) / sizeof(int)) + { } + + // Insert data into table. + void insert(const K &key, D data); + + // Find data in table. + D find(const K &key) const; + + // Remove data. + void erase(const K &key); +}; + +template +void +HashTable::insert (const K &key, D value) +{ + int isNew; + Tcl_HashEntry *pEntry = Tcl_CreateHashEntry( + &m_hashTable, + reinterpret_cast(&key), + &isNew); + Tcl_SetHashValue(pEntry, reinterpret_cast(value)); +} + +template +D +HashTable::find (const K &key) const +{ + Tcl_HashEntry *pEntry = Tcl_FindHashEntry( + const_cast(&m_hashTable), + reinterpret_cast(&key)); + if (pEntry == 0) { + return 0; + } + return reinterpret_cast(Tcl_GetHashValue(pEntry)); +} + +template +void +HashTable::erase (const K &key) +{ + Tcl_HashEntry *pEntry = Tcl_FindHashEntry( + &m_hashTable, + reinterpret_cast(&key)); + if (pEntry != 0) { + Tcl_DeleteHashEntry(pEntry); + } +} + +// This class wraps a Tcl hash table that uses null-terminated strings as keys. +// The mapped type is assumed to be a pointer type. + +template +class StringHashTable: public BasicHashTable +{ +public: + typedef const char *key_type; + typedef D mapped_type; + + StringHashTable (): BasicHashTable(TCL_STRING_KEYS) + { } + + void insert(const char *key, D value); + D find(const char *key) const; + void erase(const char *key); +}; + +template +void +StringHashTable::insert (const char *key, D value) +{ + int isNew; + Tcl_HashEntry *pEntry = Tcl_CreateHashEntry( + &m_hashTable, + const_cast(key), + &isNew); + Tcl_SetHashValue(pEntry, reinterpret_cast(value)); +} + +template +D +StringHashTable::find (const char *key) const +{ + Tcl_HashEntry *pEntry = Tcl_FindHashEntry( + const_cast(&m_hashTable), + const_cast(key)); + if (pEntry == 0) { + return 0; + } + return reinterpret_cast(Tcl_GetHashValue(pEntry)); +} + +template +void +StringHashTable::erase (const char *key) +{ + Tcl_HashEntry *pEntry = Tcl_FindHashEntry( + &m_hashTable, + const_cast(key)); + if (pEntry != 0) { + Tcl_DeleteHashEntry(pEntry); + } +} + +#endif diff --git a/src/InterfaceAdapter.cpp b/src/InterfaceAdapter.cpp new file mode 100644 index 0000000..f1117e3 --- /dev/null +++ b/src/InterfaceAdapter.cpp @@ -0,0 +1,145 @@ +// $Id: InterfaceAdapter.cpp,v 1.3 2002/02/27 01:58:45 cthuang Exp $ +#pragma warning(disable: 4786) +#include "ComObject.h" +#include "InterfaceAdapter.h" + +InterfaceAdapter::InterfaceAdapter ( + ComObject &object, + const Interface &interfaceDesc, + bool forceDispatch): + m_object(object), + m_interface(interfaceDesc) +{ + // Initialize virtual function index to method description map. + const Interface::Methods &methods = m_interface.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()); + } + + } else { + m_pVtbl = unknownVtbl; + } +} + +const Method * +InterfaceAdapter::findComMethod (int funcIndex) +{ + VtblIndexToMethodMap::const_iterator p = + m_vtblIndexToMethodMap.find(funcIndex); + if (p == m_vtblIndexToMethodMap.end()) { + return 0; + } + 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); +} + +STDMETHODIMP_(ULONG) +InterfaceAdapter::AddRef (InterfaceAdapter *pThis) +{ + return pThis->m_object.addRef(); +} + +STDMETHODIMP_(ULONG) +InterfaceAdapter::Release (InterfaceAdapter *pThis) +{ + return pThis->m_object.release(); +} + +// Implement IDispatch methods + +STDMETHODIMP +InterfaceAdapter::GetTypeInfoCount (InterfaceAdapter *, UINT *pCount) +{ + *pCount = 1; + return S_OK; +} + +STDMETHODIMP +InterfaceAdapter::GetTypeInfo ( + InterfaceAdapter *pThis, UINT index, LCID, ITypeInfo **ppTypeInfo) +{ + if (index != 0) { + *ppTypeInfo = 0; + return DISP_E_BADINDEX; + } + + ITypeInfo *pTypeInfo = pThis->m_interface.typeInfo(); + pTypeInfo->AddRef(); + *ppTypeInfo = pTypeInfo; + return S_OK; +} + +STDMETHODIMP +InterfaceAdapter::GetIDsOfNames ( + InterfaceAdapter *pThis, + REFIID, + OLECHAR **rgszNames, + UINT cNames, + LCID, + DISPID *rgDispId) +{ + ITypeInfo *pTypeInfo = pThis->m_interface.typeInfo(); + return pTypeInfo->GetIDsOfNames(rgszNames, cNames, rgDispId); +} + +STDMETHODIMP +InterfaceAdapter::Invoke ( + InterfaceAdapter *pThis, + DISPID dispid, + REFIID iid, + LCID lcid, + WORD wFlags, + DISPPARAMS *pDispParams, + VARIANT *pVarResult, + EXCEPINFO *pExcepInfo, + UINT *pArgErr) +{ + return pThis->m_object.invoke( + pThis, + dispid, + iid, + lcid, + wFlags, + pDispParams, + pVarResult, + pExcepInfo, + pArgErr); +} diff --git a/src/InterfaceAdapter.h b/src/InterfaceAdapter.h new file mode 100644 index 0000000..19bc8e0 --- /dev/null +++ b/src/InterfaceAdapter.h @@ -0,0 +1,101 @@ +// $Id: InterfaceAdapter.h,v 1.3 2002/02/27 01:58:45 cthuang Exp $ +#ifndef INTERFACEADAPTER_H +#define INTERFACEADAPTER_H + +#include +#include +#include "tcomApi.h" +#include "TypeInfo.h" + +class TCOM_API ComObject; + +// This class implements an interface for COM clients to invoke functions +// through a virtual function table. It delegates the operations to the +// ComObject class. + +class TCOM_API InterfaceAdapter +{ + // We rely on the knowledge that the C++ compiler implements objects having + // virtual functions by storing a pointer to a virtual function table + // at the beginning of the object. We simulate such an object by defining + // a class with a virtual function table pointer as the first data member. + const void *m_pVtbl; + + // delegate operations to this object + ComObject &m_object; + + // description of the interface to implement + const Interface &m_interface; + + // 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 IDispatch derived interfaces + static const void *dispatchVtbl[]; + + InterfaceAdapter(const InterfaceAdapter &); // not implemented + void operator=(const InterfaceAdapter &); // not implemented + +public: + InterfaceAdapter( + ComObject &object, + const Interface &interfaceDesc, + bool forceDispatch=false); + + // Get delegate object. + ComObject &object () const + { return m_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); + static STDMETHODIMP_(ULONG) AddRef(InterfaceAdapter *pThis); + static STDMETHODIMP_(ULONG) Release(InterfaceAdapter *pThis); + + // IDispatch implementation + static STDMETHODIMP GetTypeInfoCount( + InterfaceAdapter *pThis, UINT *pctinfo); + static STDMETHODIMP GetTypeInfo( + InterfaceAdapter *pThis, UINT itinfo, LCID lcid, ITypeInfo **pptinfo); + static STDMETHODIMP GetIDsOfNames( + InterfaceAdapter *pThis, + REFIID iid, + OLECHAR **rgszNames, + UINT cNames, + LCID lcid, + DISPID *rgdispid); + static STDMETHODIMP Invoke( + InterfaceAdapter *pThis, + DISPID dispidMember, + REFIID riid, + LCID lcid, + WORD wFlags, + DISPPARAMS *pdispparams, + VARIANT *pvarResult, + EXCEPINFO *pexcepinfo, + UINT *puArgErr); +}; + +#endif diff --git a/src/InterfaceAdapterVtbl.cpp b/src/InterfaceAdapterVtbl.cpp new file mode 100644 index 0000000..896f36d --- /dev/null +++ b/src/InterfaceAdapterVtbl.cpp @@ -0,0 +1,3131 @@ +// $Id: InterfaceAdapterVtbl.cpp,v 1.3 2001/10/13 17:56:14 Administrator Exp $ +#pragma warning(disable: 4786) +#include "InterfaceAdapter.h" +#include "ComObject.h" + +#pragma code_seg(".orpc") + +static __declspec(naked) void +delegate (void) +{ + __asm { + push ebp // set up simple stack frame + mov ebp, esp + + sub esp, 8 // set up local variables + // localVar(hrFromInvoke) + // localVar(pArgEnd) + // ebp + // funcIndex + // retAddr + // this + // args + + call invokeComObjectFunction + + // The following code adjusts the stack and returns to the caller. + // This involves copying the return address and the HRESULT + // to the bottom of the stack frame, adjusting the stack + // pointer, and returning to the caller. + push esi + mov esi, [ebp-4] // esi = address after last argument + + sub esi, 4 // esi points to bottom arg on stack + mov eax, [ebp+8] // copy retaddr down + mov [esi], eax + + sub esi, 4 + mov eax, [ebp-8] // copy hrFromInvoke down + mov [esi], eax + + mov eax, esi // reset stack and return to caller + pop esi + mov ebp, [ebp] + mov esp, eax + pop eax + ret + } +} + +#define FUNCTION_ENTRY_POINT(n) \ +static void __declspec(naked) function_##n(void) \ +{ __asm push (n) __asm jmp delegate } + +// 0 QueryInterface +// 1 AddRef +// 2 Release +FUNCTION_ENTRY_POINT(3) +FUNCTION_ENTRY_POINT(4) +FUNCTION_ENTRY_POINT(5) +FUNCTION_ENTRY_POINT(6) +FUNCTION_ENTRY_POINT(7) +FUNCTION_ENTRY_POINT(8) +FUNCTION_ENTRY_POINT(9) +FUNCTION_ENTRY_POINT(10) +FUNCTION_ENTRY_POINT(11) +FUNCTION_ENTRY_POINT(12) +FUNCTION_ENTRY_POINT(13) +FUNCTION_ENTRY_POINT(14) +FUNCTION_ENTRY_POINT(15) +FUNCTION_ENTRY_POINT(16) +FUNCTION_ENTRY_POINT(17) +FUNCTION_ENTRY_POINT(18) +FUNCTION_ENTRY_POINT(19) +FUNCTION_ENTRY_POINT(20) +FUNCTION_ENTRY_POINT(21) +FUNCTION_ENTRY_POINT(22) +FUNCTION_ENTRY_POINT(23) +FUNCTION_ENTRY_POINT(24) +FUNCTION_ENTRY_POINT(25) +FUNCTION_ENTRY_POINT(26) +FUNCTION_ENTRY_POINT(27) +FUNCTION_ENTRY_POINT(28) +FUNCTION_ENTRY_POINT(29) +FUNCTION_ENTRY_POINT(30) +FUNCTION_ENTRY_POINT(31) +FUNCTION_ENTRY_POINT(32) +FUNCTION_ENTRY_POINT(33) +FUNCTION_ENTRY_POINT(34) +FUNCTION_ENTRY_POINT(35) +FUNCTION_ENTRY_POINT(36) +FUNCTION_ENTRY_POINT(37) +FUNCTION_ENTRY_POINT(38) +FUNCTION_ENTRY_POINT(39) +FUNCTION_ENTRY_POINT(40) +FUNCTION_ENTRY_POINT(41) +FUNCTION_ENTRY_POINT(42) +FUNCTION_ENTRY_POINT(43) +FUNCTION_ENTRY_POINT(44) +FUNCTION_ENTRY_POINT(45) +FUNCTION_ENTRY_POINT(46) +FUNCTION_ENTRY_POINT(47) +FUNCTION_ENTRY_POINT(48) +FUNCTION_ENTRY_POINT(49) +FUNCTION_ENTRY_POINT(50) +FUNCTION_ENTRY_POINT(51) +FUNCTION_ENTRY_POINT(52) +FUNCTION_ENTRY_POINT(53) +FUNCTION_ENTRY_POINT(54) +FUNCTION_ENTRY_POINT(55) +FUNCTION_ENTRY_POINT(56) +FUNCTION_ENTRY_POINT(57) +FUNCTION_ENTRY_POINT(58) +FUNCTION_ENTRY_POINT(59) +FUNCTION_ENTRY_POINT(60) +FUNCTION_ENTRY_POINT(61) +FUNCTION_ENTRY_POINT(62) +FUNCTION_ENTRY_POINT(63) +FUNCTION_ENTRY_POINT(64) +FUNCTION_ENTRY_POINT(65) +FUNCTION_ENTRY_POINT(66) +FUNCTION_ENTRY_POINT(67) +FUNCTION_ENTRY_POINT(68) +FUNCTION_ENTRY_POINT(69) +FUNCTION_ENTRY_POINT(70) +FUNCTION_ENTRY_POINT(71) +FUNCTION_ENTRY_POINT(72) +FUNCTION_ENTRY_POINT(73) +FUNCTION_ENTRY_POINT(74) +FUNCTION_ENTRY_POINT(75) +FUNCTION_ENTRY_POINT(76) +FUNCTION_ENTRY_POINT(77) +FUNCTION_ENTRY_POINT(78) +FUNCTION_ENTRY_POINT(79) +FUNCTION_ENTRY_POINT(80) +FUNCTION_ENTRY_POINT(81) +FUNCTION_ENTRY_POINT(82) +FUNCTION_ENTRY_POINT(83) +FUNCTION_ENTRY_POINT(84) +FUNCTION_ENTRY_POINT(85) +FUNCTION_ENTRY_POINT(86) +FUNCTION_ENTRY_POINT(87) +FUNCTION_ENTRY_POINT(88) +FUNCTION_ENTRY_POINT(89) +FUNCTION_ENTRY_POINT(90) +FUNCTION_ENTRY_POINT(91) +FUNCTION_ENTRY_POINT(92) +FUNCTION_ENTRY_POINT(93) +FUNCTION_ENTRY_POINT(94) +FUNCTION_ENTRY_POINT(95) +FUNCTION_ENTRY_POINT(96) +FUNCTION_ENTRY_POINT(97) +FUNCTION_ENTRY_POINT(98) +FUNCTION_ENTRY_POINT(99) +FUNCTION_ENTRY_POINT(100) +FUNCTION_ENTRY_POINT(101) +FUNCTION_ENTRY_POINT(102) +FUNCTION_ENTRY_POINT(103) +FUNCTION_ENTRY_POINT(104) +FUNCTION_ENTRY_POINT(105) +FUNCTION_ENTRY_POINT(106) +FUNCTION_ENTRY_POINT(107) +FUNCTION_ENTRY_POINT(108) +FUNCTION_ENTRY_POINT(109) +FUNCTION_ENTRY_POINT(110) +FUNCTION_ENTRY_POINT(111) +FUNCTION_ENTRY_POINT(112) +FUNCTION_ENTRY_POINT(113) +FUNCTION_ENTRY_POINT(114) +FUNCTION_ENTRY_POINT(115) +FUNCTION_ENTRY_POINT(116) +FUNCTION_ENTRY_POINT(117) +FUNCTION_ENTRY_POINT(118) +FUNCTION_ENTRY_POINT(119) +FUNCTION_ENTRY_POINT(120) +FUNCTION_ENTRY_POINT(121) +FUNCTION_ENTRY_POINT(122) +FUNCTION_ENTRY_POINT(123) +FUNCTION_ENTRY_POINT(124) +FUNCTION_ENTRY_POINT(125) +FUNCTION_ENTRY_POINT(126) +FUNCTION_ENTRY_POINT(127) +FUNCTION_ENTRY_POINT(128) +FUNCTION_ENTRY_POINT(129) +FUNCTION_ENTRY_POINT(130) +FUNCTION_ENTRY_POINT(131) +FUNCTION_ENTRY_POINT(132) +FUNCTION_ENTRY_POINT(133) +FUNCTION_ENTRY_POINT(134) +FUNCTION_ENTRY_POINT(135) +FUNCTION_ENTRY_POINT(136) +FUNCTION_ENTRY_POINT(137) +FUNCTION_ENTRY_POINT(138) +FUNCTION_ENTRY_POINT(139) +FUNCTION_ENTRY_POINT(140) +FUNCTION_ENTRY_POINT(141) +FUNCTION_ENTRY_POINT(142) +FUNCTION_ENTRY_POINT(143) +FUNCTION_ENTRY_POINT(144) +FUNCTION_ENTRY_POINT(145) +FUNCTION_ENTRY_POINT(146) +FUNCTION_ENTRY_POINT(147) +FUNCTION_ENTRY_POINT(148) +FUNCTION_ENTRY_POINT(149) +FUNCTION_ENTRY_POINT(150) +FUNCTION_ENTRY_POINT(151) +FUNCTION_ENTRY_POINT(152) +FUNCTION_ENTRY_POINT(153) +FUNCTION_ENTRY_POINT(154) +FUNCTION_ENTRY_POINT(155) +FUNCTION_ENTRY_POINT(156) +FUNCTION_ENTRY_POINT(157) +FUNCTION_ENTRY_POINT(158) +FUNCTION_ENTRY_POINT(159) +FUNCTION_ENTRY_POINT(160) +FUNCTION_ENTRY_POINT(161) +FUNCTION_ENTRY_POINT(162) +FUNCTION_ENTRY_POINT(163) +FUNCTION_ENTRY_POINT(164) +FUNCTION_ENTRY_POINT(165) +FUNCTION_ENTRY_POINT(166) +FUNCTION_ENTRY_POINT(167) +FUNCTION_ENTRY_POINT(168) +FUNCTION_ENTRY_POINT(169) +FUNCTION_ENTRY_POINT(170) +FUNCTION_ENTRY_POINT(171) +FUNCTION_ENTRY_POINT(172) +FUNCTION_ENTRY_POINT(173) +FUNCTION_ENTRY_POINT(174) +FUNCTION_ENTRY_POINT(175) +FUNCTION_ENTRY_POINT(176) +FUNCTION_ENTRY_POINT(177) +FUNCTION_ENTRY_POINT(178) +FUNCTION_ENTRY_POINT(179) +FUNCTION_ENTRY_POINT(180) +FUNCTION_ENTRY_POINT(181) +FUNCTION_ENTRY_POINT(182) +FUNCTION_ENTRY_POINT(183) +FUNCTION_ENTRY_POINT(184) +FUNCTION_ENTRY_POINT(185) +FUNCTION_ENTRY_POINT(186) +FUNCTION_ENTRY_POINT(187) +FUNCTION_ENTRY_POINT(188) +FUNCTION_ENTRY_POINT(189) +FUNCTION_ENTRY_POINT(190) +FUNCTION_ENTRY_POINT(191) +FUNCTION_ENTRY_POINT(192) +FUNCTION_ENTRY_POINT(193) +FUNCTION_ENTRY_POINT(194) +FUNCTION_ENTRY_POINT(195) +FUNCTION_ENTRY_POINT(196) +FUNCTION_ENTRY_POINT(197) +FUNCTION_ENTRY_POINT(198) +FUNCTION_ENTRY_POINT(199) +FUNCTION_ENTRY_POINT(200) +FUNCTION_ENTRY_POINT(201) +FUNCTION_ENTRY_POINT(202) +FUNCTION_ENTRY_POINT(203) +FUNCTION_ENTRY_POINT(204) +FUNCTION_ENTRY_POINT(205) +FUNCTION_ENTRY_POINT(206) +FUNCTION_ENTRY_POINT(207) +FUNCTION_ENTRY_POINT(208) +FUNCTION_ENTRY_POINT(209) +FUNCTION_ENTRY_POINT(210) +FUNCTION_ENTRY_POINT(211) +FUNCTION_ENTRY_POINT(212) +FUNCTION_ENTRY_POINT(213) +FUNCTION_ENTRY_POINT(214) +FUNCTION_ENTRY_POINT(215) +FUNCTION_ENTRY_POINT(216) +FUNCTION_ENTRY_POINT(217) +FUNCTION_ENTRY_POINT(218) +FUNCTION_ENTRY_POINT(219) +FUNCTION_ENTRY_POINT(220) +FUNCTION_ENTRY_POINT(221) +FUNCTION_ENTRY_POINT(222) +FUNCTION_ENTRY_POINT(223) +FUNCTION_ENTRY_POINT(224) +FUNCTION_ENTRY_POINT(225) +FUNCTION_ENTRY_POINT(226) +FUNCTION_ENTRY_POINT(227) +FUNCTION_ENTRY_POINT(228) +FUNCTION_ENTRY_POINT(229) +FUNCTION_ENTRY_POINT(230) +FUNCTION_ENTRY_POINT(231) +FUNCTION_ENTRY_POINT(232) +FUNCTION_ENTRY_POINT(233) +FUNCTION_ENTRY_POINT(234) +FUNCTION_ENTRY_POINT(235) +FUNCTION_ENTRY_POINT(236) +FUNCTION_ENTRY_POINT(237) +FUNCTION_ENTRY_POINT(238) +FUNCTION_ENTRY_POINT(239) +FUNCTION_ENTRY_POINT(240) +FUNCTION_ENTRY_POINT(241) +FUNCTION_ENTRY_POINT(242) +FUNCTION_ENTRY_POINT(243) +FUNCTION_ENTRY_POINT(244) +FUNCTION_ENTRY_POINT(245) +FUNCTION_ENTRY_POINT(246) +FUNCTION_ENTRY_POINT(247) +FUNCTION_ENTRY_POINT(248) +FUNCTION_ENTRY_POINT(249) +FUNCTION_ENTRY_POINT(250) +FUNCTION_ENTRY_POINT(251) +FUNCTION_ENTRY_POINT(252) +FUNCTION_ENTRY_POINT(253) +FUNCTION_ENTRY_POINT(254) +FUNCTION_ENTRY_POINT(255) +FUNCTION_ENTRY_POINT(256) +FUNCTION_ENTRY_POINT(257) +FUNCTION_ENTRY_POINT(258) +FUNCTION_ENTRY_POINT(259) +FUNCTION_ENTRY_POINT(260) +FUNCTION_ENTRY_POINT(261) +FUNCTION_ENTRY_POINT(262) +FUNCTION_ENTRY_POINT(263) +FUNCTION_ENTRY_POINT(264) +FUNCTION_ENTRY_POINT(265) +FUNCTION_ENTRY_POINT(266) +FUNCTION_ENTRY_POINT(267) +FUNCTION_ENTRY_POINT(268) +FUNCTION_ENTRY_POINT(269) +FUNCTION_ENTRY_POINT(270) +FUNCTION_ENTRY_POINT(271) +FUNCTION_ENTRY_POINT(272) +FUNCTION_ENTRY_POINT(273) +FUNCTION_ENTRY_POINT(274) +FUNCTION_ENTRY_POINT(275) +FUNCTION_ENTRY_POINT(276) +FUNCTION_ENTRY_POINT(277) +FUNCTION_ENTRY_POINT(278) +FUNCTION_ENTRY_POINT(279) +FUNCTION_ENTRY_POINT(280) +FUNCTION_ENTRY_POINT(281) +FUNCTION_ENTRY_POINT(282) +FUNCTION_ENTRY_POINT(283) +FUNCTION_ENTRY_POINT(284) +FUNCTION_ENTRY_POINT(285) +FUNCTION_ENTRY_POINT(286) +FUNCTION_ENTRY_POINT(287) +FUNCTION_ENTRY_POINT(288) +FUNCTION_ENTRY_POINT(289) +FUNCTION_ENTRY_POINT(290) +FUNCTION_ENTRY_POINT(291) +FUNCTION_ENTRY_POINT(292) +FUNCTION_ENTRY_POINT(293) +FUNCTION_ENTRY_POINT(294) +FUNCTION_ENTRY_POINT(295) +FUNCTION_ENTRY_POINT(296) +FUNCTION_ENTRY_POINT(297) +FUNCTION_ENTRY_POINT(298) +FUNCTION_ENTRY_POINT(299) +FUNCTION_ENTRY_POINT(300) +FUNCTION_ENTRY_POINT(301) +FUNCTION_ENTRY_POINT(302) +FUNCTION_ENTRY_POINT(303) +FUNCTION_ENTRY_POINT(304) +FUNCTION_ENTRY_POINT(305) +FUNCTION_ENTRY_POINT(306) +FUNCTION_ENTRY_POINT(307) +FUNCTION_ENTRY_POINT(308) +FUNCTION_ENTRY_POINT(309) +FUNCTION_ENTRY_POINT(310) +FUNCTION_ENTRY_POINT(311) +FUNCTION_ENTRY_POINT(312) +FUNCTION_ENTRY_POINT(313) +FUNCTION_ENTRY_POINT(314) +FUNCTION_ENTRY_POINT(315) +FUNCTION_ENTRY_POINT(316) +FUNCTION_ENTRY_POINT(317) +FUNCTION_ENTRY_POINT(318) +FUNCTION_ENTRY_POINT(319) +FUNCTION_ENTRY_POINT(320) +FUNCTION_ENTRY_POINT(321) +FUNCTION_ENTRY_POINT(322) +FUNCTION_ENTRY_POINT(323) +FUNCTION_ENTRY_POINT(324) +FUNCTION_ENTRY_POINT(325) +FUNCTION_ENTRY_POINT(326) +FUNCTION_ENTRY_POINT(327) +FUNCTION_ENTRY_POINT(328) +FUNCTION_ENTRY_POINT(329) +FUNCTION_ENTRY_POINT(330) +FUNCTION_ENTRY_POINT(331) +FUNCTION_ENTRY_POINT(332) +FUNCTION_ENTRY_POINT(333) +FUNCTION_ENTRY_POINT(334) +FUNCTION_ENTRY_POINT(335) +FUNCTION_ENTRY_POINT(336) +FUNCTION_ENTRY_POINT(337) +FUNCTION_ENTRY_POINT(338) +FUNCTION_ENTRY_POINT(339) +FUNCTION_ENTRY_POINT(340) +FUNCTION_ENTRY_POINT(341) +FUNCTION_ENTRY_POINT(342) +FUNCTION_ENTRY_POINT(343) +FUNCTION_ENTRY_POINT(344) +FUNCTION_ENTRY_POINT(345) +FUNCTION_ENTRY_POINT(346) +FUNCTION_ENTRY_POINT(347) +FUNCTION_ENTRY_POINT(348) +FUNCTION_ENTRY_POINT(349) +FUNCTION_ENTRY_POINT(350) +FUNCTION_ENTRY_POINT(351) +FUNCTION_ENTRY_POINT(352) +FUNCTION_ENTRY_POINT(353) +FUNCTION_ENTRY_POINT(354) +FUNCTION_ENTRY_POINT(355) +FUNCTION_ENTRY_POINT(356) +FUNCTION_ENTRY_POINT(357) +FUNCTION_ENTRY_POINT(358) +FUNCTION_ENTRY_POINT(359) +FUNCTION_ENTRY_POINT(360) +FUNCTION_ENTRY_POINT(361) +FUNCTION_ENTRY_POINT(362) +FUNCTION_ENTRY_POINT(363) +FUNCTION_ENTRY_POINT(364) +FUNCTION_ENTRY_POINT(365) +FUNCTION_ENTRY_POINT(366) +FUNCTION_ENTRY_POINT(367) +FUNCTION_ENTRY_POINT(368) +FUNCTION_ENTRY_POINT(369) +FUNCTION_ENTRY_POINT(370) +FUNCTION_ENTRY_POINT(371) +FUNCTION_ENTRY_POINT(372) +FUNCTION_ENTRY_POINT(373) +FUNCTION_ENTRY_POINT(374) +FUNCTION_ENTRY_POINT(375) +FUNCTION_ENTRY_POINT(376) +FUNCTION_ENTRY_POINT(377) +FUNCTION_ENTRY_POINT(378) +FUNCTION_ENTRY_POINT(379) +FUNCTION_ENTRY_POINT(380) +FUNCTION_ENTRY_POINT(381) +FUNCTION_ENTRY_POINT(382) +FUNCTION_ENTRY_POINT(383) +FUNCTION_ENTRY_POINT(384) +FUNCTION_ENTRY_POINT(385) +FUNCTION_ENTRY_POINT(386) +FUNCTION_ENTRY_POINT(387) +FUNCTION_ENTRY_POINT(388) +FUNCTION_ENTRY_POINT(389) +FUNCTION_ENTRY_POINT(390) +FUNCTION_ENTRY_POINT(391) +FUNCTION_ENTRY_POINT(392) +FUNCTION_ENTRY_POINT(393) +FUNCTION_ENTRY_POINT(394) +FUNCTION_ENTRY_POINT(395) +FUNCTION_ENTRY_POINT(396) +FUNCTION_ENTRY_POINT(397) +FUNCTION_ENTRY_POINT(398) +FUNCTION_ENTRY_POINT(399) +FUNCTION_ENTRY_POINT(400) +FUNCTION_ENTRY_POINT(401) +FUNCTION_ENTRY_POINT(402) +FUNCTION_ENTRY_POINT(403) +FUNCTION_ENTRY_POINT(404) +FUNCTION_ENTRY_POINT(405) +FUNCTION_ENTRY_POINT(406) +FUNCTION_ENTRY_POINT(407) +FUNCTION_ENTRY_POINT(408) +FUNCTION_ENTRY_POINT(409) +FUNCTION_ENTRY_POINT(410) +FUNCTION_ENTRY_POINT(411) +FUNCTION_ENTRY_POINT(412) +FUNCTION_ENTRY_POINT(413) +FUNCTION_ENTRY_POINT(414) +FUNCTION_ENTRY_POINT(415) +FUNCTION_ENTRY_POINT(416) +FUNCTION_ENTRY_POINT(417) +FUNCTION_ENTRY_POINT(418) +FUNCTION_ENTRY_POINT(419) +FUNCTION_ENTRY_POINT(420) +FUNCTION_ENTRY_POINT(421) +FUNCTION_ENTRY_POINT(422) +FUNCTION_ENTRY_POINT(423) +FUNCTION_ENTRY_POINT(424) +FUNCTION_ENTRY_POINT(425) +FUNCTION_ENTRY_POINT(426) +FUNCTION_ENTRY_POINT(427) +FUNCTION_ENTRY_POINT(428) +FUNCTION_ENTRY_POINT(429) +FUNCTION_ENTRY_POINT(430) +FUNCTION_ENTRY_POINT(431) +FUNCTION_ENTRY_POINT(432) +FUNCTION_ENTRY_POINT(433) +FUNCTION_ENTRY_POINT(434) +FUNCTION_ENTRY_POINT(435) +FUNCTION_ENTRY_POINT(436) +FUNCTION_ENTRY_POINT(437) +FUNCTION_ENTRY_POINT(438) +FUNCTION_ENTRY_POINT(439) +FUNCTION_ENTRY_POINT(440) +FUNCTION_ENTRY_POINT(441) +FUNCTION_ENTRY_POINT(442) +FUNCTION_ENTRY_POINT(443) +FUNCTION_ENTRY_POINT(444) +FUNCTION_ENTRY_POINT(445) +FUNCTION_ENTRY_POINT(446) +FUNCTION_ENTRY_POINT(447) +FUNCTION_ENTRY_POINT(448) +FUNCTION_ENTRY_POINT(449) +FUNCTION_ENTRY_POINT(450) +FUNCTION_ENTRY_POINT(451) +FUNCTION_ENTRY_POINT(452) +FUNCTION_ENTRY_POINT(453) +FUNCTION_ENTRY_POINT(454) +FUNCTION_ENTRY_POINT(455) +FUNCTION_ENTRY_POINT(456) +FUNCTION_ENTRY_POINT(457) +FUNCTION_ENTRY_POINT(458) +FUNCTION_ENTRY_POINT(459) +FUNCTION_ENTRY_POINT(460) +FUNCTION_ENTRY_POINT(461) +FUNCTION_ENTRY_POINT(462) +FUNCTION_ENTRY_POINT(463) +FUNCTION_ENTRY_POINT(464) +FUNCTION_ENTRY_POINT(465) +FUNCTION_ENTRY_POINT(466) +FUNCTION_ENTRY_POINT(467) +FUNCTION_ENTRY_POINT(468) +FUNCTION_ENTRY_POINT(469) +FUNCTION_ENTRY_POINT(470) +FUNCTION_ENTRY_POINT(471) +FUNCTION_ENTRY_POINT(472) +FUNCTION_ENTRY_POINT(473) +FUNCTION_ENTRY_POINT(474) +FUNCTION_ENTRY_POINT(475) +FUNCTION_ENTRY_POINT(476) +FUNCTION_ENTRY_POINT(477) +FUNCTION_ENTRY_POINT(478) +FUNCTION_ENTRY_POINT(479) +FUNCTION_ENTRY_POINT(480) +FUNCTION_ENTRY_POINT(481) +FUNCTION_ENTRY_POINT(482) +FUNCTION_ENTRY_POINT(483) +FUNCTION_ENTRY_POINT(484) +FUNCTION_ENTRY_POINT(485) +FUNCTION_ENTRY_POINT(486) +FUNCTION_ENTRY_POINT(487) +FUNCTION_ENTRY_POINT(488) +FUNCTION_ENTRY_POINT(489) +FUNCTION_ENTRY_POINT(490) +FUNCTION_ENTRY_POINT(491) +FUNCTION_ENTRY_POINT(492) +FUNCTION_ENTRY_POINT(493) +FUNCTION_ENTRY_POINT(494) +FUNCTION_ENTRY_POINT(495) +FUNCTION_ENTRY_POINT(496) +FUNCTION_ENTRY_POINT(497) +FUNCTION_ENTRY_POINT(498) +FUNCTION_ENTRY_POINT(499) +FUNCTION_ENTRY_POINT(500) +FUNCTION_ENTRY_POINT(501) +FUNCTION_ENTRY_POINT(502) +FUNCTION_ENTRY_POINT(503) +FUNCTION_ENTRY_POINT(504) +FUNCTION_ENTRY_POINT(505) +FUNCTION_ENTRY_POINT(506) +FUNCTION_ENTRY_POINT(507) +FUNCTION_ENTRY_POINT(508) +FUNCTION_ENTRY_POINT(509) +FUNCTION_ENTRY_POINT(510) +FUNCTION_ENTRY_POINT(511) +FUNCTION_ENTRY_POINT(512) +FUNCTION_ENTRY_POINT(513) +FUNCTION_ENTRY_POINT(514) +FUNCTION_ENTRY_POINT(515) +FUNCTION_ENTRY_POINT(516) +FUNCTION_ENTRY_POINT(517) +FUNCTION_ENTRY_POINT(518) +FUNCTION_ENTRY_POINT(519) +FUNCTION_ENTRY_POINT(520) +FUNCTION_ENTRY_POINT(521) +FUNCTION_ENTRY_POINT(522) +FUNCTION_ENTRY_POINT(523) +FUNCTION_ENTRY_POINT(524) +FUNCTION_ENTRY_POINT(525) +FUNCTION_ENTRY_POINT(526) +FUNCTION_ENTRY_POINT(527) +FUNCTION_ENTRY_POINT(528) +FUNCTION_ENTRY_POINT(529) +FUNCTION_ENTRY_POINT(530) +FUNCTION_ENTRY_POINT(531) +FUNCTION_ENTRY_POINT(532) +FUNCTION_ENTRY_POINT(533) +FUNCTION_ENTRY_POINT(534) +FUNCTION_ENTRY_POINT(535) +FUNCTION_ENTRY_POINT(536) +FUNCTION_ENTRY_POINT(537) +FUNCTION_ENTRY_POINT(538) +FUNCTION_ENTRY_POINT(539) +FUNCTION_ENTRY_POINT(540) +FUNCTION_ENTRY_POINT(541) +FUNCTION_ENTRY_POINT(542) +FUNCTION_ENTRY_POINT(543) +FUNCTION_ENTRY_POINT(544) +FUNCTION_ENTRY_POINT(545) +FUNCTION_ENTRY_POINT(546) +FUNCTION_ENTRY_POINT(547) +FUNCTION_ENTRY_POINT(548) +FUNCTION_ENTRY_POINT(549) +FUNCTION_ENTRY_POINT(550) +FUNCTION_ENTRY_POINT(551) +FUNCTION_ENTRY_POINT(552) +FUNCTION_ENTRY_POINT(553) +FUNCTION_ENTRY_POINT(554) +FUNCTION_ENTRY_POINT(555) +FUNCTION_ENTRY_POINT(556) +FUNCTION_ENTRY_POINT(557) +FUNCTION_ENTRY_POINT(558) +FUNCTION_ENTRY_POINT(559) +FUNCTION_ENTRY_POINT(560) +FUNCTION_ENTRY_POINT(561) +FUNCTION_ENTRY_POINT(562) +FUNCTION_ENTRY_POINT(563) +FUNCTION_ENTRY_POINT(564) +FUNCTION_ENTRY_POINT(565) +FUNCTION_ENTRY_POINT(566) +FUNCTION_ENTRY_POINT(567) +FUNCTION_ENTRY_POINT(568) +FUNCTION_ENTRY_POINT(569) +FUNCTION_ENTRY_POINT(570) +FUNCTION_ENTRY_POINT(571) +FUNCTION_ENTRY_POINT(572) +FUNCTION_ENTRY_POINT(573) +FUNCTION_ENTRY_POINT(574) +FUNCTION_ENTRY_POINT(575) +FUNCTION_ENTRY_POINT(576) +FUNCTION_ENTRY_POINT(577) +FUNCTION_ENTRY_POINT(578) +FUNCTION_ENTRY_POINT(579) +FUNCTION_ENTRY_POINT(580) +FUNCTION_ENTRY_POINT(581) +FUNCTION_ENTRY_POINT(582) +FUNCTION_ENTRY_POINT(583) +FUNCTION_ENTRY_POINT(584) +FUNCTION_ENTRY_POINT(585) +FUNCTION_ENTRY_POINT(586) +FUNCTION_ENTRY_POINT(587) +FUNCTION_ENTRY_POINT(588) +FUNCTION_ENTRY_POINT(589) +FUNCTION_ENTRY_POINT(590) +FUNCTION_ENTRY_POINT(591) +FUNCTION_ENTRY_POINT(592) +FUNCTION_ENTRY_POINT(593) +FUNCTION_ENTRY_POINT(594) +FUNCTION_ENTRY_POINT(595) +FUNCTION_ENTRY_POINT(596) +FUNCTION_ENTRY_POINT(597) +FUNCTION_ENTRY_POINT(598) +FUNCTION_ENTRY_POINT(599) +FUNCTION_ENTRY_POINT(600) +FUNCTION_ENTRY_POINT(601) +FUNCTION_ENTRY_POINT(602) +FUNCTION_ENTRY_POINT(603) +FUNCTION_ENTRY_POINT(604) +FUNCTION_ENTRY_POINT(605) +FUNCTION_ENTRY_POINT(606) +FUNCTION_ENTRY_POINT(607) +FUNCTION_ENTRY_POINT(608) +FUNCTION_ENTRY_POINT(609) +FUNCTION_ENTRY_POINT(610) +FUNCTION_ENTRY_POINT(611) +FUNCTION_ENTRY_POINT(612) +FUNCTION_ENTRY_POINT(613) +FUNCTION_ENTRY_POINT(614) +FUNCTION_ENTRY_POINT(615) +FUNCTION_ENTRY_POINT(616) +FUNCTION_ENTRY_POINT(617) +FUNCTION_ENTRY_POINT(618) +FUNCTION_ENTRY_POINT(619) +FUNCTION_ENTRY_POINT(620) +FUNCTION_ENTRY_POINT(621) +FUNCTION_ENTRY_POINT(622) +FUNCTION_ENTRY_POINT(623) +FUNCTION_ENTRY_POINT(624) +FUNCTION_ENTRY_POINT(625) +FUNCTION_ENTRY_POINT(626) +FUNCTION_ENTRY_POINT(627) +FUNCTION_ENTRY_POINT(628) +FUNCTION_ENTRY_POINT(629) +FUNCTION_ENTRY_POINT(630) +FUNCTION_ENTRY_POINT(631) +FUNCTION_ENTRY_POINT(632) +FUNCTION_ENTRY_POINT(633) +FUNCTION_ENTRY_POINT(634) +FUNCTION_ENTRY_POINT(635) +FUNCTION_ENTRY_POINT(636) +FUNCTION_ENTRY_POINT(637) +FUNCTION_ENTRY_POINT(638) +FUNCTION_ENTRY_POINT(639) +FUNCTION_ENTRY_POINT(640) +FUNCTION_ENTRY_POINT(641) +FUNCTION_ENTRY_POINT(642) +FUNCTION_ENTRY_POINT(643) +FUNCTION_ENTRY_POINT(644) +FUNCTION_ENTRY_POINT(645) +FUNCTION_ENTRY_POINT(646) +FUNCTION_ENTRY_POINT(647) +FUNCTION_ENTRY_POINT(648) +FUNCTION_ENTRY_POINT(649) +FUNCTION_ENTRY_POINT(650) +FUNCTION_ENTRY_POINT(651) +FUNCTION_ENTRY_POINT(652) +FUNCTION_ENTRY_POINT(653) +FUNCTION_ENTRY_POINT(654) +FUNCTION_ENTRY_POINT(655) +FUNCTION_ENTRY_POINT(656) +FUNCTION_ENTRY_POINT(657) +FUNCTION_ENTRY_POINT(658) +FUNCTION_ENTRY_POINT(659) +FUNCTION_ENTRY_POINT(660) +FUNCTION_ENTRY_POINT(661) +FUNCTION_ENTRY_POINT(662) +FUNCTION_ENTRY_POINT(663) +FUNCTION_ENTRY_POINT(664) +FUNCTION_ENTRY_POINT(665) +FUNCTION_ENTRY_POINT(666) +FUNCTION_ENTRY_POINT(667) +FUNCTION_ENTRY_POINT(668) +FUNCTION_ENTRY_POINT(669) +FUNCTION_ENTRY_POINT(670) +FUNCTION_ENTRY_POINT(671) +FUNCTION_ENTRY_POINT(672) +FUNCTION_ENTRY_POINT(673) +FUNCTION_ENTRY_POINT(674) +FUNCTION_ENTRY_POINT(675) +FUNCTION_ENTRY_POINT(676) +FUNCTION_ENTRY_POINT(677) +FUNCTION_ENTRY_POINT(678) +FUNCTION_ENTRY_POINT(679) +FUNCTION_ENTRY_POINT(680) +FUNCTION_ENTRY_POINT(681) +FUNCTION_ENTRY_POINT(682) +FUNCTION_ENTRY_POINT(683) +FUNCTION_ENTRY_POINT(684) +FUNCTION_ENTRY_POINT(685) +FUNCTION_ENTRY_POINT(686) +FUNCTION_ENTRY_POINT(687) +FUNCTION_ENTRY_POINT(688) +FUNCTION_ENTRY_POINT(689) +FUNCTION_ENTRY_POINT(690) +FUNCTION_ENTRY_POINT(691) +FUNCTION_ENTRY_POINT(692) +FUNCTION_ENTRY_POINT(693) +FUNCTION_ENTRY_POINT(694) +FUNCTION_ENTRY_POINT(695) +FUNCTION_ENTRY_POINT(696) +FUNCTION_ENTRY_POINT(697) +FUNCTION_ENTRY_POINT(698) +FUNCTION_ENTRY_POINT(699) +FUNCTION_ENTRY_POINT(700) +FUNCTION_ENTRY_POINT(701) +FUNCTION_ENTRY_POINT(702) +FUNCTION_ENTRY_POINT(703) +FUNCTION_ENTRY_POINT(704) +FUNCTION_ENTRY_POINT(705) +FUNCTION_ENTRY_POINT(706) +FUNCTION_ENTRY_POINT(707) +FUNCTION_ENTRY_POINT(708) +FUNCTION_ENTRY_POINT(709) +FUNCTION_ENTRY_POINT(710) +FUNCTION_ENTRY_POINT(711) +FUNCTION_ENTRY_POINT(712) +FUNCTION_ENTRY_POINT(713) +FUNCTION_ENTRY_POINT(714) +FUNCTION_ENTRY_POINT(715) +FUNCTION_ENTRY_POINT(716) +FUNCTION_ENTRY_POINT(717) +FUNCTION_ENTRY_POINT(718) +FUNCTION_ENTRY_POINT(719) +FUNCTION_ENTRY_POINT(720) +FUNCTION_ENTRY_POINT(721) +FUNCTION_ENTRY_POINT(722) +FUNCTION_ENTRY_POINT(723) +FUNCTION_ENTRY_POINT(724) +FUNCTION_ENTRY_POINT(725) +FUNCTION_ENTRY_POINT(726) +FUNCTION_ENTRY_POINT(727) +FUNCTION_ENTRY_POINT(728) +FUNCTION_ENTRY_POINT(729) +FUNCTION_ENTRY_POINT(730) +FUNCTION_ENTRY_POINT(731) +FUNCTION_ENTRY_POINT(732) +FUNCTION_ENTRY_POINT(733) +FUNCTION_ENTRY_POINT(734) +FUNCTION_ENTRY_POINT(735) +FUNCTION_ENTRY_POINT(736) +FUNCTION_ENTRY_POINT(737) +FUNCTION_ENTRY_POINT(738) +FUNCTION_ENTRY_POINT(739) +FUNCTION_ENTRY_POINT(740) +FUNCTION_ENTRY_POINT(741) +FUNCTION_ENTRY_POINT(742) +FUNCTION_ENTRY_POINT(743) +FUNCTION_ENTRY_POINT(744) +FUNCTION_ENTRY_POINT(745) +FUNCTION_ENTRY_POINT(746) +FUNCTION_ENTRY_POINT(747) +FUNCTION_ENTRY_POINT(748) +FUNCTION_ENTRY_POINT(749) +FUNCTION_ENTRY_POINT(750) +FUNCTION_ENTRY_POINT(751) +FUNCTION_ENTRY_POINT(752) +FUNCTION_ENTRY_POINT(753) +FUNCTION_ENTRY_POINT(754) +FUNCTION_ENTRY_POINT(755) +FUNCTION_ENTRY_POINT(756) +FUNCTION_ENTRY_POINT(757) +FUNCTION_ENTRY_POINT(758) +FUNCTION_ENTRY_POINT(759) +FUNCTION_ENTRY_POINT(760) +FUNCTION_ENTRY_POINT(761) +FUNCTION_ENTRY_POINT(762) +FUNCTION_ENTRY_POINT(763) +FUNCTION_ENTRY_POINT(764) +FUNCTION_ENTRY_POINT(765) +FUNCTION_ENTRY_POINT(766) +FUNCTION_ENTRY_POINT(767) +FUNCTION_ENTRY_POINT(768) +FUNCTION_ENTRY_POINT(769) +FUNCTION_ENTRY_POINT(770) +FUNCTION_ENTRY_POINT(771) +FUNCTION_ENTRY_POINT(772) +FUNCTION_ENTRY_POINT(773) +FUNCTION_ENTRY_POINT(774) +FUNCTION_ENTRY_POINT(775) +FUNCTION_ENTRY_POINT(776) +FUNCTION_ENTRY_POINT(777) +FUNCTION_ENTRY_POINT(778) +FUNCTION_ENTRY_POINT(779) +FUNCTION_ENTRY_POINT(780) +FUNCTION_ENTRY_POINT(781) +FUNCTION_ENTRY_POINT(782) +FUNCTION_ENTRY_POINT(783) +FUNCTION_ENTRY_POINT(784) +FUNCTION_ENTRY_POINT(785) +FUNCTION_ENTRY_POINT(786) +FUNCTION_ENTRY_POINT(787) +FUNCTION_ENTRY_POINT(788) +FUNCTION_ENTRY_POINT(789) +FUNCTION_ENTRY_POINT(790) +FUNCTION_ENTRY_POINT(791) +FUNCTION_ENTRY_POINT(792) +FUNCTION_ENTRY_POINT(793) +FUNCTION_ENTRY_POINT(794) +FUNCTION_ENTRY_POINT(795) +FUNCTION_ENTRY_POINT(796) +FUNCTION_ENTRY_POINT(797) +FUNCTION_ENTRY_POINT(798) +FUNCTION_ENTRY_POINT(799) +FUNCTION_ENTRY_POINT(800) +FUNCTION_ENTRY_POINT(801) +FUNCTION_ENTRY_POINT(802) +FUNCTION_ENTRY_POINT(803) +FUNCTION_ENTRY_POINT(804) +FUNCTION_ENTRY_POINT(805) +FUNCTION_ENTRY_POINT(806) +FUNCTION_ENTRY_POINT(807) +FUNCTION_ENTRY_POINT(808) +FUNCTION_ENTRY_POINT(809) +FUNCTION_ENTRY_POINT(810) +FUNCTION_ENTRY_POINT(811) +FUNCTION_ENTRY_POINT(812) +FUNCTION_ENTRY_POINT(813) +FUNCTION_ENTRY_POINT(814) +FUNCTION_ENTRY_POINT(815) +FUNCTION_ENTRY_POINT(816) +FUNCTION_ENTRY_POINT(817) +FUNCTION_ENTRY_POINT(818) +FUNCTION_ENTRY_POINT(819) +FUNCTION_ENTRY_POINT(820) +FUNCTION_ENTRY_POINT(821) +FUNCTION_ENTRY_POINT(822) +FUNCTION_ENTRY_POINT(823) +FUNCTION_ENTRY_POINT(824) +FUNCTION_ENTRY_POINT(825) +FUNCTION_ENTRY_POINT(826) +FUNCTION_ENTRY_POINT(827) +FUNCTION_ENTRY_POINT(828) +FUNCTION_ENTRY_POINT(829) +FUNCTION_ENTRY_POINT(830) +FUNCTION_ENTRY_POINT(831) +FUNCTION_ENTRY_POINT(832) +FUNCTION_ENTRY_POINT(833) +FUNCTION_ENTRY_POINT(834) +FUNCTION_ENTRY_POINT(835) +FUNCTION_ENTRY_POINT(836) +FUNCTION_ENTRY_POINT(837) +FUNCTION_ENTRY_POINT(838) +FUNCTION_ENTRY_POINT(839) +FUNCTION_ENTRY_POINT(840) +FUNCTION_ENTRY_POINT(841) +FUNCTION_ENTRY_POINT(842) +FUNCTION_ENTRY_POINT(843) +FUNCTION_ENTRY_POINT(844) +FUNCTION_ENTRY_POINT(845) +FUNCTION_ENTRY_POINT(846) +FUNCTION_ENTRY_POINT(847) +FUNCTION_ENTRY_POINT(848) +FUNCTION_ENTRY_POINT(849) +FUNCTION_ENTRY_POINT(850) +FUNCTION_ENTRY_POINT(851) +FUNCTION_ENTRY_POINT(852) +FUNCTION_ENTRY_POINT(853) +FUNCTION_ENTRY_POINT(854) +FUNCTION_ENTRY_POINT(855) +FUNCTION_ENTRY_POINT(856) +FUNCTION_ENTRY_POINT(857) +FUNCTION_ENTRY_POINT(858) +FUNCTION_ENTRY_POINT(859) +FUNCTION_ENTRY_POINT(860) +FUNCTION_ENTRY_POINT(861) +FUNCTION_ENTRY_POINT(862) +FUNCTION_ENTRY_POINT(863) +FUNCTION_ENTRY_POINT(864) +FUNCTION_ENTRY_POINT(865) +FUNCTION_ENTRY_POINT(866) +FUNCTION_ENTRY_POINT(867) +FUNCTION_ENTRY_POINT(868) +FUNCTION_ENTRY_POINT(869) +FUNCTION_ENTRY_POINT(870) +FUNCTION_ENTRY_POINT(871) +FUNCTION_ENTRY_POINT(872) +FUNCTION_ENTRY_POINT(873) +FUNCTION_ENTRY_POINT(874) +FUNCTION_ENTRY_POINT(875) +FUNCTION_ENTRY_POINT(876) +FUNCTION_ENTRY_POINT(877) +FUNCTION_ENTRY_POINT(878) +FUNCTION_ENTRY_POINT(879) +FUNCTION_ENTRY_POINT(880) +FUNCTION_ENTRY_POINT(881) +FUNCTION_ENTRY_POINT(882) +FUNCTION_ENTRY_POINT(883) +FUNCTION_ENTRY_POINT(884) +FUNCTION_ENTRY_POINT(885) +FUNCTION_ENTRY_POINT(886) +FUNCTION_ENTRY_POINT(887) +FUNCTION_ENTRY_POINT(888) +FUNCTION_ENTRY_POINT(889) +FUNCTION_ENTRY_POINT(890) +FUNCTION_ENTRY_POINT(891) +FUNCTION_ENTRY_POINT(892) +FUNCTION_ENTRY_POINT(893) +FUNCTION_ENTRY_POINT(894) +FUNCTION_ENTRY_POINT(895) +FUNCTION_ENTRY_POINT(896) +FUNCTION_ENTRY_POINT(897) +FUNCTION_ENTRY_POINT(898) +FUNCTION_ENTRY_POINT(899) +FUNCTION_ENTRY_POINT(900) +FUNCTION_ENTRY_POINT(901) +FUNCTION_ENTRY_POINT(902) +FUNCTION_ENTRY_POINT(903) +FUNCTION_ENTRY_POINT(904) +FUNCTION_ENTRY_POINT(905) +FUNCTION_ENTRY_POINT(906) +FUNCTION_ENTRY_POINT(907) +FUNCTION_ENTRY_POINT(908) +FUNCTION_ENTRY_POINT(909) +FUNCTION_ENTRY_POINT(910) +FUNCTION_ENTRY_POINT(911) +FUNCTION_ENTRY_POINT(912) +FUNCTION_ENTRY_POINT(913) +FUNCTION_ENTRY_POINT(914) +FUNCTION_ENTRY_POINT(915) +FUNCTION_ENTRY_POINT(916) +FUNCTION_ENTRY_POINT(917) +FUNCTION_ENTRY_POINT(918) +FUNCTION_ENTRY_POINT(919) +FUNCTION_ENTRY_POINT(920) +FUNCTION_ENTRY_POINT(921) +FUNCTION_ENTRY_POINT(922) +FUNCTION_ENTRY_POINT(923) +FUNCTION_ENTRY_POINT(924) +FUNCTION_ENTRY_POINT(925) +FUNCTION_ENTRY_POINT(926) +FUNCTION_ENTRY_POINT(927) +FUNCTION_ENTRY_POINT(928) +FUNCTION_ENTRY_POINT(929) +FUNCTION_ENTRY_POINT(930) +FUNCTION_ENTRY_POINT(931) +FUNCTION_ENTRY_POINT(932) +FUNCTION_ENTRY_POINT(933) +FUNCTION_ENTRY_POINT(934) +FUNCTION_ENTRY_POINT(935) +FUNCTION_ENTRY_POINT(936) +FUNCTION_ENTRY_POINT(937) +FUNCTION_ENTRY_POINT(938) +FUNCTION_ENTRY_POINT(939) +FUNCTION_ENTRY_POINT(940) +FUNCTION_ENTRY_POINT(941) +FUNCTION_ENTRY_POINT(942) +FUNCTION_ENTRY_POINT(943) +FUNCTION_ENTRY_POINT(944) +FUNCTION_ENTRY_POINT(945) +FUNCTION_ENTRY_POINT(946) +FUNCTION_ENTRY_POINT(947) +FUNCTION_ENTRY_POINT(948) +FUNCTION_ENTRY_POINT(949) +FUNCTION_ENTRY_POINT(950) +FUNCTION_ENTRY_POINT(951) +FUNCTION_ENTRY_POINT(952) +FUNCTION_ENTRY_POINT(953) +FUNCTION_ENTRY_POINT(954) +FUNCTION_ENTRY_POINT(955) +FUNCTION_ENTRY_POINT(956) +FUNCTION_ENTRY_POINT(957) +FUNCTION_ENTRY_POINT(958) +FUNCTION_ENTRY_POINT(959) +FUNCTION_ENTRY_POINT(960) +FUNCTION_ENTRY_POINT(961) +FUNCTION_ENTRY_POINT(962) +FUNCTION_ENTRY_POINT(963) +FUNCTION_ENTRY_POINT(964) +FUNCTION_ENTRY_POINT(965) +FUNCTION_ENTRY_POINT(966) +FUNCTION_ENTRY_POINT(967) +FUNCTION_ENTRY_POINT(968) +FUNCTION_ENTRY_POINT(969) +FUNCTION_ENTRY_POINT(970) +FUNCTION_ENTRY_POINT(971) +FUNCTION_ENTRY_POINT(972) +FUNCTION_ENTRY_POINT(973) +FUNCTION_ENTRY_POINT(974) +FUNCTION_ENTRY_POINT(975) +FUNCTION_ENTRY_POINT(976) +FUNCTION_ENTRY_POINT(977) +FUNCTION_ENTRY_POINT(978) +FUNCTION_ENTRY_POINT(979) +FUNCTION_ENTRY_POINT(980) +FUNCTION_ENTRY_POINT(981) +FUNCTION_ENTRY_POINT(982) +FUNCTION_ENTRY_POINT(983) +FUNCTION_ENTRY_POINT(984) +FUNCTION_ENTRY_POINT(985) +FUNCTION_ENTRY_POINT(986) +FUNCTION_ENTRY_POINT(987) +FUNCTION_ENTRY_POINT(988) +FUNCTION_ENTRY_POINT(989) +FUNCTION_ENTRY_POINT(990) +FUNCTION_ENTRY_POINT(991) +FUNCTION_ENTRY_POINT(992) +FUNCTION_ENTRY_POINT(993) +FUNCTION_ENTRY_POINT(994) +FUNCTION_ENTRY_POINT(995) +FUNCTION_ENTRY_POINT(996) +FUNCTION_ENTRY_POINT(997) +FUNCTION_ENTRY_POINT(998) +FUNCTION_ENTRY_POINT(999) +FUNCTION_ENTRY_POINT(1000) +FUNCTION_ENTRY_POINT(1001) +FUNCTION_ENTRY_POINT(1002) +FUNCTION_ENTRY_POINT(1003) +FUNCTION_ENTRY_POINT(1004) +FUNCTION_ENTRY_POINT(1005) +FUNCTION_ENTRY_POINT(1006) +FUNCTION_ENTRY_POINT(1007) +FUNCTION_ENTRY_POINT(1008) +FUNCTION_ENTRY_POINT(1009) +FUNCTION_ENTRY_POINT(1010) +FUNCTION_ENTRY_POINT(1011) +FUNCTION_ENTRY_POINT(1012) +FUNCTION_ENTRY_POINT(1013) +FUNCTION_ENTRY_POINT(1014) +FUNCTION_ENTRY_POINT(1015) +FUNCTION_ENTRY_POINT(1016) +FUNCTION_ENTRY_POINT(1017) +FUNCTION_ENTRY_POINT(1018) +FUNCTION_ENTRY_POINT(1019) +FUNCTION_ENTRY_POINT(1020) +FUNCTION_ENTRY_POINT(1021) +FUNCTION_ENTRY_POINT(1022) +FUNCTION_ENTRY_POINT(1023) + +const void *InterfaceAdapter::unknownVtbl[] = { + InterfaceAdapter::QueryInterface, + InterfaceAdapter::AddRef, + InterfaceAdapter::Release, + function_3, + function_4, + function_5, + function_6, + function_7, + function_8, + function_9, + function_10, + function_11, + function_12, + function_13, + function_14, + function_15, + function_16, + function_17, + function_18, + function_19, + function_20, + function_21, + function_22, + function_23, + function_24, + function_25, + function_26, + function_27, + function_28, + function_29, + function_30, + function_31, + function_32, + function_33, + function_34, + function_35, + function_36, + function_37, + function_38, + function_39, + function_40, + function_41, + function_42, + function_43, + function_44, + function_45, + function_46, + function_47, + function_48, + function_49, + function_50, + function_51, + function_52, + function_53, + function_54, + function_55, + function_56, + function_57, + function_58, + function_59, + function_60, + function_61, + function_62, + function_63, + function_64, + function_65, + function_66, + function_67, + function_68, + function_69, + function_70, + function_71, + function_72, + function_73, + function_74, + function_75, + function_76, + function_77, + function_78, + function_79, + function_80, + function_81, + function_82, + function_83, + function_84, + function_85, + function_86, + function_87, + function_88, + function_89, + function_90, + function_91, + function_92, + function_93, + function_94, + function_95, + function_96, + function_97, + function_98, + function_99, + function_100, + function_101, + function_102, + function_103, + function_104, + function_105, + function_106, + function_107, + function_108, + function_109, + function_110, + function_111, + function_112, + function_113, + function_114, + function_115, + function_116, + function_117, + function_118, + function_119, + function_120, + function_121, + function_122, + function_123, + function_124, + function_125, + function_126, + function_127, + function_128, + function_129, + function_130, + function_131, + function_132, + function_133, + function_134, + function_135, + function_136, + function_137, + function_138, + function_139, + function_140, + function_141, + function_142, + function_143, + function_144, + function_145, + function_146, + function_147, + function_148, + function_149, + function_150, + function_151, + function_152, + function_153, + function_154, + function_155, + function_156, + function_157, + function_158, + function_159, + function_160, + function_161, + function_162, + function_163, + function_164, + function_165, + function_166, + function_167, + function_168, + function_169, + function_170, + function_171, + function_172, + function_173, + function_174, + function_175, + function_176, + function_177, + function_178, + function_179, + function_180, + function_181, + function_182, + function_183, + function_184, + function_185, + function_186, + function_187, + function_188, + function_189, + function_190, + function_191, + function_192, + function_193, + function_194, + function_195, + function_196, + function_197, + function_198, + function_199, + function_200, + function_201, + function_202, + function_203, + function_204, + function_205, + function_206, + function_207, + function_208, + function_209, + function_210, + function_211, + function_212, + function_213, + function_214, + function_215, + function_216, + function_217, + function_218, + function_219, + function_220, + function_221, + function_222, + function_223, + function_224, + function_225, + function_226, + function_227, + function_228, + function_229, + function_230, + function_231, + function_232, + function_233, + function_234, + function_235, + function_236, + function_237, + function_238, + function_239, + function_240, + function_241, + function_242, + function_243, + function_244, + function_245, + function_246, + function_247, + function_248, + function_249, + function_250, + function_251, + function_252, + function_253, + function_254, + function_255, + function_256, + function_257, + function_258, + function_259, + function_260, + function_261, + function_262, + function_263, + function_264, + function_265, + function_266, + function_267, + function_268, + function_269, + function_270, + function_271, + function_272, + function_273, + function_274, + function_275, + function_276, + function_277, + function_278, + function_279, + function_280, + function_281, + function_282, + function_283, + function_284, + function_285, + function_286, + function_287, + function_288, + function_289, + function_290, + function_291, + function_292, + function_293, + function_294, + function_295, + function_296, + function_297, + function_298, + function_299, + function_300, + function_301, + function_302, + function_303, + function_304, + function_305, + function_306, + function_307, + function_308, + function_309, + function_310, + function_311, + function_312, + function_313, + function_314, + function_315, + function_316, + function_317, + function_318, + function_319, + function_320, + function_321, + function_322, + function_323, + function_324, + function_325, + function_326, + function_327, + function_328, + function_329, + function_330, + function_331, + function_332, + function_333, + function_334, + function_335, + function_336, + function_337, + function_338, + function_339, + function_340, + function_341, + function_342, + function_343, + function_344, + function_345, + function_346, + function_347, + function_348, + function_349, + function_350, + function_351, + function_352, + function_353, + function_354, + function_355, + function_356, + function_357, + function_358, + function_359, + function_360, + function_361, + function_362, + function_363, + function_364, + function_365, + function_366, + function_367, + function_368, + function_369, + function_370, + function_371, + function_372, + function_373, + function_374, + function_375, + function_376, + function_377, + function_378, + function_379, + function_380, + function_381, + function_382, + function_383, + function_384, + function_385, + function_386, + function_387, + function_388, + function_389, + function_390, + function_391, + function_392, + function_393, + function_394, + function_395, + function_396, + function_397, + function_398, + function_399, + function_400, + function_401, + function_402, + function_403, + function_404, + function_405, + function_406, + function_407, + function_408, + function_409, + function_410, + function_411, + function_412, + function_413, + function_414, + function_415, + function_416, + function_417, + function_418, + function_419, + function_420, + function_421, + function_422, + function_423, + function_424, + function_425, + function_426, + function_427, + function_428, + function_429, + function_430, + function_431, + function_432, + function_433, + function_434, + function_435, + function_436, + function_437, + function_438, + function_439, + function_440, + function_441, + function_442, + function_443, + function_444, + function_445, + function_446, + function_447, + function_448, + function_449, + function_450, + function_451, + function_452, + function_453, + function_454, + function_455, + function_456, + function_457, + function_458, + function_459, + function_460, + function_461, + function_462, + function_463, + function_464, + function_465, + function_466, + function_467, + function_468, + function_469, + function_470, + function_471, + function_472, + function_473, + function_474, + function_475, + function_476, + function_477, + function_478, + function_479, + function_480, + function_481, + function_482, + function_483, + function_484, + function_485, + function_486, + function_487, + function_488, + function_489, + function_490, + function_491, + function_492, + function_493, + function_494, + function_495, + function_496, + function_497, + function_498, + function_499, + function_500, + function_501, + function_502, + function_503, + function_504, + function_505, + function_506, + function_507, + function_508, + function_509, + function_510, + function_511, + function_512, + function_513, + function_514, + function_515, + function_516, + function_517, + function_518, + function_519, + function_520, + function_521, + function_522, + function_523, + function_524, + function_525, + function_526, + function_527, + function_528, + function_529, + function_530, + function_531, + function_532, + function_533, + function_534, + function_535, + function_536, + function_537, + function_538, + function_539, + function_540, + function_541, + function_542, + function_543, + function_544, + function_545, + function_546, + function_547, + function_548, + function_549, + function_550, + function_551, + function_552, + function_553, + function_554, + function_555, + function_556, + function_557, + function_558, + function_559, + function_560, + function_561, + function_562, + function_563, + function_564, + function_565, + function_566, + function_567, + function_568, + function_569, + function_570, + function_571, + function_572, + function_573, + function_574, + function_575, + function_576, + function_577, + function_578, + function_579, + function_580, + function_581, + function_582, + function_583, + function_584, + function_585, + function_586, + function_587, + function_588, + function_589, + function_590, + function_591, + function_592, + function_593, + function_594, + function_595, + function_596, + function_597, + function_598, + function_599, + function_600, + function_601, + function_602, + function_603, + function_604, + function_605, + function_606, + function_607, + function_608, + function_609, + function_610, + function_611, + function_612, + function_613, + function_614, + function_615, + function_616, + function_617, + function_618, + function_619, + function_620, + function_621, + function_622, + function_623, + function_624, + function_625, + function_626, + function_627, + function_628, + function_629, + function_630, + function_631, + function_632, + function_633, + function_634, + function_635, + function_636, + function_637, + function_638, + function_639, + function_640, + function_641, + function_642, + function_643, + function_644, + function_645, + function_646, + function_647, + function_648, + function_649, + function_650, + function_651, + function_652, + function_653, + function_654, + function_655, + function_656, + function_657, + function_658, + function_659, + function_660, + function_661, + function_662, + function_663, + function_664, + function_665, + function_666, + function_667, + function_668, + function_669, + function_670, + function_671, + function_672, + function_673, + function_674, + function_675, + function_676, + function_677, + function_678, + function_679, + function_680, + function_681, + function_682, + function_683, + function_684, + function_685, + function_686, + function_687, + function_688, + function_689, + function_690, + function_691, + function_692, + function_693, + function_694, + function_695, + function_696, + function_697, + function_698, + function_699, + function_700, + function_701, + function_702, + function_703, + function_704, + function_705, + function_706, + function_707, + function_708, + function_709, + function_710, + function_711, + function_712, + function_713, + function_714, + function_715, + function_716, + function_717, + function_718, + function_719, + function_720, + function_721, + function_722, + function_723, + function_724, + function_725, + function_726, + function_727, + function_728, + function_729, + function_730, + function_731, + function_732, + function_733, + function_734, + function_735, + function_736, + function_737, + function_738, + function_739, + function_740, + function_741, + function_742, + function_743, + function_744, + function_745, + function_746, + function_747, + function_748, + function_749, + function_750, + function_751, + function_752, + function_753, + function_754, + function_755, + function_756, + function_757, + function_758, + function_759, + function_760, + function_761, + function_762, + function_763, + function_764, + function_765, + function_766, + function_767, + function_768, + function_769, + function_770, + function_771, + function_772, + function_773, + function_774, + function_775, + function_776, + function_777, + function_778, + function_779, + function_780, + function_781, + function_782, + function_783, + function_784, + function_785, + function_786, + function_787, + function_788, + function_789, + function_790, + function_791, + function_792, + function_793, + function_794, + function_795, + function_796, + function_797, + function_798, + function_799, + function_800, + function_801, + function_802, + function_803, + function_804, + function_805, + function_806, + function_807, + function_808, + function_809, + function_810, + function_811, + function_812, + function_813, + function_814, + function_815, + function_816, + function_817, + function_818, + function_819, + function_820, + function_821, + function_822, + function_823, + function_824, + function_825, + function_826, + function_827, + function_828, + function_829, + function_830, + function_831, + function_832, + function_833, + function_834, + function_835, + function_836, + function_837, + function_838, + function_839, + function_840, + function_841, + function_842, + function_843, + function_844, + function_845, + function_846, + function_847, + function_848, + function_849, + function_850, + function_851, + function_852, + function_853, + function_854, + function_855, + function_856, + function_857, + function_858, + function_859, + function_860, + function_861, + function_862, + function_863, + function_864, + function_865, + function_866, + function_867, + function_868, + function_869, + function_870, + function_871, + function_872, + function_873, + function_874, + function_875, + function_876, + function_877, + function_878, + function_879, + function_880, + function_881, + function_882, + function_883, + function_884, + function_885, + function_886, + function_887, + function_888, + function_889, + function_890, + function_891, + function_892, + function_893, + function_894, + function_895, + function_896, + function_897, + function_898, + function_899, + function_900, + function_901, + function_902, + function_903, + function_904, + function_905, + function_906, + function_907, + function_908, + function_909, + function_910, + function_911, + function_912, + function_913, + function_914, + function_915, + function_916, + function_917, + function_918, + function_919, + function_920, + function_921, + function_922, + function_923, + function_924, + function_925, + function_926, + function_927, + function_928, + function_929, + function_930, + function_931, + function_932, + function_933, + function_934, + function_935, + function_936, + function_937, + function_938, + function_939, + function_940, + function_941, + function_942, + function_943, + function_944, + function_945, + function_946, + function_947, + function_948, + function_949, + function_950, + function_951, + function_952, + function_953, + function_954, + function_955, + function_956, + function_957, + function_958, + function_959, + function_960, + function_961, + function_962, + function_963, + function_964, + function_965, + function_966, + function_967, + function_968, + function_969, + function_970, + function_971, + function_972, + function_973, + function_974, + function_975, + function_976, + function_977, + function_978, + function_979, + function_980, + function_981, + function_982, + function_983, + function_984, + function_985, + function_986, + function_987, + function_988, + function_989, + function_990, + function_991, + function_992, + function_993, + function_994, + function_995, + function_996, + function_997, + function_998, + function_999, + function_1000, + function_1001, + function_1002, + function_1003, + function_1004, + function_1005, + function_1006, + function_1007, + function_1008, + function_1009, + function_1010, + function_1011, + function_1012, + function_1013, + function_1014, + function_1015, + function_1016, + function_1017, + function_1018, + function_1019, + function_1020, + function_1021, + function_1022, + function_1023 +}; + +const void *InterfaceAdapter::dispatchVtbl[] = { + InterfaceAdapter::QueryInterface, + InterfaceAdapter::AddRef, + InterfaceAdapter::Release, + InterfaceAdapter::GetTypeInfoCount, + InterfaceAdapter::GetTypeInfo, + InterfaceAdapter::GetIDsOfNames, + InterfaceAdapter::Invoke, + function_7, + function_8, + function_9, + function_10, + function_11, + function_12, + function_13, + function_14, + function_15, + function_16, + function_17, + function_18, + function_19, + function_20, + function_21, + function_22, + function_23, + function_24, + function_25, + function_26, + function_27, + function_28, + function_29, + function_30, + function_31, + function_32, + function_33, + function_34, + function_35, + function_36, + function_37, + function_38, + function_39, + function_40, + function_41, + function_42, + function_43, + function_44, + function_45, + function_46, + function_47, + function_48, + function_49, + function_50, + function_51, + function_52, + function_53, + function_54, + function_55, + function_56, + function_57, + function_58, + function_59, + function_60, + function_61, + function_62, + function_63, + function_64, + function_65, + function_66, + function_67, + function_68, + function_69, + function_70, + function_71, + function_72, + function_73, + function_74, + function_75, + function_76, + function_77, + function_78, + function_79, + function_80, + function_81, + function_82, + function_83, + function_84, + function_85, + function_86, + function_87, + function_88, + function_89, + function_90, + function_91, + function_92, + function_93, + function_94, + function_95, + function_96, + function_97, + function_98, + function_99, + function_100, + function_101, + function_102, + function_103, + function_104, + function_105, + function_106, + function_107, + function_108, + function_109, + function_110, + function_111, + function_112, + function_113, + function_114, + function_115, + function_116, + function_117, + function_118, + function_119, + function_120, + function_121, + function_122, + function_123, + function_124, + function_125, + function_126, + function_127, + function_128, + function_129, + function_130, + function_131, + function_132, + function_133, + function_134, + function_135, + function_136, + function_137, + function_138, + function_139, + function_140, + function_141, + function_142, + function_143, + function_144, + function_145, + function_146, + function_147, + function_148, + function_149, + function_150, + function_151, + function_152, + function_153, + function_154, + function_155, + function_156, + function_157, + function_158, + function_159, + function_160, + function_161, + function_162, + function_163, + function_164, + function_165, + function_166, + function_167, + function_168, + function_169, + function_170, + function_171, + function_172, + function_173, + function_174, + function_175, + function_176, + function_177, + function_178, + function_179, + function_180, + function_181, + function_182, + function_183, + function_184, + function_185, + function_186, + function_187, + function_188, + function_189, + function_190, + function_191, + function_192, + function_193, + function_194, + function_195, + function_196, + function_197, + function_198, + function_199, + function_200, + function_201, + function_202, + function_203, + function_204, + function_205, + function_206, + function_207, + function_208, + function_209, + function_210, + function_211, + function_212, + function_213, + function_214, + function_215, + function_216, + function_217, + function_218, + function_219, + function_220, + function_221, + function_222, + function_223, + function_224, + function_225, + function_226, + function_227, + function_228, + function_229, + function_230, + function_231, + function_232, + function_233, + function_234, + function_235, + function_236, + function_237, + function_238, + function_239, + function_240, + function_241, + function_242, + function_243, + function_244, + function_245, + function_246, + function_247, + function_248, + function_249, + function_250, + function_251, + function_252, + function_253, + function_254, + function_255, + function_256, + function_257, + function_258, + function_259, + function_260, + function_261, + function_262, + function_263, + function_264, + function_265, + function_266, + function_267, + function_268, + function_269, + function_270, + function_271, + function_272, + function_273, + function_274, + function_275, + function_276, + function_277, + function_278, + function_279, + function_280, + function_281, + function_282, + function_283, + function_284, + function_285, + function_286, + function_287, + function_288, + function_289, + function_290, + function_291, + function_292, + function_293, + function_294, + function_295, + function_296, + function_297, + function_298, + function_299, + function_300, + function_301, + function_302, + function_303, + function_304, + function_305, + function_306, + function_307, + function_308, + function_309, + function_310, + function_311, + function_312, + function_313, + function_314, + function_315, + function_316, + function_317, + function_318, + function_319, + function_320, + function_321, + function_322, + function_323, + function_324, + function_325, + function_326, + function_327, + function_328, + function_329, + function_330, + function_331, + function_332, + function_333, + function_334, + function_335, + function_336, + function_337, + function_338, + function_339, + function_340, + function_341, + function_342, + function_343, + function_344, + function_345, + function_346, + function_347, + function_348, + function_349, + function_350, + function_351, + function_352, + function_353, + function_354, + function_355, + function_356, + function_357, + function_358, + function_359, + function_360, + function_361, + function_362, + function_363, + function_364, + function_365, + function_366, + function_367, + function_368, + function_369, + function_370, + function_371, + function_372, + function_373, + function_374, + function_375, + function_376, + function_377, + function_378, + function_379, + function_380, + function_381, + function_382, + function_383, + function_384, + function_385, + function_386, + function_387, + function_388, + function_389, + function_390, + function_391, + function_392, + function_393, + function_394, + function_395, + function_396, + function_397, + function_398, + function_399, + function_400, + function_401, + function_402, + function_403, + function_404, + function_405, + function_406, + function_407, + function_408, + function_409, + function_410, + function_411, + function_412, + function_413, + function_414, + function_415, + function_416, + function_417, + function_418, + function_419, + function_420, + function_421, + function_422, + function_423, + function_424, + function_425, + function_426, + function_427, + function_428, + function_429, + function_430, + function_431, + function_432, + function_433, + function_434, + function_435, + function_436, + function_437, + function_438, + function_439, + function_440, + function_441, + function_442, + function_443, + function_444, + function_445, + function_446, + function_447, + function_448, + function_449, + function_450, + function_451, + function_452, + function_453, + function_454, + function_455, + function_456, + function_457, + function_458, + function_459, + function_460, + function_461, + function_462, + function_463, + function_464, + function_465, + function_466, + function_467, + function_468, + function_469, + function_470, + function_471, + function_472, + function_473, + function_474, + function_475, + function_476, + function_477, + function_478, + function_479, + function_480, + function_481, + function_482, + function_483, + function_484, + function_485, + function_486, + function_487, + function_488, + function_489, + function_490, + function_491, + function_492, + function_493, + function_494, + function_495, + function_496, + function_497, + function_498, + function_499, + function_500, + function_501, + function_502, + function_503, + function_504, + function_505, + function_506, + function_507, + function_508, + function_509, + function_510, + function_511, + function_512, + function_513, + function_514, + function_515, + function_516, + function_517, + function_518, + function_519, + function_520, + function_521, + function_522, + function_523, + function_524, + function_525, + function_526, + function_527, + function_528, + function_529, + function_530, + function_531, + function_532, + function_533, + function_534, + function_535, + function_536, + function_537, + function_538, + function_539, + function_540, + function_541, + function_542, + function_543, + function_544, + function_545, + function_546, + function_547, + function_548, + function_549, + function_550, + function_551, + function_552, + function_553, + function_554, + function_555, + function_556, + function_557, + function_558, + function_559, + function_560, + function_561, + function_562, + function_563, + function_564, + function_565, + function_566, + function_567, + function_568, + function_569, + function_570, + function_571, + function_572, + function_573, + function_574, + function_575, + function_576, + function_577, + function_578, + function_579, + function_580, + function_581, + function_582, + function_583, + function_584, + function_585, + function_586, + function_587, + function_588, + function_589, + function_590, + function_591, + function_592, + function_593, + function_594, + function_595, + function_596, + function_597, + function_598, + function_599, + function_600, + function_601, + function_602, + function_603, + function_604, + function_605, + function_606, + function_607, + function_608, + function_609, + function_610, + function_611, + function_612, + function_613, + function_614, + function_615, + function_616, + function_617, + function_618, + function_619, + function_620, + function_621, + function_622, + function_623, + function_624, + function_625, + function_626, + function_627, + function_628, + function_629, + function_630, + function_631, + function_632, + function_633, + function_634, + function_635, + function_636, + function_637, + function_638, + function_639, + function_640, + function_641, + function_642, + function_643, + function_644, + function_645, + function_646, + function_647, + function_648, + function_649, + function_650, + function_651, + function_652, + function_653, + function_654, + function_655, + function_656, + function_657, + function_658, + function_659, + function_660, + function_661, + function_662, + function_663, + function_664, + function_665, + function_666, + function_667, + function_668, + function_669, + function_670, + function_671, + function_672, + function_673, + function_674, + function_675, + function_676, + function_677, + function_678, + function_679, + function_680, + function_681, + function_682, + function_683, + function_684, + function_685, + function_686, + function_687, + function_688, + function_689, + function_690, + function_691, + function_692, + function_693, + function_694, + function_695, + function_696, + function_697, + function_698, + function_699, + function_700, + function_701, + function_702, + function_703, + function_704, + function_705, + function_706, + function_707, + function_708, + function_709, + function_710, + function_711, + function_712, + function_713, + function_714, + function_715, + function_716, + function_717, + function_718, + function_719, + function_720, + function_721, + function_722, + function_723, + function_724, + function_725, + function_726, + function_727, + function_728, + function_729, + function_730, + function_731, + function_732, + function_733, + function_734, + function_735, + function_736, + function_737, + function_738, + function_739, + function_740, + function_741, + function_742, + function_743, + function_744, + function_745, + function_746, + function_747, + function_748, + function_749, + function_750, + function_751, + function_752, + function_753, + function_754, + function_755, + function_756, + function_757, + function_758, + function_759, + function_760, + function_761, + function_762, + function_763, + function_764, + function_765, + function_766, + function_767, + function_768, + function_769, + function_770, + function_771, + function_772, + function_773, + function_774, + function_775, + function_776, + function_777, + function_778, + function_779, + function_780, + function_781, + function_782, + function_783, + function_784, + function_785, + function_786, + function_787, + function_788, + function_789, + function_790, + function_791, + function_792, + function_793, + function_794, + function_795, + function_796, + function_797, + function_798, + function_799, + function_800, + function_801, + function_802, + function_803, + function_804, + function_805, + function_806, + function_807, + function_808, + function_809, + function_810, + function_811, + function_812, + function_813, + function_814, + function_815, + function_816, + function_817, + function_818, + function_819, + function_820, + function_821, + function_822, + function_823, + function_824, + function_825, + function_826, + function_827, + function_828, + function_829, + function_830, + function_831, + function_832, + function_833, + function_834, + function_835, + function_836, + function_837, + function_838, + function_839, + function_840, + function_841, + function_842, + function_843, + function_844, + function_845, + function_846, + function_847, + function_848, + function_849, + function_850, + function_851, + function_852, + function_853, + function_854, + function_855, + function_856, + function_857, + function_858, + function_859, + function_860, + function_861, + function_862, + function_863, + function_864, + function_865, + function_866, + function_867, + function_868, + function_869, + function_870, + function_871, + function_872, + function_873, + function_874, + function_875, + function_876, + function_877, + function_878, + function_879, + function_880, + function_881, + function_882, + function_883, + function_884, + function_885, + function_886, + function_887, + function_888, + function_889, + function_890, + function_891, + function_892, + function_893, + function_894, + function_895, + function_896, + function_897, + function_898, + function_899, + function_900, + function_901, + function_902, + function_903, + function_904, + function_905, + function_906, + function_907, + function_908, + function_909, + function_910, + function_911, + function_912, + function_913, + function_914, + function_915, + function_916, + function_917, + function_918, + function_919, + function_920, + function_921, + function_922, + function_923, + function_924, + function_925, + function_926, + function_927, + function_928, + function_929, + function_930, + function_931, + function_932, + function_933, + function_934, + function_935, + function_936, + function_937, + function_938, + function_939, + function_940, + function_941, + function_942, + function_943, + function_944, + function_945, + function_946, + function_947, + function_948, + function_949, + function_950, + function_951, + function_952, + function_953, + function_954, + function_955, + function_956, + function_957, + function_958, + function_959, + function_960, + function_961, + function_962, + function_963, + function_964, + function_965, + function_966, + function_967, + function_968, + function_969, + function_970, + function_971, + function_972, + function_973, + function_974, + function_975, + function_976, + function_977, + function_978, + function_979, + function_980, + function_981, + function_982, + function_983, + function_984, + function_985, + function_986, + function_987, + function_988, + function_989, + function_990, + function_991, + function_992, + function_993, + function_994, + function_995, + function_996, + function_997, + function_998, + function_999, + function_1000, + function_1001, + function_1002, + function_1003, + function_1004, + function_1005, + function_1006, + function_1007, + function_1008, + function_1009, + function_1010, + function_1011, + function_1012, + function_1013, + function_1014, + function_1015, + function_1016, + function_1017, + function_1018, + function_1019, + function_1020, + function_1021, + function_1022, + function_1023 +}; diff --git a/src/Makefile b/src/Makefile new file mode 100644 index 0000000..9ce33e0 --- /dev/null +++ b/src/Makefile @@ -0,0 +1,21 @@ +# $Id: Makefile,v 1.10 2002/05/31 04:03:06 cthuang Exp $ + +debug: + tclsh &&| +set libDir [file join [info library] "../tcom"] +file copy -force Debug/tcom.dll $libDir +file copy -force dllserver_Debug/tcominproc.dll $libDir +file copy -force exeserver_Debug/tcomlocal.exe $libDir +set libDir [file join [info library] "../TclScript"] +file copy -force TclScript_Debug/TclScript.dll $libDir +| + +release: + tclsh &&| +set libDir [file join [info library] "../tcom"] +file copy -force Release/tcom.dll $libDir +file copy -force dllserver_Release/tcominproc.dll $libDir +file copy -force exeserver_Release/tcomlocal.exe $libDir +set libDir [file join [info library] "../TclScript"] +file copy -force TclScript_Release/TclScript.dll $libDir +| diff --git a/src/Reference.cpp b/src/Reference.cpp new file mode 100644 index 0000000..49e9a79 --- /dev/null +++ b/src/Reference.cpp @@ -0,0 +1,588 @@ +// $Id: Reference.cpp,v 1.69 2002/06/28 00:53:46 cthuang Exp $ +#pragma warning(disable: 4786) +#include +#include "ComObject.h" +#include "TypeLib.h" +#include "Uuid.h" +#include "Arguments.h" +#include "Reference.h" + +Reference::Connection::Connection (Tcl_Interp *interp, + IUnknown *pSource, + const Interface &eventInterfaceDesc, + TclObject servant) +{ + HRESULT hr; + + // Get connection point container. + IConnectionPointContainerPtr pContainer; + hr = pSource->QueryInterface( + IID_IConnectionPointContainer, + reinterpret_cast(&pContainer)); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + // Find connection point. + hr = pContainer->FindConnectionPoint( + eventInterfaceDesc.iid(), &m_pConnectionPoint); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + // Create event sink. + ComObject *pComObject = ComObject::newInstance( + eventInterfaceDesc, + interp, + servant, + ""); + + // Connect to connection point. + hr = m_pConnectionPoint->Advise(pComObject->unknown(), &m_adviseCookie); + if (FAILED(hr)) { + _com_issue_error(hr); + } +} + +Reference::Connection::~Connection () +{ + m_pConnectionPoint->Unadvise(m_adviseCookie); + m_pConnectionPoint->Release(); +} + +Reference::Reference (IUnknown *pUnknown, const Interface *pInterface): + m_pUnknown(pUnknown), + m_pDispatch(0), + m_pInterface(pInterface), + m_pClass(0), + m_haveClsid(false) +{ } + +Reference::Reference ( + IUnknown *pUnknown, const Interface *pInterface, REFCLSID clsid): + m_pUnknown(pUnknown), + m_pDispatch(0), + m_pInterface(pInterface), + m_pClass(0), + m_clsid(clsid), + m_haveClsid(true) +{ } + +Reference::~Reference() +{ + unadvise(); + if (m_pDispatch != 0) { + m_pDispatch->Release(); + } + m_pUnknown->Release(); + delete m_pClass; +} + +IDispatch * +Reference::dispatch () +{ + if (m_pDispatch == 0) { + HRESULT hr = m_pUnknown->QueryInterface( + IID_IDispatch, reinterpret_cast(&m_pDispatch)); + if (FAILED(hr)) { + m_pDispatch = 0; + } + } + return m_pDispatch; +} + +const Class * +Reference::classDesc () +{ + if (!m_haveClsid) { + return 0; + } + + if (m_pClass == 0) { + TypeLib *pTypeLib = TypeLib::loadByClsid(m_clsid); + if (pTypeLib != 0) { + const Class *pClass = pTypeLib->findClass(m_clsid); + if (pClass != 0) { + m_pClass = new Class(*pClass); + } + } + delete pTypeLib; + } + + return m_pClass; +} + +void +Reference::advise (Tcl_Interp *interp, + const Interface &eventInterfaceDesc, + TclObject servant) +{ + m_connections.push_back(new Connection( + interp, m_pUnknown, eventInterfaceDesc, servant)); +} + +void +Reference::unadvise () +{ + for (Connections::iterator p = m_connections.begin(); + p != m_connections.end(); ++p) { + delete *p; + } + m_connections.clear(); +} + +bool +Reference::operator== (const Reference &rhs) const +{ + HRESULT hr; + + IUnknown *pUnknown1; + hr = m_pUnknown->QueryInterface( + IID_IUnknown, reinterpret_cast(&pUnknown1)); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + IUnknown *pUnknown2; + rhs.m_pUnknown->QueryInterface( + IID_IUnknown, reinterpret_cast(&pUnknown2)); + if (FAILED(hr)) { + pUnknown1->Release(); + _com_issue_error(hr); + } + + bool result = pUnknown1 == pUnknown2; + + pUnknown1->Release(); + pUnknown2->Release(); + + return result; +} + +HRESULT +Reference::invokeDispatch ( + MEMBERID memberid, + WORD dispatchFlags, + const TypedArguments &arguments, + VARIANT *pResult) +{ + IDispatch *pDispatch = dispatch(); + if (pDispatch == 0) { + return E_NOINTERFACE; + } + + // Remove missing optional arguments from the end of the argument list. + // This permits calling servers which modify their action depending on + // the actual number of arguments. + DISPPARAMS *pParams = arguments.dispParams(); + + // Count the number of missing arguments. + unsigned cMissingArgs = 0; + VARIANT *pArg = pParams->rgvarg + pParams->cNamedArgs; + for (unsigned i = pParams->cNamedArgs; i < pParams->cArgs; ++i) { + if (V_VT(pArg) != VT_ERROR || V_ERROR(pArg) != DISP_E_PARAMNOTFOUND) { + break; + } + + ++cMissingArgs; + ++pArg; + } + + // Move the named arguments up next to the remaining unnamed arguments and + // adjust the DISPPARAMS struct. + if (cMissingArgs > 0) { + for (unsigned i = 0; i < pParams->cNamedArgs; ++i) { + pParams->rgvarg[i + cMissingArgs] = pParams->rgvarg[i]; + } + pParams->cArgs -= cMissingArgs; + pParams->rgvarg += cMissingArgs; + } + + EXCEPINFO excepInfo; + memset(&excepInfo, 0, sizeof(excepInfo)); + unsigned argErr; + + // Invoke through IDispatch interface. + HRESULT hr = pDispatch->Invoke( + memberid, + IID_NULL, + LOCALE_USER_DEFAULT, + dispatchFlags, + pParams, + pResult, + &excepInfo, + &argErr); + + if (hr == DISP_E_EXCEPTION) { + // Clean up exception information strings. + _bstr_t source(excepInfo.bstrSource, false); + _bstr_t description(excepInfo.bstrDescription, false); + _bstr_t helpFile(excepInfo.bstrHelpFile, false); + + hr = excepInfo.scode; + if (hr == 0) { + hr = _com_error::WCodeToHRESULT(excepInfo.wCode); + } + throw DispatchException(hr, description); + } + + return hr; +} + +HRESULT +Reference::invoke (MEMBERID memberid, + WORD dispatchFlags, + const TypedArguments &arguments, + VARIANT *pResult) +{ + if (m_pInterface != 0 && !m_pInterface->dispatchOnly()) { + EXCEPINFO excepInfo; + memset(&excepInfo, 0, sizeof(excepInfo)); + unsigned argErr; + + // Invoke through virtual function table. + ITypeInfo *pTypeInfo = interfaceDesc()->typeInfo(); + HRESULT hr = pTypeInfo->Invoke( + m_pUnknown, + memberid, + dispatchFlags, + arguments.dispParams(), + pResult, + &excepInfo, + &argErr); + + if (SUCCEEDED(hr)) { + return hr; + } + } + + return invokeDispatch(memberid, dispatchFlags, arguments, pResult); +} + +// IID of .NET Framework _Object interface +struct __declspec(uuid("65074F7F-63C0-304E-AF0A-D51741CB4A8D")) DotNetObject; + +const Interface * +Reference::findInterfaceFromDispatch (IUnknown *pUnknown) +{ + HRESULT hr; + + // See if the object implements IDispatch. + IDispatchPtr pDispatch; + hr = pUnknown->QueryInterface( + IID_IDispatch, reinterpret_cast(&pDispatch)); + if (FAILED(hr)) { + return 0; + } + + // Ask the IDispatch interface for type information. + unsigned count; + hr = pDispatch->GetTypeInfoCount(&count); + if (hr == E_NOTIMPL) { + return 0; + } + if (FAILED(hr)) { + _com_issue_error(hr); + } + if (count == 0) { + return 0; + } + + ITypeInfoPtr pTypeInfo; + hr = pDispatch->GetTypeInfo( + 0, + LOCALE_USER_DEFAULT, + &pTypeInfo); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + // Get the interface description. + TypeAttr typeAttr(pTypeInfo); + + if (IsEqualIID(typeAttr->guid, __uuidof(DotNetObject))) { + // The .NET Framework implements IDispatch::GetTypeInfo for classes + // declared with the attribute ClassInterface(ClassInterfaceType.None) + // by returning a description of the _Object interface. + return 0; + } + + const Interface *pInterface = + InterfaceManager::instance().newInterface(typeAttr->guid, pTypeInfo); + + if (pInterface->methods().empty() && pInterface->properties().empty()) { + // No invokable methods or properties where found in the interface + // description. + return 0; + } + return pInterface; +} + +const Interface * +Reference::findInterfaceFromClsid (REFCLSID clsid) +{ + const Interface *pInterface = 0; + + TypeLib *pTypeLib = TypeLib::loadByClsid(clsid); + if (pTypeLib != 0) { + const Class *pClass = pTypeLib->findClass(clsid); + if (pClass != 0) { + pInterface = pClass->defaultInterface(); + } + } + delete pTypeLib; + + return pInterface; +} + +const Interface * +Reference::findInterfaceFromIid (REFIID iid) +{ + const Interface *pInterface = 0; + + TypeLib *pTypeLib = TypeLib::loadByIid(iid); + if (pTypeLib != 0) { + pInterface = InterfaceManager::instance().find(iid); + } + delete pTypeLib; + + return pInterface; +} + +const Interface * +Reference::findInterface (IUnknown *pUnknown, REFCLSID clsid) +{ + const Interface *pInterface = 0; + + if (pUnknown != 0) { + pInterface = findInterfaceFromDispatch(pUnknown); + } + + if (pInterface == 0) { + pInterface = findInterfaceFromClsid(clsid); + } + + return pInterface; +} + +Reference * +Reference::createInstance ( + REFCLSID clsid, + const Interface *pInterface, + DWORD clsCtx, + const char *serverHost) +{ + // If we know it's a custom interface, then query for an interface pointer + // to that interface, otherwise query for an IUnknown interface. + const IID &iid = (pInterface == 0) ? IID_IUnknown : pInterface->iid(); + + HRESULT hr; + IUnknown *pUnknown; + + // Create an instance of the specified class. +#ifdef _WIN32_DCOM + if (serverHost == 0 + || serverHost[0] == '\0' + || strcmp(serverHost, "localhost") == 0 + || strcmp(serverHost, "127.0.0.1") == 0) { + // When creating an instance on the local machine, call + // CoCreateInstance instead of CoCreateInstanceEx with a null pointer + // to COSERVERINFO. This works around occasional failures in the RPC + // DLL on Windows NT 4.0, even when connecting to a server on the local + // machine. + hr = CoCreateInstance( + clsid, + NULL, + clsCtx, + iid, + reinterpret_cast(&pUnknown)); + } else { + COSERVERINFO serverInfo; + memset(&serverInfo, 0, sizeof(serverInfo)); + _bstr_t serverHostBstr(serverHost); + serverInfo.pwszName = serverHostBstr; + + MULTI_QI qi; + qi.pIID = &iid; + qi.pItf = NULL; + qi.hr = 0; + + hr = CoCreateInstanceEx( + clsid, + NULL, + clsCtx, + &serverInfo, + 1, + &qi); + if (SUCCEEDED(hr)) { + pUnknown = static_cast(qi.pItf); + } + } +#else + hr = CoCreateInstance( + clsid, + NULL, + clsCtx, + iid, + reinterpret_cast(&pUnknown)); +#endif + if (FAILED(hr)) { + _com_issue_error(hr); + } + + if (pInterface == 0) { + pInterface = findInterface(pUnknown, clsid); + if (pInterface != 0) { + // Get a pointer to the derived interface. + IUnknown *pNew; + hr = pUnknown->QueryInterface( + pInterface->iid(), + reinterpret_cast(&pNew)); + if (SUCCEEDED(hr)) { + pUnknown->Release(); + pUnknown = pNew; + } + } + } + + return new Reference(pUnknown, pInterface, clsid); +} + +Reference * +Reference::createInstance ( + const char *progId, + DWORD clsCtx, + const char *serverHost) +{ + // Convert the Prog ID to a CLSID. + CLSID clsid; + HRESULT hr = CLSIDFromProgID(_bstr_t(progId), &clsid); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + return createInstance(clsid, 0, clsCtx, serverHost); +} + +Reference * +Reference::getActiveObject (REFCLSID clsid, const Interface *pInterface) +{ + HRESULT hr; + + // Retrieve the instance of the object. + IUnknownPtr pActive; + hr = GetActiveObject(clsid, NULL, &pActive); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + // If we know it's a custom interface, then query for an interface pointer + // to that interface, otherwise query for an IUnknown interface. + IUnknown *pUnknown; + hr = pActive->QueryInterface( + (pInterface == 0) ? IID_IUnknown : pInterface->iid(), + reinterpret_cast(&pUnknown)); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + if (pInterface == 0) { + pInterface = findInterface(pUnknown, clsid); + if (pInterface != 0) { + // Get a pointer to the derived interface. + IUnknown *pNew; + hr = pUnknown->QueryInterface( + pInterface->iid(), + reinterpret_cast(&pNew)); + if (SUCCEEDED(hr)) { + pUnknown->Release(); + pUnknown = pNew; + } + } + } + + return new Reference(pUnknown, pInterface, clsid); +} + +Reference * +Reference::getActiveObject (const char *progId) +{ + // Convert the Prog ID to a CLSID. + CLSID clsid; + HRESULT hr = CLSIDFromProgID(_bstr_t(progId), &clsid); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + return getActiveObject(clsid, 0); +} + +Reference * +Reference::getObject (const char *displayName) +{ + IUnknown *pUnknown; + HRESULT hr = CoGetObject( + _bstr_t(displayName), + NULL, + IID_IUnknown, + reinterpret_cast(&pUnknown)); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + const Interface *pInterface = findInterfaceFromDispatch(pUnknown); + return new Reference(pUnknown, pInterface); +} + +Reference * +Reference::queryInterface (IUnknown *pOrig, REFIID iid) +{ + if (pOrig == 0) { + _com_issue_error(E_POINTER); + } + + IUnknown *pUnknown; + HRESULT hr = pOrig->QueryInterface( + iid, + reinterpret_cast(&pUnknown)); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + const Interface *pInterface = 0; + if (!IsEqualIID(iid, IID_IDispatch)) { + pInterface = findInterfaceFromIid(iid); + if (pInterface == 0) { + pInterface = findInterfaceFromDispatch(pUnknown); + } + } + + return new Reference(pUnknown, pInterface); +} + +Reference * +Reference::newReference (IUnknown *pOrig, const Interface *pInterface) +{ + if (pOrig == 0) { + _com_issue_error(E_POINTER); + } + + if (pInterface == 0) { + pInterface = findInterfaceFromDispatch(pOrig); + } + + // If we know it's a custom interface, then query for an interface pointer + // to that interface, otherwise query for an IUnknown interface. + const IID &iid = (pInterface == 0) ? IID_IUnknown : pInterface->iid(); + + IUnknown *pUnknown; + HRESULT hr = pOrig->QueryInterface( + iid, + reinterpret_cast(&pUnknown)); + if (FAILED(hr)) { + pUnknown = pOrig; + pUnknown->AddRef(); + } + + return new Reference(pUnknown, pInterface); +} diff --git a/src/Reference.h b/src/Reference.h new file mode 100644 index 0000000..5c423d5 --- /dev/null +++ b/src/Reference.h @@ -0,0 +1,179 @@ +// $Id: Reference.h,v 1.41 2002/06/12 02:14:08 cthuang Exp $ +#ifndef REFERENCE_H +#define REFERENCE_H + +#include +#include "tcomApi.h" +#include "TclObject.h" +#include "TypeInfo.h" + +class TypedArguments; + +// Throw this exception when invoke returns DISP_E_EXCEPTION. + +class DispatchException +{ + SCODE m_scode; + _bstr_t m_description; + +public: + DispatchException (SCODE scode, const _bstr_t &description): + m_scode(scode), + m_description(description) + { } + + SCODE scode () const + { return m_scode; } + + const _bstr_t &description () const + { return m_description; } +}; + +// This class holds an interface pointer and the interface description needed +// to invoke methods on it. + +class TCOM_API Reference +{ + // This represents a connection from a connection point to an event sink. + + class TCOM_API Connection + { + // pointer to connection point + IConnectionPoint *m_pConnectionPoint; + + // cookie returned from Advise + DWORD m_adviseCookie; + + public: + // Create an event sink object and connect it to the connection point. + Connection( + Tcl_Interp *interp, + IUnknown *pSource, + const Interface &eventInterfaceDesc, + TclObject servant); + + // Disconnect from the connection point and release the pointer to the + // connection point. + ~Connection(); + }; + + // collection of event connections + typedef std::vector Connections; + Connections m_connections; + + // interface pointer to the object + IUnknown *m_pUnknown; + + // this pointer is non-null if the object implements IDispatch + IDispatch *m_pDispatch; + + // interface description includes information about methods and properties + const Interface *m_pInterface; + + // class description includes information about interfaces exposed + Class *m_pClass; + + // CLSID of the class the COM object implements + CLSID m_clsid; + + // true if we know the CLSID of the class the COM object implements + bool m_haveClsid; + + // The constructor assumes the reference count on the interface pointer has + // already been incremented. This object will decrement the reference + // count when it is destroyed. + Reference(IUnknown *pUnknown, const Interface *pInterface); + Reference( + IUnknown *pUnknown, const Interface *pInterface, REFCLSID clsid); + + // Do not allow instances of this class to be copied. + Reference(const Reference &rhs); + Reference &operator=(const Reference &rhs); + + // Try to get interface description from IDispatch object. + static const Interface *findInterfaceFromDispatch(IUnknown *pUnknown); + + // Try to get interface description from type library specified by CLSID. + static const Interface *findInterfaceFromClsid(REFCLSID clsid); + + // Try to get interface description from type library specified by IID. + static const Interface *findInterfaceFromIid(REFIID iid); + + // Get description of interface implemented by the object. + static const Interface *findInterface(IUnknown *pUnknown, REFCLSID clsid); + +public: + // destructor + ~Reference(); + + // Perform a QueryInterface on the interface pointer and create a reference. + static Reference *newReference( + IUnknown *pUnknown, const Interface *pInterface=0); + + // Perform a QueryInterface on the interface pointer and create a reference. + static Reference *queryInterface(IUnknown *pUnknown, REFIID iid); + + // Create an object using CoCreateInstance and construct a reference. + static Reference *createInstance( + REFCLSID clsid, + const Interface *pInterface, + DWORD clsCtx, + const char *serverHost); + + // Create an object using CoCreateInstance and construct a reference. + static Reference *createInstance( + const char *progId, DWORD clsCtx, const char *serverHost); + + // Get an object using GetActiveObject and construct a reference. + static Reference *getActiveObject( + REFCLSID clsid, const Interface *pInterface); + + // Get an object using GetActiveObject and construct a reference. + static Reference *getActiveObject(const char *progId); + + // Get an object using CoGetObject and construct a reference. + static Reference *getObject(const char *displayName); + + // Get raw interface pointer. + IUnknown *unknown () const + { return m_pUnknown; } + + // If the object implements IDispatch, return an IDispatch pointer, + // else return 0. + IDispatch *dispatch(); + + // Get interface description. + const Interface *interfaceDesc () const + { return m_pInterface; } + + // Get class description. + const Class *classDesc(); + + // Invoke a method or property using IDispatch. + HRESULT invokeDispatch( + MEMBERID memberid, + WORD dispatchFlags, + const TypedArguments &arguments, + VARIANT *pResult); + + // Invoke a method or property. + HRESULT invoke( + MEMBERID memberid, + WORD dispatchFlags, + const TypedArguments &arguments, + VARIANT *pResult); + + // Create an event sink object and connect it to the connection point. + void advise( + Tcl_Interp *interp, + const Interface &eventInterfaceDesc, + TclObject servant); + + // Disconnect all connected event sink objects. + void unadvise(); + + // Compare for COM identity. + bool operator==(const Reference &rhs) const; +}; + +#endif diff --git a/src/RegistryKey.cpp b/src/RegistryKey.cpp new file mode 100644 index 0000000..4a9f3be --- /dev/null +++ b/src/RegistryKey.cpp @@ -0,0 +1,81 @@ +// $Id: RegistryKey.cpp,v 1.6 2001/11/28 16:10:57 cthuang Exp $ +#include "RegistryKey.h" + +void +RegistryKey::open (HKEY hkey, const std::string &subkeyName) +{ + LONG result = RegOpenKeyEx( + hkey, + subkeyName.c_str(), + 0, + KEY_READ, + &m_hkey); + if (result != ERROR_SUCCESS) { + throw std::runtime_error("cannot read registry key " + subkeyName); + } +} + +RegistryKey::RegistryKey (HKEY hkey, const std::string &subkeyName) +{ + open(hkey, subkeyName); +} + +RegistryKey::RegistryKey (const RegistryKey &key, + const std::string &subkeyName) +{ + open(key.m_hkey, subkeyName); +} + +RegistryKey::~RegistryKey () +{ + RegCloseKey(m_hkey); +} + +std::string +RegistryKey::subkeyName (int index) +{ + char name[256]; + DWORD size = sizeof(name); + FILETIME lastWriteTime; + + LONG result = RegEnumKeyEx( + m_hkey, + index, + name, + &size, + NULL, + NULL, + NULL, + &lastWriteTime); + if (result != ERROR_SUCCESS) { + throw std::runtime_error("RegEnumKeyEx"); + } + + return std::string(name); +} + +std::string +RegistryKey::value () +{ + return value(""); +} + +std::string +RegistryKey::value (const char *valueName) +{ + BYTE data[256]; + DWORD size = sizeof(data); + + LONG result = RegQueryValueEx( + m_hkey, + valueName, + NULL, + NULL, + data, + &size); + if (result != ERROR_SUCCESS) { + throw std::runtime_error("RegQueryValueEx"); + } + + return std::string(reinterpret_cast(data)); +} diff --git a/src/RegistryKey.h b/src/RegistryKey.h new file mode 100644 index 0000000..e1b06da --- /dev/null +++ b/src/RegistryKey.h @@ -0,0 +1,34 @@ +// $Id: RegistryKey.h,v 1.5 2001/11/28 16:10:57 cthuang Exp $ +#ifndef REGISTRYKEY_H +#define REGISTRYKEY_H + +#include +#include +#define WIN32_LEAN_AND_MEAN +#include + +// This class represents a registry key. + +class RegistryKey +{ + HKEY m_hkey; + + // Open registry key. + void open(HKEY hkey, const std::string &subkeyName); + +public: + RegistryKey(HKEY hkey, const std::string &subkeyName); + RegistryKey(const RegistryKey &key, const std::string &subkeyName); + ~RegistryKey(); + + // Get name of subkey under this key. + std::string subkeyName(int index); + + // Get data for default value under this key. + std::string value(); + + // Get data for value under this key. + std::string value(const char *valueName); +}; + +#endif diff --git a/src/Singleton.h b/src/Singleton.h new file mode 100644 index 0000000..7a6543a --- /dev/null +++ b/src/Singleton.h @@ -0,0 +1,59 @@ +// $Id: Singleton.h,v 1.9 2002/04/13 03:53:56 cthuang Exp $ +#ifndef SINGLETON_H +#define SINGLETON_H + +#include +#include "mutex.h" + +// This template class provides code to construct and destroy a singleton. + +template +class Singleton +{ + // singleton instance + static T *ms_pInstance; + + // used to synchronize construction of singleton instance + static Mutex ms_singletonMutex; + + // Delete the instance when exiting. + static void exitProc(ClientData clientData); + +public: + // Get instance. + static T &instance(); +}; + +template +T *Singleton::ms_pInstance = 0; + +template +Mutex Singleton::ms_singletonMutex; + +template +void +Singleton::exitProc (ClientData clientData) +{ + delete reinterpret_cast(clientData); +} + +template +T & +Singleton::instance () +{ + if (ms_pInstance == 0) { + LOCK_MUTEX(ms_singletonMutex) + if (ms_pInstance == 0) { + ms_pInstance = new T; + + // Install an exit handler to destroy the instance when Tcl exits + // instead of depending on the destruction of a static C++ object + // because the Tcl library may have been finalized before the + // destructor is called. + Tcl_CreateExitHandler(exitProc, ms_pInstance); + } + } + return *ms_pInstance; +} + +#endif diff --git a/src/SupportErrorInfo.cpp b/src/SupportErrorInfo.cpp new file mode 100644 index 0000000..e2dd645 --- /dev/null +++ b/src/SupportErrorInfo.cpp @@ -0,0 +1,27 @@ +// $Id: SupportErrorInfo.cpp,v 1.3 2001/07/17 02:24:08 cthuang Exp $ +#include "ComObject.h" +#include "SupportErrorInfo.h" + +STDMETHODIMP +SupportErrorInfo::QueryInterface (REFIID iid, void **ppv) +{ + return m_object.queryInterface(iid, ppv); +} + +STDMETHODIMP_(ULONG) +SupportErrorInfo::AddRef () +{ + return m_object.addRef(); +} + +STDMETHODIMP_(ULONG) +SupportErrorInfo::Release () +{ + return m_object.release(); +} + +STDMETHODIMP +SupportErrorInfo::InterfaceSupportsErrorInfo (REFIID iid) +{ + return m_object.implemented(iid); +} diff --git a/src/SupportErrorInfo.h b/src/SupportErrorInfo.h new file mode 100644 index 0000000..40d94b5 --- /dev/null +++ b/src/SupportErrorInfo.h @@ -0,0 +1,30 @@ +// $Id: SupportErrorInfo.h,v 1.3 2001/07/17 02:24:08 cthuang Exp $ +#ifndef SUPPORTERRORINFO_H +#define SUPPORTERRORINFO_H + +#include +#include "tcomApi.h" + +class TCOM_API ComObject; + +// This class implements ISupportErrorInfo. + +class SupportErrorInfo: public ISupportErrorInfo +{ + ComObject &m_object; + +public: + SupportErrorInfo (ComObject &object): + m_object(object) + { } + + // IUnknown implementation + STDMETHODIMP QueryInterface(REFIID riid, void **ppvObj); + STDMETHODIMP_(ULONG) AddRef(); + STDMETHODIMP_(ULONG) Release(); + + // ISupportErrorInfo implementation + STDMETHODIMP InterfaceSupportsErrorInfo(REFIID riid); +}; + +#endif diff --git a/src/TclInterp.cpp b/src/TclInterp.cpp new file mode 100644 index 0000000..0a2f93a --- /dev/null +++ b/src/TclInterp.cpp @@ -0,0 +1,124 @@ +// $Id: TclInterp.cpp,v 1.12 2002/04/13 03:53:56 cthuang Exp $ +#include +#include "RegistryKey.h" +#include "TclObject.h" +#include "TclInterp.h" + +TclInterp::TclInterp (): + m_hmodTcl(NULL), + m_interp(0) +{ } + +void +TclInterp::terminate () +{ + if (m_interp != 0) { + Tcl_DeleteInterp(m_interp); + } + + if (m_hmodTcl != NULL) { + FreeLibrary(m_hmodTcl); + } +} + +void +TclInterp::initialize (const std::string &dllPath) +{ + if (m_interp == 0) { + doInitialize(dllPath); + } +} + +// Load the Tcl DLL. First try to load from the given path. If that +// fails, look for the Tcl DLL path in the registry and try loading it. + +static HINSTANCE +loadTclLibrary (const std::string &firstDllPath, std::string &foundDllPath) +{ + if (!firstDllPath.empty()) { + _bstr_t path(firstDllPath.c_str()); + HINSTANCE hmod = LoadLibrary(path); + if (hmod != NULL) { + foundDllPath = firstDllPath; + return hmod; + } + } + + std::string activeTclKeyName("SOFTWARE\\ActiveState\\ActiveTcl"); + RegistryKey activeTclKey(HKEY_LOCAL_MACHINE, activeTclKeyName); + std::string currentVersion = activeTclKey.value("CurrentVersion"); + + std::istringstream iss(currentVersion); + int major, minor; + char dot; + iss >> major >> dot >> minor; + + std::string versionKeyName(activeTclKeyName); + versionKeyName += "\\"; + versionKeyName += currentVersion; + RegistryKey versionKey(HKEY_LOCAL_MACHINE, versionKeyName); + + std::ostringstream oss; + oss << versionKey.value() << "\\bin\\tcl" << major << minor << ".dll"; + std::string dllPath(oss.str()); + + _bstr_t path(dllPath.c_str()); + HINSTANCE hmod = LoadLibrary(path); + if (hmod != NULL) { + foundDllPath = dllPath; + } + return hmod; +} + +void +TclInterp::doInitialize (const std::string &firstDllPath) +{ + // Load Tcl library. + std::string dllPath; + m_hmodTcl = loadTclLibrary(firstDllPath, dllPath); + if (m_hmodTcl == NULL) { + throw std::runtime_error("LoadLibrary"); + } + + // Get address of Tcl_CreateInterp function. + typedef Tcl_Interp *(*CreateInterpFunc)(); + CreateInterpFunc createInterp = reinterpret_cast( + GetProcAddress(m_hmodTcl, "Tcl_CreateInterp")); + if (createInterp == NULL) { + throw std::runtime_error("GetProcAddress Tcl_CreateInterp"); + } + + // Create Tcl interpreter. + m_interp = createInterp(); + if (Tcl_InitStubs(m_interp, "8.1", 0) == NULL) { + throw std::runtime_error("Tcl_InitStubs"); + } + + Tcl_FindExecutable(dllPath.c_str()); + + // Find and source Tcl initialization script. + if (Tcl_Init(m_interp) != TCL_OK) { + throw std::runtime_error(Tcl_GetStringResult(m_interp)); + } +} + +int +TclInterp::eval (const std::string &script) +{ + return Tcl_EvalEx( + m_interp, + const_cast(script.data()), + script.size(), + TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL); +} + +int +TclInterp::eval (TclObject script, TclObject *pResult) +{ + int completionCode = Tcl_EvalObjEx( + m_interp, script, TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL); + if (pResult != 0) { + *pResult = Tcl_GetObjResult(m_interp); + } + return completionCode; +} diff --git a/src/TclInterp.h b/src/TclInterp.h new file mode 100644 index 0000000..bbfa522 --- /dev/null +++ b/src/TclInterp.h @@ -0,0 +1,50 @@ +// $Id: TclInterp.h,v 1.8 2002/04/13 03:53:56 cthuang Exp $ +#ifndef TCLINTERP_H +#define TCLINTERP_H + +#include +#include + +class TclObject; + +// This class provides access to a Tcl interpreter loaded from a DLL. + +class TclInterp +{ + HINSTANCE m_hmodTcl; + Tcl_Interp *m_interp; + + // Load and initialize interpreter. + void doInitialize(const std::string &dllPath); + + // Do not allow others to copy instances of this class. + TclInterp(const TclInterp &); // not implemented + void operator=(const TclInterp &); // not implemented + +public: + TclInterp(); + + // Load Tcl DLL and create interpreter. + void initialize(const std::string &dllPath); + + // Delete interpreter and unload Tcl DLL. + void terminate(); + + // Evaluate script. + int eval(const std::string &script); + int eval(TclObject script, TclObject *pResult=0); + + // Get interpreter result as a string. + const char *resultString() const + { return Tcl_GetStringResult(m_interp); } + +#if 0 + // Get variable value. + int getVariable(const char *name, TclObject *pValue) const; + + // Set variable value. + int setVariable(const char *name, TclObject value); +#endif +}; + +#endif diff --git a/src/TclModule.cpp b/src/TclModule.cpp new file mode 100644 index 0000000..3a4f05c --- /dev/null +++ b/src/TclModule.cpp @@ -0,0 +1,42 @@ +// $Id: TclModule.cpp,v 1.5 2002/04/13 03:53:56 cthuang Exp $ +#pragma warning(disable: 4786) +#include "TclObject.h" +#include "TclModule.h" +#include "RegistryKey.h" + +int +TclModule::registerFactoryByScript (const std::string &clsid) +{ + // Get registry key containing initialization data. + std::string subkeyName("CLSID\\"); + subkeyName += clsid; + subkeyName += "\\tcom"; + RegistryKey extensionKey(HKEY_CLASSES_ROOT, subkeyName); + + // Initialize Tcl interpreter. + std::string tclDllPath; + try { + tclDllPath = extensionKey.value("TclDLL"); + } + catch (std::runtime_error &) + { } + + m_interp.initialize(tclDllPath); + + // Execute Tcl script which should register a class factory. + std::string script = extensionKey.value("Script"); + int completionCode = m_interp.eval(script); + if (completionCode != TCL_OK) { + const char *errMsg = m_interp.resultString(); + MessageBox(NULL, errMsg, "tcom Server Error", MB_OK); + } + + return completionCode; +} + +void +TclModule::terminate () +{ + revokeFactories(); + m_interp.terminate(); +} diff --git a/src/TclModule.h b/src/TclModule.h new file mode 100644 index 0000000..af95d6b --- /dev/null +++ b/src/TclModule.h @@ -0,0 +1,29 @@ +// $Id: TclModule.h,v 1.4 2002/04/13 03:53:56 cthuang Exp $ +#ifndef TCLMODULE_H +#define TCLMODULE_H + +#include "ComModule.h" +#include "TclInterp.h" + +// This is a COM module used to implement COM objects in Tcl. + +class TclModule: public ComModule +{ + TclInterp m_interp; + +protected: + TclModule () + { } + +public: + // Register a class factory by executing a Tcl script associated with + // its CLSID. It's expected the Tcl script will register a class factory + // using the "::tcom::object registerfactory" command. + // Returns a Tcl completion code. + int registerFactoryByScript(const std::string &clsid); + + // Shut down server. + void terminate(); +}; + +#endif diff --git a/src/TclObject.cpp b/src/TclObject.cpp new file mode 100644 index 0000000..dc164f7 --- /dev/null +++ b/src/TclObject.cpp @@ -0,0 +1,610 @@ +// $Id: TclObject.cpp,v 1.29 2002/05/31 04:03:06 cthuang Exp $ +#include "TclObject.h" +#ifdef WIN32 +#include "Extension.h" +#include "Reference.h" +#endif + +Tcl_ObjType *TclTypes::ms_pBooleanType; +Tcl_ObjType *TclTypes::ms_pDoubleType; +Tcl_ObjType *TclTypes::ms_pIntType; +Tcl_ObjType *TclTypes::ms_pListType; +#if TCL_MINOR_VERSION >= 1 +Tcl_ObjType *TclTypes::ms_pByteArrayType; +#endif + +void +TclTypes::initialize () +{ + // Don't worry about multiple threads initializing this data because they + // should all produce the same result anyway. + ms_pBooleanType = Tcl_GetObjType("boolean"); + ms_pDoubleType = Tcl_GetObjType("double"); + ms_pIntType = Tcl_GetObjType("int"); + ms_pListType = Tcl_GetObjType("list"); +#if TCL_MINOR_VERSION >= 1 + ms_pByteArrayType = Tcl_GetObjType("bytearray"); +#endif +} + + +TclObject::TclObject (): + m_pObj(Tcl_NewObj()) +{ Tcl_IncrRefCount(m_pObj); } + +TclObject::TclObject (const TclObject &rhs): + m_pObj(rhs.m_pObj) +{ Tcl_IncrRefCount(m_pObj); } + +TclObject::TclObject (Tcl_Obj *pObj): + m_pObj(pObj) +{ Tcl_IncrRefCount(m_pObj); } + +TclObject::TclObject (const char *src, int len): + m_pObj(Tcl_NewStringObj(const_cast(src), len)) +{ Tcl_IncrRefCount(m_pObj); } + +#if TCL_MINOR_VERSION >= 2 +TclObject::TclObject (const wchar_t *src, int len): + m_pObj(Tcl_NewUnicodeObj( + const_cast(reinterpret_cast(src)), + len)) +{ Tcl_IncrRefCount(m_pObj); } + +static Tcl_Obj * +newUnicodeObj (const Tcl_UniChar *pWide, int length) +{ + if (pWide == 0) { + return Tcl_NewObj(); + } + return Tcl_NewUnicodeObj(const_cast(pWide), length); +} +#endif + +TclObject::TclObject (const std::string &s): + m_pObj(Tcl_NewStringObj(const_cast(s.data()), s.size())) +{ Tcl_IncrRefCount(m_pObj); } + +TclObject::TclObject (bool value): + m_pObj(Tcl_NewBooleanObj(static_cast(value))) +{ Tcl_IncrRefCount(m_pObj); } + +TclObject::TclObject (int value): + m_pObj(Tcl_NewIntObj(value)) +{ Tcl_IncrRefCount(m_pObj); } + +TclObject::TclObject (long value): + m_pObj(Tcl_NewLongObj(value)) +{ Tcl_IncrRefCount(m_pObj); } + +TclObject::TclObject (double value): + m_pObj(Tcl_NewDoubleObj(value)) +{ Tcl_IncrRefCount(m_pObj); } + +TclObject::TclObject (int objc, Tcl_Obj *CONST objv[]): + m_pObj(Tcl_NewListObj(objc, objv)) +{ Tcl_IncrRefCount(m_pObj); } + +TclObject::~TclObject () +{ Tcl_DecrRefCount(m_pObj); } + +TclObject & +TclObject::operator= (const TclObject &rhs) +{ + Tcl_IncrRefCount(rhs.m_pObj); + Tcl_DecrRefCount(m_pObj); + m_pObj = rhs.m_pObj; + return *this; +} + +TclObject & +TclObject::operator= (Tcl_Obj *pObj) +{ + Tcl_IncrRefCount(pObj); + Tcl_DecrRefCount(m_pObj); + m_pObj = pObj; + return *this; +} + +bool +TclObject::getBool () const +{ + int value; + Tcl_GetBooleanFromObj(0, m_pObj, &value); + return value != 0; +} + +int +TclObject::getInt () const +{ + int value; + Tcl_GetIntFromObj(0, m_pObj, &value); + return value; +} + +long +TclObject::getLong () const +{ + long value; + Tcl_GetLongFromObj(0, m_pObj, &value); + return value; +} + +double +TclObject::getDouble () const +{ + double value; + Tcl_GetDoubleFromObj(0, m_pObj, &value); + return value; +} + +TclObject & +TclObject::lappend (Tcl_Obj *pElement) +{ + if (Tcl_IsShared(m_pObj)) { + Tcl_DecrRefCount(m_pObj); + m_pObj = Tcl_DuplicateObj(m_pObj); + Tcl_IncrRefCount(m_pObj); + } + Tcl_ListObjAppendElement(NULL, m_pObj, pElement); + // TODO: Should check for error result if conversion to list failed. + return *this; +} + +#ifdef WIN32 + +TclObject::TclObject (VARIANT *pSrc, const Type &type, Tcl_Interp *interp) +{ + HRESULT hr; + + if (V_VT(pSrc) & VT_ARRAY) { + // We can handle only one-dimensional arrays. + SAFEARRAY *psa = V_ARRAY(pSrc); + if (SafeArrayGetDim(psa) != 1) { + _com_issue_error(E_INVALIDARG); + } + + // Get index range. + long lowerBound; + hr = SafeArrayGetLBound(psa, 1, &lowerBound); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + long upperBound; + hr = SafeArrayGetUBound(psa, 1, &upperBound); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + // Get element type. + VARTYPE vt = V_VT(pSrc) & VT_TYPEMASK; + + switch (vt) { + case VT_UNKNOWN: + case VT_DISPATCH: + // Convert array of IUnknown to Tcl list of interface pointer + // handles. + { + IUnknown **pData; + hr = SafeArrayAccessData( + psa, reinterpret_cast(&pData)); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + m_pObj = Tcl_NewListObj(0, 0); + for (long i = lowerBound; i <= upperBound; ++i) { + Tcl_Obj *pElement = + Extension::referenceHandles.newObj( + interp, Reference::newReference(pData[i])); + Tcl_ListObjAppendElement(interp, m_pObj, pElement); + } + + hr = SafeArrayUnaccessData(psa); + if (FAILED(hr)) { + _com_issue_error(hr); + } + } + break; + + case VT_UI1: + { + unsigned char *pData; + hr = SafeArrayAccessData( + psa, reinterpret_cast(&pData)); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + long length = upperBound - lowerBound + 1; + m_pObj = +#if TCL_MINOR_VERSION >= 1 + // Convert array of bytes to Tcl byte array. + Tcl_NewByteArrayObj(pData, length); +#else + // Convert array of bytes to Tcl string. + Tcl_NewStringObj(reinterpret_cast(pData), length); +#endif + + hr = SafeArrayUnaccessData(psa); + if (FAILED(hr)) { + _com_issue_error(hr); + } + } + break; + + default: + // Convert array of other types to Tcl list of objects. + { + m_pObj = Tcl_NewListObj(0, 0); + for (long i = lowerBound; i <= upperBound; ++i) { + _variant_t elementVar; + + if (vt == VT_VARIANT) { + hr = SafeArrayGetElement(psa, &i, &elementVar); + } else { + // I hope the element can be contained in a VARIANT. + V_VT(&elementVar) = vt; + hr = SafeArrayGetElement( + psa, &i, &elementVar.punkVal); + } + if (FAILED(hr)) { + _com_issue_error(hr); + } + + TclObject element(&elementVar, type, interp); + Tcl_ListObjAppendElement(interp, m_pObj, element); + } + } + } + + } else { + switch (V_VT(pSrc)) { + case VT_BOOL: + m_pObj = Tcl_NewBooleanObj(V_BOOL(pSrc)); + break; + + case VT_I1: + case VT_UI1: + m_pObj = Tcl_NewLongObj(V_I1(pSrc)); + break; + + case VT_I2: + case VT_UI2: + m_pObj = Tcl_NewLongObj(V_I2(pSrc)); + break; + + case VT_I4: + case VT_UI4: + case VT_INT: + case VT_UINT: + m_pObj = Tcl_NewLongObj(V_I4(pSrc)); + break; + + case VT_R4: + m_pObj = Tcl_NewDoubleObj(V_R4(pSrc)); + break; + + case VT_DATE: + case VT_R8: + m_pObj = Tcl_NewDoubleObj(V_R8(pSrc)); + break; + + case VT_DISPATCH: + { + const Interface *pInterface = + InterfaceManager::instance().find(type.iid()); + m_pObj = Extension::referenceHandles.newObj( + interp, + Reference::newReference(V_DISPATCH(pSrc), pInterface)); + } + break; + + case VT_UNKNOWN: + { + const Interface *pInterface = + InterfaceManager::instance().find(type.iid()); + m_pObj = Extension::referenceHandles.newObj( + interp, + Reference::newReference(V_UNKNOWN(pSrc), pInterface)); + } + break; + + case VT_NULL: + m_pObj = Tcl_NewObj(); + break; + + case VT_LPSTR: + m_pObj = Tcl_NewStringObj(V_I1REF(pSrc), -1); + break; + + case VT_LPWSTR: + { +#if TCL_MINOR_VERSION >= 2 + // Uses Unicode function introduced in Tcl 8.2. + m_pObj = newUnicodeObj(V_UI2REF(pSrc), -1); +#else + const wchar_t *pWide = V_UI2REF(pSrc); + _bstr_t str(pWide); + m_pObj = Tcl_NewStringObj(str, -1); +#endif + } + break; + + default: + if (V_VT(pSrc) == VT_USERDEFINED && type.name() == "GUID") { + Uuid uuid(*static_cast(V_BYREF(pSrc))); + m_pObj = Tcl_NewStringObj( + const_cast(uuid.toString().c_str()), -1); + } else { + _bstr_t str(pSrc); +#if TCL_MINOR_VERSION >= 2 + // Uses Unicode function introduced in Tcl 8.2. + wchar_t *pWide = str; + m_pObj = newUnicodeObj( + reinterpret_cast(pWide), str.length()); +#else + m_pObj = Tcl_NewStringObj(str, -1); +#endif + } + } + } + + Tcl_IncrRefCount(m_pObj); +} + +BSTR +TclObject::getBSTR () const +{ +#if TCL_MINOR_VERSION >= 2 + // Uses Unicode function introduced in Tcl 8.2. + return SysAllocString(getUnicode()); +#else + _bstr_t str(c_str()); + return SysAllocString(str); +#endif +} + +void +TclObject::toVariant (VARIANT *pDest, + const Type &type, + Tcl_Interp *interp, + bool addRef) +{ + VariantClear(pDest); + VARTYPE vt = type.vartype(); + + Reference *pReference = Extension::referenceHandles.find(interp, m_pObj); + if (pReference != 0) { + // Convert interface pointer handle to interface pointer. + if (addRef) { + // Must increment reference count of interface pointers returned + // from methods. + pReference->unknown()->AddRef(); + } + + IDispatch *pDispatch = pReference->dispatch(); + if (pDispatch != 0) { + V_VT(pDest) = VT_DISPATCH; + V_DISPATCH(pDest) = pDispatch; + } else { + V_VT(pDest) = VT_UNKNOWN; + V_UNKNOWN(pDest) = pReference->unknown(); + } + + } else if (m_pObj->typePtr == &Extension::unknownPointerType) { + // Convert to interface pointer. + IUnknown *pUnknown = static_cast( + m_pObj->internalRep.otherValuePtr); + if (addRef) { + // Must increment reference count of interface pointers returned + // from methods. + pUnknown->AddRef(); + } + V_VT(pDest) = VT_UNKNOWN; + V_UNKNOWN(pDest) = pUnknown; + + } else if (vt == VT_SAFEARRAY) { + // Convert Tcl list to SAFEARRAY. + int numElements; + Tcl_Obj **pElements; + if (Tcl_ListObjGetElements(interp, m_pObj, &numElements, &pElements) + != TCL_OK) { + _com_issue_error(E_INVALIDARG); + } + + const Type &elementType = type.elementType(); + SAFEARRAY *psa = + SafeArrayCreateVector(elementType.vartype(), 0, numElements); + if (psa == 0) { + _com_issue_error(E_OUTOFMEMORY); + } + + void *pData; + HRESULT hr; + hr = SafeArrayAccessData(psa, &pData); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + for (int i = 0; i < numElements; ++i) { + TclObject value(pElements[i]); + + switch (elementType.vartype()) { + case VT_BOOL: + static_cast(pData)[i] = + value.getBool() ? VARIANT_TRUE : VARIANT_FALSE; + break; + + case VT_R4: + static_cast(pData)[i] = + static_cast(value.getDouble()); + break; + + case VT_R8: + static_cast(pData)[i] = value.getDouble(); + break; + + case VT_BSTR: + static_cast(pData)[i] = value.getBSTR(); + break; + + case VT_VARIANT: + { + VARIANT *pDest = static_cast(pData) + i; + VariantInit(pDest); + value.toVariant(pDest, elementType, interp); + } + break; + + default: + static_cast(pData)[i] = value.getLong(); + } + } + + hr = SafeArrayUnaccessData(psa); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + V_VT(pDest) = VT_ARRAY | elementType.vartype(); + V_ARRAY(pDest) = psa; + + } else if (m_pObj->typePtr == TclTypes::listType()) { + // Convert Tcl list to array of VARIANT. + int numElements; + Tcl_Obj **pElements; + if (Tcl_ListObjGetElements(interp, m_pObj, &numElements, &pElements) + != TCL_OK) { + _com_issue_error(E_INVALIDARG); + } + + SAFEARRAY *psa = SafeArrayCreateVector(VT_VARIANT, 0, numElements); + if (psa == 0) { + _com_issue_error(E_OUTOFMEMORY); + } + + VARIANT *pData; + HRESULT hr; + hr = SafeArrayAccessData(psa, reinterpret_cast(&pData)); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + for (int i = 0; i < numElements; ++i) { + TclObject value(pElements[i]); + VariantInit(&pData[i]); + value.toVariant(&pData[i], Type::variant(), interp, addRef); + } + + hr = SafeArrayUnaccessData(psa); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + V_VT(pDest) = VT_ARRAY | VT_VARIANT; + V_ARRAY(pDest) = psa; + +#if TCL_MINOR_VERSION >= 1 + } else if (m_pObj->typePtr == TclTypes::byteArrayType()) { + // Convert Tcl byte array to array of bytes. + int length; + unsigned char *pBytes = Tcl_GetByteArrayFromObj(m_pObj, &length); + + SAFEARRAY *psa = SafeArrayCreateVector(VT_UI1, 0, length); + if (psa == 0) { + _com_issue_error(E_OUTOFMEMORY); + } + + unsigned char *pDestData; + HRESULT hr; + hr = SafeArrayAccessData( + psa, reinterpret_cast(&pDestData)); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + memcpy(pDestData, pBytes, length); + + hr = SafeArrayUnaccessData(psa); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + V_VT(pDest) = VT_ARRAY | VT_UI1; + V_ARRAY(pDest) = psa; +#endif + + } else if (m_pObj->typePtr == &Extension::naType) { + // This variant indicates a missing optional argument. + VariantCopy(pDest, &vtMissing); + + } else if (m_pObj->typePtr == &Extension::nullType) { + V_VT(pDest) = VT_NULL; + + } else if (m_pObj->typePtr == TclTypes::intType()) { + long value; + if (Tcl_GetLongFromObj(interp, m_pObj, &value) != TCL_OK) { + value = 0; + } + V_VT(pDest) = VT_I4; + V_I4(pDest) = value; + + if (vt != VT_VARIANT && vt != VT_USERDEFINED) { + VariantChangeType(pDest, pDest, 0, vt); + } + + } else if (m_pObj->typePtr == TclTypes::doubleType()) { + double value; + if (Tcl_GetDoubleFromObj(interp, m_pObj, &value) != TCL_OK) { + value = 0.0; + } + V_VT(pDest) = VT_R8; + V_R8(pDest) = value; + + if (vt != VT_VARIANT && vt != VT_USERDEFINED) { + VariantChangeType(pDest, pDest, 0, vt); + } + + } else if (m_pObj->typePtr == TclTypes::booleanType()) { + int value; + if (Tcl_GetBooleanFromObj(interp, m_pObj, &value) != TCL_OK) { + value = 0; + } + V_VT(pDest) = VT_BOOL; + V_BOOL(pDest) = (value != 0) ? VARIANT_TRUE : VARIANT_FALSE; + + if (vt != VT_VARIANT && vt != VT_USERDEFINED) { + VariantChangeType(pDest, pDest, 0, vt); + } + + } else if (vt == VT_BOOL) { + V_VT(pDest) = VT_BOOL; + V_BOOL(pDest) = getBool() ? VARIANT_TRUE : VARIANT_FALSE; + + } else { +#if TCL_MINOR_VERSION >= 2 + // Uses Unicode function introduced in Tcl 8.2. + const wchar_t *pStringRep = + reinterpret_cast(Tcl_GetUnicode(m_pObj)); +#else + const char *pStringRep = Tcl_GetStringFromObj(m_pObj, 0); +#endif + _variant_t var(pStringRep); + + // If trying to convert from a string to a date, + // we need to convert to a double (VT_R8) first. + if (vt == VT_DATE) { + var.ChangeType(VT_R8); + } + + // Try to convert from a string representation. + if (vt != VT_VARIANT && vt != VT_USERDEFINED && vt != VT_LPWSTR) { + var.ChangeType(vt); + } + VariantCopy(pDest, &var); + } +} + +#endif diff --git a/src/TclObject.h b/src/TclObject.h new file mode 100644 index 0000000..9a71502 --- /dev/null +++ b/src/TclObject.h @@ -0,0 +1,123 @@ +// $Id: TclObject.h,v 1.12 2002/04/12 02:55:28 cthuang Exp $ +#ifndef TCLOBJECT_H +#define TCLOBJECT_H + +#ifdef WIN32 +#include "TypeInfo.h" +#endif +#include +#include +#include "tcomApi.h" + +// This class provides access to Tcl's built-in internal representation types. + +class TclTypes +{ + static Tcl_ObjType *ms_pBooleanType; + static Tcl_ObjType *ms_pDoubleType; + static Tcl_ObjType *ms_pIntType; + static Tcl_ObjType *ms_pListType; + +public: + static void initialize(); + + static Tcl_ObjType *booleanType () + { return ms_pBooleanType; } + + static Tcl_ObjType *doubleType () + { return ms_pDoubleType; } + + static Tcl_ObjType *intType () + { return ms_pIntType; } + + static Tcl_ObjType *listType () + { return ms_pListType; } + +#if TCL_MINOR_VERSION >= 1 +private: + static Tcl_ObjType *ms_pByteArrayType; + +public: + static Tcl_ObjType *byteArrayType () + { return ms_pByteArrayType; } +#endif +}; + +// This class wraps a Tcl_Obj pointer to provide copy and value semantics by +// automatically incrementing and decrementing its reference count. + +class TCOM_API TclObject +{ + Tcl_Obj *m_pObj; + +public: + TclObject(); + TclObject(const TclObject &rhs); + TclObject(Tcl_Obj *pObj); + TclObject(const char *src, int len = -1); + TclObject(const std::string &s); + TclObject(bool value); + TclObject(int value); + TclObject(long value); + TclObject(double value); + TclObject(int objc, Tcl_Obj *CONST objv[]); + ~TclObject(); + + TclObject &operator=(const TclObject &rhs); + TclObject &operator=(Tcl_Obj *pObj); + + // Get raw object pointer. + operator Tcl_Obj * () const + { return const_cast(m_pObj); } + + // Get UTF-8 string representation of the object. + const char *c_str () const + { return Tcl_GetStringFromObj(const_cast(m_pObj), 0); } + +#if TCL_MINOR_VERSION >= 2 + // Construct Unicode string value. + TclObject(const wchar_t *src, int len = -1); + + // Get Unicode string representation of the object. + const wchar_t *getUnicode() const + { return reinterpret_cast( + Tcl_GetUnicode(const_cast(m_pObj))); } +#endif + + // Convert object to bool and return value. + bool getBool() const; + + // Convert object to int and return value. + int getInt() const; + + // Convert object to long and return value. + long getLong() const; + + // Convert object to double and return value. + double getDouble() const; + + // Convert the object to a list if it's not already a list, + // and then append the element to the end of the list. + TclObject &lappend(Tcl_Obj *pElement); + +#ifdef WIN32 + // Construct Tcl object from VARIANT value. + TclObject( + VARIANT *pSrc, // VARIANT value to convert from + const Type &type, // expected type for interface pointers + Tcl_Interp *interp); + + // Convert Tcl object to VARIANT value. + void toVariant( + VARIANT *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; +#endif +}; + +#endif diff --git a/src/TclScript.cpp b/src/TclScript.cpp new file mode 100644 index 0000000..71954c6 --- /dev/null +++ b/src/TclScript.cpp @@ -0,0 +1,230 @@ +// $Id: TclScript.cpp,v 1.10 2002/07/14 18:42:57 cthuang Exp $ +#include "ActiveScriptError.h" +#include "Reference.h" +#include "TypeInfo.h" +#include "Extension.h" +#include "tclRunTime.h" + +#define NAMESPACE "::TclScriptEngine::" +#define ENGINE_PACKAGE_NAME "TclScript" +#define ENGINE_PACKAGE_VERSION "1.0" + +static int +outputdebugCmd ( + ClientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "message"); + return TCL_ERROR; + } + + Tcl_Obj *pMessage = objv[1]; + if (Tcl_IsShared(pMessage)) { + pMessage = Tcl_DuplicateObj(pMessage); + } + Tcl_IncrRefCount(pMessage); + Tcl_AppendToObj(pMessage, "\n", 1); + OutputDebugString(Tcl_GetStringFromObj(pMessage, 0)); + Tcl_DecrRefCount(pMessage); + return TCL_OK; +} + +static int +getnameditemCmd ( + ClientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc < 3 || objc > 4) { + Tcl_WrongNumArgs( + interp, 1, objv, "scriptSiteHandle itemName ?subItemName?"); + return TCL_ERROR; + } + + Reference *pRef = Extension::referenceHandles.find(interp, objv[1]); + if (pRef == 0) { + const char *arg = Tcl_GetStringFromObj(objv[1], 0); + Tcl_AppendResult(interp, "invalid handle ", arg, NULL); + return TCL_ERROR; + } + + try { + HRESULT hr; + + IActiveScriptSitePtr pScriptSite; + hr = pRef->unknown()->QueryInterface( + IID_IActiveScriptSite, reinterpret_cast(&pScriptSite)); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + TclObject itemName(objv[2]); + IUnknownPtr pUnknown; + hr = pScriptSite->GetItemInfo( + itemName.getUnicode(), SCRIPTINFO_IUNKNOWN, &pUnknown, 0); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + TclObject subItemName; + if (objc == 4) { + subItemName = objv[3]; + } + + int subItemNameLength; + Tcl_GetStringFromObj(subItemName, &subItemNameLength); + + Reference *pNewRef; + if (subItemNameLength == 0) { + pNewRef = Reference::newReference(pUnknown); + } else { + IDispatchPtr pDispatch; + hr = pUnknown->QueryInterface( + IID_IDispatch, reinterpret_cast(&pDispatch)); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + // Get the DISPID of the name. + wchar_t *wideSubItemName = const_cast( + subItemName.getUnicode()); + + DISPID dispid; + hr = pDispatch->GetIDsOfNames( + IID_NULL, + &wideSubItemName, + 1, + LOCALE_USER_DEFAULT, + &dispid); + if (FAILED(hr)) { + // If we didn't find the name, then return an empty Tcl result. + Tcl_ResetResult(interp); + return TCL_OK; + } + + // Try to get the property. + EXCEPINFO excepInfo; + memset(&excepInfo, 0, sizeof(excepInfo)); + UINT argErr = 0; + + _variant_t returnValue; + + DISPPARAMS dispParams; + dispParams.rgvarg = NULL; + dispParams.rgdispidNamedArgs = NULL; + dispParams.cArgs = 0; + dispParams.cNamedArgs = 0; + + hr = pDispatch->Invoke( + dispid, + IID_NULL, + LOCALE_USER_DEFAULT, + DISPATCH_PROPERTYGET, + &dispParams, + &returnValue, + &excepInfo, + &argErr); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + if (V_VT(&returnValue) != VT_DISPATCH) { + Tcl_AppendResult(interp, "sub item is not an IDispatch", NULL); + return TCL_ERROR; + } + + pNewRef = Reference::newReference(V_DISPATCH(&returnValue)); + } + + Tcl_SetObjResult( + interp, Extension::referenceHandles.newObj(interp, pNewRef)); + } + catch (_com_error &e) { + return Extension::setComErrorResult(interp, e, __FILE__, __LINE__); + } + + return TCL_OK; +} + +static int +activescripterrorCmd ( + ClientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc != 7) { + Tcl_WrongNumArgs( + interp, + 1, + objv, + "hresult source description lineNum charPos sourceLineText"); + return TCL_ERROR; + } + + TclObject hresult(objv[1]); + TclObject source(objv[2]); + TclObject description(objv[3]); + TclObject lineNumber(objv[4]); + TclObject characterPosition(objv[5]); + TclObject sourceLineText(objv[6]); + + try { + ActiveScriptError *pActiveScriptError = new ActiveScriptError( + hresult.getLong(), + source.c_str(), + description.c_str(), + lineNumber.getLong(), + characterPosition.getLong(), + sourceLineText.c_str()); + + Tcl_Obj *pResult = Tcl_NewObj(); + Tcl_InvalidateStringRep(pResult); + pResult->typePtr = &Extension::unknownPointerType; + pResult->internalRep.otherValuePtr = pActiveScriptError; + + Tcl_SetObjResult(interp, pResult); + } + catch (_com_error &e) { + return Extension::setComErrorResult(interp, e, __FILE__, __LINE__); + } + + return TCL_OK; +} + +extern "C" DLLEXPORT int +Tclscript_Init (Tcl_Interp *interp) +{ +#ifdef USE_TCL_STUBS + // Stubs were introduced in Tcl 8.1. + if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { + return TCL_ERROR; + } +#endif + + Tcl_CreateObjCommand( + interp, NAMESPACE "outputdebug", outputdebugCmd, 0, 0); + Tcl_CreateObjCommand( + interp, NAMESPACE "getnameditem", getnameditemCmd, 0, 0); + Tcl_CreateObjCommand( + interp, NAMESPACE "activescripterror", activescripterrorCmd, 0, 0); + + return Tcl_PkgProvide(interp, ENGINE_PACKAGE_NAME, ENGINE_PACKAGE_VERSION); +} + +extern "C" DLLEXPORT int +Tclscript_SafeInit (Tcl_Interp *interp) +{ +#ifdef USE_TCL_STUBS + // Stubs were introduced in Tcl 8.1. + if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { + return TCL_ERROR; + } +#endif + + return Tcl_PkgProvide(interp, ENGINE_PACKAGE_NAME, ENGINE_PACKAGE_VERSION); +} diff --git a/src/TclScript.dsp b/src/TclScript.dsp new file mode 100644 index 0000000..12f542d --- /dev/null +++ b/src/TclScript.dsp @@ -0,0 +1,125 @@ +# Microsoft Developer Studio Project File - Name="TclScript" - Package Owner=<4> +# Microsoft Developer Studio Generated Build File, Format Version 6.00 +# ** DO NOT EDIT ** + +# TARGTYPE "Win32 (x86) Dynamic-Link Library" 0x0102 + +CFG=TclScript - Win32 Debug +!MESSAGE This is not a valid makefile. To build this project using NMAKE, +!MESSAGE use the Export Makefile command and run +!MESSAGE +!MESSAGE NMAKE /f "TclScript.mak". +!MESSAGE +!MESSAGE You can specify a configuration when running NMAKE +!MESSAGE by defining the macro CFG on the command line. For example: +!MESSAGE +!MESSAGE NMAKE /f "TclScript.mak" CFG="TclScript - Win32 Debug" +!MESSAGE +!MESSAGE Possible choices for configuration are: +!MESSAGE +!MESSAGE "TclScript - Win32 Release" (based on "Win32 (x86) Dynamic-Link Library") +!MESSAGE "TclScript - Win32 Debug" (based on "Win32 (x86) Dynamic-Link Library") +!MESSAGE + +# Begin Project +# PROP AllowPerConfigDependencies 0 +# PROP Scc_ProjName "" +# PROP Scc_LocalPath "" +CPP=cl.exe +MTL=midl.exe +RSC=rc.exe + +!IF "$(CFG)" == "TclScript - Win32 Release" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 0 +# PROP BASE Output_Dir "TclScript___Win32_Release" +# PROP BASE Intermediate_Dir "TclScript___Win32_Release" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 0 +# PROP Output_Dir "TclScript_Release" +# PROP Intermediate_Dir "TclScript_Release" +# 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 BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32 +# ADD MTL /nologo /D "NDEBUG" /win32 +# SUBTRACT MTL /mktyplib203 +# ADD BASE RSC /l 0x409 /d "NDEBUG" +# ADD RSC /l 0x409 /d "NDEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /machine:I386 +# ADD LINK32 Release\tcom.lib rpcrt4.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /libpath:"\tcl\lib" + +!ELSEIF "$(CFG)" == "TclScript - Win32 Debug" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 1 +# PROP BASE Output_Dir "TclScript___Win32_Debug" +# PROP BASE Intermediate_Dir "TclScript___Win32_Debug" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 1 +# PROP Output_Dir "TclScript_Debug" +# PROP Intermediate_Dir "TclScript_Debug" +# 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 BASE MTL /nologo /D "_DEBUG" /mktyplib203 /win32 +# ADD MTL /nologo /D "_DEBUG" /win32 +# SUBTRACT MTL /mktyplib203 +# ADD BASE RSC /l 0x409 /d "_DEBUG" +# ADD RSC /l 0x409 /d "_DEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /pdbtype:sept +# ADD LINK32 Debug\tcom.lib rpcrt4.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /libpath:"\tcl\lib" + +!ENDIF + +# Begin Target + +# Name "TclScript - Win32 Release" +# Name "TclScript - Win32 Debug" +# Begin Group "Source Files" + +# PROP Default_Filter "cpp;c;cxx;rc;def;r;odl;idl;hpj;bat" +# Begin Source File + +SOURCE=.\ActiveScriptError.cpp +# End Source File +# Begin Source File + +SOURCE=.\TclScript.cpp +# End Source File +# Begin Source File + +SOURCE=.\TclScript.idl +# End Source File +# Begin Source File + +SOURCE=.\TclScriptVersion.rc +# End Source File +# End Group +# Begin Group "Header Files" + +# PROP Default_Filter "h;hpp;hxx;hm;inl" +# Begin Source File + +SOURCE=.\ActiveScriptError.h +# End Source File +# End Group +# Begin Group "Resource Files" + +# PROP Default_Filter "ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe" +# End Group +# End Target +# End Project diff --git a/src/TclScript.idl b/src/TclScript.idl new file mode 100644 index 0000000..1dbdf31 --- /dev/null +++ b/src/TclScript.idl @@ -0,0 +1,27 @@ +import "activscp.idl"; +import "objsafe.idl"; + +#if _MSC_VER >= 1300 +#define IActiveScriptParse IActiveScriptParse32 +#endif + +[ + uuid(0A0059B8-E0B0-11D2-942A-00C04F7040AC), + version(1.0), + helpstring("TclScript 1.0 Type Library") +] +library TclScript +{ + importlib("stdole32.tlb"); + + [ + uuid(0A0059C5-E0B0-11D2-942A-00C04F7040AD), + helpstring("Engine Class") + ] + coclass Engine + { + [default] interface IActiveScript; + interface IActiveScriptParse; + interface IObjectSafety; + }; +}; diff --git a/src/TclScriptVersion.rc b/src/TclScriptVersion.rc new file mode 100644 index 0000000..914a688 --- /dev/null +++ b/src/TclScriptVersion.rc @@ -0,0 +1,35 @@ +// $Id: TclScriptVersion.rc,v 1.3 2002/04/27 18:15:24 cthuang Exp $ +#include +#include "version.h" +#include "buildNumber.h" + +VS_VERSION_INFO VERSIONINFO + FILEVERSION PACKAGE_MAJOR_VERSION,PACKAGE_MINOR_VERSION,0,BUILD_NUMBER + PRODUCTVERSION PACKAGE_MAJOR_VERSION,PACKAGE_MINOR_VERSION,0,BUILD_NUMBER + FILEFLAGSMASK VS_FFI_FILEFLAGSMASK +#ifdef _DEBUG + FILEFLAGS VS_FF_DEBUG +#else + FILEFLAGS 0 +#endif + FILEOS VOS__WINDOWS32 + FILETYPE VFT_DLL + FILESUBTYPE VFT2_UNKNOWN +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040904b0" + BEGIN + VALUE "FileDescription", "Tcl script engine" + VALUE "FileVersion", PACKAGE_VERSION + VALUE "LegalCopyright", "Copyright 2002 by Chin Huang" + VALUE "OriginalFilename", "TclScript.dll" + VALUE "ProductName", "Tcl script engine" + VALUE "ProductVersion", PACKAGE_VERSION + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x409, 1200 + END +END diff --git a/src/ThreadLocalStorage.h b/src/ThreadLocalStorage.h new file mode 100644 index 0000000..71770d1 --- /dev/null +++ b/src/ThreadLocalStorage.h @@ -0,0 +1,64 @@ +// $Id: ThreadLocalStorage.h,v 1.1 2002/04/20 15:43:57 cthuang Exp $ +#ifndef THREADLOCALSTORAGE_H +#define THREADLOCALSTORAGE_H + +#include "mutex.h" + +// This factory creates an instance of type T for each calling thread. + +template +class ThreadLocalStorage +{ + // used to synchronize initialization of index + Mutex m_mutex; + + DWORD m_index; + bool m_initialized; + + // not implemented + ThreadLocalStorage(const ThreadLocalStorage &); + void operator=(const ThreadLocalStorage &); + +public: + ThreadLocalStorage(); + ~ThreadLocalStorage(); + + // Get instance specific to the calling thread. + T &instance() const; +}; + +template +ThreadLocalStorage::ThreadLocalStorage () +{ + LOCK_MUTEX(m_mutex) + + if (!m_initialized) { + m_index = TlsAlloc(); + m_initialized = true; + } +} + +template +ThreadLocalStorage::~ThreadLocalStorage () +{ + LOCK_MUTEX(m_mutex) + + if (m_initialized) { + TlsFree(m_index); + m_initialized = false; + } +} + +template +T & +ThreadLocalStorage::instance () const +{ + T *pValue = static_cast(TlsGetValue(m_index)); + if (pValue == 0) { + pValue = new T; + TlsSetValue(m_index, pValue); + } + return *pValue; +} + +#endif diff --git a/src/TypeInfo.cpp b/src/TypeInfo.cpp new file mode 100644 index 0000000..39b5fda --- /dev/null +++ b/src/TypeInfo.cpp @@ -0,0 +1,645 @@ +// $Id: TypeInfo.cpp,v 1.58 2002/04/20 06:11:32 cthuang Exp $ +#pragma warning(disable: 4786) +#include +#include +#include "Uuid.h" +#include "TypeInfo.h" + +std::string +getTypeInfoName (ITypeInfo *pTypeInfo, MEMBERID id) +{ + BSTR nameStr = 0; + HRESULT hResult = pTypeInfo->GetDocumentation( + id, &nameStr, NULL, NULL, NULL); + if (FAILED(hResult) || nameStr == 0) { + return std::string(); + } + _bstr_t wrapper(nameStr, false); + return std::string(wrapper); +} + + +struct VarTypeStringAssoc { + VARTYPE vt; + const char *name; +}; + +static VarTypeStringAssoc varTypeStringAssocs[] = { + { VT_EMPTY, "EMPTY" }, + { VT_NULL, "NULL" }, + { VT_I2, "I2" }, + { VT_I4, "I4" }, + { VT_R4, "R4" }, + { VT_R8, "R8" }, + { VT_CY, "CY" }, + { VT_DATE, "DATE" }, + { VT_BSTR, "BSTR" }, + { VT_DISPATCH, "DISPATCH" }, + { VT_ERROR, "ERROR" }, + { VT_BOOL, "BOOL" }, + { VT_VARIANT, "VARIANT" }, + { VT_UNKNOWN, "UNKNOWN" }, + { VT_DECIMAL, "DECIMAL" }, + { VT_RECORD, "RECORD" }, + { VT_I1, "I1" }, + { VT_UI1, "UI1" }, + { VT_UI2, "UI2" }, + { VT_UI4, "UI4" }, + { VT_INT, "INT" }, + { VT_UINT, "UINT" }, + { VT_VOID, "VOID" }, + { VT_LPSTR, "LPSTR" }, + { VT_LPWSTR, "LPWSTR" }, + { VT_ARRAY, "ARRAY" }, +}; + +// This class maps from a VARTYPE to a string representation. + +class VarTypeToStringMap: public std::map +{ +public: + VarTypeToStringMap(); +}; + +VarTypeToStringMap::VarTypeToStringMap () +{ + const int n = sizeof(varTypeStringAssocs) / sizeof(VarTypeStringAssoc); + for (int i = 0; i < n; ++i) { + const VarTypeStringAssoc &assoc = varTypeStringAssocs[i]; + insert(value_type(assoc.vt, assoc.name)); + } +} + +static VarTypeToStringMap varTypeToStringMap; + +// This class maps from a string representation to a VARTYPE. + +class StringToVarTypeMap: public std::map +{ +public: + StringToVarTypeMap(); +}; + +StringToVarTypeMap::StringToVarTypeMap () +{ + const int n = sizeof(varTypeStringAssocs) / sizeof(VarTypeStringAssoc); + for (int i = 0; i < n; ++i) { + const VarTypeStringAssoc &assoc = varTypeStringAssocs[i]; + insert(value_type(assoc.name, assoc.vt)); + } +} + +static StringToVarTypeMap stringToVarTypeMap; + +Type Type::ms_variant("VARIANT"); + +Type::Type (const ITypeInfoPtr &pTypeInfo, TYPEDESC &typeDesc): + m_pointerCount(0), + m_pElementType(0) +{ + UuidCreateNil(&m_iid); + readTypeDesc(pTypeInfo, typeDesc); +} + +Type::Type (const std::string &str): + m_pointerCount(0), + m_pElementType(0) +{ + UuidCreateNil(&m_iid); + + std::istringstream in(str); + std::string token; + while (in >> token) { + if (token[0] == '*') { + ++m_pointerCount; + } else { + StringToVarTypeMap::iterator p = stringToVarTypeMap.find(token); + if (p == stringToVarTypeMap.end()) { + m_vt = VT_USERDEFINED; + m_name = token; + } else { + m_vt = p->second; + } + } + } +} + +Type::Type (const Type &rhs): + m_name(rhs.m_name), + m_vt(rhs.m_vt), + m_iid(rhs.m_iid), + m_pointerCount(rhs.m_pointerCount), + m_pElementType(rhs.m_pElementType ? new Type(*rhs.m_pElementType) : 0) +{ } + +Type::~Type () +{ + delete m_pElementType; +} + +Type & +Type::operator= (const Type &rhs) +{ + m_name = rhs.m_name; + m_vt = rhs.m_vt; + m_iid = rhs.m_iid; + m_pointerCount = rhs.m_pointerCount; + + delete m_pElementType; + m_pElementType = rhs.m_pElementType ? new Type(*rhs.m_pElementType) : 0; + + return *this; +} + +std::string +Type::toString () const +{ + switch (m_vt) { + case VT_USERDEFINED: + return m_name; + + case VT_SAFEARRAY: + { + std::ostringstream out; + out << "SAFEARRAY(" << elementType().toString() << ")"; + return out.str(); + } + + default: + { + VarTypeToStringMap::iterator p = varTypeToStringMap.find(m_vt); + if (p != varTypeToStringMap.end()) { + return p->second; + } + + std::ostringstream out; + out << "vartype0x" << std::hex << m_vt; + return out.str(); + } + } +} + +void +Type::readTypeDesc (const ITypeInfoPtr &pTypeInfo, TYPEDESC &typeDesc) +{ + HRESULT hr; + + switch (typeDesc.vt) { + case VT_USERDEFINED: + { + // It's an alias. Expand the alias. + ITypeInfoPtr pRefTypeInfo; + hr = pTypeInfo->GetRefTypeInfo(typeDesc.hreftype, &pRefTypeInfo); + if (SUCCEEDED(hr)) { + if (m_name.empty()) { + m_name = getTypeInfoName(pRefTypeInfo); + } + + TypeAttr typeAttr(pRefTypeInfo); + if (typeAttr->typekind == TKIND_ALIAS) { + // Type expanded to another alias! + readTypeDesc(pRefTypeInfo, typeAttr->tdescAlias); + } else if (typeAttr->typekind == TKIND_ENUM) { + m_vt = VT_I4; + } else { + m_vt = typeDesc.vt; + m_iid = typeAttr->guid; + } + } + } + break; + + case VT_PTR: + // It's a pointer. Dereference and try to interpret with one less + // level of indirection. + ++m_pointerCount; + readTypeDesc(pTypeInfo, *typeDesc.lptdesc); + break; + + case VT_SAFEARRAY: + // It's a SAFEARRAY. Get the element type. + m_pElementType = new Type(pTypeInfo, *typeDesc.lptdesc); + m_vt = typeDesc.vt; + break; + + default: + m_vt = typeDesc.vt; + } +} + +Parameter::Parameter (const ITypeInfoPtr &pTypeInfo, + ELEMDESC &elemDesc, + const char *name): + m_flags(elemDesc.paramdesc.wParamFlags), + m_type(pTypeInfo, elemDesc.tdesc), + m_name(name) +{ + if (m_flags == 0) { + // No parameter passing flags are set. Assume it's an in parameter. + m_flags = PARAMFLAG_FIN; + } +} + +Parameter::Parameter (const std::string &modes, + const std::string &type, + const std::string &name): + m_flags(0), + m_type(type), + m_name(name) +{ + std::istringstream in(modes); + std::string token; + while (in >> token) { + if (token == "in") { + m_flags |= PARAMFLAG_FIN; + } else if (token == "out") { + m_flags |= PARAMFLAG_FOUT; + } + } +} + + +Method::Method (const ITypeInfoPtr &pTypeInfo, DISPID memberid, ELEMDESC &elemDesc): + m_memberid(memberid), + m_type(pTypeInfo, elemDesc.tdesc) +{ + // Get name. + BSTR nameBstr; + unsigned numNames; + HRESULT hr = pTypeInfo->GetNames( + memberid, + &nameBstr, + 1, + &numNames); + if (FAILED(hr)) { + // TODO: I should throw an exception here. + return; + } + + // Initialize name. + _bstr_t name(nameBstr, false); + m_name = std::string(name); +} + +Method::Method (const ITypeInfoPtr &pTypeInfo, FuncDesc &funcDesc): + m_memberid(funcDesc->memid), + m_type(pTypeInfo, funcDesc->elemdescFunc.tdesc), + m_invokeKind(funcDesc->invkind), + m_vtblIndex(funcDesc->oVft / 4), + m_vararg(funcDesc->cParamsOpt == -1) +{ + // Get method and parameter names. + BSTR *pNames = new BSTR[funcDesc->cParams + 1]; + unsigned numNames; + HRESULT hr = pTypeInfo->GetNames( + funcDesc->memid, + pNames, + funcDesc->cParams + 1, + &numNames); + if (FAILED(hr)) { + // TODO: I should throw an exception here. + delete[] pNames; + return; + } + + // Initialize method name. + _bstr_t methodName(pNames[0], false); + m_name = std::string(methodName); + + // Get parameter types. + for (unsigned i = 1; i < numNames; ++i) { + _bstr_t paramName(pNames[i], false); + Parameter parameter( + pTypeInfo, + funcDesc->lprgelemdescParam[i - 1], + paramName); + addParameter(parameter); + } + + // Some TKIND_INTERFACE methods specify a parameter is a return value + // with the PARAMFLAG_FRETVAL flag. Check if the last parameter is + // actually a return value. + if (m_type.vartype() == VT_HRESULT) { + m_type = Type("VOID"); + + if (m_parameters.size() > 0) { + Parameter last = m_parameters.back(); + if ((last.flags() & (PARAMFLAG_FOUT|PARAMFLAG_FRETVAL)) + == (PARAMFLAG_FOUT|PARAMFLAG_FRETVAL)) { + m_type = last.type(); + m_parameters.pop_back(); + } + } + } + + delete[] pNames; +} + +Method::Method (MEMBERID memberid, + const std::string &type, + const std::string &name, + INVOKEKIND invokeKind): + m_memberid(memberid), + m_type(type), + m_name(name), + m_invokeKind(invokeKind) +{ } + + +Property::Property (const ITypeInfoPtr &pTypeInfo, FuncDesc &funcDesc): + Method(pTypeInfo, funcDesc), + m_readOnly(true) +{ + initialize(); +} + +Property::Property (const ITypeInfoPtr &pTypeInfo, VarDesc &varDesc): + Method(pTypeInfo, varDesc->memid, varDesc->elemdescVar), + m_readOnly((varDesc->wVarFlags & VARFLAG_FREADONLY) != 0) +{ + initialize(); +} + +Property::Property (MEMBERID memberid, + const std::string &modes, + const std::string &type, + const std::string &name): + Method(memberid, type, name, INVOKE_PROPERTYGET), + m_readOnly(true) +{ + // Initialize readable/writable flags. + std::istringstream in(modes); + std::string token; + while (in >> token) { + if (token == "in") { + m_readOnly = false; + } + } +} + +void +Property::initialize () +{ + switch (invokeKind()) { + case INVOKE_PROPERTYPUT: + m_putDispatchFlag = DISPATCH_PROPERTYPUT; + break; + case INVOKE_PROPERTYPUTREF: + m_putDispatchFlag = DISPATCH_PROPERTYPUTREF; + break; + } +} + +void +Property::merge (const Property &property) +{ + // Set dispatch flag used for property put. + switch (property.invokeKind()) { + case INVOKE_PROPERTYPUT: + m_putDispatchFlag = DISPATCH_PROPERTYPUT; + break; + case INVOKE_PROPERTYPUTREF: + m_putDispatchFlag = DISPATCH_PROPERTYPUTREF; + break; + } + + // Set read only flag. + if (property.invokeKind() != INVOKE_PROPERTYGET) { + m_readOnly = false; + } + + // Set property value type. + if (property.type().vartype() != VT_VOID) { + type(property.type()); + } +} + + +std::string +Interface::iidString () const +{ + Uuid uuid(m_iid); + return uuid.toString(); +} + +void +Interface::addMethod (const Method &method) +{ + // Do we already have information on this method? + for (Methods::iterator p = m_methods.begin(); p != m_methods.end(); ++p) { + if (p->memberid() == method.memberid() + && p->vtblIndex() == method.vtblIndex()) { + return; + } + } + + // Add method description. + m_methods.push_back(method); +} + +void +Interface::addProperty (const Property &property) +{ + // Do we already have information on this property? + for (Properties::iterator p = m_properties.begin(); + p != m_properties.end(); ++p) { + if (p->memberid() == property.memberid()) { + p->merge(property); + return; + } + } + + // Add property description. + m_properties.push_back(property); +} + +void +Interface::readFunctions (const ITypeInfoPtr &pTypeInfo, TypeAttr &typeAttr) +{ + HRESULT hr; + + // Don't expose the IUnknown and IDispatch functions to the Tcl script + // because of potential dangers. + if (IsEqualIID(typeAttr->guid, IID_IUnknown) + || IsEqualIID(typeAttr->guid, IID_IDispatch)) { + return; + } + + // Get properties and methods from inherited interfaces. + for (int i = 0; i < typeAttr->cImplTypes; ++i) { + HREFTYPE hRefType; + hr = pTypeInfo->GetRefTypeOfImplType(i, &hRefType); + if (FAILED(hr)) { + break; + } + + ITypeInfoPtr pSuperTypeInfo; + hr = pTypeInfo->GetRefTypeInfo(hRefType, &pSuperTypeInfo); + if (FAILED(hr)) { + break; + } + TypeAttr superTypeAttr(pSuperTypeInfo); + readFunctions(pSuperTypeInfo, superTypeAttr); + } + + bool dual = (typeAttr->wTypeFlags & TYPEFLAG_FDUAL) != 0; + + // Get properties and methods of this interface. + for (int j = 0; j < typeAttr->cFuncs; ++j) { + FuncDesc funcDesc(pTypeInfo, j); + + if (dual && funcDesc->funckind == FUNC_DISPATCH + && funcDesc->oVft < 28) { + // Don't expose the IUnknown and IDispatch functions to the Tcl + // script because of potential dangers. + continue; + } + + Method method(pTypeInfo, funcDesc); + addMethod(method); + + if (funcDesc->invkind != INVOKE_FUNC) { + // This is a property get/set function. + Property property(pTypeInfo, funcDesc); + addProperty(property); + } + } + + // Some objects expose their properties as variable members. + for (int k = 0; k < typeAttr->cVars; ++k) { + VarDesc varDesc(pTypeInfo, k); + + if (varDesc->varkind == VAR_DISPATCH) { + Property property(pTypeInfo, varDesc); + addProperty(property); + } + } + + // Add missing parameter description to property put functions. + for (Methods::iterator pMethod = m_methods.begin(); + pMethod != m_methods.end(); ++pMethod) { + if (pMethod->invokeKind() == INVOKE_PROPERTYPUT + || pMethod->invokeKind() == INVOKE_PROPERTYPUTREF) { + const Property *pProperty = findProperty(pMethod->name().c_str()); + if (pProperty != 0) { + Parameter parameter( + PARAMFLAG_FIN, + pProperty->type(), + "propertyValue"); + pMethod->addParameter(parameter); + } + } + } +} + +void +Interface::readTypeInfo (const ITypeInfoPtr &pTypeInfo) +{ + m_name = getTypeInfoName(pTypeInfo); + + TypeAttr typeAttr(pTypeInfo); + m_iid = typeAttr->guid; + m_dispatchOnly = (typeAttr->typekind == TKIND_DISPATCH) && + ((typeAttr->wTypeFlags & TYPEFLAG_FDUAL) == 0); + m_dispatchable = (typeAttr->wTypeFlags & TYPEFLAG_FDISPATCHABLE) != 0; + + m_methods.reserve(typeAttr->cFuncs); + m_properties.reserve(typeAttr->cFuncs); + readFunctions(pTypeInfo, typeAttr); +} + +const Method * +Interface::findMethod (const char *name) const +{ + for (Methods::const_iterator p = m_methods.begin(); + p != m_methods.end(); ++p) { + if (p->name() == name) { + return &(*p); + } + } + return 0; +} + +const Property * +Interface::findProperty (const char *name) const +{ + for (Properties::const_iterator p = m_properties.begin(); + p != m_properties.end(); ++p) { + if (p->name() == name) { + return &(*p); + } + } + return 0; +} + + +Singleton InterfaceManager::ms_singleton; + +InterfaceManager & +InterfaceManager::instance () +{ + return ms_singleton.instance(); +} + +InterfaceManager::InterfaceManager () +{ +} + +InterfaceManager::~InterfaceManager () +{ + // Delete cached interface descriptions. + m_hashTable.forEach(Delete()); +} + +const Interface * +InterfaceManager::newInterface (REFIID iid, const ITypeInfoPtr &pTypeInfo) +{ + LOCK_MUTEX(m_mutex) + + Interface *pInterface = m_hashTable.find(iid); + if (pInterface == 0) { + pInterface = new Interface(pTypeInfo); + m_hashTable.insert(iid, pInterface); + } + return pInterface; +} + +Interface * +InterfaceManager::newInterface (REFIID iid, const char *name) +{ + LOCK_MUTEX(m_mutex) + + Interface *pInterface = m_hashTable.find(iid); + if (pInterface == 0) { + pInterface = new Interface(iid, name); + m_hashTable.insert(iid, pInterface); + } + return pInterface; +} + +const Interface * +InterfaceManager::find (REFIID iid) const +{ + LOCK_MUTEX(m_mutex) + + return m_hashTable.find(iid); +} + + +FuncDesc::FuncDesc (const ITypeInfoPtr &pTypeInfo, unsigned index): + m_pTypeInfo(pTypeInfo) +{ + HRESULT hr = m_pTypeInfo->GetFuncDesc(index, &m_pFuncDesc); + if (FAILED(hr)) { + _com_issue_error(hr); + } +} + +VarDesc::VarDesc (const ITypeInfoPtr &pTypeInfo, unsigned index): + m_pTypeInfo(pTypeInfo) +{ + HRESULT hr = m_pTypeInfo->GetVarDesc(index, &m_pVarDesc); + if (FAILED(hr)) { + _com_issue_error(hr); + } +} diff --git a/src/TypeInfo.h b/src/TypeInfo.h new file mode 100644 index 0000000..2794e1a --- /dev/null +++ b/src/TypeInfo.h @@ -0,0 +1,455 @@ +// $Id: TypeInfo.h,v 1.41 2002/04/20 06:11:32 cthuang Exp $ +#ifndef TYPEINFO_H +#define TYPEINFO_H + +#include +#include +#include +#include "tcomApi.h" +#include "Uuid.h" +#include "HashTable.h" +#include "Singleton.h" + +// Define smart pointer class named ITypeInfoPtr which automatically calls the +// IUnknown methods. +_COM_SMARTPTR_TYPEDEF(ITypeInfo, __uuidof(ITypeInfo)); + +// Get name of type described by the ITypeInfo object. +std::string getTypeInfoName(ITypeInfo *pTypeInfo, MEMBERID id=MEMBERID_NIL); + +// This wrapper class takes ownership of the resource and is responsible for +// releasing it. + +class TCOM_API TypeAttr +{ + ITypeInfoPtr m_pTypeInfo; + TYPEATTR *m_pTypeAttr; + + // Do not allow others to copy instances of this class. + TypeAttr(const TypeAttr &); // not implemented + void operator=(const TypeAttr &); // not implemented + +public: + // TODO: I should probably check for a failure result and throw an + // exception in that case. + TypeAttr (const ITypeInfoPtr &pTypeInfo): + m_pTypeInfo(pTypeInfo) + { m_pTypeInfo->GetTypeAttr(&m_pTypeAttr); } + + ~TypeAttr () + { m_pTypeInfo->ReleaseTypeAttr(m_pTypeAttr); } + + // Deference pointer. + TYPEATTR *operator-> () const + { return m_pTypeAttr; } +}; + +// This wrapper class takes ownership of the resource and is responsible for +// releasing it. + +class TCOM_API FuncDesc +{ + ITypeInfoPtr m_pTypeInfo; + FUNCDESC *m_pFuncDesc; + + // Do not allow others to copy instances of this class. + FuncDesc(const FuncDesc &); // not implemented + void operator=(const FuncDesc &); // not implemented + +public: + FuncDesc(const ITypeInfoPtr &pTypeInfo, unsigned index); + + ~FuncDesc () + { m_pTypeInfo->ReleaseFuncDesc(m_pFuncDesc); } + + // Dereference pointer. + FUNCDESC *operator-> () const + { return m_pFuncDesc; } +}; + +// This wrapper class takes ownership of the resource and is responsible for +// releasing it. + +class TCOM_API VarDesc +{ + ITypeInfoPtr m_pTypeInfo; + VARDESC *m_pVarDesc; + + // Do not allow others to copy instances of this class. + VarDesc(const VarDesc &); // not implemented + void operator=(const VarDesc &); // not implemented + +public: + VarDesc(const ITypeInfoPtr &pTypeInfo, unsigned index); + + ~VarDesc () + { m_pTypeInfo->ReleaseVarDesc(m_pVarDesc); } + + // Dereference pointer. + VARDESC *operator-> () const + { return m_pVarDesc; } +}; + +// This class describes a type for a function return value or parameter. + +class TCOM_API Type +{ + std::string m_name; + VARTYPE m_vt; + IID m_iid; + unsigned m_pointerCount; + Type *m_pElementType; // element type for arrays + + // description for VARIANT type + static Type ms_variant; + + void readTypeDesc(const ITypeInfoPtr &pTypeInfo, TYPEDESC &typeDesc); + +public: + Type(const ITypeInfoPtr &pTypeInfo, TYPEDESC &typeDesc); + Type(const std::string &str); + Type(const Type &rhs); + + ~Type(); + + Type &operator=(const Type &rhs); + + const std::string &name () const + { return m_name; } + + VARTYPE vartype () const + { return m_vt; } + + const IID &iid () const + { return m_iid; } + + unsigned pointerCount () const + { return m_pointerCount; } + + const Type &elementType () const + { return *m_pElementType; } + + // Get string representation. + std::string toString() const; + + // Get description for VARIANT type. + static Type &variant() + { return ms_variant; } +}; + +// This class describes a function parameter. + +class TCOM_API Parameter +{ + std::string m_name; + Type m_type; + unsigned m_flags; + +public: + Parameter(const ITypeInfoPtr &pTypeInfo, ELEMDESC &elemDesc, const char *name); + + Parameter( + const std::string &modes, + const std::string &type, + const std::string &name); + + Parameter (unsigned flags, const Type &type, const char *name): + m_flags(flags), + m_type(type), + m_name(name) + { } + + const std::string &name () const + { return m_name; } + + const Type &type () const + { return m_type; } + + unsigned flags () const + { return m_flags; } +}; + +// This class describes a method. + +class TCOM_API Method +{ +public: + typedef std::vector Parameters; + +private: + std::string m_name; + Type m_type; + Parameters m_parameters; + MEMBERID m_memberid; + INVOKEKIND m_invokeKind; + short m_vtblIndex; // position in virtual function table + bool m_vararg; // method accepts variable number of arguments + +protected: + Method(const ITypeInfoPtr &pTypeInfo, DISPID memberid, ELEMDESC &elemDesc); + +public: + Method(const ITypeInfoPtr &pTypeInfo, FuncDesc &funcDesc); + + Method( + MEMBERID memberid, + const std::string &type, + const std::string &name, + INVOKEKIND invokeKind=INVOKE_FUNC); + + // Get method name. + const std::string &name () const + { return m_name; } + + // Get return value type. + const Type &type () const + { return m_type; } + + // Set return value type. + void type (const Type &rhs) + { m_type = rhs; } + + // Insert parameter. + void addParameter (const Parameter ¶meter) + { m_parameters.push_back(parameter); } + + // Get parameters. + const Parameters ¶meters () const + { return m_parameters; } + + // Get member ID. + MEMBERID memberid () const + { return m_memberid; } + + // Get indicator whether this is a method or property. + INVOKEKIND invokeKind () const + { return m_invokeKind; } + + // Set indicator whether this is a method or property. + void invokeKind (INVOKEKIND invokeKind) + { m_invokeKind = invokeKind; } + + // Get position in virtual function table. + short vtblIndex () const + { return m_vtblIndex; } + + // Return true if the method accepts variable number of arguments. + bool vararg () const + { return m_vararg; } +}; + +// This class describes a property. + +class TCOM_API Property: public Method +{ + WORD m_putDispatchFlag; + bool m_readOnly; + + // Initialize data members. + void initialize(); + +public: + Property(const ITypeInfoPtr &pTypeInfo, FuncDesc &funcDesc); + Property(const ITypeInfoPtr &pTypeInfo, VarDesc &varDesc); + + Property( + MEMBERID memberid, + const std::string &modes, + const std::string &type, + const std::string &name); + + // Merge data from other property into this one. + void merge(const Property &property); + + // Get dispatch flag for setting property. + WORD putDispatchFlag () const + { return m_putDispatchFlag; } + + // Get read only flag. + bool readOnly () const + { return m_readOnly; } +}; + +// This describes an interface. + +class TCOM_API Interface +{ + // Make the following a friend so it can construct instances of this class. + friend class InterfaceManager; + +public: + typedef std::vector Methods; + typedef std::vector Properties; + +private: + ITypeInfoPtr m_pTypeInfo; + IID m_iid; + std::string m_name; + Methods m_methods; + Properties m_properties; + bool m_dispatchOnly; + bool m_dispatchable; + + // Get information on methods and properties. + void readFunctions(const ITypeInfoPtr &pTypeInfo, TypeAttr &typeAttr); + + // Get information on interface. + void readTypeInfo(const ITypeInfoPtr &pTypeInfo); + + // Constructors + Interface (const ITypeInfoPtr &pTypeInfo): + m_pTypeInfo(pTypeInfo) + { readTypeInfo(pTypeInfo); } + + Interface (REFIID iid, const char *name): + m_iid(iid), + m_name(name) + { } + +public: + // Get IID. + const IID &iid () const + { return m_iid; } + + // Get string representatin of IID. + std::string iidString() const; + + // Get name. + const std::string &name () const + { return m_name; } + + // Get type info description. + ITypeInfo *typeInfo () const + { return m_pTypeInfo.GetInterfacePtr(); } + + // Insert method information. + void addMethod(const Method &method); + + // Get methods. + const Methods &methods () const + { return m_methods; } + + // Find the named method. + const Method *findMethod(const char *name) const; + + // Insert property information. + void addProperty(const Property &property); + + // Get properties. + const Properties &properties () const + { return m_properties; } + + // Find the named property. + const Property *findProperty(const char *name) const; + + // Return true if this interface can only be invoked through IDispatch. + bool dispatchOnly () const + { return m_dispatchOnly; } + + // Return true if this interface derives from IDispatch. + bool dispatchable () const + { return m_dispatchable; } +}; + +// This is a cache of interface descriptions. + +class TCOM_API InterfaceManager +{ + // used to synchronize access to hash table + Mutex m_mutex; + + // IID to interface description map + typedef HashTable IidToInterfaceDescMap; + IidToInterfaceDescMap m_hashTable; + + friend class Singleton; + static Singleton ms_singleton; + + // Do not allow others to create or copy instances of this class. + InterfaceManager(); + ~InterfaceManager(); + InterfaceManager(const InterfaceManager &); // not implemented + void operator=(const InterfaceManager &); // not implemented + +public: + // Get singleton instance. + static InterfaceManager &instance(); + + // If the interface description already exists, return it, + // otherwise create a new interface description. + const Interface *newInterface(REFIID iid, const ITypeInfoPtr &pTypeInfo); + + // If the interface description already exists, return it, + // otherwise create a new interface description. + Interface *newInterface(REFIID iid, const char *name); + + // Look for the interface description. + const Interface *find(REFIID iid) const; +}; + +// This adapts an interface description so we can create a handle for it. +// We need this because the handle support classes take ownership of the +// application objects passed to them and will delete them, but the +// InterfaceManager maintains the life cycle of interface descriptions. + +class TCOM_API InterfaceHolder +{ + const Interface *m_pInterface; + +public: + InterfaceHolder (const Interface *pInterface): + m_pInterface(pInterface) + { } + + const Interface *interfaceDesc () const + { return m_pInterface; } +}; + +// This describes a class. + +class Class +{ +public: + typedef std::vector Interfaces; + +private: + std::string m_name; + CLSID m_clsid; + Interfaces m_interfaces; + const Interface *m_pDefaultInterface; + const Interface *m_pSourceInterface; + +public: + Class(const ITypeInfoPtr &pTypeInfo); + Class( + const char *name, + const CLSID &clsid, + const Interface *pDefaultInterface, + const Interface *pSourceInterface); + + // Get name. + const std::string &name () const + { return m_name; } + + // Get CLSID. + const CLSID &clsid () const + { return m_clsid; } + + // Get CLSID as string. + std::string clsidString () const + { Uuid uuid(m_clsid); return uuid.toString(); } + + // Get interfaces this class implements. + const Interfaces &interfaces () const + { return m_interfaces; } + + // Get default interface. + const Interface *defaultInterface () const + { return m_pDefaultInterface; } + + // Get default source interface. + const Interface *sourceInterface () const + { return m_pSourceInterface; } +}; + +#endif diff --git a/src/TypeLib.cpp b/src/TypeLib.cpp new file mode 100644 index 0000000..37f4591 --- /dev/null +++ b/src/TypeLib.cpp @@ -0,0 +1,366 @@ +// $Id: TypeLib.cpp,v 1.29 2002/03/09 16:40:24 cthuang Exp $ +#pragma warning(disable: 4786) +#include +#include "RegistryKey.h" +#include "TypeInfo.h" +#include "TypeLib.h" + +Class::Class (const ITypeInfoPtr &pTypeInfo): + m_name(getTypeInfoName(pTypeInfo)), + m_pDefaultInterface(0), + m_pSourceInterface(0) +{ + HRESULT hr; + + TypeAttr typeAttr(pTypeInfo); + m_clsid = typeAttr->guid; + + // Get interfaces this class implements. + unsigned interfaceCount = static_cast(typeAttr->cImplTypes); + for (unsigned i = 0; i < interfaceCount; ++i) { + HREFTYPE hRefType; + hr = pTypeInfo->GetRefTypeOfImplType(i, &hRefType); + if (FAILED(hr)) { + break; + } + + ITypeInfoPtr pInterfaceTypeInfo; + hr = pTypeInfo->GetRefTypeInfo(hRefType, &pInterfaceTypeInfo); + if (FAILED(hr)) { + break; + } + TypeAttr interfaceTypeAttr(pInterfaceTypeInfo); + + const Interface *pInterface = InterfaceManager::instance().newInterface( + interfaceTypeAttr->guid, pInterfaceTypeInfo); + + int flags; + hr = pTypeInfo->GetImplTypeFlags(i, &flags); + if (FAILED(hr)) { + break; + } + flags &= (IMPLTYPEFLAG_FDEFAULT | IMPLTYPEFLAG_FSOURCE); + + if (flags == IMPLTYPEFLAG_FDEFAULT) { + m_pDefaultInterface = pInterface; + } else if (flags == (IMPLTYPEFLAG_FDEFAULT | IMPLTYPEFLAG_FSOURCE)) { + m_pSourceInterface = pInterface; + } + + if ((flags & IMPLTYPEFLAG_FSOURCE) == 0) { + if (m_pDefaultInterface == 0) { + m_pDefaultInterface = pInterface; + } + m_interfaces.push_back(pInterface); + } + } +} + +Class::Class ( + const char *name, + REFCLSID clsid, + const Interface *pDefaultInterface, + const Interface *pSourceInterface): + m_name(name), + m_clsid(clsid), + m_pDefaultInterface(pDefaultInterface), + m_pSourceInterface(pSourceInterface) +{ + m_interfaces.push_back(pDefaultInterface); +} + + +Enum::Enum (const ITypeInfoPtr &pTypeInfo, TypeAttr &attr): + m_name(getTypeInfoName(pTypeInfo)) +{ + HRESULT hr; + + for (int iEnum = 0; iEnum < attr->cVars; ++iEnum) { + // Get enumerator description. + VARDESC *pVarDesc; + hr = pTypeInfo->GetVarDesc(iEnum, &pVarDesc); + if (FAILED(hr)) { + break; + } + + // Get enumerator name. + BSTR bstrName; + UINT namesReturned; + hr = pTypeInfo->GetNames(pVarDesc->memid, &bstrName, 1, &namesReturned); + if (SUCCEEDED(hr)) { + // Remember enumerator name and value. + _bstr_t enumNameBstr(bstrName); + std::string enumName(enumNameBstr); + + _variant_t enumValueVar(pVarDesc->lpvarValue); + _bstr_t enumValueBstr(enumValueVar); + std::string enumValue(enumValueBstr); + + insert(value_type(enumName, enumValue)); + } + + pTypeInfo->ReleaseVarDesc(pVarDesc); + } +} + + +TypeLib * +TypeLib::load (const char *name, bool registerTypeLib) +{ + _bstr_t nameStr(name); + REGKIND regKind = registerTypeLib ? REGKIND_REGISTER : REGKIND_NONE; + ITypeLibPtr pTypeLib; + HRESULT hr = LoadTypeLibEx(nameStr, regKind, &pTypeLib); + if (FAILED(hr)) { + _com_issue_error(hr); + } + return new TypeLib(pTypeLib); +} + +TypeLib * +TypeLib::loadByLibid (const std::string &libidStr, const std::string &version) +{ + // Remove braces so UuidFromString does not complain. + std::string cleanLibid; + if (libidStr[0] == '{') { + cleanLibid = libidStr.substr(1, libidStr.size() - 2); + } else { + cleanLibid = libidStr; + } + + IID libid; + if (UuidFromString( + reinterpret_cast(const_cast(cleanLibid.c_str())), + &libid) != RPC_S_OK) { + return 0; + } + + std::string::size_type i = version.find('.'); + std::istringstream majorIn(version.substr(0, i)); + unsigned short majorVersion; + majorIn >> majorVersion; + + unsigned short minorVersion = 0; + if (i != std::string::npos) { + std::istringstream minorIn(version.substr(i + 1)); + minorIn >> minorVersion; + } + + ITypeLibPtr pTypeLib; + HRESULT hr = LoadRegTypeLib( + libid, majorVersion, minorVersion, LOCALE_USER_DEFAULT, &pTypeLib); + if (FAILED(hr)) { + _com_issue_error(hr); + } + return new TypeLib(pTypeLib); +} + +TypeLib * +TypeLib::loadByClsid (REFCLSID clsid) +{ + std::string libidStr, version; + try { + // Get the LIBID of the type library for the class. + std::string clsidSubkeyName("CLSID\\{"); + Uuid uuid(clsid); + clsidSubkeyName.append(uuid.toString()); + clsidSubkeyName.append("}"); + + std::string typeLibSubkeyName = + clsidSubkeyName + "\\TypeLib"; + RegistryKey typeLibKey(HKEY_CLASSES_ROOT, typeLibSubkeyName); + libidStr = typeLibKey.value(); + + std::string versionSubkeyName = + clsidSubkeyName + "\\Version"; + RegistryKey versionKey(HKEY_CLASSES_ROOT, versionSubkeyName); + version = versionKey.value(); + } + catch (std::runtime_error &) { + return 0; + } + return loadByLibid(libidStr, version); +} + +TypeLib * +TypeLib::loadByIid (REFIID iid) +{ + std::string libidStr, version; + try { + // Get the LIBID of the type library for the interface. + std::string typeLibSubkeyName("Interface\\{"); + Uuid uuid(iid); + typeLibSubkeyName.append(uuid.toString()); + typeLibSubkeyName.append("}\\TypeLib"); + + RegistryKey typeLibKey(HKEY_CLASSES_ROOT, typeLibSubkeyName); + libidStr = typeLibKey.value(); + version = typeLibKey.value("Version"); + } + catch (std::runtime_error &) { + return 0; + } + return loadByLibid(libidStr, version); +} + +void +TypeLib::unregister (const char *name) +{ + HRESULT hr; + + ITypeLibPtr pTypeLib; + _bstr_t nameStr(name); + hr = LoadTypeLibEx(nameStr, REGKIND_NONE, &pTypeLib); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + TypeLibAttr pLibAttr(pTypeLib); + + hr = UnRegisterTypeLib( + pLibAttr->guid, + pLibAttr->wMajorVerNum, + pLibAttr->wMinorVerNum, + LANG_NEUTRAL, + SYS_WIN32); + if (FAILED(hr)) { + _com_issue_error(hr); + } +} + +std::string +TypeLib::libidString () const +{ + TypeLibAttr pLibAttr(m_pTypeLib); + + Uuid uuid(pLibAttr->guid); + return uuid.toString(); +} + +std::string +TypeLib::version () const +{ + TypeLibAttr pLibAttr(m_pTypeLib); + + std::ostringstream out; + out << pLibAttr->wMajorVerNum << '.' << pLibAttr->wMinorVerNum; + return out.str(); +} + +std::string +TypeLib::name () const +{ + BSTR nameStr; + HRESULT hr = m_pTypeLib->GetDocumentation( + MEMBERID_NIL, &nameStr, NULL, NULL, NULL); + if (FAILED(hr)) { + return std::string(); + } + _bstr_t wrapper(nameStr, false); + return std::string(wrapper); +} + +std::string +TypeLib::documentation () const +{ + BSTR docStr; + HRESULT hr = m_pTypeLib->GetDocumentation( + MEMBERID_NIL, NULL, &docStr, NULL, NULL); + if (FAILED(hr)) { + return std::string(); + } + _bstr_t wrapper(docStr, false); + return std::string(wrapper); +} + +const Interface * +TypeLib::findInterface (const char *name) const +{ + for (Interfaces::const_iterator p = m_interfaces.begin(); + p != m_interfaces.end(); ++p) { + if ((*p)->name() == name) { + return *p; + } + } + return 0; +} + +const Class * +TypeLib::findClass (const char *name) const +{ + for (Classes::const_iterator p = m_classes.begin(); + p != m_classes.end(); ++p) { + if (p->name() == name) { + return &(*p); + } + } + return 0; +} + +const Class * +TypeLib::findClass (REFCLSID clsid) const +{ + for (Classes::const_iterator p = m_classes.begin(); + p != m_classes.end(); ++p) { + if (IsEqualCLSID(p->clsid(), clsid)) { + return &(*p); + } + } + return 0; +} + +const Enum * +TypeLib::findEnum (const char *name) const +{ + for (Enums::const_iterator p = m_enums.begin(); p != m_enums.end(); ++p) { + if (p->name() == name) { + return &(*p); + } + } + return 0; +} + +void +TypeLib::readTypeLib () +{ + HRESULT hResult; + + unsigned count = m_pTypeLib->GetTypeInfoCount(); + for (unsigned index = 0; index < count; ++index) { + ITypeInfoPtr pTypeInfo; + hResult = m_pTypeLib->GetTypeInfo(index, &pTypeInfo); + if (FAILED(hResult)) { + continue; + } + TypeAttr typeAttr(pTypeInfo); + + switch (typeAttr->typekind) { + case TKIND_DISPATCH: + case TKIND_INTERFACE: + // Read interface description. + { + const Interface *pInterface = + InterfaceManager::instance().newInterface( + typeAttr->guid, pTypeInfo); + m_interfaces.push_back(pInterface); + } + break; + + case TKIND_COCLASS: + // Read class description. + { + Class aClass(pTypeInfo); + m_classes.push_back(aClass); + } + break; + + case TKIND_ENUM: + // Read the enumeration values. + { + Enum anEnum(pTypeInfo, typeAttr); + m_enums.push_back(anEnum); + } + break; + } + } +} diff --git a/src/TypeLib.h b/src/TypeLib.h new file mode 100644 index 0000000..8d989a1 --- /dev/null +++ b/src/TypeLib.h @@ -0,0 +1,140 @@ +// $Id: TypeLib.h,v 1.21 2002/03/09 16:40:24 cthuang Exp $ +#ifndef TYPELIB_H +#define TYPELIB_H + +#include +#include +#include +#include "TypeInfo.h" + +// This describes an enumeration with a map where +// the key is an enumerator name and +// the data is the enumerator value. + +class Enum: public std::map +{ + std::string m_name; + +public: + Enum(const ITypeInfoPtr &pTypeInfo, TypeAttr &attr); + + // Get name. + const std::string &name () const + { return m_name; } +}; + +// Define smart pointer class named ITypeLibPtr which automatically calls the +// IUnknown methods. +_COM_SMARTPTR_TYPEDEF(ITypeLib, __uuidof(ITypeLib)); + +// This wrapper class takes ownership of the resource and is responsible for +// releasing it. + +class TCOM_API TypeLibAttr +{ + ITypeLibPtr m_pTypeLib; + TLIBATTR *m_pLibAttr; + + // Do not allow others to copy instances of this class. + TypeLibAttr(const TypeLibAttr &); // not implemented + void operator=(const TypeLibAttr &); // not implemented + +public: + // TODO: I should probably check for a failure result and throw an + // exception in that case. + TypeLibAttr (const ITypeLibPtr &pTypeLib): + m_pTypeLib(pTypeLib) + { m_pTypeLib->GetLibAttr(&m_pLibAttr); } + + ~TypeLibAttr () + { m_pTypeLib->ReleaseTLibAttr(m_pLibAttr); } + + // Deference pointer. + TLIBATTR *operator-> () const + { return m_pLibAttr; } +}; + +// This class represents a type library. + +class TypeLib +{ +public: + typedef std::vector Interfaces; + typedef std::vector Classes; + typedef std::vector Enums; + +private: + ITypeLibPtr m_pTypeLib; + Interfaces m_interfaces; + Classes m_classes; + Enums m_enums; + + TypeLib (const ITypeLibPtr &pTypeLib): + m_pTypeLib(pTypeLib) + { readTypeLib(); } + + // Do not allow others to copy instances of this class. + TypeLib(const TypeLib &); // not implemented + void operator=(const TypeLib &); // not implemented + + // Get information from type library. + void readTypeLib(); + +public: + // Load a type library from the specified file. + static TypeLib *load(const char *name, bool registerTypeLib=false); + + // Unregister a type library. + static void unregister(const char *name); + + // Load a type library specified by a LIBID. + // Return 0 if the required registry entries were not found. + static TypeLib *loadByLibid( + const std::string &libid, const std::string &version); + + // Load a type library specified by a CLSID. + // Return 0 if the required registry entries were not found. + static TypeLib *loadByClsid(REFCLSID clsid); + + // Load a type library specified by an IID. + // Return 0 if the required registry entries were not found. + static TypeLib *loadByIid(REFIID iid); + + // Get string representation of type library ID. + std::string libidString() const; + + // Get type library version. + std::string version() const; + + // Get type library name. + std::string name() const; + + // Get type library documentation string. + std::string documentation() const; + + // Get interfaces. + const Interfaces &interfaces () const + { return m_interfaces; } + + // Get the named interface. + const Interface *findInterface(const char *name) const; + + // Get classes. + const Classes &classes () const + { return m_classes; } + + // Get the named class. + const Class *findClass(const char *name) const; + + // Find class by CLSID. + const Class *findClass(REFCLSID clsid) const; + + // Get enumerations. + const Enums &enums () const + { return m_enums; } + + // Get the named enumeration. + const Enum *findEnum(const char *name) const; +}; + +#endif diff --git a/src/Uuid.cpp b/src/Uuid.cpp new file mode 100644 index 0000000..a45e740 --- /dev/null +++ b/src/Uuid.cpp @@ -0,0 +1,14 @@ +// $Id: Uuid.cpp,v 1.2 2000/04/20 18:37:40 chuang Exp $ +#include "Uuid.h" + +std::string +Uuid::toString () const +{ + unsigned char *str; + if (UuidToString(const_cast(&m_uuid), &str) != RPC_S_OK) { + return std::string(); + } + std::string result(reinterpret_cast(str)); + RpcStringFree(&str); + return result; +} diff --git a/src/Uuid.h b/src/Uuid.h new file mode 100644 index 0000000..ab01674 --- /dev/null +++ b/src/Uuid.h @@ -0,0 +1,34 @@ +// $Id: Uuid.h,v 1.3 2000/04/28 19:37:53 chuang Exp $ +#ifndef UUID_H +#define UUID_H + +#include +#include +#include +#include "tcomApi.h" + +// This class wraps a UUID to provide convenience functions. + +class TCOM_API Uuid +{ + UUID m_uuid; + +public: + // Construct from UUID. + Uuid (const UUID &uuid): + m_uuid(uuid) + { } + + // less than operator + bool operator< (const Uuid &rhs) const + { return memcmp(&m_uuid, &rhs.m_uuid, sizeof(UUID)) < 0; } + + // equals operator + bool operator== (const Uuid &rhs) const + { return memcmp(&m_uuid, &rhs.m_uuid, sizeof(UUID)) == 0; } + + // Return string representation. + std::string toString() const; +}; + +#endif diff --git a/src/bindCmd.cpp b/src/bindCmd.cpp new file mode 100644 index 0000000..a336015 --- /dev/null +++ b/src/bindCmd.cpp @@ -0,0 +1,238 @@ +// $Id: bindCmd.cpp,v 1.52 2002/04/13 03:53:56 cthuang Exp $ +#pragma warning(disable: 4786) +#include "Extension.h" +#include "Reference.h" +#include "TypeLib.h" + +// Get the interface description for the specified IID. +// On failure, put a message in the Tcl interpreter result and return 0. + +static const Interface * +getInterfaceDesc (Tcl_Interp *interp, REFIID iid) +{ + const Interface *pInterface = InterfaceManager::instance().find(iid); + if (pInterface == 0) { + Tcl_AppendResult( + interp, "no event interface information", NULL); + } + return pInterface; +} + +// Get the default source interface from the class description provided by +// IProvideClassInfo. +// On failure, return 0. + +static const Interface * +findEventInterfaceFromProvideClassInfo (IUnknown *pObject) +{ + HRESULT hr; + + IProvideClassInfoPtr pProvideClassInfo; + hr = pObject->QueryInterface( + IID_IProvideClassInfo, + reinterpret_cast(&pProvideClassInfo)); + if (FAILED(hr)) { + return 0; + } + + ITypeInfoPtr pClassTypeInfo; + hr = pProvideClassInfo->GetClassInfo(&pClassTypeInfo); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + // Get default source interface from class description. + Class aClass(pClassTypeInfo); + return aClass.sourceInterface(); +} + +// Get the default source interface from the class description loaded from a +// type library specified by a CLSID. +// On failure, return 0. + +static const Interface * +findEventInterfaceFromClsid (Reference *pReference) +{ + const Class *pClass = pReference->classDesc(); + if (pClass == 0) { + return 0; + } + return pClass->sourceInterface(); +} + +// Get the event interface managed by the first connection point from the +// connection point container. +// On failure, put a message in the Tcl interpreter result and return 0. + +static const Interface * +findEventInterfaceFromConnectionPoint (Tcl_Interp *interp, IUnknown *pObject) +{ + HRESULT hr; + + // Get connection point container. + IConnectionPointContainerPtr pContainer; + hr = pObject->QueryInterface( + IID_IConnectionPointContainer, + reinterpret_cast(&pContainer)); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + // Get connection point enumerator. + IEnumConnectionPointsPtr pEnum; + hr = pContainer->EnumConnectionPoints(&pEnum); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + // Get first connection point. + IConnectionPointPtr pConnectionPoint; + ULONG count; + hr = pEnum->Next(1, &pConnectionPoint, &count); + if (FAILED(hr)) { + _com_issue_error(hr); + } + if (count == 0) { + Tcl_AppendResult( + interp, "IEnumConnectionPoints returned no elements", NULL); + return 0; + } + + // Get IID of event interface managed by the connection point. + IID iid; + hr = pConnectionPoint->GetConnectionInterface(&iid); + if (FAILED(hr)) { + _com_issue_error(hr); + } + + // Get interface description for the IID. + const Interface *pInterface = InterfaceManager::instance().find(iid); + if (pInterface != 0) { + return pInterface; + } + + // If we don't have the interface description in the cache, try loading + // it from the type library. + TypeLib *pTypeLib = TypeLib::loadByIid(iid); + delete pTypeLib; + return getInterfaceDesc(interp, iid); +} + +// Find the event interface. +// On failure, put a message in the Tcl interpreter result and return 0. + +static const Interface * +findEventInterface ( + Tcl_Interp *interp, + Reference *pReference, + char *eventIIDStr) +{ + if (eventIIDStr != 0) { + // The script provided the IID of the event interface. + IID eventIID; + if (UuidFromString(reinterpret_cast(eventIIDStr), + &eventIID) != RPC_S_OK) { + Tcl_AppendResult( + interp, + "cannot convert to IID: ", + eventIIDStr, + NULL); + return 0; + } + + return getInterfaceDesc(interp, eventIID); + } + + const Interface *pInterface; + + // If the object implements IProvideClassInfo, get the default source + // interface from the class description. + pInterface = findEventInterfaceFromProvideClassInfo(pReference->unknown()); + if (pInterface != 0) { + return pInterface; + } + + // If we know the CLSID of the object's class, load the type library + // containing the class description, and get the default source interface + // from the class description. + pInterface = findEventInterfaceFromClsid(pReference); + if (pInterface != 0) { + return pInterface; + } + + // Get the event interface of the first connection point in the connection + // pointer container. + return findEventInterfaceFromConnectionPoint(interp, pReference->unknown()); +} + +// This Tcl command binds a Tcl command to an event sink. + +int +Extension::bindCmd ( + ClientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc < 3 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "object sinkCommand ?eventIID?"); + return TCL_ERROR; + } + + Reference *pReference = referenceHandles.find(interp, objv[1]); + if (pReference == 0) { + const char *arg = Tcl_GetStringFromObj(objv[1], 0); + Tcl_AppendResult( + interp, "invalid interface pointer handle ", arg, NULL); + return TCL_ERROR; + } + + TclObject servant(objv[2]); + + char *eventIIDStr = (objc < 4) ? 0 : Tcl_GetStringFromObj(objv[3], 0); + + try { + const Interface *pEventInterface = findEventInterface( + interp, pReference, eventIIDStr); + if (pEventInterface == 0) { + return TCL_ERROR; + } + + pReference->advise(interp, *pEventInterface, servant); + } + catch (_com_error &e) { + return setComErrorResult(interp, e, __FILE__, __LINE__); + } + return TCL_OK; +} + +// This Tcl command tears down all event connections to the object. + +int +Extension::unbindCmd ( + ClientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "object"); + return TCL_ERROR; + } + + Reference *pReference = referenceHandles.find(interp, objv[1]); + if (pReference == 0) { + const char *arg = Tcl_GetStringFromObj(objv[1], 0); + Tcl_AppendResult( + interp, "invalid interface pointer handle ", arg, NULL); + return TCL_ERROR; + } + + try { + pReference->unadvise(); + } + catch (_com_error &e) { + return setComErrorResult(interp, e, __FILE__, __LINE__); + } + return TCL_OK; +} diff --git a/src/buildNumber.h b/src/buildNumber.h new file mode 100644 index 0000000..dd59692 --- /dev/null +++ b/src/buildNumber.h @@ -0,0 +1 @@ +#define BUILD_NUMBER 13 diff --git a/src/comsupp.cpp b/src/comsupp.cpp new file mode 100644 index 0000000..a4128f5 --- /dev/null +++ b/src/comsupp.cpp @@ -0,0 +1,60 @@ +// $Id: comsupp.cpp,v 1.2 2001/07/12 04:09:58 cthuang Exp $ +// +// These functions are defined in comsupp.lib but Borland C++ does not include +// that library in its distribution, so we implement them here when compiling +// with Borland C++. +#include +#include +#include +#include + +// This value represents a missing optional parameter. +_variant_t vtMissing(DISP_E_PARAMNOTFOUND, VT_ERROR); + +// COM error handling routine + +void __stdcall +_com_issue_error (HRESULT hr) throw(_com_error) +{ + throw _com_error(hr); +} + +namespace _com_util { + +// Convert char * to BSTR + +BSTR __stdcall +ConvertStringToBSTR (const char* pSrc) throw(_com_error) +{ + if (pSrc == 0) { + return SysAllocString(0); + } + + // Guess the number of wide characters needed. + size_t destLen = strlen(pSrc) + 1; + wchar_t *pDest = new wchar_t[destLen]; + mbstowcs(pDest, pSrc, destLen); + BSTR result = SysAllocString(pDest); + delete[] pDest; + return result; +} + +// Convert BSTR to char * + +char* __stdcall +ConvertBSTRToString (BSTR pSrc) throw(_com_error) +{ + if (pSrc == 0) { + char *pDest = new char[1]; + *pDest = '\0'; + return pDest; + } + + // Guess the number of bytes needed. + size_t destLen = wcslen(pSrc) * 3 + 1; + char *pDest = new char[destLen]; + wcstombs(pDest, pSrc, destLen); + return pDest; +} + +} //namespace diff --git a/src/configureCmd.cpp b/src/configureCmd.cpp new file mode 100644 index 0000000..7e8ee1c --- /dev/null +++ b/src/configureCmd.cpp @@ -0,0 +1,95 @@ +// $Id: configureCmd.cpp,v 1.7 2002/04/13 03:53:57 cthuang Exp $ +#pragma warning(disable: 4786) +#include "Extension.h" + +// This Tcl command sets and retrieves configuration options. + +int +Extension::configureCmd ( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc < 2) { + Tcl_WrongNumArgs( + interp, 1, objv, "?optionName? ?value? ?optionName value? ..."); + return TCL_ERROR; + } + + Extension *pExtension = + static_cast(clientData); + + static char *options[] = { + "-concurrency", NULL + }; + enum OptionEnum { + CONCURRENCY + }; + + int index; + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch (index) { + case CONCURRENCY: + if (objc == 2) { + // Get concurrency model. + char *result; + switch (pExtension->concurrencyModel()) { + case COINIT_APARTMENTTHREADED: + result = "apartmentthreaded"; + break; +#ifdef _WIN32_DCOM + case COINIT_MULTITHREADED: +#else + case 0: +#endif + result = "multithreaded"; + break; + default: + result = "unknown"; + } + Tcl_AppendResult(interp, result, NULL); + + } else if (objc == 3) { + // Set concurrency model. + static char *options[] = { + "apartmentthreaded", "multithreaded", NULL + }; + enum OptionEnum { + APARTMENTTHREADED, MULTITHREADED + }; + + int index; + if (Tcl_GetIndexFromObj(interp, objv[2], options, "concurrency", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + DWORD flags; + switch (index) { + case APARTMENTTHREADED: + flags = COINIT_APARTMENTTHREADED; + break; + case MULTITHREADED: +#ifdef _WIN32_DCOM + flags = COINIT_MULTITHREADED; +#else + flags = 0; +#endif + break; + } + pExtension->concurrencyModel(flags); + + } else { + Tcl_WrongNumArgs( + interp, 2, objv, "apartmentthreaded|multithreaded"); + return TCL_ERROR; + } + return TCL_OK; + } + return TCL_ERROR; +} diff --git a/src/dllmain.cpp b/src/dllmain.cpp new file mode 100644 index 0000000..537d1c1 --- /dev/null +++ b/src/dllmain.cpp @@ -0,0 +1,81 @@ +// $Id: dllmain.cpp,v 1.16 2002/07/14 18:42:57 cthuang Exp $ +#pragma warning(disable: 4786) +#include "Uuid.h" +#include "HandleSupport.h" +#include "TclModule.h" +#include "TclInterp.h" +#include "tclRunTime.h" + +// This class implements a COM module for DLL-based servers. + +class DllModule: public TclModule +{ +public: + DllModule () + { } + + virtual void initializeCom(DWORD coinitFlags); +}; + +static DllModule module; + +void +DllModule::initializeCom (DWORD /*coinitFlags*/) +{ + // Do nothing. In-process servers should not call CoInitializeEx. +} + + +STDAPI +DllCanUnloadNow () +{ + return (module.lockCount() == 0) ? S_OK : S_FALSE; +} + +STDAPI +DllGetClassObject (REFCLSID clsid, REFIID iid, void **ppv) +{ + try { + IClassFactory *pFactory = module.find(clsid); + if (pFactory == 0) { + // Use CLSID to find initialize script from registry. + std::string clsidStr("{"); + Uuid uuid(clsid); + clsidStr += uuid.toString(); + clsidStr += "}"; + + int completionCode = module.registerFactoryByScript(clsidStr); + if (completionCode != TCL_OK) { + *ppv = 0; + return E_UNEXPECTED; + } + + pFactory = module.find(clsid); + } + + if (pFactory == 0) { + *ppv = 0; + return CLASS_E_CLASSNOTAVAILABLE; + } + return pFactory->QueryInterface(iid, ppv); + } + catch (...) { + *ppv = 0; + return CLASS_E_CLASSNOTAVAILABLE; + } +} + +BOOL WINAPI +DllMain ( + HINSTANCE hinstDLL, // handle to the DLL module + DWORD reason, // reason for calling function + LPVOID reserved) // reserved +{ + switch (reason) { + case DLL_PROCESS_DETACH: + module.terminate(); + break; + } + + return TRUE; +} diff --git a/src/dllserver.def b/src/dllserver.def new file mode 100644 index 0000000..ac20831 --- /dev/null +++ b/src/dllserver.def @@ -0,0 +1,5 @@ +LIBRARY tcominproc.dll + +EXPORTS + DllCanUnloadNow PRIVATE + DllGetClassObject PRIVATE diff --git a/src/dllserver.dsp b/src/dllserver.dsp new file mode 100644 index 0000000..34ad259 --- /dev/null +++ b/src/dllserver.dsp @@ -0,0 +1,139 @@ +# Microsoft Developer Studio Project File - Name="dllserver" - Package Owner=<4> +# Microsoft Developer Studio Generated Build File, Format Version 6.00 +# ** DO NOT EDIT ** + +# TARGTYPE "Win32 (x86) Dynamic-Link Library" 0x0102 + +CFG=dllserver - Win32 Debug +!MESSAGE This is not a valid makefile. To build this project using NMAKE, +!MESSAGE use the Export Makefile command and run +!MESSAGE +!MESSAGE NMAKE /f "dllserver.mak". +!MESSAGE +!MESSAGE You can specify a configuration when running NMAKE +!MESSAGE by defining the macro CFG on the command line. For example: +!MESSAGE +!MESSAGE NMAKE /f "dllserver.mak" CFG="dllserver - Win32 Debug" +!MESSAGE +!MESSAGE Possible choices for configuration are: +!MESSAGE +!MESSAGE "dllserver - Win32 Release" (based on "Win32 (x86) Dynamic-Link Library") +!MESSAGE "dllserver - Win32 Debug" (based on "Win32 (x86) Dynamic-Link Library") +!MESSAGE + +# Begin Project +# PROP AllowPerConfigDependencies 0 +# PROP Scc_ProjName "" +# PROP Scc_LocalPath "" +CPP=cl.exe +MTL=midl.exe +RSC=rc.exe + +!IF "$(CFG)" == "dllserver - Win32 Release" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 0 +# PROP BASE Output_Dir "dllserver___Win32_Release" +# PROP BASE Intermediate_Dir "dllserver___Win32_Release" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 0 +# PROP Output_Dir "dllserver_Release" +# PROP Intermediate_Dir "dllserver_Release" +# 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 BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32 +# ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32 +# ADD BASE RSC /l 0x409 /d "NDEBUG" +# ADD RSC /l 0x409 /d "NDEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /machine:I386 +# ADD LINK32 Release\tcom.lib rpcrt4.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /out:"dllserver_Release/tcominproc.dll" /libpath:"\tcl\lib" + +!ELSEIF "$(CFG)" == "dllserver - Win32 Debug" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 1 +# PROP BASE Output_Dir "dllserver___Win32_Debug" +# PROP BASE Intermediate_Dir "dllserver___Win32_Debug" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 1 +# PROP Output_Dir "dllserver_Debug" +# PROP Intermediate_Dir "dllserver_Debug" +# 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 BASE MTL /nologo /D "_DEBUG" /mktyplib203 /win32 +# ADD MTL /nologo /D "_DEBUG" /mktyplib203 /win32 +# ADD BASE RSC /l 0x409 /d "_DEBUG" +# ADD RSC /l 0x409 /d "_DEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /pdbtype:sept +# ADD LINK32 Debug\tcom.lib rpcrt4.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /out:"dllserver_Debug/tcominproc.dll" /libpath:"\tcl\lib" + +!ENDIF + +# Begin Target + +# Name "dllserver - Win32 Release" +# Name "dllserver - Win32 Debug" +# Begin Group "Source Files" + +# PROP Default_Filter "cpp;c;cxx;rc;def;r;odl;idl;hpj;bat" +# Begin Source File + +SOURCE=.\dllmain.cpp +# End Source File +# Begin Source File + +SOURCE=.\dllserver.def +# End Source File +# Begin Source File + +SOURCE=.\dllserverVersion.rc +# End Source File +# Begin Source File + +SOURCE=.\RegistryKey.cpp +# End Source File +# Begin Source File + +SOURCE=.\TclInterp.cpp +# End Source File +# Begin Source File + +SOURCE=.\TclModule.cpp +# End Source File +# End Group +# Begin Group "Header Files" + +# PROP Default_Filter "h;hpp;hxx;hm;inl" +# Begin Source File + +SOURCE=.\RegistryKey.h +# End Source File +# Begin Source File + +SOURCE=.\TclInterp.h +# End Source File +# Begin Source File + +SOURCE=.\TclModule.h +# End Source File +# End Group +# Begin Group "Resource Files" + +# PROP Default_Filter "ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe" +# End Group +# End Target +# End Project diff --git a/src/dllserverVersion.rc b/src/dllserverVersion.rc new file mode 100644 index 0000000..484be11 --- /dev/null +++ b/src/dllserverVersion.rc @@ -0,0 +1,35 @@ +// $Id: dllserverVersion.rc,v 1.5 2002/04/27 18:15:24 cthuang Exp $ +#include +#include "version.h" +#include "buildNumber.h" + +VS_VERSION_INFO VERSIONINFO + FILEVERSION PACKAGE_MAJOR_VERSION,PACKAGE_MINOR_VERSION,0,BUILD_NUMBER + PRODUCTVERSION PACKAGE_MAJOR_VERSION,PACKAGE_MINOR_VERSION,0,BUILD_NUMBER + FILEFLAGSMASK VS_FFI_FILEFLAGSMASK +#ifdef _DEBUG + FILEFLAGS VS_FF_DEBUG +#else + FILEFLAGS 0 +#endif + FILEOS VOS__WINDOWS32 + FILETYPE VFT_DLL + FILESUBTYPE VFT2_UNKNOWN +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040904b0" + BEGIN + VALUE "FileDescription", "tcom in-process server" + VALUE "FileVersion", PACKAGE_VERSION + VALUE "LegalCopyright", "Copyright 2002 by Chin Huang" + VALUE "OriginalFilename", "tcominproc.dll" + VALUE "ProductName", "tcom in-process server" + VALUE "ProductVersion", PACKAGE_VERSION + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x409, 1200 + END +END diff --git a/src/exemain.cpp b/src/exemain.cpp new file mode 100644 index 0000000..abd3919 --- /dev/null +++ b/src/exemain.cpp @@ -0,0 +1,119 @@ +// $Id: exemain.cpp,v 1.12 2002/07/14 18:42:57 cthuang Exp $ +#pragma warning(disable: 4786) +#include "TclModule.h" +#include "tclRunTime.h" + +// This class implements a COM module for an EXE server. + +class ExeModule: public TclModule +{ + DWORD m_threadId; + HANDLE m_shutdownEvent; + +protected: + virtual DWORD regclsFlags() const; + +public: + // Increment lock count. + virtual void lock(); + + // Decrement lock count. + virtual long unlock(); + + // Wait for the shutdown event to be raised. + void waitForShutdown(); + + // Start thread waiting for shutdown event. + bool startMonitor(DWORD threadId); +}; + +DWORD +ExeModule::regclsFlags () const +{ + return ComModule::regclsFlags() | REGCLS_SUSPENDED; +} + +void +ExeModule::lock() +{ + CoAddRefServerProcess(); +} + +long +ExeModule::unlock() +{ + long count = CoReleaseServerProcess(); + if (count == 0) { + // Notify monitor to exit application. + SetEvent(m_shutdownEvent); + } + return count; +} + +void +ExeModule::waitForShutdown() +{ + WaitForSingleObject(m_shutdownEvent, INFINITE); + CloseHandle(m_shutdownEvent); + PostThreadMessage(m_threadId, WM_QUIT, 0, 0); +} + +// Passed to CreateThread to monitor the shutdown event. + +static DWORD WINAPI +monitorProc (void *pv) +{ + ExeModule *pModule = reinterpret_cast(pv); + pModule->waitForShutdown(); + return 0; +} + +bool +ExeModule::startMonitor (DWORD threadId) +{ + m_threadId = threadId; + + m_shutdownEvent = CreateEvent(NULL, false, false, NULL); + if (m_shutdownEvent == NULL) { + return false; + } + + DWORD myThreadId; + HANDLE h = CreateThread(NULL, 0, monitorProc, this, 0, &myThreadId); + return h != NULL; +} + +extern "C" int WINAPI +WinMain (HINSTANCE /*hInstance*/, + HINSTANCE /*hPrevInstance*/, + LPTSTR lpCmdLine, + int /*nShowCmd*/) +{ + ExeModule module; + module.startMonitor(GetCurrentThreadId()); + + // Get CLSID string from command line. + std::string cmdLine(lpCmdLine); + std::string::size_type clsidEnd = cmdLine.find_first_of(" \t"); + std::string clsidStr(cmdLine, 0, clsidEnd); + + // Evaluate script to register class. + int completionCode = module.registerFactoryByScript(clsidStr); + if (completionCode != TCL_OK) { + return completionCode; + } + + CoResumeClassObjects(); + + MSG msg; + while (GetMessage(&msg, 0, 0, 0)) { + DispatchMessage(&msg); + } + + module.terminate(); + + // Wait for any threads to finish. + Sleep(1000); + + return 0; +} diff --git a/src/exeserver.dsp b/src/exeserver.dsp new file mode 100644 index 0000000..e1b59a5 --- /dev/null +++ b/src/exeserver.dsp @@ -0,0 +1,135 @@ +# Microsoft Developer Studio Project File - Name="exeserver" - Package Owner=<4> +# Microsoft Developer Studio Generated Build File, Format Version 6.00 +# ** DO NOT EDIT ** + +# TARGTYPE "Win32 (x86) Application" 0x0101 + +CFG=exeserver - Win32 Debug +!MESSAGE This is not a valid makefile. To build this project using NMAKE, +!MESSAGE use the Export Makefile command and run +!MESSAGE +!MESSAGE NMAKE /f "exeserver.mak". +!MESSAGE +!MESSAGE You can specify a configuration when running NMAKE +!MESSAGE by defining the macro CFG on the command line. For example: +!MESSAGE +!MESSAGE NMAKE /f "exeserver.mak" CFG="exeserver - Win32 Debug" +!MESSAGE +!MESSAGE Possible choices for configuration are: +!MESSAGE +!MESSAGE "exeserver - Win32 Release" (based on "Win32 (x86) Application") +!MESSAGE "exeserver - Win32 Debug" (based on "Win32 (x86) Application") +!MESSAGE + +# Begin Project +# PROP AllowPerConfigDependencies 0 +# PROP Scc_ProjName "" +# PROP Scc_LocalPath "" +CPP=cl.exe +MTL=midl.exe +RSC=rc.exe + +!IF "$(CFG)" == "exeserver - Win32 Release" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 0 +# PROP BASE Output_Dir "exeserver___Win32_Release" +# PROP BASE Intermediate_Dir "exeserver___Win32_Release" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 0 +# PROP Output_Dir "exeserver_Release" +# PROP Intermediate_Dir "exeserver_Release" +# PROP Ignore_Export_Lib 0 +# PROP Target_Dir "" +# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /YX /FD /c +# ADD CPP /nologo /MD /W3 /GX /Zi /Od /I "\tcl\include" /D "NDEBUG" /D "WIN32" /D "_WINDOWS" /D "_MBCS" /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" +# ADD RSC /l 0x409 /d "NDEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /machine:I386 +# ADD LINK32 Release\tcom.lib rpcrt4.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /debug /machine:I386 /out:"exeserver_Release/tcomlocal.exe" /libpath:"\tcl\lib" + +!ELSEIF "$(CFG)" == "exeserver - Win32 Debug" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 1 +# PROP BASE Output_Dir "exeserver___Win32_Debug" +# PROP BASE Intermediate_Dir "exeserver___Win32_Debug" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 1 +# PROP Output_Dir "exeserver_Debug" +# PROP Intermediate_Dir "exeserver_Debug" +# PROP Ignore_Export_Lib 0 +# PROP Target_Dir "" +# ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /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 "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" +# ADD RSC /l 0x409 /d "_DEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /debug /machine:I386 /pdbtype:sept +# ADD LINK32 Debug\tcom.lib rpcrt4.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /debug /machine:I386 /out:"exeserver_Debug/tcomlocal.exe" /libpath:"\tcl\lib" + +!ENDIF + +# Begin Target + +# Name "exeserver - Win32 Release" +# Name "exeserver - Win32 Debug" +# Begin Group "Source Files" + +# PROP Default_Filter "cpp;c;cxx;rc;def;r;odl;idl;hpj;bat" +# Begin Source File + +SOURCE=.\exemain.cpp +# End Source File +# Begin Source File + +SOURCE=.\exeserverVersion.rc +# End Source File +# Begin Source File + +SOURCE=.\RegistryKey.cpp +# End Source File +# Begin Source File + +SOURCE=.\TclInterp.cpp +# End Source File +# Begin Source File + +SOURCE=.\TclModule.cpp +# End Source File +# End Group +# Begin Group "Header Files" + +# PROP Default_Filter "h;hpp;hxx;hm;inl" +# Begin Source File + +SOURCE=.\RegistryKey.h +# End Source File +# Begin Source File + +SOURCE=.\TclInterp.h +# End Source File +# Begin Source File + +SOURCE=.\TclModule.h +# End Source File +# End Group +# Begin Group "Resource Files" + +# PROP Default_Filter "ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe" +# End Group +# End Target +# End Project diff --git a/src/exeserverVersion.rc b/src/exeserverVersion.rc new file mode 100644 index 0000000..711106b --- /dev/null +++ b/src/exeserverVersion.rc @@ -0,0 +1,35 @@ +// $Id: exeserverVersion.rc,v 1.5 2002/04/27 18:15:24 cthuang Exp $ +#include +#include "version.h" +#include "buildNumber.h" + +VS_VERSION_INFO VERSIONINFO + FILEVERSION PACKAGE_MAJOR_VERSION,PACKAGE_MINOR_VERSION,0,BUILD_NUMBER + PRODUCTVERSION PACKAGE_MAJOR_VERSION,PACKAGE_MINOR_VERSION,0,BUILD_NUMBER + FILEFLAGSMASK VS_FFI_FILEFLAGSMASK +#ifdef _DEBUG + FILEFLAGS VS_FF_DEBUG +#else + FILEFLAGS 0 +#endif + FILEOS VOS__WINDOWS32 + FILETYPE VFT_APP + FILESUBTYPE VFT2_UNKNOWN +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040904b0" + BEGIN + VALUE "FileDescription", "tcom local server" + VALUE "FileVersion", PACKAGE_VERSION + VALUE "LegalCopyright", "Copyright 2002 by Chin Huang" + VALUE "OriginalFilename", "tcomlocal.exe" + VALUE "ProductName", "tcom local server" + VALUE "ProductVersion", PACKAGE_VERSION + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x409, 1200 + END +END diff --git a/src/foreachCmd.cpp b/src/foreachCmd.cpp new file mode 100644 index 0000000..d61e3bb --- /dev/null +++ b/src/foreachCmd.cpp @@ -0,0 +1,185 @@ +// $Id: foreachCmd.cpp,v 1.10 2002/05/31 04:03:06 cthuang Exp $ +#include "Extension.h" +#include +#include "Reference.h" +#include "Arguments.h" + +// This Tcl command iterates through the elements in a COM collection. + +int +Extension::foreachCmd ( + ClientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc != 4) { + Tcl_WrongNumArgs( + interp, 1, objv, "varList collectionHandle script"); + return TCL_ERROR; + } + + Tcl_Obj *pVarList = objv[1]; + Tcl_Obj *pBody = objv[3]; + + Reference *pCollection = referenceHandles.find(interp, objv[2]); + if (pCollection == 0) { + const char *arg = Tcl_GetStringFromObj(objv[2], 0); + Tcl_AppendResult( + interp, "invalid interface pointer handle ", arg, NULL); + return TCL_ERROR; + } + + // Collections should implement a _NewEnum method which returns an object + // that enumerates the elements. + HRESULT hr; + PositionalArguments arguments; + _variant_t varResult; + + hr = pCollection->invoke( + DISPID_NEWENUM, + DISPATCH_METHOD | DISPATCH_PROPERTYGET, + arguments, + &varResult); + if (FAILED(hr) || V_VT(&varResult) != VT_UNKNOWN) { + Tcl_AppendResult(interp, "object is not a collection", NULL); + return TCL_ERROR; + } + IUnknownPtr pUnk(V_UNKNOWN(&varResult)); + + // Get a specific kind of enumeration. + IEnumVARIANTPtr pEnumVARIANT; + IEnumUnknownPtr pEnumUnknown; + enum EnumKind { ENUM_VARIANT, ENUM_UNKNOWN }; + EnumKind enumKind; + + hr = pUnk->QueryInterface( + IID_IEnumVARIANT, reinterpret_cast(&pEnumVARIANT)); + if (SUCCEEDED(hr)) { + enumKind = ENUM_VARIANT; + } else { + hr = pUnk->QueryInterface( + IID_IEnumUnknown, reinterpret_cast(&pEnumUnknown)); + if (SUCCEEDED(hr)) { + enumKind = ENUM_UNKNOWN; + } + } + + if (FAILED(hr)) { + Tcl_AppendResult(interp, + "Unknown enumerator type: not IEnumVARIANT or IEnumUnknown", NULL); + return TCL_ERROR; + } + + int completionCode; + + int varc; // number of loop variables + completionCode = Tcl_ListObjLength(interp, pVarList, &varc); + if (completionCode != TCL_OK) { + return TCL_ERROR; + } + if (varc < 1) { + Tcl_AppendResult(interp, "foreach varlist is empty", NULL); + return TCL_ERROR; + } + + while (true) { + // If the variable list has been converted to another kind of Tcl + // object, convert it back to a list and refetch the pointer to its + // element array. + Tcl_Obj **varv; + completionCode = + Tcl_ListObjGetElements(interp, pVarList, &varc, &varv); + if (completionCode != TCL_OK) { + return TCL_ERROR; + } + + // Assign values to all loop variables. + int v = 0; + for (; v < varc; ++v) { + TclObject value; + ULONG count; + + switch (enumKind) { + case ENUM_VARIANT: + { + _variant_t elementVar; + hr = pEnumVARIANT->Next(1, &elementVar, &count); + if (hr == S_OK && count > 0) { + value = TclObject(&elementVar, Type::variant(), interp); + } + } + break; + + case ENUM_UNKNOWN: + { + IUnknown *pElement; + hr = pEnumUnknown->Next(1, &pElement, &count); + if (hr == S_OK && count > 0) { + value = referenceHandles.newObj( + interp, Reference::newReference(pElement)); + } + } + break; + } + + if (FAILED(hr)) { + _com_issue_error(hr); + } + if (hr != S_OK || count == 0) { + break; + } + + Tcl_Obj *varValuePtr = Tcl_ObjSetVar2( + interp, varv[v], NULL, value, TCL_LEAVE_ERR_MSG); + if (varValuePtr == NULL) { + return TCL_ERROR; + } + } + + if (v == 0) { + completionCode = TCL_OK; + break; + } + + if (v < varc) { + TclObject empty; + + for (; v < varc; ++v) { + Tcl_Obj *varValuePtr = Tcl_ObjSetVar2( + interp, varv[v], NULL, empty, TCL_LEAVE_ERR_MSG); + if (varValuePtr == NULL) { + return TCL_ERROR; + } + } + } + + // Execute the script body. + completionCode = +#if TCL_MINOR_VERSION >= 1 + Tcl_EvalObjEx(interp, pBody, 0); +#else + Tcl_EvalObj(interp, pBody); +#endif + + if (completionCode == TCL_CONTINUE) { + // do nothing + } else if (completionCode == TCL_BREAK) { + completionCode = TCL_OK; + break; + } else if (completionCode == TCL_ERROR) { + std::ostringstream oss; + oss << "\n (\"foreach\" body line %d)" << interp->errorLine; + Tcl_AddObjErrorInfo( + interp, const_cast(oss.str().c_str()), -1); + break; + } else if (completionCode != TCL_OK) { + break; + } + } + + if (completionCode == TCL_OK) { + Tcl_ResetResult(interp); + } + return completionCode; +} diff --git a/src/importCmd.cpp b/src/importCmd.cpp new file mode 100644 index 0000000..2682c14 --- /dev/null +++ b/src/importCmd.cpp @@ -0,0 +1,534 @@ +// $Id: importCmd.cpp,v 1.26 2002/05/31 04:03:06 cthuang Exp $ +#pragma warning(disable: 4786) +#include "Extension.h" +#include +#include "Reference.h" +#include "TypeLib.h" +#include "TclObject.h" + +// interface currently being parsed +static Interface *s_pCurrentInterface; + +// Parse method parameters from list. + +static int +listObjToParameters (Tcl_Interp *interp, Tcl_Obj *pParameters, Method &method) +{ + int paramCount; + if (Tcl_ListObjLength(interp, pParameters, ¶mCount) != TCL_OK) { + return TCL_ERROR; + } + + for (int i = 0; i < paramCount; ++i) { + Tcl_Obj *pParameter; + if (Tcl_ListObjIndex(interp, pParameters, i, &pParameter) + != TCL_OK) { + return TCL_ERROR; + } + + int paramObjc; + Tcl_Obj **paramObjv; + if (Tcl_ListObjGetElements(interp, pParameter, ¶mObjc, ¶mObjv) + != TCL_OK) { + return TCL_ERROR; + } + Parameter parameter( + Tcl_GetStringFromObj(paramObjv[0], 0), + Tcl_GetStringFromObj(paramObjv[1], 0), + Tcl_GetStringFromObj(paramObjv[2], 0)); + method.addParameter(parameter); + } + + return TCL_OK; +} + +// This Tcl command defines a method. + +int +Extension::methodCmd ( + ClientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc != 5) { + Tcl_WrongNumArgs(interp, 1, objv, "dispid returnType name parameters"); + return TCL_ERROR; + } + int dispid; + if (Tcl_GetIntFromObj(interp, objv[1], &dispid) != TCL_OK) { + return TCL_ERROR; + } + char *returnType = Tcl_GetStringFromObj(objv[2], 0); + char *name = Tcl_GetStringFromObj(objv[3], 0); + + Method method(dispid, returnType, name); + if (listObjToParameters(interp, objv[4], method) != TCL_OK) { + return TCL_ERROR; + } + s_pCurrentInterface->addMethod(method); + + return TCL_OK; +} + +// This Tcl command defines a property. + +int +Extension::propertyCmd ( + ClientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc < 5 || objc > 6) { + Tcl_WrongNumArgs( + interp, + 1, + objv, + "dispid modes type name ?parameters?"); + return TCL_ERROR; + } + int dispid; + if (Tcl_GetIntFromObj(interp, objv[1], &dispid) != TCL_OK) { + return TCL_ERROR; + } + char *modes = Tcl_GetStringFromObj(objv[2], 0); + char *type = Tcl_GetStringFromObj(objv[3], 0); + char *name = Tcl_GetStringFromObj(objv[4], 0); + + Property property(dispid, modes, type, name); + if (objc == 6) { + if (listObjToParameters(interp, objv[5], property) != TCL_OK) { + return TCL_ERROR; + } + } + s_pCurrentInterface->addProperty(property); + + return TCL_OK; +} + +// This Tcl command queries an interface pointer for a specific interface +// and returns a new interface pointer handle. + +static int +interfaceObjCmd ( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "object"); + return TCL_ERROR; + } + + Reference *pSrcRef = Extension::referenceHandles.find(interp, objv[1]); + if (pSrcRef == 0) { + return TCL_ERROR; + } + + const Interface *pInterface = + reinterpret_cast(clientData); + try { + Tcl_SetObjResult( + interp, + Extension::referenceHandles.newObj( + interp, + Reference::newReference(pSrcRef->unknown(), pInterface))); + } + catch (_com_error &e) { + return Extension::setComErrorResult(interp, e, __FILE__, __LINE__); + } + return TCL_OK; +} + +// This Tcl command defines an interface. + +int +Extension::interfaceCmd ( + ClientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc < 3 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "name iid ?body?"); + return TCL_ERROR; + } + char *name = Tcl_GetStringFromObj(objv[1], 0); + char *iidStr = Tcl_GetStringFromObj(objv[2], 0); + + IID iid; + if (UuidFromString(reinterpret_cast(iidStr), &iid) + != RPC_S_OK) { + Tcl_AppendResult(interp, "cannot convert to IID: ", iidStr, NULL); + return TCL_ERROR; + } + + Interface *pInterface; + if (objc == 4) { + pInterface = + InterfaceManager::instance().newInterface(iid, name); + + s_pCurrentInterface = pInterface; + + int completionCode = +#if TCL_MINOR_VERSION >= 1 + Tcl_EvalObjEx(interp, objv[3], TCL_EVAL_GLOBAL); +#else + Tcl_GlobalEvalObj(interp, objv[3]); +#endif + + if (completionCode != TCL_OK) { + return TCL_ERROR; + } + } else { + pInterface = const_cast( + InterfaceManager::instance().find(iid)); + if (pInterface == 0) { + Tcl_AppendResult(interp, "unknown IID ", iidStr, NULL); + return TCL_ERROR; + } + } + + Tcl_CreateObjCommand( + interp, + name, + interfaceObjCmd, + reinterpret_cast(pInterface), + (Tcl_CmdDeleteProc *)0); + return TCL_OK; +} + +// This Tcl command creates an instance of a COM class and returns an +// interface pointer handle. + +static int +classObjCmd ( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc > 4) { + Tcl_WrongNumArgs( + interp, + 1, + objv, + "?-inproc? ?-local? ?-remote? ?-withevents servant? ?hostName?"); + return TCL_ERROR; + } + + DWORD clsCtx = CLSCTX_SERVER; + bool withEvents = false; + TclObject servant; + + int i = 1; + for (; i < objc; ++i) { + static char *options[] = { + "-inproc", "-local", "-remote", "-withevents", NULL + }; + enum OptionEnum { + OPTION_INPROC, OPTION_LOCAL, OPTION_REMOTE, OPTION_WITHEVENTS + }; + + int index; + if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", 0, &index) + != TCL_OK) { + break; + } + + switch (index) { + case OPTION_INPROC: + clsCtx = CLSCTX_INPROC_SERVER; + break; + case OPTION_LOCAL: + clsCtx = CLSCTX_LOCAL_SERVER; + break; + case OPTION_REMOTE: + clsCtx = CLSCTX_REMOTE_SERVER; + break; + case OPTION_WITHEVENTS: + if (i + 1 < objc) { + withEvents = true; + servant = objv[++i]; + } + break; + } + } + + char *hostName = (i < objc) ? Tcl_GetStringFromObj(objv[i], 0) : 0; + if (clsCtx == CLSCTX_REMOTE_SERVER && hostName == 0) { + Tcl_AppendResult( + interp, "hostname required with -remote option", NULL); + return TCL_ERROR; + } + + Class *pClass = reinterpret_cast(clientData); + try { + Reference *pRef = Reference::createInstance( + pClass->clsid(), + pClass->defaultInterface(), + clsCtx, + hostName); + + if (withEvents) { + if (pClass->sourceInterface() == 0) { + Tcl_AppendResult( + interp, "no default event source", NULL); + return TCL_ERROR; + } + pRef->advise(interp, *(pClass->sourceInterface()), servant); + } + + Tcl_SetObjResult( + interp, + Extension::referenceHandles.newObj(interp, pRef)); + } + catch (_com_error &e) { + return Extension::setComErrorResult(interp, e, __FILE__, __LINE__); + } + return TCL_OK; +} + +static void +classCmdDeleteProc (ClientData clientData) +{ + delete reinterpret_cast(clientData); +} + +// This Tcl command defines a COM class. + +int +Extension::classCmd ( + ClientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc < 4 || objc > 5) { + Tcl_WrongNumArgs(interp, 1, objv, "name clsid defaultIID ?sourceIID?"); + return TCL_ERROR; + } + char *name = Tcl_GetStringFromObj(objv[1], 0); + char *clsidStr = Tcl_GetStringFromObj(objv[2], 0); + char *defaultStr = Tcl_GetStringFromObj(objv[3], 0); + char *sourceStr = (objc == 5) ? Tcl_GetStringFromObj(objv[4], 0) : 0; + + // Convert CLSID. + CLSID clsid; + if (UuidFromString(reinterpret_cast(clsidStr), &clsid) + != RPC_S_OK) { + Tcl_AppendResult(interp, "cannot convert to CLSID: ", clsidStr, NULL); + return TCL_ERROR; + } + + // Convert default IID. + IID iid; + + if (UuidFromString(reinterpret_cast(defaultStr), &iid) + != RPC_S_OK) { + Tcl_AppendResult(interp, "cannot convert to IID: ", defaultStr, NULL); + return TCL_ERROR; + } + + const Interface *pDefaultInterface = InterfaceManager::instance().find(iid); + if (pDefaultInterface == 0) { + Tcl_AppendResult(interp, "unknown interface ", defaultStr, NULL); + return TCL_ERROR; + } + + // Convert source IID. + const Interface *pSourceInterface; + if (sourceStr != 0) { + if (UuidFromString(reinterpret_cast(sourceStr), &iid) + != RPC_S_OK) { + Tcl_AppendResult(interp, "cannot convert to IID: ", sourceStr, NULL); + return TCL_ERROR; + } + + pSourceInterface = InterfaceManager::instance().find(iid); + if (pSourceInterface == 0) { + Tcl_AppendResult(interp, "unknown interface ", sourceStr, NULL); + return TCL_ERROR; + } + } else { + pSourceInterface = 0; + } + + Tcl_CreateObjCommand( + interp, + name, + classObjCmd, + new Class(name, clsid, pDefaultInterface, pSourceInterface), + classCmdDeleteProc); + return TCL_OK; +} + +const Class * +Extension::findClassByCmdName (Tcl_Interp *interp, Tcl_Obj *pName) +{ + char *nameStr = Tcl_GetStringFromObj(pName, 0); + + Tcl_CmdInfo cmdInfo; + if (Tcl_GetCommandInfo(interp, nameStr, &cmdInfo) == 0) { + return 0; + } + + if (cmdInfo.objProc == classObjCmd) { + return static_cast(cmdInfo.objClientData); + } + return 0; +} + +const Interface * +Extension::findInterfaceByCmdName (Tcl_Interp *interp, Tcl_Obj *pNameObj) +{ + char *pName = Tcl_GetStringFromObj(pNameObj, 0); + + // Check if it's the name of an interface. + Tcl_CmdInfo cmdInfo; + if (Tcl_GetCommandInfo(interp, pName, &cmdInfo) == 0) { + return 0; + } + + if (cmdInfo.objProc == interfaceObjCmd) { + return reinterpret_cast(cmdInfo.objClientData); + } + + return 0; +} + +// This Tcl command reads interface and class information from a type library +// and creates Tcl commands for accessing that information. + +int +Extension::importCmd ( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "typeLibrary ?namespace?"); + return TCL_ERROR; + } + + Extension *pExtension = + static_cast(clientData); + pExtension->initializeCom(); + + char *typeLibName = Tcl_GetStringFromObj(objv[1], 0); + + try { + TypeLib *pTypeLib = TypeLib::load(typeLibName); + + // Create the new Tcl commands in a namespace named after the type + // library, unless a specific namespace was given. + std::string namesp; + if (objc > 2) { + namesp = Tcl_GetStringFromObj(objv[2], 0); + } else { + namesp = pTypeLib->name(); + } + std::string fullyQualifiedNamespace = "::" + namesp; + + std::ostringstream script; + script << "namespace eval " << fullyQualifiedNamespace << " {" + << std::endl; + + // Export interface commands. + const TypeLib::Interfaces &interfaces = pTypeLib->interfaces(); + TypeLib::Interfaces::const_iterator pInterface; + for (pInterface = interfaces.begin(); pInterface != interfaces.end(); + ++pInterface) { + script << "namespace export " << (*pInterface)->name() << std::endl; + } + + // Export class commands. + const TypeLib::Classes &classes = pTypeLib->classes(); + TypeLib::Classes::const_iterator pClass; + for (pClass = classes.begin(); pClass != classes.end(); ++pClass) { + script << "namespace export " << pClass->name() << std::endl; + } + + // Generate IID and CLSID constants. + script << "array set __uuidof {" << std::endl; + + for (pInterface = interfaces.begin(); pInterface != interfaces.end(); + ++pInterface) { + script << (*pInterface)->name() << ' ' << (*pInterface)->iidString() + << std::endl; + } + + for (pClass = classes.begin(); pClass != classes.end(); ++pClass) { + script << pClass->name() << ' ' << pClass->clsidString() + << std::endl; + } + + script << '}' << std::endl; // end of array set + + // Generate enumerations. + const TypeLib::Enums &enums = pTypeLib->enums(); + for (TypeLib::Enums::const_iterator pEnum = enums.begin(); + pEnum != enums.end(); ++pEnum) { + script << "array set " << pEnum->name() << " {" << std::endl; + + for (Enum::const_iterator p = pEnum->begin(); p != pEnum->end(); + ++p) { + script << p->first << ' ' << p->second << std::endl; + } + + script << '}' << std::endl; // end of array set + } + + script << '}' << std::endl; // end of namespace + +#if TCL_MINOR_VERSION >= 1 + Tcl_EvalEx( + interp, + const_cast(script.str().c_str()), + -1, + TCL_EVAL_GLOBAL); +#else + Tcl_Eval(interp, const_cast(script.str().c_str())); +#endif + + // Create interface commands. + for (pInterface = interfaces.begin(); pInterface != interfaces.end(); + ++pInterface) { + std::string fullyQualifiedName = + fullyQualifiedNamespace + "::" + (*pInterface)->name(); + + Tcl_CreateObjCommand( + interp, + const_cast(fullyQualifiedName.c_str()), + interfaceObjCmd, + const_cast(*pInterface), + 0); + } + + // Create class commands. + for (pClass = classes.begin(); pClass != classes.end(); ++pClass) { + std::string fullyQualifiedName = + fullyQualifiedNamespace + "::" + pClass->name(); + + Tcl_CreateObjCommand( + interp, + const_cast(fullyQualifiedName.c_str()), + classObjCmd, + new Class(*pClass), + classCmdDeleteProc); + } + + // Return the library name. + Tcl_AppendResult(interp, pTypeLib->name().c_str(), NULL); + + delete pTypeLib; + } + catch (_com_error &e) { + return setComErrorResult(interp, e, __FILE__, __LINE__); + } + + return TCL_OK; +} diff --git a/src/infoCmd.cpp b/src/infoCmd.cpp new file mode 100644 index 0000000..2a3dffd --- /dev/null +++ b/src/infoCmd.cpp @@ -0,0 +1,269 @@ +// $Id: infoCmd.cpp,v 1.31 2002/04/13 03:53:57 cthuang Exp $ +#include "Extension.h" +#include "TclObject.h" +#include "Reference.h" + +static int interfaceObjCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); +HandleSupport Extension::interfaceHolderHandles(interfaceObjCmd); + +// Convert type description to a Tcl list representation. + +static TclObject +typeToListObj (const Type &type) +{ + TclObject list(Tcl_NewListObj(0, 0)); + + list.lappend( + Tcl_NewStringObj(const_cast(type.toString().c_str()), -1)); + + for (unsigned i = 0; i < type.pointerCount(); ++i) { + list.lappend(Tcl_NewStringObj("*", -1)); + } + + return list; +} + +// Convert parameter description to a Tcl list representation. + +static TclObject +parameterToListObj (const Parameter ¶meter) +{ + TclObject list(Tcl_NewListObj(0, 0)); + + // Put parameter passing modes. + TclObject modes(Tcl_NewListObj(0, 0)); + + if (parameter.flags() & PARAMFLAG_FIN) { + modes.lappend(Tcl_NewStringObj("in", -1)); + } + if (parameter.flags() & PARAMFLAG_FOUT) { + modes.lappend(Tcl_NewStringObj("out", -1)); + } + list.lappend(modes); + + // Put parameter type. + list.lappend(typeToListObj(parameter.type())); + + // Put parameter name. + list.lappend( + Tcl_NewStringObj(const_cast(parameter.name().c_str()), -1)); + + return list; +} + +// Convert method description to a Tcl list representation. + +static TclObject +methodToListObj (const Method &method) +{ + TclObject list(Tcl_NewListObj(0, 0)); + + // Put member id. + list.lappend(Tcl_NewIntObj(method.memberid())); + + // Put return type. + list.lappend(typeToListObj(method.type())); + + // Put method name. + list.lappend( + Tcl_NewStringObj(const_cast(method.name().c_str()), -1)); + + // Put parameters. + TclObject parameterList(Tcl_NewListObj(0, 0)); + + const Method::Parameters ¶meters = method.parameters(); + for (Method::Parameters::const_iterator p = parameters.begin(); + p != parameters.end(); ++p) { + parameterList.lappend(parameterToListObj(*p)); + } + + list.lappend(parameterList); + + return list; +} + +// Implement interface descriptor object command. + +static int +interfaceObjCmd ( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "method ?arg ...?"); + return TCL_ERROR; + } + + static char *options[] = { + "iid", "methods", "name", "properties", NULL + }; + enum MethodEnum { + IID, METHODS, NAME, PROPERTIES + }; + + int index; + if (Tcl_GetIndexFromObj(interp, objv[1], options, "method", 0, &index) + != TCL_OK) { + return TCL_ERROR; + } + + const InterfaceHolder *pHolder = + reinterpret_cast(clientData); + const Interface *pInterface = pHolder->interfaceDesc(); + + switch (index) { + case IID: + // Get IID. + Tcl_AppendResult(interp, pInterface->iidString().c_str(), NULL); + return TCL_OK; + + case METHODS: + // Get method descriptions. + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } else { + TclObject methodList(Tcl_NewListObj(0, 0)); + + const Interface::Methods &methods = pInterface->methods(); + for (Interface::Methods::const_iterator p = methods.begin(); + p != methods.end(); ++p) { + methodList.lappend(methodToListObj(*p)); + } + + Tcl_SetObjResult(interp, methodList); + } + return TCL_OK; + + case NAME: + // Get interface name. + Tcl_AppendResult(interp, pInterface->name().c_str(), NULL); + return TCL_OK; + + case PROPERTIES: + // Get property descriptions. + // Returns a list where each element is a list consisting of + // { dispatchID {modes} {type} name {parameters} } + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } else { + TclObject propertyList(Tcl_NewListObj(0, 0)); + + const Interface::Properties &properties = pInterface->properties(); + for (Interface::Properties::const_iterator p = properties.begin(); + p != properties.end(); ++p) { + TclObject property(Tcl_NewListObj(0, 0)); + + // Set dispatch ID. + property.lappend(Tcl_NewIntObj(p->memberid())); + + // Set read/write modes. + TclObject modes(Tcl_NewListObj(0, 0)); + + if (!p->readOnly()) { + modes.lappend(Tcl_NewStringObj("in", -1)); + } + modes.lappend(Tcl_NewStringObj("out", -1)); + + property.lappend(modes); + + // Set property type. + property.lappend(typeToListObj(p->type())); + + // Put property name. + property.lappend(Tcl_NewStringObj( + const_cast(p->name().c_str()), -1)); + + // Put parameters. + const Property::Parameters ¶meters = p->parameters(); + if (parameters.size() > 0) { + TclObject parameterList(Tcl_NewListObj(0, 0)); + + for (Property::Parameters::const_iterator q = + parameters.begin(); q != parameters.end(); ++q) { + parameterList.lappend(parameterToListObj(*q)); + } + + property.lappend(parameterList); + } + + propertyList.lappend(property); + } + + Tcl_SetObjResult(interp, propertyList); + } + return TCL_OK; + } + + return TCL_ERROR; +} + +// This Tcl command returns descriptions of object interfaces. + +int +Extension::infoCmd ( + ClientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); + return TCL_ERROR; + } + + static char *options[] = { + "interface", NULL + }; + enum SubCommandEnum { + INTERFACE + }; + + int index; + if (Tcl_GetIndexFromObj(interp, objv[1], options, "subcommand", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch (index) { + case INTERFACE: + // Create interface description object. + { + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "handle"); + return TCL_ERROR; + } + const Interface *pInterface; + Tcl_Obj *pObj = objv[2]; + + Reference *pRef = Extension::referenceHandles.find(interp, pObj); + if (pRef != 0) { + pInterface = pRef->interfaceDesc(); + } else { + pInterface = Extension::findInterfaceByCmdName(interp, pObj); + if (pInterface == 0) { + const Class *pClass = + Extension::findClassByCmdName(interp, pObj); + if (pClass != 0) { + pInterface = pClass->defaultInterface(); + } + } + } + + if (pInterface == 0) { + Tcl_AppendResult(interp, "cannot get type information", NULL); + return TCL_ERROR; + } + + InterfaceHolder *pHolder = new InterfaceHolder(pInterface); + Tcl_Obj *pHandle = + interfaceHolderHandles.newObj(interp, pHolder); + Tcl_SetObjResult(interp, pHandle); + } + return TCL_OK; + } + return TCL_ERROR; +} diff --git a/src/main.cpp b/src/main.cpp new file mode 100644 index 0000000..160c515 --- /dev/null +++ b/src/main.cpp @@ -0,0 +1,66 @@ +// $Id: main.cpp,v 1.70 2002/07/14 18:42:57 cthuang Exp $ +#pragma warning(disable: 4786) +#include "ComModule.h" +#include "Extension.h" +#include "TclObject.h" +#include "version.h" +#include "tclRunTime.h" + +/* + * This procedure performs application-specific initialization. + * Most applications, especially those that incorporate additional + * packages, will have their own version of this procedure. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in interp->result if an error occurs. + * + * Side effects: + * Depends on the startup script. + */ +extern "C" DLLEXPORT int +Tcom_Init (Tcl_Interp *interp) +{ +#ifdef USE_TCL_STUBS + // Stubs were introduced in Tcl 8.1. + if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { + return TCL_ERROR; + } +#endif + + // Get pointers to Tcl's built-in internal representation types. + TclTypes::initialize(); + + Extension *pExtension = new Extension(interp); + pExtension->concurrencyModel(COINIT_APARTMENTTHREADED); + + // Initialize handle support. + CmdNameType::instance(); + new HandleNameToRepMap(interp); + + return Tcl_PkgProvide(interp, PACKAGE_NAME, PACKAGE_VERSION); +} + +/* + * This procedure initializes commands for a safe interpreter. + * You would leave out of this procedure any commands you deemed unsafe. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + */ +extern "C" DLLEXPORT int +Tcom_SafeInit ( + Tcl_Interp *interp) +{ +#ifdef USE_TCL_STUBS + // Stubs were introduced in Tcl 8.1. + if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { + return TCL_ERROR; + } +#endif + + return Tcl_PkgProvide(interp, PACKAGE_NAME, PACKAGE_VERSION); +} diff --git a/src/mutex.h b/src/mutex.h new file mode 100644 index 0000000..3ee1f72 --- /dev/null +++ b/src/mutex.h @@ -0,0 +1,73 @@ +// $Id: mutex.h,v 1.7 2002/04/13 03:53:57 cthuang Exp $ +#ifndef MUTEX_H +#define MUTEX_H + +#define WIN32_LEAN_AND_MEAN +#include + +// This class is used for mutual-exclusion synchronization. + +class CriticalSectionMutex +{ + CRITICAL_SECTION m_cs; + + // Disallow others from copying instances of this class. + CriticalSectionMutex(const CriticalSectionMutex &); // not implemented + void operator=(const CriticalSectionMutex &); // not implemented + +public: + CriticalSectionMutex () + { InitializeCriticalSection(&m_cs); } + + ~CriticalSectionMutex () + { DeleteCriticalSection(&m_cs); } + + void enter () + { EnterCriticalSection(&m_cs); } + + void leave () + { LeaveCriticalSection(&m_cs); } +}; + +// This class mirrors the operations of a mutex except the operations do +// nothing. + +class FakeMutex +{ +public: + void enter () + { } + + void leave () + { } +}; + +#ifdef TCL_THREADS +typedef CriticalSectionMutex Mutex; +#else +typedef FakeMutex Mutex; +#endif + +// This class locks a mutex when constructed and unlocks it when destroyed. + +class SingleLock +{ + Mutex &m_mutex; + +public: + SingleLock (Mutex &mutex): + m_mutex(mutex) + { m_mutex.enter(); } + + ~SingleLock () + { m_mutex.leave(); } +}; + +#ifdef TCL_THREADS +#define LOCK_MUTEX(mutex) \ + SingleLock criticalSectionLock(const_cast(mutex)); +#else +#define LOCK_MUTEX(mutex) +#endif + +#endif diff --git a/src/naCmd.cpp b/src/naCmd.cpp new file mode 100644 index 0000000..2b6f4d1 --- /dev/null +++ b/src/naCmd.cpp @@ -0,0 +1,93 @@ +// $Id: naCmd.cpp,v 1.6 2002/04/27 18:15:24 cthuang Exp $ +#include "Extension.h" +#include + +// The string representation is the same for all objects of this type. + +static char naStringRep[] = PACKAGE_NAMESPACE "NA"; + +static void +naUpdateString (Tcl_Obj *pObj) +{ + pObj->length = sizeof(naStringRep) - 1; + pObj->bytes = Tcl_Alloc(pObj->length + 1); + strcpy(pObj->bytes, naStringRep); +} + +// Do not allow conversion from other types. + +static int +naSetFromAny (Tcl_Interp *interp, Tcl_Obj *) +{ + if (interp != NULL) { + Tcl_AppendResult( + interp, "cannot convert to ", Extension::naType.name, NULL); + } + return TCL_ERROR; +} + +Tcl_ObjType Extension::naType = { + naStringRep, + NULL, + NULL, + naUpdateString, + naSetFromAny +}; + +// Create an NA object. + +Tcl_Obj * +Extension::newNaObj () +{ + Tcl_Obj *pObj = Tcl_NewObj(); + Tcl_InvalidateStringRep(pObj); + pObj->typePtr = &naType; + return pObj; +} + +// This Tcl command returns an object used to represent a missing optional +// argument. + +int +Extension::naCmd ( + ClientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc == 1) { + // Return a missing argument token. + Tcl_SetObjResult(interp, newNaObj()); + return TCL_OK; + } + + static char *options[] = { + "ismissing", NULL + }; + enum SubCommandEnum { + ISMISSING + }; + + int index; + if (Tcl_GetIndexFromObj(interp, objv[1], options, "subcommand", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch (index) { + case ISMISSING: + // Return true if the object is a missing argument token. + { + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "object"); + return TCL_ERROR; + } + + Tcl_SetObjResult( + interp, + Tcl_NewBooleanObj(objv[2]->typePtr == &naType)); + } + return TCL_OK; + } + return TCL_ERROR; +} diff --git a/src/nullCmd.cpp b/src/nullCmd.cpp new file mode 100644 index 0000000..91fc3aa --- /dev/null +++ b/src/nullCmd.cpp @@ -0,0 +1,58 @@ +// $Id: nullCmd.cpp,v 1.9 2002/04/27 18:15:24 cthuang Exp $ +#include "Extension.h" +#include + +// The string representation is the same for all objects of this type. + +static char nullStringRep[] = PACKAGE_NAMESPACE "NULL"; + +static void +nullUpdateString (Tcl_Obj *pObj) +{ + pObj->length = sizeof(nullStringRep) - 1; + pObj->bytes = Tcl_Alloc(pObj->length + 1); + strcpy(pObj->bytes, nullStringRep); +} + +// Do not allow conversion from other types. + +static int +nullSetFromAny (Tcl_Interp *interp, Tcl_Obj *) +{ + if (interp != NULL) { + Tcl_AppendResult( + interp, "cannot convert to ", Extension::nullType.name, NULL); + } + return TCL_ERROR; +} + +Tcl_ObjType Extension::nullType = { + nullStringRep, + NULL, + NULL, + nullUpdateString, + nullSetFromAny +}; + +// This Tcl command returns a null object which be used to pass a null pointer +// argument. + +int +Extension::nullCmd ( + ClientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + + Tcl_Obj *pObj = Tcl_NewObj(); + Tcl_InvalidateStringRep(pObj); + pObj->typePtr = &nullType; + + Tcl_SetObjResult(interp, pObj); + return TCL_OK; +} diff --git a/src/objectCmd.cpp b/src/objectCmd.cpp new file mode 100644 index 0000000..9f2c010 --- /dev/null +++ b/src/objectCmd.cpp @@ -0,0 +1,288 @@ +// $Id: objectCmd.cpp,v 1.30 2002/04/27 18:15:24 cthuang Exp $ +#pragma warning(disable: 4786) +#include "Extension.h" +#include +#include "ComObject.h" +#include "ComObjectFactory.h" +#include "ComModule.h" + +// Set the string representation to match the internal representation. + +static void +unknownPointerUpdateString (Tcl_Obj *pObj) +{ + std::ostringstream oss; + oss << "0x" << std::hex << pObj->internalRep.otherValuePtr; + std::string stringRep(oss.str()); + + pObj->length = stringRep.size(); + pObj->bytes = Tcl_Alloc(pObj->length + 1); + stringRep.copy(pObj->bytes, pObj->length); + pObj->bytes[pObj->length] = '\0'; +} + +// Set internal representation from string representation. + +static int +unknownPointerSetFromAny (Tcl_Interp *interp, Tcl_Obj *) +{ + // Do not allow conversion from other types. + if (interp != NULL) { + Tcl_AppendResult( + interp, + "cannot convert to ", + Extension::unknownPointerType.name, + NULL); + } + return TCL_ERROR; +} + +Tcl_ObjType Extension::unknownPointerType = { + PACKAGE_NAMESPACE "UnknownPointer", + NULL, + NULL, + unknownPointerUpdateString, + unknownPointerSetFromAny +}; + +// This Tcl command registers a factory that creates COM objects. + +static int +objectRegisterFactoryCmd ( + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* The argument objects. */ +{ + bool registerActiveOpt = false; + bool singletonOpt = false; + + int i = 2; + for (; i < objc; ++i) { + static char *options[] = { + "-registeractive", "-singleton", NULL + }; + enum OptionEnum { + OPTION_REGISTERACTIVE, + OPTION_SINGLETON + }; + + int index; + if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", 0, &index) + != TCL_OK) { + break; + } + + switch (index) { + case OPTION_REGISTERACTIVE: + registerActiveOpt = true; + break; + case OPTION_SINGLETON: + singletonOpt = true; + break; + } + } + + if (objc - i < 2 || objc - i > 3) { + Tcl_WrongNumArgs( + interp, + 2, + objv, + "?-singleton? class constructCommand ?destroyCommand?"); + return TCL_ERROR; + } + + const Class *pClass = Extension::findClassByCmdName(interp, objv[i]); + if (pClass == 0) { + char *className = Tcl_GetStringFromObj(objv[i], 0); + Tcl_AppendResult(interp, "unknown class ", className, NULL); + return TCL_ERROR; + } + + TclObject constructor(objv[i + 1]); + + TclObject destructor; + if (objc - i == 3) { + destructor = objv[i + 2]; + } + + ComObjectFactory *pFactory; + if (singletonOpt) { + pFactory = new SingletonObjectFactory( + pClass->interfaces(), + interp, + constructor, + destructor, + registerActiveOpt); + } else { + pFactory = new ComObjectFactory( + pClass->interfaces(), + interp, + constructor, + destructor, + registerActiveOpt); + } + ComModule::instance().registerFactory(pClass->clsid(), pFactory); + return TCL_OK; +} + +// Find interface description from imported interface name. +// On error, put a message in the Tcl interpreter result and return 0. + +static const Interface * +findInterface (Tcl_Interp *interp, Tcl_Obj *pName) +{ + const Interface *pInterface = Extension::findInterfaceByCmdName(interp, pName); + if (pInterface == 0) { + char *nameStr = Tcl_GetStringFromObj(pName, 0); + Tcl_AppendResult( + interp, "unknown interface name: ", nameStr, NULL); + } + return pInterface; +} + +// This Tcl command creates a COM object. + +static int +objectCreateCmd ( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + bool registerActiveOpt = false; + + int i = 2; + for (; i < objc; ++i) { + static char *options[] = { + "-registeractive", NULL + }; + enum OptionEnum { + OPTION_REGISTERACTIVE + }; + + int index; + if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", 0, &index) + != TCL_OK) { + break; + } + + switch (index) { + case OPTION_REGISTERACTIVE: + registerActiveOpt = true; + break; + } + } + + if (objc - i < 2 || objc - i > 3) { + Tcl_WrongNumArgs( + interp, + 2, + objv, + "?-registeractive? class servant ?destroyCommand?"); + return TCL_ERROR; + } + + TclObject servant(objv[i + 1]); + + TclObject destructor; + if (objc - i == 3) { + destructor = objv[i + 2]; + } + + try { + ComObject *pComObject; + + const Class *pClass = Extension::findClassByCmdName(interp, objv[i]); + if (pClass != 0) { + pComObject = ComObject::newInstance( + pClass->interfaces(), + interp, + servant, + destructor); + + if (registerActiveOpt) { + pComObject->registerActiveObject(pClass->clsid()); + } + } else { + // Check if the argument is a list of imported interface names. + int interfaceCount; + Tcl_Obj **interfaceObj; + int result = Tcl_ListObjGetElements( + interp, objv[i], &interfaceCount, &interfaceObj); + if (result != TCL_OK) { + return TCL_ERROR; + } + if (interfaceCount < 1) { + Tcl_AppendResult( + interp, "must specify at least one interface name", NULL); + return TCL_ERROR; + } + + Class::Interfaces interfaces; + for (int i = 0; i < interfaceCount; ++i) { + const Interface *pInterface = + findInterface(interp, interfaceObj[i]); + if (pInterface == 0) { + return TCL_ERROR; + } + interfaces.push_back(pInterface); + } + + pComObject = ComObject::newInstance( + interfaces, + interp, + servant, + destructor); + } + + Tcl_Obj *pObj = Tcl_NewObj(); + Tcl_InvalidateStringRep(pObj); + pObj->typePtr = &Extension::unknownPointerType; + pObj->internalRep.otherValuePtr = pComObject->unknown(); + + Tcl_SetObjResult(interp, pObj); + } + catch (_com_error &e) { + return Extension::setComErrorResult(interp, e, __FILE__, __LINE__); + } + return TCL_OK; +} + +// This Tcl command provides operations for creating COM objects. + +int +Extension::objectCmd ( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); + return TCL_ERROR; + } + + Extension *pExtension = + static_cast(clientData); + pExtension->initializeCom(); + + static char *options[] = { + "create", "registerfactory", NULL + }; + enum SubCommandEnum { + CREATE, REGISTER_FACTORY + }; + + int index; + if (Tcl_GetIndexFromObj(interp, objv[1], options, "subcommand", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch (index) { + case CREATE: + return objectCreateCmd(interp, objc, objv); + case REGISTER_FACTORY: + return objectRegisterFactoryCmd(interp, objc, objv); + } + return TCL_ERROR; +} diff --git a/src/refCmd.cpp b/src/refCmd.cpp new file mode 100644 index 0000000..6b4e641 --- /dev/null +++ b/src/refCmd.cpp @@ -0,0 +1,772 @@ +// $Id: refCmd.cpp,v 1.43 2002/06/12 02:14:08 cthuang Exp $ +#pragma warning(disable: 4786) +#include "Extension.h" +#include +#include "Reference.h" +#include "TypeInfo.h" +#include "TclObject.h" +#include "Arguments.h" + +static int referenceObjCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); +HandleSupport Extension::referenceHandles(referenceObjCmd); + +// Check if the object implements ISupportErrorInfo. If it does, get the +// error information. Return true if successful. + +static bool +getErrorInfo (Reference *pReference, IErrorInfo **ppErrorInfo) +{ + const Interface *pInterface = pReference->interfaceDesc(); + if (pInterface == 0) { + return false; + } + + ISupportErrorInfoPtr pSupportErrorInfo; + HRESULT hr = pReference->unknown()->QueryInterface( + IID_ISupportErrorInfo, reinterpret_cast(&pSupportErrorInfo)); + if (FAILED(hr)) { + return false; + } + + if (pSupportErrorInfo->InterfaceSupportsErrorInfo(pInterface->iid()) + != S_OK) { + return false; + } + + return GetErrorInfo(0, ppErrorInfo) == S_OK; +} + +// Set the Tcl errorCode variable and the Tcl interpreter result. +// Returns TCL_ERROR. + +static int +setErrorCodeAndResult ( + Tcl_Interp *interp, + HRESULT hresult, + const _bstr_t &description, + const char *file, + int line) +{ + TclObject errorCode(Tcl_NewListObj(0, 0)); + errorCode.lappend(Tcl_NewStringObj("COM", -1)); + + TclObject result(Tcl_NewListObj(0, 0)); + + // Append HRESULT value in hexadecimal string format. + std::ostringstream hrOut; + hrOut << "0x" << std::hex << hresult; + TclObject hrObj(hrOut.str()); + errorCode.lappend(hrObj); + 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); + +#ifndef NDEBUG + // Append file and line number. + std::ostringstream fileLine; + fileLine << file << ' ' << line; + TclObject fileLineObj(fileLine.str()); + result.lappend(fileLineObj); +#endif + + Tcl_SetObjErrorCode(interp, errorCode); + Tcl_SetObjResult(interp, result); + return TCL_ERROR; +} + +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 = 0; + FormatMessageW( + FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM, + NULL, + e.Error(), + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), + reinterpret_cast(&pMessage), + 0, + NULL); + + if (pMessage != 0) { + int nLen = wcslen(pMessage); + 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); +} + +// Invoke a method or property. + +static int +invoke (Tcl_Interp *interp, + int objc, // number of arguments + Tcl_Obj *CONST objv[], // arguments + Reference *pReference, + const Method *pMethod, + bool namedArgOpt, + TypedArguments &arguments, + WORD dispatchFlags) +{ + // Set up return value. + _variant_t returnValue; + VARIANT *pReturnValue = (pMethod->type().vartype() == VT_VOID) + ? 0 : &returnValue; + + // Invoke it. + HRESULT hr; + if (namedArgOpt) { + hr = pReference->invokeDispatch( + pMethod->memberid(), + dispatchFlags, + arguments, + pReturnValue); + } else { + hr = pReference->invoke( + pMethod->memberid(), + dispatchFlags, + arguments, + pReturnValue); + } + if (FAILED(hr)) { + _com_issue_error(hr); + } + + // Store values returned from out parameters. + arguments.storeOutValues(interp, objc, objv, pMethod->parameters()); + + // Convert return value. + if (pReturnValue != 0) { + TclObject value(pReturnValue, pMethod->type(), interp); + Tcl_SetObjResult(interp, value); + } + return TCL_OK; +} + +// Set Tcl result to a wrong number of arguments error message. + +static void +wrongNumArgs ( + Tcl_Interp *interp, // current interpreter + Tcl_Obj *CONST objv[], // method name + const Method::Parameters ¶meters) // expected parameters +{ + if (parameters.size() > 0) { + std::ostringstream paramNames; + bool first = true; + for (Property::Parameters::const_iterator p = + parameters.begin(); p != parameters.end(); ++p) { + if (first) { + first = false; + } else { + paramNames << ' '; + } + paramNames << p->name(); + } + Tcl_WrongNumArgs( + interp, 1, objv, const_cast(paramNames.str().c_str())); + } else { + Tcl_WrongNumArgs(interp, 1, objv, 0); + } + +} + +// Get or put an object property. + +static int +invokeProperty ( + Tcl_Interp *interp, // Current interpreter + int objc, + Tcl_Obj *CONST objv[], // property name and arguments + Reference *pReference, + const Property *pProperty) +{ + WORD dispatchFlags; + const Property::Parameters ¶meters = pProperty->parameters(); + + if (objc > parameters.size() + 2) { + wrongNumArgs(interp, objv, parameters); + return TCL_ERROR; + + } else if (objc == parameters.size() + 2) { + // Put property. + dispatchFlags = pProperty->putDispatchFlag(); + + } else { + // Get property. + dispatchFlags = DISPATCH_PROPERTYGET; + } + + PositionalArguments arguments; + int result = arguments.initialize( + interp, objc - 1, objv + 1, *pProperty, dispatchFlags); + if (result != TCL_OK) { + return result; + } + + return invoke( + interp, + objc - 1, + objv + 1, + pReference, + pProperty, + false, + arguments, + dispatchFlags); +} + +// Invoke a method without any type information using IDispatch. +// Return a Tcl completion code. + +static int +invokeWithoutInterfaceDesc ( + Tcl_Interp *interp, + Reference *pReference, + int objc, + Tcl_Obj *CONST objv[], // method name and arguments + WORD dispatchFlags) +{ + HRESULT hr; + + IDispatch *pDispatch = pReference->dispatch(); + if (pDispatch == 0) { + Tcl_AppendResult(interp, "object does not implement IDispatch", NULL); + return TCL_ERROR; + } + + // Ask for named method or property. + const char *name = Tcl_GetStringFromObj(objv[0], 0); + _bstr_t bstrName(name); + OLECHAR *names[1]; + names[0] = bstrName; + + DISPID dispatchID; + hr = pDispatch->GetIDsOfNames( + IID_NULL, names, 1, LOCALE_USER_DEFAULT, &dispatchID); + if (FAILED(hr)) { + Tcl_AppendResult( + interp, + "object does not implement method or property ", + name, + NULL); + return TCL_ERROR; + } + + UntypedArguments arguments; + int result = arguments.initialize( + interp, objc - 1, objv + 1, dispatchFlags); + if (result != TCL_OK) { + return result; + } + + // Set up return value. + _variant_t varReturnValue; + VARIANT *pReturnValue = + (dispatchFlags & DISPATCH_PROPERTYPUT) ? 0 : &varReturnValue; + + // Invoke method. + EXCEPINFO excepInfo; + memset(&excepInfo, 0, sizeof(excepInfo)); + + unsigned argErr; + hr = pDispatch->Invoke( + dispatchID, + IID_NULL, + LOCALE_USER_DEFAULT, + dispatchFlags, + arguments.dispParams(), + pReturnValue, + &excepInfo, + &argErr); + if (hr == DISP_E_EXCEPTION) { + // Clean up exception information strings. + _bstr_t source(excepInfo.bstrSource, false); + _bstr_t description(excepInfo.bstrDescription, false); + _bstr_t helpFile(excepInfo.bstrHelpFile, false); + + throw DispatchException(excepInfo.scode, description); + } + + if (FAILED(hr)) { + _com_issue_error(hr); + } + + if (pReturnValue != 0) { + TclObject returnValue(pReturnValue, Type::variant(), interp); + Tcl_SetObjResult(interp, returnValue); + } + return TCL_OK; +} + +// This Tcl command invokes a method or property on an interface pointer. + +static int +referenceObjCmd ( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + bool namedArgOpt = false; + WORD dispatchFlags = DISPATCH_METHOD | DISPATCH_PROPERTYGET; + + int i = 1; + for (; i < objc; ++i) { + static char *options[] = { + "-get", "-method", "-namedarg", "-set", NULL + }; + enum OptionEnum { + OPTION_GET, OPTION_METHOD, OPTION_NAMEDARG, OPTION_SET + }; + + int index; + if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", 0, &index) + != TCL_OK) { + break; + } + + switch (index) { + case OPTION_GET: + dispatchFlags = DISPATCH_PROPERTYGET; + break; + case OPTION_METHOD: + dispatchFlags = DISPATCH_METHOD; + break; + case OPTION_NAMEDARG: + namedArgOpt = true; + break; + case OPTION_SET: + dispatchFlags = DISPATCH_PROPERTYPUT; + break; + } + } + + if (objc - i < 1) { + Tcl_AppendResult( + interp, "usage: handle ?options? method ?arg ...?", NULL); + return TCL_ERROR; + } + + Reference *pReference = reinterpret_cast(clientData); + + int result; + try { + // Get interface description. + const Interface *pInterface = pReference->interfaceDesc(); + if (pInterface == 0) { + return invokeWithoutInterfaceDesc( + interp, pReference, objc - i, objv + i, dispatchFlags); + } + + const Method *pMethod; + const Property *pProperty; + const char *name = Tcl_GetStringFromObj(objv[i], 0); + + if ((pProperty = pInterface->findProperty(name)) != 0) { + // It's a property. + result = invokeProperty( + interp, + objc - i, + objv + i, + pReference, + pProperty); + + } else if ((pMethod = pInterface->findMethod(name)) != 0) { + // It's a method. + ++i; + NamedArguments namedArguments; + PositionalArguments positionalArguments; + TypedArguments *pArguments; + + if (namedArgOpt) { + pArguments = &namedArguments; + } else { + // Return an error if too many arguments were given. + const Method::Parameters ¶meters = pMethod->parameters(); + if (!pMethod->vararg() && objc - i > parameters.size()) { + wrongNumArgs(interp, objv + i - 1, parameters); + return TCL_ERROR; + } + pArguments = &positionalArguments; + } + result = pArguments->initialize( + interp, objc - i, objv + i, *pMethod, DISPATCH_METHOD); + if (result != TCL_OK) { + return result; + } + + result = invoke( + interp, + objc - i, + objv + i, + pReference, + pMethod, + namedArgOpt, + *pArguments, + DISPATCH_METHOD); + + } else { + Tcl_AppendResult( + interp, + "interface ", + pInterface->name().c_str(), + " does not have method or property ", + name, + NULL); + result = TCL_ERROR; + } + } + catch (_com_error &e) { + IErrorInfoPtr pErrorInfo; + if (getErrorInfo(pReference, &pErrorInfo)) { + BSTR descBstr; + pErrorInfo->GetDescription(&descBstr); + _bstr_t description(descBstr, false); + + result = setErrorCodeAndResult( + interp, e.Error(), description, __FILE__, __LINE__); + } else { + result = Extension::setComErrorResult( + interp, e, __FILE__, __LINE__); + } + } + catch (DispatchException &e) { + result = setErrorCodeAndResult( + interp, e.scode(), e.description(), __FILE__, __LINE__); + } + return result; +} + +// This command gets an interface pointer to an object identified by a moniker. + +static int +getObjectCmd ( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "monikerName"); + return TCL_ERROR; + } + + char *monikerName = Tcl_GetStringFromObj(objv[2], 0); + + try { + Reference *pReference = Reference::getObject(monikerName); + Tcl_SetObjResult( + interp, Extension::referenceHandles.newObj(interp, pReference)); + } + catch (_com_error &e) { + return Extension::setComErrorResult(interp, e, __FILE__, __LINE__); + } + return TCL_OK; +} + +// This command returns the reference count of an interface pointer. + +static int +countCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "handle"); + return TCL_ERROR; + } + + Reference *pReference = Extension::referenceHandles.find(interp, objv[2]); + if (pReference == 0) { + char *arg = Tcl_GetStringFromObj(objv[2], 0); + Tcl_AppendResult( + interp, "invalid interface pointer handle ", arg, NULL); + return TCL_ERROR; + } + + IUnknown *pUnknown = pReference->unknown(); + pUnknown->AddRef(); + long count = pUnknown->Release(); + + Tcl_SetObjResult(interp, Tcl_NewLongObj(count)); + return TCL_OK; +} + +// This command compares two interface pointers for COM identity. + +static int +equalCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "handle1 handle2"); + return TCL_ERROR; + } + + Reference *pReference1 = Extension::referenceHandles.find(interp, objv[2]); + if (pReference1 == 0) { + char *arg = Tcl_GetStringFromObj(objv[2], 0); + Tcl_AppendResult( + interp, "invalid interface pointer handle1 ", arg, NULL); + return TCL_ERROR; + } + + Reference *pReference2 = Extension::referenceHandles.find(interp, objv[3]); + if (pReference2 == 0) { + char *arg = Tcl_GetStringFromObj(objv[3], 0); + Tcl_AppendResult( + interp, "invalid interface pointer handle2 ", arg, NULL); + return TCL_ERROR; + } + + Tcl_SetObjResult( + interp, Tcl_NewBooleanObj(*pReference1 == *pReference2)); + return TCL_OK; +} + +// This command queries an interface pointer for an IDispatch interface. + +static int +queryDispatchCmd ( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "handle"); + return TCL_ERROR; + } + + Reference *pReference = Extension::referenceHandles.find(interp, objv[2]); + if (pReference == 0) { + char *arg = Tcl_GetStringFromObj(objv[2], (int *)0); + Tcl_AppendResult( + interp, "invalid interface pointer handle ", arg, NULL); + return TCL_ERROR; + } + + try { + Reference *pNewRef = Reference::queryInterface( + pReference->unknown(), IID_IDispatch); + Tcl_SetObjResult( + interp, + Extension::referenceHandles.newObj(interp, pNewRef)); + } + catch (_com_error &e) { + return Extension::setComErrorResult(interp, e, __FILE__, __LINE__); + } + return TCL_OK; +} + +// This command queries an interface pointer for a given interface. + +static int +queryInterfaceCmd ( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "handle IID"); + return TCL_ERROR; + } + + Reference *pReference = Extension::referenceHandles.find(interp, objv[2]); + if (pReference == 0) { + char *arg = Tcl_GetStringFromObj(objv[2], (int *)0); + Tcl_AppendResult( + interp, "invalid interface pointer handle ", arg, NULL); + return TCL_ERROR; + } + + char *iidStr = Tcl_GetStringFromObj(objv[3], (int *)0); + IID iid; + if (UuidFromString(reinterpret_cast(iidStr), &iid) + != RPC_S_OK) { + Tcl_AppendResult( + interp, + "cannot convert to IID: ", + iidStr, + NULL); + return TCL_ERROR; + } + + try { + Reference *pNewRef = Reference::queryInterface( + pReference->unknown(), iid); + Tcl_SetObjResult( + interp, + Extension::referenceHandles.newObj(interp, pNewRef)); + } + catch (_com_error &e) { + return Extension::setComErrorResult(interp, e, __FILE__, __LINE__); + } + return TCL_OK; +} + +// This Tcl command gets a reference to an object. + +int +Extension::refCmd ( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand argument ..."); + return TCL_ERROR; + } + + Extension *pExtension = + static_cast(clientData); + pExtension->initializeCom(); + + static char *options[] = { + "count", + "createobject", + "equal", + "getactiveobject", + "getobject", + "querydispatch", + "queryinterface", + NULL + }; + enum SubCommandEnum { + COUNT, CREATEOBJECT, EQUAL, GETACTIVEOBJECT, GETOBJECT, QUERYDISPATCH, + QUERYINTERFACE + }; + + int subCommand; + if (Tcl_GetIndexFromObj(interp, objv[1], options, "subcommand", 0, + &subCommand) != TCL_OK) { + return TCL_ERROR; + } + + switch (subCommand) { + case COUNT: + return countCmd(interp, objc, objv); + case EQUAL: + return equalCmd(interp, objc, objv); + case GETOBJECT: + return getObjectCmd(interp, objc, objv); + case QUERYDISPATCH: + return queryDispatchCmd(interp, objc, objv); + case QUERYINTERFACE: + return queryInterfaceCmd(interp, objc, objv); + } + + bool clsIdOpt = false; + DWORD clsCtx = CLSCTX_SERVER; + + int i = 2; + for (; i < objc; ++i) { + static char *options[] = { + "-clsid", "-inproc", "-local", "-remote", NULL + }; + enum OptionEnum { + OPTION_CLSID, OPTION_INPROC, OPTION_LOCAL, OPTION_REMOTE + }; + + int index; + if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", 0, &index) + != TCL_OK) { + break; + } + + switch (index) { + case OPTION_CLSID: + clsIdOpt = true; + break; + case OPTION_INPROC: + clsCtx = CLSCTX_INPROC_SERVER; + break; + case OPTION_LOCAL: + clsCtx = CLSCTX_LOCAL_SERVER; + break; + case OPTION_REMOTE: + clsCtx = CLSCTX_REMOTE_SERVER; + break; + } + } + + if (i >= objc) { + Tcl_WrongNumArgs( + interp, + 2, + objv, + "?-clsid? ?-inproc? ?-local? ?-remote? progID ?hostName?"); + return TCL_ERROR; + } + + char *progId = Tcl_GetStringFromObj(objv[i], 0); + + char *hostName = (i + 1 < objc) ? Tcl_GetStringFromObj(objv[i + 1], 0) : 0; + if (clsCtx == CLSCTX_REMOTE_SERVER && hostName == 0) { + Tcl_AppendResult( + interp, "hostname required with -remote option", NULL); + return TCL_ERROR; + } + + try { + Reference *pReference; + + if (clsIdOpt) { + CLSID clsid; + if (UuidFromString( + reinterpret_cast(progId), &clsid) != RPC_S_OK) { + Tcl_AppendResult( + interp, + "cannot convert to CLSID: ", + progId, + NULL); + return TCL_ERROR; + } + pReference = (subCommand == GETACTIVEOBJECT) + ? Reference::getActiveObject(clsid, 0) + : Reference::createInstance(clsid, 0, clsCtx, hostName); + + } else { + pReference = (subCommand == GETACTIVEOBJECT) + ? Reference::getActiveObject(progId) + : Reference::createInstance(progId, clsCtx, hostName); + } + + Tcl_SetObjResult( + interp, + referenceHandles.newObj(interp, pReference)); + } + catch (_com_error &e) { + return setComErrorResult(interp, e, __FILE__, __LINE__); + } + return TCL_OK; +} diff --git a/src/resource.h b/src/resource.h new file mode 100644 index 0000000..c123d68 --- /dev/null +++ b/src/resource.h @@ -0,0 +1,15 @@ +//{{NO_DEPENDENCIES}} +// Microsoft Developer Studio generated include file. +// Used by dllserver.rc +// + +// Next default values for new objects +// +#ifdef APSTUDIO_INVOKED +#ifndef APSTUDIO_READONLY_SYMBOLS +#define _APS_NEXT_RESOURCE_VALUE 101 +#define _APS_NEXT_COMMAND_VALUE 40001 +#define _APS_NEXT_CONTROL_VALUE 1000 +#define _APS_NEXT_SYMED_VALUE 101 +#endif +#endif diff --git a/src/shortPathNameCmd.cpp b/src/shortPathNameCmd.cpp new file mode 100644 index 0000000..a885e22 --- /dev/null +++ b/src/shortPathNameCmd.cpp @@ -0,0 +1,25 @@ +// $Id: shortPathNameCmd.cpp,v 1.3 2002/04/13 03:53:57 cthuang Exp $ +#include "Extension.h" +#define WIN32_LEAN_AND_MEAN +#include + +// This Tcl command returns the short path form of a input path. + +int +Extension::shortPathNameCmd ( + ClientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "inputPathName"); + return TCL_ERROR; + } + + char shortPath[MAX_PATH]; + GetShortPathName( + Tcl_GetStringFromObj(objv[1], 0), shortPath, sizeof(shortPath)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(shortPath, -1)); + return TCL_OK; +} diff --git a/src/tclRunTime.h b/src/tclRunTime.h new file mode 100644 index 0000000..4c89f3c --- /dev/null +++ b/src/tclRunTime.h @@ -0,0 +1,16 @@ +// $Id: tclRunTime.h,v 1.1 2002/07/15 04:03:54 cthuang Exp $ +#ifndef TCLRUNTIME_H +#define TCLRUNTIME_H + +#include + +// Link the Tcl run-time library. +#ifdef USE_TCL_STUBS +#pragma comment(lib, \ + "tclstub" STRINGIFY(JOIN(TCL_MAJOR_VERSION, TCL_MINOR_VERSION))) +#else +#pragma comment(lib, \ + "tcl" STRINGIFY(JOIN(TCL_MAJOR_VERSION, TCL_MINOR_VERSION))) +#endif + +#endif diff --git a/src/tcom.dsp b/src/tcom.dsp new file mode 100644 index 0000000..1672759 --- /dev/null +++ b/src/tcom.dsp @@ -0,0 +1,353 @@ +# Microsoft Developer Studio Project File - Name="tcom" - Package Owner=<4> +# Microsoft Developer Studio Generated Build File, Format Version 6.00 +# ** DO NOT EDIT ** + +# TARGTYPE "Win32 (x86) Dynamic-Link Library" 0x0102 + +CFG=tcom - Win32 No DCOM Debug +!MESSAGE This is not a valid makefile. To build this project using NMAKE, +!MESSAGE use the Export Makefile command and run +!MESSAGE +!MESSAGE NMAKE /f "tcom.mak". +!MESSAGE +!MESSAGE You can specify a configuration when running NMAKE +!MESSAGE by defining the macro CFG on the command line. For example: +!MESSAGE +!MESSAGE NMAKE /f "tcom.mak" CFG="tcom - Win32 No DCOM Debug" +!MESSAGE +!MESSAGE Possible choices for configuration are: +!MESSAGE +!MESSAGE "tcom - Win32 Release" (based on "Win32 (x86) Dynamic-Link Library") +!MESSAGE "tcom - Win32 Debug" (based on "Win32 (x86) Dynamic-Link Library") +!MESSAGE "tcom - Win32 No DCOM Release" (based on "Win32 (x86) Dynamic-Link Library") +!MESSAGE "tcom - Win32 No DCOM Debug" (based on "Win32 (x86) Dynamic-Link Library") +!MESSAGE + +# Begin Project +# PROP AllowPerConfigDependencies 0 +# PROP Scc_ProjName "" +# PROP Scc_LocalPath "" +CPP=cl.exe +MTL=midl.exe +RSC=rc.exe + +!IF "$(CFG)" == "tcom - Win32 Release" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 0 +# PROP BASE Output_Dir "Release" +# PROP BASE Intermediate_Dir "Release" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 0 +# PROP Output_Dir "Release" +# PROP Intermediate_Dir "Release" +# 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 BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32 +# ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32 +# ADD BASE RSC /l 0x409 /d "NDEBUG" +# ADD RSC /l 0x409 /d "NDEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /machine:I386 +# ADD LINK32 rpcrt4.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /libpath:"\tcl\lib" + +!ELSEIF "$(CFG)" == "tcom - Win32 Debug" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 1 +# PROP BASE Output_Dir "Debug" +# PROP BASE Intermediate_Dir "Debug" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 1 +# PROP Output_Dir "Debug" +# PROP Intermediate_Dir "Debug" +# 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 BASE MTL /nologo /D "_DEBUG" /mktyplib203 /win32 +# ADD MTL /nologo /D "_DEBUG" /mktyplib203 /win32 +# ADD BASE RSC /l 0x409 /d "_DEBUG" +# ADD RSC /l 0x409 /d "_DEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /pdbtype:sept +# ADD LINK32 rpcrt4.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /libpath:"\tcl\lib" + +!ELSEIF "$(CFG)" == "tcom - Win32 No DCOM Release" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 0 +# PROP BASE Output_Dir "tcom___Win32_No_DCOM_Release" +# PROP BASE Intermediate_Dir "tcom___Win32_No_DCOM_Release" +# PROP BASE Ignore_Export_Lib 0 +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 0 +# PROP Output_Dir "No_DCOM_Release" +# PROP Intermediate_Dir "No_DCOM_Release" +# 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 BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32 +# ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32 +# ADD BASE RSC /l 0x409 /d "NDEBUG" +# ADD RSC /l 0x409 /d "NDEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 tk80.lib tcl80.lib rpcrt4.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /machine:I386 /libpath:"e:\tcl\lib" +# ADD LINK32 rpcrt4.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /libpath:"\tcl\lib" + +!ELSEIF "$(CFG)" == "tcom - Win32 No DCOM Debug" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 1 +# PROP BASE Output_Dir "tcom___Win32_No_DCOM_Debug" +# PROP BASE Intermediate_Dir "tcom___Win32_No_DCOM_Debug" +# PROP BASE Ignore_Export_Lib 0 +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 1 +# PROP Output_Dir "No_DCOM_Debug" +# PROP Intermediate_Dir "No_DCOM_Debug" +# 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 BASE MTL /nologo /D "_DEBUG" /mktyplib203 /win32 +# ADD MTL /nologo /D "_DEBUG" /mktyplib203 /win32 +# ADD BASE RSC /l 0x409 /d "_DEBUG" +# ADD RSC /l 0x409 /d "_DEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 tk80.lib tcl80.lib rpcrt4.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /pdbtype:sept /libpath:"c:\tcl\lib" +# ADD LINK32 rpcrt4.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /libpath:"\tcl\lib" + +!ENDIF + +# Begin Target + +# Name "tcom - Win32 Release" +# Name "tcom - Win32 Debug" +# Name "tcom - Win32 No DCOM Release" +# Name "tcom - Win32 No DCOM Debug" +# Begin Group "Source Files" + +# PROP Default_Filter "cpp;c;cxx;rc;def;r;odl;idl;hpj;bat" +# Begin Source File + +SOURCE=.\Arguments.cpp +# End Source File +# Begin Source File + +SOURCE=.\bindCmd.cpp +# End Source File +# Begin Source File + +SOURCE=.\ComModule.cpp +# End Source File +# Begin Source File + +SOURCE=.\ComObject.cpp +# End Source File +# Begin Source File + +SOURCE=.\ComObjectFactory.cpp +# End Source File +# Begin Source File + +SOURCE=.\configureCmd.cpp +# End Source File +# Begin Source File + +SOURCE=.\Extension.cpp +# End Source File +# Begin Source File + +SOURCE=.\foreachCmd.cpp +# End Source File +# Begin Source File + +SOURCE=.\HandleSupport.cpp +# End Source File +# Begin Source File + +SOURCE=.\importCmd.cpp +# End Source File +# Begin Source File + +SOURCE=.\infoCmd.cpp +# End Source File +# Begin Source File + +SOURCE=.\InterfaceAdapter.cpp +# End Source File +# Begin Source File + +SOURCE=.\InterfaceAdapterVtbl.cpp +# End Source File +# Begin Source File + +SOURCE=.\main.cpp +# End Source File +# Begin Source File + +SOURCE=.\naCmd.cpp +# End Source File +# Begin Source File + +SOURCE=.\nullCmd.cpp +# End Source File +# Begin Source File + +SOURCE=.\objectCmd.cpp +# End Source File +# Begin Source File + +SOURCE=.\refCmd.cpp +# End Source File +# Begin Source File + +SOURCE=.\Reference.cpp +# End Source File +# Begin Source File + +SOURCE=.\RegistryKey.cpp +# End Source File +# Begin Source File + +SOURCE=.\shortPathNameCmd.cpp +# End Source File +# Begin Source File + +SOURCE=.\SupportErrorInfo.cpp +# End Source File +# Begin Source File + +SOURCE=.\TclObject.cpp +# End Source File +# Begin Source File + +SOURCE=.\tcomVersion.rc +# End Source File +# Begin Source File + +SOURCE=.\TypeInfo.cpp +# End Source File +# Begin Source File + +SOURCE=.\TypeLib.cpp +# End Source File +# Begin Source File + +SOURCE=.\typelibCmd.cpp +# End Source File +# Begin Source File + +SOURCE=.\Uuid.cpp +# End Source File +# End Group +# Begin Group "Header Files" + +# PROP Default_Filter "h;hpp;hxx;hm;inl" +# Begin Source File + +SOURCE=.\Arguments.h +# End Source File +# Begin Source File + +SOURCE=.\ComModule.h +# End Source File +# Begin Source File + +SOURCE=.\ComObject.h +# End Source File +# Begin Source File + +SOURCE=.\ComObjectFactory.h +# End Source File +# Begin Source File + +SOURCE=.\Extension.h +# End Source File +# Begin Source File + +SOURCE=.\HandleSupport.h +# End Source File +# Begin Source File + +SOURCE=.\HashTable.h +# End Source File +# Begin Source File + +SOURCE=.\InterfaceAdapter.h +# End Source File +# Begin Source File + +SOURCE=.\mutex.h +# End Source File +# Begin Source File + +SOURCE=.\Reference.h +# End Source File +# Begin Source File + +SOURCE=.\RegistryKey.h +# End Source File +# Begin Source File + +SOURCE=.\Singleton.h +# End Source File +# Begin Source File + +SOURCE=.\SupportErrorInfo.h +# End Source File +# Begin Source File + +SOURCE=.\TclObject.h +# End Source File +# Begin Source File + +SOURCE=.\tclRunTime.h +# End Source File +# Begin Source File + +SOURCE=.\tcomApi.h +# End Source File +# Begin Source File + +SOURCE=.\ThreadLocalStorage.h +# End Source File +# Begin Source File + +SOURCE=.\TypeInfo.h +# End Source File +# Begin Source File + +SOURCE=.\TypeLib.h +# End Source File +# Begin Source File + +SOURCE=.\Uuid.h +# End Source File +# End Group +# Begin Group "Resource Files" + +# PROP Default_Filter "ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe" +# End Group +# End Target +# End Project diff --git a/src/tcom.dsw b/src/tcom.dsw new file mode 100644 index 0000000..66a5795 --- /dev/null +++ b/src/tcom.dsw @@ -0,0 +1,74 @@ +Microsoft Developer Studio Workspace File, Format Version 6.00 +# WARNING: DO NOT EDIT OR DELETE THIS WORKSPACE FILE! + +############################################################################### + +Project: "TclScript"=.\TclScript.dsp - Package Owner=<4> + +Package=<5> +{{{ +}}} + +Package=<4> +{{{ + Begin Project Dependency + Project_Dep_Name tcom + End Project Dependency +}}} + +############################################################################### + +Project: "dllserver"=.\dllserver.dsp - Package Owner=<4> + +Package=<5> +{{{ +}}} + +Package=<4> +{{{ + Begin Project Dependency + Project_Dep_Name tcom + End Project Dependency +}}} + +############################################################################### + +Project: "exeserver"=.\exeserver.dsp - Package Owner=<4> + +Package=<5> +{{{ +}}} + +Package=<4> +{{{ + Begin Project Dependency + Project_Dep_Name tcom + End Project Dependency +}}} + +############################################################################### + +Project: "tcom"=.\tcom.dsp - Package Owner=<4> + +Package=<5> +{{{ +}}} + +Package=<4> +{{{ +}}} + +############################################################################### + +Global: + +Package=<5> +{{{ +}}} + +Package=<3> +{{{ +}}} + +############################################################################### + diff --git a/src/tcomApi.h b/src/tcomApi.h new file mode 100644 index 0000000..1cdd220 --- /dev/null +++ b/src/tcomApi.h @@ -0,0 +1,13 @@ +// $Id: tcomApi.h,v 1.1 2000/04/22 21:39:36 chuang Exp $ +#ifndef TCOMAPI_H +#define TCOMAPI_H + +#pragma warning(disable: 4251) + +#ifdef TCOM_EXPORTS +#define TCOM_API __declspec(dllexport) +#else +#define TCOM_API __declspec(dllimport) +#endif + +#endif diff --git a/src/tcomVersion.rc b/src/tcomVersion.rc new file mode 100644 index 0000000..12e742b --- /dev/null +++ b/src/tcomVersion.rc @@ -0,0 +1,35 @@ +// $Id: tcomVersion.rc,v 1.5 2002/04/27 18:15:24 cthuang Exp $ +#include +#include "version.h" +#include "buildNumber.h" + +VS_VERSION_INFO VERSIONINFO + FILEVERSION PACKAGE_MAJOR_VERSION,PACKAGE_MINOR_VERSION,0,BUILD_NUMBER + PRODUCTVERSION PACKAGE_MAJOR_VERSION,PACKAGE_MINOR_VERSION,0,BUILD_NUMBER + FILEFLAGSMASK VS_FFI_FILEFLAGSMASK +#ifdef _DEBUG + FILEFLAGS VS_FF_DEBUG +#else + FILEFLAGS 0 +#endif + FILEOS VOS__WINDOWS32 + FILETYPE VFT_DLL + FILESUBTYPE VFT2_UNKNOWN +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040904b0" + BEGIN + VALUE "FileDescription", "tcom Tcl extension" + VALUE "FileVersion", PACKAGE_VERSION + VALUE "LegalCopyright", "Copyright 2002 by Chin Huang" + VALUE "OriginalFilename", "tcom.dll" + VALUE "ProductName", "tcom Tcl extension" + VALUE "ProductVersion", PACKAGE_VERSION + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x409, 1200 + END +END diff --git a/src/typelibCmd.cpp b/src/typelibCmd.cpp new file mode 100644 index 0000000..b5da966 --- /dev/null +++ b/src/typelibCmd.cpp @@ -0,0 +1,256 @@ +// $Id: typelibCmd.cpp,v 1.29 2002/04/13 03:53:57 cthuang Exp $ +#pragma warning(disable: 4786) +#include "Extension.h" +#include "TypeLib.h" + +static int typeLibObjCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []); +HandleSupport Extension::typeLibHandles(typeLibObjCmd); + +// Implement type library object command. + +static int +typeLibObjCmd ( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "method ?arg ...?"); + return TCL_ERROR; + } + + static char *options[] = { + "class", "documentation", "enum", "interface", "libid", "name", "version", NULL + }; + enum MethodEnum { + CLASS, DOCUMENTATION, ENUM, INTERFACE, LIBID, NAME, VERSION + }; + + int index; + if (Tcl_GetIndexFromObj(interp, objv[1], options, "method", 0, &index) + != TCL_OK) { + return TCL_ERROR; + } + + const TypeLib *pTypeLib = reinterpret_cast(clientData); + + switch (index) { + case CLASS: + if (objc == 2) { + // Get list of class names. + const TypeLib::Classes &classes = pTypeLib->classes(); + for (TypeLib::Classes::const_iterator p = classes.begin(); + p != classes.end(); ++p) { + Tcl_AppendElement( + interp, + const_cast(p->name().c_str())); + } + + } else if (objc == 3) { + // Get class description. + char *className = Tcl_GetStringFromObj(objv[2], 0); + + const Class *pClass = pTypeLib->findClass(className); + if (pClass == 0) { + Tcl_AppendResult( + interp, + "class not found: ", + className, + NULL); + return TCL_ERROR; + } + + // Append CLSID. + Tcl_AppendElement( + interp, + const_cast(pClass->clsidString().c_str())); + + // Append name of default interface. + Tcl_AppendElement( + interp, + const_cast( + pClass->defaultInterface()->name().c_str())); + + // Append name of source interface. + if (pClass->sourceInterface() != 0) { + Tcl_AppendElement( + interp, + const_cast( + pClass->sourceInterface()->name().c_str())); + } + + } else { + + Tcl_WrongNumArgs(interp, 2, objv, "?className?"); + return TCL_ERROR; + } + return TCL_OK; + + case DOCUMENTATION: + // Get type library documentation. + Tcl_AppendResult(interp, pTypeLib->documentation().c_str(), NULL); + return TCL_OK; + + case ENUM: + if (objc == 2) { + // Return list of enumerations. + const TypeLib::Enums &enums = pTypeLib->enums(); + for (TypeLib::Enums::const_iterator p = enums.begin(); + p != enums.end(); ++p) { + Tcl_AppendElement( + interp, + const_cast(p->name().c_str())); + } + + } else { + // Get the named enumeration. + char *name = Tcl_GetStringFromObj(objv[2], 0); + const Enum *pEnum = pTypeLib->findEnum(name); + if (pEnum == 0) { + Tcl_AppendResult(interp, "unknown enumeration ", name, NULL); + return TCL_ERROR; + } + + if (objc == 3) { + // Return list of enumerator name/value pairs. + for (Enum::const_iterator p = pEnum->begin(); p != pEnum->end(); + ++p) { + Tcl_AppendElement(interp, + const_cast(p->first.c_str())); + Tcl_AppendElement(interp, + const_cast(p->second.c_str())); + } + + } else if (objc == 4) { + // Return value of named enumerator. + char *name = Tcl_GetStringFromObj(objv[3], 0); + + Enum::const_iterator p = pEnum->find(name); + if (p == pEnum->end()) { + Tcl_AppendResult(interp, "unknown enumerator ", name, NULL); + return TCL_ERROR; + } + + Tcl_AppendElement(interp, + const_cast(p->second.c_str())); + + } else { + Tcl_WrongNumArgs( + interp, + 2, + objv, + "?enumerationName? ?enumeratorName?"); + return TCL_ERROR; + } + } + return TCL_OK; + + case INTERFACE: + if (objc == 2) { + // Get list of interface names. + const TypeLib::Interfaces &interfaces = pTypeLib->interfaces(); + for (TypeLib::Interfaces::const_iterator p = interfaces.begin(); + p != interfaces.end(); ++p) { + Tcl_AppendElement( + interp, + const_cast((*p)->name().c_str())); + } + + } else if (objc == 3) { + // Get interface description. + char *name = Tcl_GetStringFromObj(objv[2], 0); + + const Interface *pInterface = pTypeLib->findInterface(name); + if (pInterface == 0) { + Tcl_AppendResult( + interp, + "interface not found: ", + name, + NULL); + return TCL_ERROR; + } + + InterfaceHolder *pHolder = new InterfaceHolder(pInterface); + Tcl_Obj *pHandle = + Extension::interfaceHolderHandles.newObj(interp, pHolder); + Tcl_SetObjResult(interp, pHandle); + + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?interfaceName?"); + return TCL_ERROR; + } + return TCL_OK; + + case LIBID: + Tcl_AppendResult(interp, pTypeLib->libidString().c_str(), NULL); + return TCL_OK; + + case NAME: + Tcl_AppendResult(interp, pTypeLib->name().c_str(), NULL); + return TCL_OK; + + case VERSION: + Tcl_AppendResult(interp, pTypeLib->version().c_str(), NULL); + return TCL_OK; + } + + return TCL_ERROR; +} + +// This Tcl command loads a type library. + +int +Extension::typelibCmd ( + ClientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "option typeLibrary"); + return TCL_ERROR; + } + + static char *options[] = { + "load", "register", "unregister", NULL + }; + enum SubCommandEnum { + LOAD, REGISTER, UNREGISTER + }; + + int index; + if (Tcl_GetIndexFromObj(interp, objv[1], options, "subcommand", 0, &index) + != TCL_OK) { + return TCL_ERROR; + } + + char *typeLibName = Tcl_GetStringFromObj(objv[2], 0); + + try { + TypeLib *pTypeLib; + + switch (index) { + case LOAD: + pTypeLib = TypeLib::load(typeLibName); + Tcl_SetObjResult( + interp, + typeLibHandles.newObj(interp, pTypeLib)); + break; + + case REGISTER: + pTypeLib = TypeLib::load(typeLibName, true); + delete pTypeLib; + break; + + case UNREGISTER: + TypeLib::unregister(typeLibName); + break; + } + } + catch (_com_error &e) { + return setComErrorResult(interp, e, __FILE__, __LINE__); + } + + return TCL_OK; +} diff --git a/src/version.h b/src/version.h new file mode 100644 index 0000000..090cd68 --- /dev/null +++ b/src/version.h @@ -0,0 +1,14 @@ +// $Id: version.h,v 1.3 2002/04/27 18:15:24 cthuang Exp $ +#ifndef VERSION_H +#define VERSION_H + +#define PACKAGE_MAJOR_VERSION 3 +#define PACKAGE_MINOR_VERSION 8 + +#define MAKE_VERSION_STRING0(MAJOR,MINOR) #MAJOR "." #MINOR +#define MAKE_VERSION_STRING(MAJOR,MINOR) MAKE_VERSION_STRING0(MAJOR,MINOR) + +#define PACKAGE_VERSION \ + MAKE_VERSION_STRING(PACKAGE_MAJOR_VERSION,PACKAGE_MINOR_VERSION) + +#endif diff --git a/tests/all.tcl b/tests/all.tcl new file mode 100644 index 0000000..b2d4f9e --- /dev/null +++ b/tests/all.tcl @@ -0,0 +1,20 @@ +# $Id: all.tcl,v 1.1 2002/03/16 04:53:17 cthuang Exp $ +# +# This file contains a top-level script to run all of the tests. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +set ::tcltest::testSingleFile false +set ::tcltest::testsDirectory [file dir [info script]] + +foreach file [::tcltest::getMatchingFiles] { + if {[catch {source $file} msg]} { + puts stdout $msg + } +} + +::tcltest::cleanupTests 1 +return diff --git a/tests/foreach.test b/tests/foreach.test new file mode 100644 index 0000000..55ea329 --- /dev/null +++ b/tests/foreach.test @@ -0,0 +1,42 @@ +# $Id: foreach.test,v 1.1 2002/03/16 04:53:17 cthuang Exp $ +# +# This file contains tests for the ::tcom::foreach command. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +test foreach-1.1 {::tcom::foreach} { + package require tcom + + set application [::tcom::ref createobject "Excel.Application"] + $application Visible 1 + + set workbooks [$application Workbooks] + set workbook [$workbooks Add] + set worksheets [$workbook Worksheets] + set worksheet [$worksheets Item [expr 1]] + + set cells [$worksheet Cells] + set i 0 + foreach row {1 2 3} { + foreach column {A B C} { + $cells Item $row $column [incr i] + } + } + + set cellCount 0 + set range [$worksheet Range "A1:C3"] + ::tcom::foreach cell $range { + incr cellCount + } + + $workbook Saved 1 + $application Quit + + set cellCount +} {9} + +::tcltest::cleanupTests +return diff --git a/tests/namedarg.test b/tests/namedarg.test new file mode 100644 index 0000000..6b461d6 --- /dev/null +++ b/tests/namedarg.test @@ -0,0 +1,49 @@ +# $Id: namedarg.test,v 1.1 2002/06/21 02:38:50 cthuang Exp $ +# +# This file contains tests invoking methods through IDispatch with named +# arguments. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +test namedarg-1.1 {named arguments, ChartWizard} { + package require tcom + + set application [::tcom::ref createobject "Excel.Application"] + $application Visible 1 + + set workbooks [$application Workbooks] + set workbook [$workbooks Add] + set worksheets [$workbook Worksheets] + set worksheet [$worksheets Item [expr 1]] + + set cells [$worksheet Cells] + $cells Item 1 A "North" + $cells Item 1 B "South" + $cells Item 1 C "East" + $cells Item 1 D "West" + $cells Item 2 A 5.2 + $cells Item 2 B 10.0 + $cells Item 2 C 8.0 + $cells Item 2 D 20.0 + set sourceRange [$worksheet Range "A1" "D2"] + + set charts [$workbook Charts] + set chart [$charts Add] + $chart -namedarg ChartWizard \ + Source $sourceRange \ + Gallery [expr -4102] \ + PlotBy [expr 1] \ + CategoryLabels [expr 1] \ + SeriesLabels [expr 0] \ + Title "Sales Percentages" + + # Prevent Excel from prompting to save the document on close. + $workbook Saved 1 + $application Quit +} {} + +::tcltest::cleanupTests +return diff --git a/tests/ref.test b/tests/ref.test new file mode 100644 index 0000000..bf28e22 --- /dev/null +++ b/tests/ref.test @@ -0,0 +1,52 @@ +# $Id: ref.test,v 1.2 2002/06/29 15:44:21 cthuang Exp $ +# +# This file contains tests for the ::tcom::ref command. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +test createobject-1.1 {::tcom::ref createobject, Excel} { + package require tcom + + set application [::tcom::ref createobject "Excel.Application"] + $application Visible 1 + + set workbooks [$application Workbooks] + set workbook [$workbooks Add] + set worksheets [$workbook Worksheets] + set worksheet [$worksheets Item [expr 1]] + + set cells [$worksheet Cells] + set i 0 + foreach row {1 2 3} { + foreach column {A B C} { + $cells Item $row $column [incr i] + } + } + + $workbook Saved 1 + $application Quit +} {} + +test createobject-1.2 {::tcom::ref createobject, Banking example server} { + package require tcom + + set bank [::tcom::ref createobject "Banking.Bank"] + set account [$bank CreateAccount] + $account Deposit 30 + $account Withdraw 20 + $account Balance +} {10} + +test getobject-1.1 {::tcom::ref getobject, ADSI} { + package require tcom + + set computerName $env(COMPUTERNAME) + set object [::tcom::ref getobject "WinNT://$computerName,computer"] + $object Class +} {Computer} + +::tcltest::cleanupTests +return