--- /dev/null
+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.
--- /dev/null
+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.
--- /dev/null
+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.
--- /dev/null
+# $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 $@
--- /dev/null
+<?xml version="1.0"?>
+<!-- $Id: article2html.xsl,v 1.11 2002/06/29 15:34:52 cthuang Exp $ -->
+<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform">
+ <xsl:output method="html" encoding="UTF-8"
+ doctype-public="-//W3C//DTD HTML 4.01 Transitional//EN"
+ doctype-system="http://www.w3.org/TR/html4/loose.dtd"/>
+
+ <xsl:template match="article">
+ <html>
+ <head>
+ <title><xsl:value-of select="artheader/title"/></title>
+ <style type="text/css">
+ .command
+ { font-style: normal; font-weight: bold; }
+ .option
+ { font-style: normal; font-weight: bold; }
+ .replaceable
+ { font-style: italic; font-weight: normal; }
+ .listing
+ { font-size: 9pt; }
+ </style>
+ </head>
+ <body>
+ <h1><xsl:value-of select="artheader/title"/></h1>
+ <xsl:apply-templates/>
+ </body>
+ </html>
+ </xsl:template>
+
+ <xsl:template match="artheader"/>
+
+ <xsl:template match="cmdsynopsis">
+ <xsl:apply-templates/>
+ </xsl:template>
+
+ <xsl:template match="arg">
+ <var>
+ <xsl:choose>
+ <xsl:when test="@choice='plain'"></xsl:when>
+ <xsl:otherwise>?</xsl:otherwise>
+ </xsl:choose>
+ <xsl:apply-templates/>
+ <xsl:choose>
+ <xsl:when test="@rep='repeat'"> ...</xsl:when>
+ </xsl:choose>
+ <xsl:choose>
+ <xsl:when test="@choice='plain'"></xsl:when>
+ <xsl:otherwise>?</xsl:otherwise>
+ </xsl:choose>
+ </var>
+ </xsl:template>
+
+ <xsl:template match="option">
+ <code><xsl:apply-templates/></code>
+ </xsl:template>
+
+ <xsl:template match="sect1">
+ <xsl:apply-templates/>
+ </xsl:template>
+
+ <xsl:template match="sect1/title">
+ <h2><xsl:value-of select="text()"/></h2>
+ </xsl:template>
+
+ <xsl:template match="command">
+ <span class="command"><xsl:apply-templates/></span>
+ </xsl:template>
+
+ <xsl:template match="sbr">
+ <br/>
+ </xsl:template>
+
+ <xsl:template match="variablelist">
+ <dl>
+ <xsl:apply-templates/>
+ </dl>
+ </xsl:template>
+
+ <xsl:template match="varlistentry">
+ <xsl:apply-templates/>
+ </xsl:template>
+
+ <xsl:template match="varlistentry/term">
+ <dt><xsl:apply-templates/></dt>
+ </xsl:template>
+
+ <xsl:template match="varlistentry/listitem">
+ <dd><xsl:apply-templates/></dd>
+ </xsl:template>
+
+ <xsl:template match="para">
+ <p><xsl:apply-templates/></p>
+ </xsl:template>
+
+ <xsl:template match="replaceable">
+ <var><xsl:apply-templates/></var>
+ </xsl:template>
+
+ <xsl:template match="literal">
+ <tt><xsl:apply-templates/></tt>
+ </xsl:template>
+
+ <xsl:template match="programlisting">
+ <table bgcolor="#CCCCCC" width="100%"><tr><td><pre class="listing">
+ <xsl:apply-templates/>
+ </pre></td></tr></table>
+ </xsl:template>
+
+ <xsl:template match="screen">
+ <table bgcolor="#FFFFCC" width="100%"><tr><td><pre>
+ <xsl:apply-templates/>
+ </pre></td></tr></table>
+ </xsl:template>
+
+ <xsl:template match="userinput">
+ <kbd><xsl:apply-templates/></kbd>
+ </xsl:template>
+
+ <xsl:template match="mediaobject">
+ <div><xsl:apply-templates/></div>
+ </xsl:template>
+
+ <xsl:template match="imageobject">
+ <xsl:apply-templates/>
+ </xsl:template>
+
+ <xsl:template match="imagedata">
+ <img src="{@fileref}"/>
+ </xsl:template>
+
+ <xsl:template match="*">
+ <font color="red">
+ <xsl:text><</xsl:text>
+ <xsl:value-of select="name(.)"/>
+ <xsl:text>></xsl:text>
+ <xsl:apply-templates/>
+ <xsl:text></</xsl:text>
+ <xsl:value-of select="name(.)"/>
+ <xsl:text>></xsl:text>
+ </font>
+ </xsl:template>
+
+</xsl:stylesheet>
--- /dev/null
+<?xml version="1.0"?>
+<!-- $Id: refentry2html.xsl,v 1.16 2002/06/29 15:34:52 cthuang Exp $ -->
+<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform">
+ <xsl:output method="html" encoding="UTF-8"
+ doctype-public="-//W3C//DTD HTML 4.01 Transitional//EN"
+ doctype-system="http://www.w3.org/TR/html4/loose.dtd"/>
+
+ <xsl:template match="refentry">
+ <html>
+ <head>
+ <title><xsl:value-of select="refnamediv/refname"/></title>
+ <style type="text/css">
+ .command
+ { font-style: normal; font-weight: bold; }
+ .option
+ { font-style: normal; font-weight: bold; }
+ .parameter
+ { font-style: italic; font-weight: normal; }
+ </style>
+ </head>
+ <body>
+ <h2>Name</h2>
+ <p><xsl:value-of select="refnamediv/refname"/> -- <xsl:value-of select="refnamediv/refpurpose"/></p>
+ <xsl:apply-templates/>
+ </body>
+ </html>
+ </xsl:template>
+
+ <xsl:template match="docinfo"/>
+
+ <xsl:template match="refmeta"/>
+
+ <xsl:template match="refnamediv"/>
+
+ <xsl:template match="refsynopsisdiv">
+ <h2>Synopsis</h2>
+ <xsl:apply-templates/>
+ </xsl:template>
+
+ <xsl:template match="cmdsynopsis">
+ <xsl:apply-templates/>
+ </xsl:template>
+
+ <xsl:template match="arg">
+ <var>
+ <xsl:choose>
+ <xsl:when test="@choice='plain'"></xsl:when>
+ <xsl:otherwise>?</xsl:otherwise>
+ </xsl:choose>
+ <xsl:apply-templates/>
+ <xsl:choose>
+ <xsl:when test="@rep='repeat'"> ...</xsl:when>
+ </xsl:choose>
+ <xsl:choose>
+ <xsl:when test="@choice='plain'"></xsl:when>
+ <xsl:otherwise>?</xsl:otherwise>
+ </xsl:choose>
+ </var>
+ </xsl:template>
+
+ <xsl:template match="option">
+ <span class="option"><xsl:apply-templates/></span>
+ </xsl:template>
+
+ <xsl:template match="refsect1">
+ <xsl:apply-templates/>
+ </xsl:template>
+
+ <xsl:template match="refsect1/title">
+ <h2><xsl:value-of select="text()"/></h2>
+ </xsl:template>
+
+ <xsl:template match="refsect2">
+ <xsl:apply-templates/>
+ </xsl:template>
+
+ <xsl:template match="refsect2/title">
+ <h3><xsl:value-of select="text()"/></h3>
+ </xsl:template>
+
+ <xsl:template match="command">
+ <span class="command"><xsl:apply-templates/></span>
+ </xsl:template>
+
+ <xsl:template match="sbr">
+ <br/>
+ </xsl:template>
+
+ <xsl:template match="variablelist">
+ <dl>
+ <xsl:apply-templates/>
+ </dl>
+ </xsl:template>
+
+ <xsl:template match="varlistentry">
+ <xsl:apply-templates/>
+ </xsl:template>
+
+ <xsl:template match="varlistentry/term">
+ <dt><xsl:apply-templates/></dt>
+ </xsl:template>
+
+ <xsl:template match="varlistentry/listitem">
+ <dd><xsl:apply-templates/></dd>
+ </xsl:template>
+
+ <xsl:template match="para">
+ <p><xsl:apply-templates/></p>
+ </xsl:template>
+
+ <xsl:template match="parameter">
+ <var><xsl:apply-templates/></var>
+ </xsl:template>
+
+ <xsl:template match="literal">
+ <tt><xsl:apply-templates/></tt>
+ </xsl:template>
+
+ <xsl:template match="table">
+ <blockquote>
+ <xsl:apply-templates/>
+ </blockquote>
+ </xsl:template>
+
+ <xsl:template match="table/title">
+ <b><xsl:value-of select="."/></b><br/>
+ </xsl:template>
+
+ <xsl:template match="table/tgroup">
+ <table border="1">
+ <xsl:apply-templates/>
+ </table>
+ </xsl:template>
+
+ <xsl:template match="thead">
+ <xsl:apply-templates/>
+ </xsl:template>
+
+ <xsl:template match="tbody">
+ <xsl:apply-templates/>
+ </xsl:template>
+
+ <xsl:template match="row">
+ <tr><xsl:apply-templates/></tr>
+ </xsl:template>
+
+ <xsl:template match="thead/row/entry">
+ <td><b><xsl:value-of select="."/></b></td>
+ </xsl:template>
+
+ <xsl:template match="tbody/row/entry">
+ <td><xsl:value-of select="."/></td>
+ </xsl:template>
+
+ <xsl:template match="programlisting">
+ <table bgcolor="#CCCCCC" width="100%"><tr><td><pre>
+ <xsl:apply-templates/>
+ </pre></td></tr></table>
+ </xsl:template>
+
+ <xsl:template match="*">
+ <font color="red">
+ <xsl:text><</xsl:text>
+ <xsl:value-of select="name(.)"/>
+ <xsl:text>></xsl:text>
+ <xsl:apply-templates/>
+ <xsl:text></</xsl:text>
+ <xsl:value-of select="name(.)"/>
+ <xsl:text>></xsl:text>
+ </font>
+ </xsl:template>
+
+</xsl:stylesheet>
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd"><html>
+<head>
+<META http-equiv="Content-Type" content="text/html; charset=UTF-8">
+<title>COM Object Implementation in Tcl</title>
+<style type="text/css">
+ .command
+ { font-style: normal; font-weight: bold; }
+ .option
+ { font-style: normal; font-weight: bold; }
+ .replaceable
+ { font-style: italic; font-weight: normal; }
+ .listing
+ { font-size: 9pt; }
+ </style>
+</head>
+<body>
+<h1>COM Object Implementation in Tcl</h1>
+
+
+ <h2>Introduction</h2>
+ <p>This article shows by example how to implement COM objects in
+ Tcl with the <span class="command">tcom</span> extension. It shows how an object
+ can be implemented by an [incr Tcl] class or in just plain Tcl.
+ </p>
+ <div>
+
+ <img src="bankingClassDiagram.png">
+
+ </div>
+ <p>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.
+ </p>
+
+
+ <h2>Write MIDL Specification</h2>
+ <p> The file <tt>Banking.idl</tt> contains the MIDL
+ specification for the COM interfaces and classes. The interfaces can be
+ declared <tt>dual</tt> because <span class="command">tcom</span> can
+ implement objects whose operations are invoked through the IDispatch
+ interface or the virtual function table.</p>
+ <table bgcolor="#CCCCCC" width="100%"><tr><td><pre class="listing">
+
+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;
+ };
+};
+</pre></td></tr></table>
+
+
+ <h2>Create Type Library</h2>
+ <p>Run this command to generate a type library file
+ <tt>Banking.tlb</tt> from the MIDL specification.</p>
+ <table bgcolor="#FFFFCC" width="100%"><tr><td><pre>
+
+<kbd>midl Banking.idl</kbd>
+</pre></td></tr></table>
+
+
+ <h2>Create Tcl Package</h2>
+ <p>The <span class="command">tcom</span> 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.</p>
+
+ <p>Create a directory for the package by making a subdirectory named
+ <tt>Banking</tt> under one of the directories in the
+ <tt>auto_path</tt> variable. Create a
+ <tt>pkgIndex.tcl</tt> file in the package directory.</p>
+<table bgcolor="#CCCCCC" width="100%"><tr><td><pre class="listing">
+
+package ifneeded Banking 1.0 [list source [file join $dir server.itcl]]
+</pre></td></tr></table>
+
+ <p>Copy the <tt>Banking.tlb</tt> type library file into the
+ package directory.</p>
+
+ <p>Create the following <tt>server.itcl</tt> file in the package
+ directory. This file defines [incr Tcl] classes that implement the
+ IBank and IAccount interfaces.</p>
+
+ <table bgcolor="#CCCCCC" width="100%"><tr><td><pre class="listing">
+
+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
+</pre></td></tr></table>
+
+ <p>On line 1, the <span class="command">::tcom::object create</span> 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 <tt>_get_</tt>
+ and <tt>_set_</tt> to the property name. When the last reference
+ to the COM object is released, <span class="command">tcom</span> invokes the
+ <tt>delete object</tt> command with the [incr Tcl] object handle as
+ an additional argument to clean up the [incr Tcl] object.</p>
+
+ <p>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 <tt>BankImpl
+ #auto</tt> command which creates a BankImpl [incr Tcl] object and
+ returns a handle to that object. To clean up when the COM object is
+ destroyed, <span class="command">tcom</span> invokes the <tt>delete
+ object</tt> command with the [incr Tcl] object handle as an additional
+ argument.</p>
+
+
+ <h2>Register Server</h2>
+ <p>Run these Tcl commands to create entries in the Windows registry
+ required by COM and the <span class="command">tcom</span> server implementation.
+ </p>
+ <table bgcolor="#FFFFCC" width="100%"><tr><td><pre>
+
+<kbd>package require tcom</kbd>
+<kbd>::tcom::server register Banking.tlb</kbd>
+</pre></td></tr></table>
+
+
+ <h2>Implement Client</h2>
+ <p>The <tt>client.tcl</tt> 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.</p>
+ <table bgcolor="#CCCCCC" width="100%"><tr><td><pre class="listing">
+
+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]
+</pre></td></tr></table>
+
+
+ <h2>Implement Objects In Plain Tcl</h2>
+ <p>You can implement objects in plain Tcl. The servant command passed to
+ the <span class="command">::tcom::object create</span> command can be the name of any
+ object-style command. Similarly, the factory command passed to the
+ <span class="command">::tcom::object registerfactory</span> command can return the
+ name of any object-style command. The following Tcl script defines the
+ procedures <tt>accountImpl</tt> and <tt>bankImpl</tt>,
+ which have parameters in the style of a method name followed by any
+ arguments.</p>
+ <table bgcolor="#CCCCCC" width="100%"><tr><td><pre class="listing">
+
+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}
+</pre></td></tr></table>
+
+</body>
+</html>
--- /dev/null
+<?xml version="1.0"?>
+<!-- $Id: server.xml,v 1.23 2002/06/29 15:34:52 cthuang Exp $ -->
+<!DOCTYPE article PUBLIC "-//OASIS//DTD DocBook XML V4.1.2//EN" "docbookx.dtd">
+<article>
+ <artheader>
+ <date>$Date: 2002/06/29 15:34:52 $</date>
+ <releaseinfo>$Revision: 1.23 $</releaseinfo>
+ <title>COM Object Implementation in Tcl</title>
+ </artheader>
+ <sect1>
+ <title>Introduction</title>
+ <para>This article shows by example how to implement COM objects in
+ Tcl with the <command>tcom</command> extension. It shows how an object
+ can be implemented by an [incr Tcl] class or in just plain Tcl.
+ </para>
+ <mediaobject>
+ <imageobject>
+ <imagedata fileref="bankingClassDiagram.png" format="PNG"/>
+ </imageobject>
+ </mediaobject>
+ <para>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.
+ </para>
+ </sect1>
+ <sect1>
+ <title>Write MIDL Specification</title>
+ <para> The file <literal>Banking.idl</literal> contains the MIDL
+ specification for the COM interfaces and classes. The interfaces can be
+ declared <literal>dual</literal> because <command>tcom</command> can
+ implement objects whose operations are invoked through the IDispatch
+ interface or the virtual function table.</para>
+ <programlisting>
+
+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;
+ };
+};
+</programlisting>
+ </sect1>
+ <sect1>
+ <title>Create Type Library</title>
+ <para>Run this command to generate a type library file
+ <literal>Banking.tlb</literal> from the MIDL specification.</para>
+ <screen>
+
+<userinput>midl Banking.idl</userinput>
+</screen>
+ </sect1>
+ <sect1>
+ <title>Create Tcl Package</title>
+ <para>The <command>tcom</command> 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.</para>
+
+ <para>Create a directory for the package by making a subdirectory named
+ <literal>Banking</literal> under one of the directories in the
+ <literal>auto_path</literal> variable. Create a
+ <literal>pkgIndex.tcl</literal> file in the package directory.</para>
+<programlisting>
+
+package ifneeded Banking 1.0 [list source [file join $dir server.itcl]]
+</programlisting>
+
+ <para>Copy the <literal>Banking.tlb</literal> type library file into the
+ package directory.</para>
+
+ <para>Create the following <literal>server.itcl</literal> file in the package
+ directory. This file defines [incr Tcl] classes that implement the
+ IBank and IAccount interfaces.</para>
+
+ <programlisting>
+
+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
+</programlisting>
+
+ <para>On line 1, the <command>::tcom::object create</command> 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 <literal>_get_</literal>
+ and <literal>_set_</literal> to the property name. When the last reference
+ to the COM object is released, <command>tcom</command> invokes the
+ <literal>delete object</literal> command with the [incr Tcl] object handle as
+ an additional argument to clean up the [incr Tcl] object.</para>
+
+ <para>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 <literal>BankImpl
+ #auto</literal> command which creates a BankImpl [incr Tcl] object and
+ returns a handle to that object. To clean up when the COM object is
+ destroyed, <command>tcom</command> invokes the <literal>delete
+ object</literal> command with the [incr Tcl] object handle as an additional
+ argument.</para>
+ </sect1>
+ <sect1>
+ <title>Register Server</title>
+ <para>Run these Tcl commands to create entries in the Windows registry
+ required by COM and the <command>tcom</command> server implementation.
+ </para>
+ <screen>
+
+<userinput>package require tcom</userinput>
+<userinput>::tcom::server register Banking.tlb</userinput>
+</screen>
+ </sect1>
+ <sect1>
+ <title>Implement Client</title>
+ <para>The <literal>client.tcl</literal> 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.</para>
+ <programlisting>
+
+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]
+</programlisting>
+ </sect1>
+ <sect1>
+ <title>Implement Objects In Plain Tcl</title>
+ <para>You can implement objects in plain Tcl. The servant command passed to
+ the <command>::tcom::object create</command> command can be the name of any
+ object-style command. Similarly, the factory command passed to the
+ <command>::tcom::object registerfactory</command> command can return the
+ name of any object-style command. The following Tcl script defines the
+ procedures <literal>accountImpl</literal> and <literal>bankImpl</literal>,
+ which have parameters in the style of a method name followed by any
+ arguments.</para>
+ <programlisting>
+
+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}
+</programlisting>
+ </sect1>
+</article>
--- /dev/null
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd"><html>
+<head>
+<META http-equiv="Content-Type" content="text/html; charset=UTF-8">
+<title>tcom</title>
+<style type="text/css">
+ .command
+ { font-style: normal; font-weight: bold; }
+ .option
+ { font-style: normal; font-weight: bold; }
+ .parameter
+ { font-style: italic; font-weight: normal; }
+ </style>
+</head>
+<body>
+<h2>Name</h2>
+<p>tcom -- Access COM objects from Tcl</p>
+
+
+
+ <h2>Synopsis</h2>
+
+ <span class="command">package require tcom</span>
+ <var>?<span class="option">3.8</span>?</var>
+ <br>
+ <span class="command">::tcom::ref</span>
+ <span class="command">createobject</span>
+ <var>?<span class="option">-inproc</span>?</var>
+ <var>?<span class="option">-local</span>?</var>
+ <var>?<span class="option">-remote</span>?</var>
+ <var>?<span class="option">-clsid</span>?</var>
+ <var>progID</var>
+ <var>?hostName?</var>
+ <br>
+ <span class="command">::tcom::ref</span>
+ <span class="command">getactiveobject</span>
+ <var>?<span class="option">-clsid</span>?</var>
+ <var>progID</var>
+ <br>
+ <span class="command">::tcom::ref</span>
+ <span class="command">getobject</span>
+ <var>pathName</var>
+ <br>
+ <span class="command">::tcom::ref</span>
+ <span class="command">equal</span>
+ <var>handle1</var>
+ <var>handle2</var>
+ <br>
+ <var>handle</var>
+ <var>?<span class="option">-method</span>?</var>
+ <var>method</var>
+ <var>?argument ...?</var>
+ <br>
+ <var>handle</var>
+ <var><span class="option">-namedarg</span></var>
+ <var>method</var>
+ <var>?argumentName argumentValue ...?</var>
+ <br>
+ <var>handle</var>
+ <var>?<span class="option">-get</span>?</var>
+ <var>?<span class="option">-set</span>?</var>
+ <var>property</var>
+ <var>?index ...?</var>
+ <var>?value?</var>
+ <br>
+ <span class="command">::tcom::foreach</span>
+ <var>varname</var>
+ <var>collectionHandle</var>
+ <var>body</var>
+ <br>
+ <span class="command">::tcom::foreach</span>
+ <var>varlist</var>
+ <var>collectionHandle</var>
+ <var>body</var>
+ <br>
+ <span class="command">::tcom::bind</span>
+ <var>handle</var>
+ <var>command</var>
+ <var>?eventIID?</var>
+ <br>
+ <span class="command">::tcom::unbind</span>
+ <var>handle</var>
+ <br>
+ <span class="command">::tcom::na</span>
+ <br>
+ <span class="command">::tcom::info interface</span>
+ <var>handle</var>
+ <br>
+ <span class="command">::tcom::configure</span>
+ <var>name</var>
+ <var>?value?</var>
+ <br>
+ <span class="command">::tcom::import</span>
+ <var>typeLibrary</var>
+ <var>?namespace?</var>
+ <br>
+
+
+
+ <h2>Description</h2>
+ <p>The <span class="command">tcom</span> package provides commands to access COM
+ objects through IDispatch and IUnknown derived interfaces.</p>
+
+
+ <h2>Commands</h2>
+ <dl>
+
+ <dt>
+
+ <span class="command">::tcom::ref</span>
+ <span class="command">createobject</span>
+ <var>?<span class="option">-inproc</span>?</var>
+ <var>?<span class="option">-local</span>?</var>
+ <var>?<span class="option">-remote</span>?</var>
+ <var>?<span class="option">-clsid</span>?</var>
+ <var>progID</var>
+ <var>?hostName?</var>
+ <br>
+ <span class="command">::tcom::ref</span>
+ <span class="command">getactiveobject</span>
+ <var>?<span class="option">-clsid</span>?</var>
+ <var>progID</var>
+
+ </dt>
+ <dd>
+ <p>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.
+ </p>
+ <p>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.</p>
+ <p>The <span class="command">createobject</span> subcommand creates an instance
+ of the object. The <span class="option">-inproc</span> option requests the object be
+ created in the same process. The <span class="option">-local</span> option requests
+ the object be created in another process on the local machine. The
+ <span class="option">-remote</span> option requests the object be created on a remote
+ machine. The <var>progID</var> parameter is the programmatic
+ identifier of the object class. Use the <span class="option">-clsid</span> option if
+ you want to specify the class using a class ID instead. The
+ <var>hostName</var> parameter specifies the machine where you
+ want to create the object instance.</p>
+ <p>The <span class="command">getactiveobject</span> subcommand gets a reference
+ to an already existing object.</p>
+ </dd>
+
+
+ <dt>
+
+ <span class="command">::tcom::ref</span>
+ <span class="command">getobject</span>
+ <var>pathName</var>
+
+ </dt>
+ <dd>
+ <p>This command returns a reference to a COM object from a file. The
+ <var>pathName</var> parameter is the full path and name of the
+ file containing the object.</p>
+ </dd>
+
+
+ <dt>
+
+ <span class="command">::tcom::ref</span>
+ <span class="command">equal</span>
+ <var>handle1</var>
+ <var>handle2</var>
+
+ </dt>
+ <dd>
+ <p>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.</p>
+ </dd>
+
+
+ <dt>
+
+ <var>handle</var>
+ <var>?<span class="option">-method</span>?</var>
+ <var>method</var>
+ <var>?argument ...?</var>
+
+ </dt>
+ <dd>
+ <p>This command invokes a method on the object represented by the
+ <var>handle</var>. 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
+ <span class="command">tcom</span> cannot get information about the object's
+ interface, you may have to use the <span class="option">-method</span> option to
+ specify you want to invoke a method.</p>
+ </dd>
+
+
+ <dt>
+
+ <var>handle</var>
+ <var><span class="option">-namedarg</span></var>
+ <var>method</var>
+ <var>?argumentName argumentValue ...?</var>
+
+ </dt>
+ <dd>
+ <p>Use the <span class="option">-namedarg</span> 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.</p>
+ </dd>
+
+
+ <dt>
+
+ <var>handle</var>
+ <var>?<span class="option">-get</span>?</var>
+ <var>?<span class="option">-set</span>?</var>
+ <var>property</var>
+ <var>?index ...?</var>
+ <var>?value?</var>
+
+ </dt>
+ <dd>
+ <p>This command gets or sets a property of the object represented by
+ the <var>handle</var>. If you supply a
+ <var>value</var> 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
+ <var>index</var> 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
+ <span class="command">tcom</span> cannot get information about the object's
+ interface, you may have to use the <span class="option">-get</span> or
+ <span class="option">-set</span> option to specify you want to get or set a property
+ respectively.</p>
+ </dd>
+
+
+ <dt>
+
+ <span class="command">::tcom::foreach</span>
+ <var>varname</var>
+ <var>collectionHandle</var>
+ <var>body</var>
+ <br>
+ <span class="command">::tcom::foreach</span>
+ <var>varlist</var>
+ <var>collectionHandle</var>
+ <var>body</var>
+
+ </dt>
+ <dd>
+ <p>This command implements a loop where the loop variable(s) take on
+ values from a collection object represented by
+ <var>collectionHandle</var>. In the simplest case, there
+ is one loop variable, <var>varname</var>. The
+ <var>body</var> argument is a Tcl script. For each
+ element of the collection, the command assigns the contents of the element
+ to <var>varname</var>, then calls the Tcl interpreter to
+ execute <var>body</var>.</p>
+ <p>In the general case, there can be more than one loop variable.
+ During each iteration of the loop, the variables of
+ <var>varlist</var> 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.</p>
+ <p>The <span class="command">break</span> and <span class="command">continue</span>
+ statements may be invoked inside <var>body</var>, with the
+ same effect as in the <span class="command">for</span> command. The
+ <span class="command">::tcom::foreach</span> command returns an empty string.</p>
+ </dd>
+
+
+ <dt>
+
+ <span class="command">::tcom::bind</span>
+ <var>handle</var>
+ <var>command</var>
+ <var>?eventIID?</var>
+
+ </dt>
+ <dd>
+ <p>This command specifies a Tcl command that will be executed when
+ events are received from an object. The
+ <var>command</var> will be called with additional
+ arguments: the event name and the event arguments. By default, the event
+ interface is the default event source interface of the object's class.
+ Use the <var>eventIID</var> parameter to specify the IID
+ of another event interface.</p>
+ </dd>
+
+
+ <dt>
+
+ <span class="command">::tcom::unbind</span>
+ <var>handle</var>
+
+ </dt>
+ <dd>
+ <p>This command tears down all event connections to the object that
+ were set up by the <span class="command">::tcom::bind</span> command.</p>
+ </dd>
+
+
+ <dt>
+
+ <span class="command">::tcom::na</span>
+
+ </dt>
+ <dd>
+ <p>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.</p>
+ </dd>
+
+
+ <dt>
+
+ <span class="command">::tcom::info interface</span>
+ <var>handle</var>
+
+ </dt>
+ <dd>
+ <p>This command returns a handle representing a description of the
+ interface exposed by the object. The handle supports the following
+ commands.</p>
+ <dl>
+
+ <dt>
+
+ <var>interfaceHandle</var>
+ <span class="command">iid</span>
+
+ </dt>
+ <dd>
+ <p>This command returns an interface identifier code.</p>
+ </dd>
+
+
+ <dt>
+
+ <var>interfaceHandle</var>
+ <span class="command">methods</span>
+
+ </dt>
+ <dd>
+ <p>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.</p>
+ </dd>
+
+
+ <dt>
+
+ <var>interfaceHandle</var>
+ <span class="command">name</span>
+
+ </dt>
+ <dd>
+ <p>This command returns the interface's name.</p>
+ </dd>
+
+
+ <dt>
+
+ <var>interfaceHandle</var>
+ <span class="command">properties</span>
+
+ </dt>
+ <dd>
+ <p>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.</p>
+ </dd>
+
+ </dl>
+ </dd>
+
+
+ <dt>
+
+ <span class="command">::tcom::configure</span>
+ <var>name</var>
+ <var>?value?</var>
+
+ </dt>
+ <dd>
+ <p>This command sets and retrieves options for the package. If
+ <var>name</var> is supplied but no
+ <var>value</var> then the command returns the current
+ value of the given option. If one or more pairs of
+ <var>name</var> and <var>value</var> are
+ supplied, the command sets each of the named options to the corresponding
+ value; in this case the return value is an empty string.</p>
+ <dl>
+
+ <dt>
+
+ <var><span class="option">-concurrency</span></var>
+ <var>?concurrencyModel?</var>
+
+ </dt>
+ <dd>
+ <p>This option sets the concurrency model, which can be
+ <span class="option">apartmentthreaded</span> or <span class="option">multithreaded</span>.
+ The default is <span class="option">apartmentthreaded</span>. 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.</p>
+ </dd>
+
+ </dl>
+ </dd>
+
+ </dl>
+
+
+ <h2>Importing Type Library Information</h2>
+
+ <span class="command">::tcom::import</span>
+ <var>typeLibrary</var>
+ <var>?namespace?</var>
+
+ <p>Use the <span class="command">::tcom::import</span> command to convert type
+ information from a type library into Tcl commands to access COM classes and
+ interfaces. The <var>typeLibrary</var> 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
+ <var>namespace</var> argument. This command returns the
+ library name stored in the type library file.</p>
+
+ <h3>Commands</h3>
+ <dl>
+
+ <dt>
+
+ <var>class</var>
+ <var>?<span class="option">-inproc</span>?</var>
+ <var>?<span class="option">-local</span>?</var>
+ <var>?<span class="option">-remote</span>?</var>
+ <var>?hostName?</var>
+
+ </dt>
+ <dd>
+ <p>For each class in the type library,
+ <span class="command">::tcom::import</span> 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 <var>hostName</var> 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.</p>
+ </dd>
+
+
+ <dt>
+
+ <var>interface</var>
+ <var>handle</var>
+
+ </dt>
+ <dd>
+ <p>For each interface in the type library,
+ <span class="command">::tcom::import</span> defines a Tcl command with the same
+ name as the interface. The interface command queries the object
+ represented by <var>handle</var> 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.</p>
+ </dd>
+
+ </dl>
+
+
+ <h3>Enumerations</h3>
+ <p>The <span class="command">::tcom::import</span> 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.</p>
+
+
+
+ <h2>Tcl Value to VARIANT Mapping</h2>
+ <p>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.</p>
+ <p>When invoking COM object methods, <span class="command">tcom</span> tries to
+ convert each Tcl argument to the parameter type specified by the method
+ interface. For example, if a method accepts an <tt>int</tt>
+ parameter, <span class="command">tcom</span> 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.</p>
+ <p><span class="command">Tcom</span> uses the Tcl value's internal representation
+ type as a hint to choose the resulting VARIANT type.</p>
+ <blockquote>
+ <b>Tcl value to VARIANT mapping</b><br>
+ <table border="1">
+
+ <tr>
+ <td><b>Tcl internal representation</b></td>
+ <td><b>VARIANT type</b></td>
+ </tr>
+
+
+ <tr>
+ <td>boolean</td>
+ <td>VT_BOOL</td>
+ </tr>
+ <tr>
+ <td>int</td>
+ <td>VT_I4</td>
+ </tr>
+ <tr>
+ <td>double</td>
+ <td>VT_R8</td>
+ </tr>
+ <tr>
+ <td>list</td>
+ <td>one-dimensional array of VT_VARIANT</td>
+ </tr>
+ <tr>
+ <td>bytearray</td>
+ <td>one-dimensional array of VT_UI1</td>
+ </tr>
+ <tr>
+ <td>other</td>
+ <td>VT_BSTR</td>
+ </tr>
+
+ </table>
+ </blockquote>
+
+ <h3>Invoking Methods With VARIANT Parameters</h3>
+ <p>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 <span class="command">Item</span> 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.</p>
+ <table bgcolor="#CCCCCC" width="100%"><tr><td><pre>
+
+# Assume $collection is a handle to a collection.
+set element [$collection Item 1]
+</pre></td></tr></table>
+ <p>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.</p>
+<table bgcolor="#CCCCCC" width="100%"><tr><td><pre>
+
+set numElements [$collection Count]
+for {set i 1} {$i <= $numElements} {incr i} { ;# 1
+ set element [$collection Item $i] ;# 2
+}
+</pre></td></tr></table>
+ <p>In line 1, the <span class="command">for</span> command sets the internal
+ representation of <tt>$i</tt> to an int type as a side effect of
+ evaluating the condition expression <tt>{$i <=
+ $numElements}</tt>. The command in line 2 passes the integer value in
+ <tt>$i</tt> to the Item method, which should succeed if the method
+ can handle integer index values.</p>
+
+
+</body>
+</html>
--- /dev/null
+<?xml version="1.0"?>
+<!-- $Id: tcom.n.xml,v 1.63 2002/04/12 23:44:50 cthuang Exp $ -->
+<!DOCTYPE refentry PUBLIC "-//OASIS//DTD DocBook XML V4.1.2//EN" "docbookx.dtd">
+<refentry id="tcom">
+ <docinfo>
+ <date>$Date: 2002/04/12 23:44:50 $</date>
+ <releaseinfo>$Revision: 1.63 $</releaseinfo>
+ </docinfo>
+ <refmeta>
+ <refentrytitle>tcom</refentrytitle>
+ <manvolnum>n</manvolnum>
+ </refmeta>
+ <refnamediv>
+ <refname>tcom</refname>
+ <refpurpose>Access COM objects from Tcl</refpurpose>
+ </refnamediv>
+ <refsynopsisdiv>
+ <cmdsynopsis>
+ <command>package require tcom</command>
+ <arg><option>3.8</option></arg>
+ <sbr/>
+ <command>::tcom::ref</command>
+ <command>createobject</command>
+ <arg><option>-inproc</option></arg>
+ <arg><option>-local</option></arg>
+ <arg><option>-remote</option></arg>
+ <arg><option>-clsid</option></arg>
+ <arg choice="plain">progID</arg>
+ <arg>hostName</arg>
+ <sbr/>
+ <command>::tcom::ref</command>
+ <command>getactiveobject</command>
+ <arg><option>-clsid</option></arg>
+ <arg choice="plain">progID</arg>
+ <sbr/>
+ <command>::tcom::ref</command>
+ <command>getobject</command>
+ <arg choice="plain">pathName</arg>
+ <sbr/>
+ <command>::tcom::ref</command>
+ <command>equal</command>
+ <arg choice="plain">handle1</arg>
+ <arg choice="plain">handle2</arg>
+ <sbr/>
+ <arg choice="plain">handle</arg>
+ <arg><option>-method</option></arg>
+ <arg choice="plain">method</arg>
+ <arg rep="repeat">argument</arg>
+ <sbr/>
+ <arg choice="plain">handle</arg>
+ <arg choice="plain"><option>-namedarg</option></arg>
+ <arg choice="plain">method</arg>
+ <arg rep="repeat">argumentName argumentValue</arg>
+ <sbr/>
+ <arg choice="plain">handle</arg>
+ <arg><option>-get</option></arg>
+ <arg><option>-set</option></arg>
+ <arg choice="plain">property</arg>
+ <arg rep="repeat">index</arg>
+ <arg>value</arg>
+ <sbr/>
+ <command>::tcom::foreach</command>
+ <arg choice="plain">varname</arg>
+ <arg choice="plain">collectionHandle</arg>
+ <arg choice="plain">body</arg>
+ <sbr/>
+ <command>::tcom::foreach</command>
+ <arg choice="plain">varlist</arg>
+ <arg choice="plain">collectionHandle</arg>
+ <arg choice="plain">body</arg>
+ <sbr/>
+ <command>::tcom::bind</command>
+ <arg choice="plain">handle</arg>
+ <arg choice="plain">command</arg>
+ <arg>eventIID</arg>
+ <sbr/>
+ <command>::tcom::unbind</command>
+ <arg choice="plain">handle</arg>
+ <sbr/>
+ <command>::tcom::na</command>
+ <sbr/>
+ <command>::tcom::info interface</command>
+ <arg choice="plain">handle</arg>
+ <sbr/>
+ <command>::tcom::configure</command>
+ <arg choice="plain">name</arg>
+ <arg>value</arg>
+ <sbr/>
+ <command>::tcom::import</command>
+ <arg choice="plain">typeLibrary</arg>
+ <arg>namespace</arg>
+ <sbr/>
+ </cmdsynopsis>
+ </refsynopsisdiv>
+ <refsect1 id="description">
+ <title>Description</title>
+ <para>The <command>tcom</command> package provides commands to access COM
+ objects through IDispatch and IUnknown derived interfaces.</para>
+ </refsect1>
+ <refsect1 id="commands">
+ <title>Commands</title>
+ <variablelist>
+ <varlistentry>
+ <term>
+ <cmdsynopsis id="ref_createobject">
+ <command>::tcom::ref</command>
+ <command>createobject</command>
+ <arg><option>-inproc</option></arg>
+ <arg><option>-local</option></arg>
+ <arg><option>-remote</option></arg>
+ <arg><option>-clsid</option></arg>
+ <arg choice="plain">progID</arg>
+ <arg>hostName</arg>
+ <sbr/>
+ <command>::tcom::ref</command>
+ <command>getactiveobject</command>
+ <arg><option>-clsid</option></arg>
+ <arg choice="plain">progID</arg>
+ </cmdsynopsis>
+ </term>
+ <listitem>
+ <para>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.
+ </para>
+ <para>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.</para>
+ <para>The <command>createobject</command> subcommand creates an instance
+ of the object. The <option>-inproc</option> option requests the object be
+ created in the same process. The <option>-local</option> option requests
+ the object be created in another process on the local machine. The
+ <option>-remote</option> option requests the object be created on a remote
+ machine. The <parameter>progID</parameter> parameter is the programmatic
+ identifier of the object class. Use the <option>-clsid</option> option if
+ you want to specify the class using a class ID instead. The
+ <parameter>hostName</parameter> parameter specifies the machine where you
+ want to create the object instance.</para>
+ <para>The <command>getactiveobject</command> subcommand gets a reference
+ to an already existing object.</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term>
+ <cmdsynopsis id="ref_getobject">
+ <command>::tcom::ref</command>
+ <command>getobject</command>
+ <arg choice="plain">pathName</arg>
+ </cmdsynopsis>
+ </term>
+ <listitem>
+ <para>This command returns a reference to a COM object from a file. The
+ <parameter>pathName</parameter> parameter is the full path and name of the
+ file containing the object.</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term>
+ <cmdsynopsis id="ref_equal">
+ <command>::tcom::ref</command>
+ <command>equal</command>
+ <arg choice="plain">handle1</arg>
+ <arg choice="plain">handle2</arg>
+ </cmdsynopsis>
+ </term>
+ <listitem>
+ <para>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.</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term>
+ <cmdsynopsis id="handle_method">
+ <arg choice="plain">handle</arg>
+ <arg><option>-method</option></arg>
+ <arg choice="plain">method</arg>
+ <arg rep="repeat">argument</arg>
+ </cmdsynopsis>
+ </term>
+ <listitem>
+ <para>This command invokes a method on the object represented by the
+ <parameter>handle</parameter>. 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
+ <command>tcom</command> cannot get information about the object's
+ interface, you may have to use the <option>-method</option> option to
+ specify you want to invoke a method.</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term>
+ <cmdsynopsis id="namedarg">
+ <arg choice="plain">handle</arg>
+ <arg choice="plain"><option>-namedarg</option></arg>
+ <arg choice="plain">method</arg>
+ <arg rep="repeat">argumentName argumentValue</arg>
+ </cmdsynopsis>
+ </term>
+ <listitem>
+ <para>Use the <option>-namedarg</option> 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.</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term>
+ <cmdsynopsis id="handle_property">
+ <arg choice="plain">handle</arg>
+ <arg><option>-get</option></arg>
+ <arg><option>-set</option></arg>
+ <arg choice="plain">property</arg>
+ <arg rep="repeat">index</arg>
+ <arg>value</arg>
+ </cmdsynopsis>
+ </term>
+ <listitem>
+ <para>This command gets or sets a property of the object represented by
+ the <parameter>handle</parameter>. If you supply a
+ <parameter>value</parameter> 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
+ <parameter>index</parameter> 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
+ <command>tcom</command> cannot get information about the object's
+ interface, you may have to use the <option>-get</option> or
+ <option>-set</option> option to specify you want to get or set a property
+ respectively.</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term>
+ <cmdsynopsis id="foreach">
+ <command>::tcom::foreach</command>
+ <arg choice="plain">varname</arg>
+ <arg choice="plain">collectionHandle</arg>
+ <arg choice="plain">body</arg>
+ <sbr/>
+ <command>::tcom::foreach</command>
+ <arg choice="plain">varlist</arg>
+ <arg choice="plain">collectionHandle</arg>
+ <arg choice="plain">body</arg>
+ </cmdsynopsis>
+ </term>
+ <listitem>
+ <para>This command implements a loop where the loop variable(s) take on
+ values from a collection object represented by
+ <parameter>collectionHandle</parameter>. In the simplest case, there
+ is one loop variable, <parameter>varname</parameter>. The
+ <parameter>body</parameter> argument is a Tcl script. For each
+ element of the collection, the command assigns the contents of the element
+ to <parameter>varname</parameter>, then calls the Tcl interpreter to
+ execute <parameter>body</parameter>.</para>
+ <para>In the general case, there can be more than one loop variable.
+ During each iteration of the loop, the variables of
+ <parameter>varlist</parameter> 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.</para>
+ <para>The <command>break</command> and <command>continue</command>
+ statements may be invoked inside <parameter>body</parameter>, with the
+ same effect as in the <command>for</command> command. The
+ <command>::tcom::foreach</command> command returns an empty string.</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term>
+ <cmdsynopsis id="bind">
+ <command>::tcom::bind</command>
+ <arg choice="plain">handle</arg>
+ <arg choice="plain">command</arg>
+ <arg>eventIID</arg>
+ </cmdsynopsis>
+ </term>
+ <listitem>
+ <para>This command specifies a Tcl command that will be executed when
+ events are received from an object. The
+ <parameter>command</parameter> will be called with additional
+ arguments: the event name and the event arguments. By default, the event
+ interface is the default event source interface of the object's class.
+ Use the <parameter>eventIID</parameter> parameter to specify the IID
+ of another event interface.</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term>
+ <cmdsynopsis id="unbind">
+ <command>::tcom::unbind</command>
+ <arg choice="plain">handle</arg>
+ </cmdsynopsis>
+ </term>
+ <listitem>
+ <para>This command tears down all event connections to the object that
+ were set up by the <command>::tcom::bind</command> command.</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term>
+ <cmdsynopsis id="na">
+ <command>::tcom::na</command>
+ </cmdsynopsis>
+ </term>
+ <listitem>
+ <para>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.</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term>
+ <cmdsynopsis id="info">
+ <command>::tcom::info interface</command>
+ <arg choice="plain">handle</arg>
+ </cmdsynopsis>
+ </term>
+ <listitem>
+ <para>This command returns a handle representing a description of the
+ interface exposed by the object. The handle supports the following
+ commands.</para>
+ <variablelist>
+ <varlistentry>
+ <term>
+ <cmdsynopsis id="interface_iid">
+ <arg choice="plain">interfaceHandle</arg>
+ <command>iid</command>
+ </cmdsynopsis>
+ </term>
+ <listitem>
+ <para>This command returns an interface identifier code.</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term>
+ <cmdsynopsis id="interface_methods">
+ <arg choice="plain">interfaceHandle</arg>
+ <command>methods</command>
+ </cmdsynopsis>
+ </term>
+ <listitem>
+ <para>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.</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term>
+ <cmdsynopsis id="interface_name">
+ <arg choice="plain">interfaceHandle</arg>
+ <command>name</command>
+ </cmdsynopsis>
+ </term>
+ <listitem>
+ <para>This command returns the interface's name.</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term>
+ <cmdsynopsis id="interface_properties">
+ <arg choice="plain">interfaceHandle</arg>
+ <command>properties</command>
+ </cmdsynopsis>
+ </term>
+ <listitem>
+ <para>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.</para>
+ </listitem>
+ </varlistentry>
+ </variablelist>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term>
+ <cmdsynopsis id="configure">
+ <command>::tcom::configure</command>
+ <arg choice="plain">name</arg>
+ <arg>value</arg>
+ </cmdsynopsis>
+ </term>
+ <listitem>
+ <para>This command sets and retrieves options for the package. If
+ <parameter>name</parameter> is supplied but no
+ <parameter>value</parameter> then the command returns the current
+ value of the given option. If one or more pairs of
+ <parameter>name</parameter> and <parameter>value</parameter> are
+ supplied, the command sets each of the named options to the corresponding
+ value; in this case the return value is an empty string.</para>
+ <variablelist>
+ <varlistentry>
+ <term>
+ <cmdsynopsis id="configure_concurrency">
+ <arg choice="plain"><option>-concurrency</option></arg>
+ <arg>concurrencyModel</arg>
+ </cmdsynopsis>
+ </term>
+ <listitem>
+ <para>This option sets the concurrency model, which can be
+ <option>apartmentthreaded</option> or <option>multithreaded</option>.
+ The default is <option>apartmentthreaded</option>. 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.</para>
+ </listitem>
+ </varlistentry>
+ </variablelist>
+ </listitem>
+ </varlistentry>
+ </variablelist>
+ </refsect1>
+ <refsect1 id="typelib">
+ <title>Importing Type Library Information</title>
+ <cmdsynopsis id="import">
+ <command>::tcom::import</command>
+ <arg choice="plain">typeLibrary</arg>
+ <arg>namespace</arg>
+ </cmdsynopsis>
+ <para>Use the <command>::tcom::import</command> command to convert type
+ information from a type library into Tcl commands to access COM classes and
+ interfaces. The <parameter>typeLibrary</parameter> 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
+ <parameter>namespace</parameter> argument. This command returns the
+ library name stored in the type library file.</para>
+ <refsect2 id="import_commands">
+ <title>Commands</title>
+ <variablelist>
+ <varlistentry>
+ <term>
+ <cmdsynopsis id="import_class">
+ <arg choice="plain">class</arg>
+ <arg><option>-inproc</option></arg>
+ <arg><option>-local</option></arg>
+ <arg><option>-remote</option></arg>
+ <arg>hostName</arg>
+ </cmdsynopsis>
+ </term>
+ <listitem>
+ <para>For each class in the type library,
+ <command>::tcom::import</command> 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 <parameter>hostName</parameter> 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.</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term>
+ <cmdsynopsis id="import_interface">
+ <arg choice="plain">interface</arg>
+ <arg choice="plain">handle</arg>
+ </cmdsynopsis>
+ </term>
+ <listitem>
+ <para>For each interface in the type library,
+ <command>::tcom::import</command> defines a Tcl command with the same
+ name as the interface. The interface command queries the object
+ represented by <parameter>handle</parameter> 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.</para>
+ </listitem>
+ </varlistentry>
+ </variablelist>
+ </refsect2>
+ <refsect2 id="enumerations">
+ <title>Enumerations</title>
+ <para>The <command>::tcom::import</command> 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.</para>
+ </refsect2>
+ </refsect1>
+ <refsect1 id="mapping">
+ <title>Tcl Value to VARIANT Mapping</title>
+ <para>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.</para>
+ <para>When invoking COM object methods, <command>tcom</command> tries to
+ convert each Tcl argument to the parameter type specified by the method
+ interface. For example, if a method accepts an <literal>int</literal>
+ parameter, <command>tcom</command> 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.</para>
+ <para><command>Tcom</command> uses the Tcl value's internal representation
+ type as a hint to choose the resulting VARIANT type.</para>
+ <table>
+ <title>Tcl value to VARIANT mapping</title>
+ <tgroup cols="2">
+ <thead>
+ <row>
+ <entry>Tcl internal representation</entry>
+ <entry>VARIANT type</entry>
+ </row>
+ </thead>
+ <tbody>
+ <row>
+ <entry>boolean</entry>
+ <entry>VT_BOOL</entry>
+ </row>
+ <row>
+ <entry>int</entry>
+ <entry>VT_I4</entry>
+ </row>
+ <row>
+ <entry>double</entry>
+ <entry>VT_R8</entry>
+ </row>
+ <row>
+ <entry>list</entry>
+ <entry>one-dimensional array of VT_VARIANT</entry>
+ </row>
+ <row>
+ <entry>bytearray</entry>
+ <entry>one-dimensional array of VT_UI1</entry>
+ </row>
+ <row>
+ <entry>other</entry>
+ <entry>VT_BSTR</entry>
+ </row>
+ </tbody>
+ </tgroup>
+ </table>
+ <refsect2 id="collections">
+ <title>Invoking Methods With VARIANT Parameters</title>
+ <para>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 <command>Item</command> 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.</para>
+ <programlisting>
+
+# Assume $collection is a handle to a collection.
+set element [$collection Item 1]
+</programlisting>
+ <para>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.</para>
+<programlisting>
+
+set numElements [$collection Count]
+for {set i 1} {$i <= $numElements} {incr i} { ;# 1
+ set element [$collection Item $i] ;# 2
+}
+</programlisting>
+ <para>In line 1, the <command>for</command> command sets the internal
+ representation of <literal>$i</literal> to an int type as a side effect of
+ evaluating the condition expression <literal>{$i <=
+ $numElements}</literal>. The command in line 2 passes the integer value in
+ <literal>$i</literal> to the Item method, which should succeed if the method
+ can handle integer index values.</para>
+ </refsect2>
+ </refsect1>
+</refentry>
--- /dev/null
+# $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 {<META http-equiv="Content-Type"[^>]*>} [$source transformNode $xslt] \
+ {<META http-equiv="Content-Type" content="text/html; charset=UTF-8">} \
+ resultHtml
+
+set out [open [lindex $argv 2] "w"]
+fconfigure $out -translation binary
+puts -nonewline $out $resultHtml
+close $out
--- /dev/null
+# $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]]
--- /dev/null
+# $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}
--- /dev/null
+# $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}
--- /dev/null
+# $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}
--- /dev/null
+# $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]]
--- /dev/null
+# $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
--- /dev/null
+# $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]]
--- /dev/null
+# $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
+ }
+ }
+ }
+}
--- /dev/null
+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;
+ };
+};
--- /dev/null
+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]
--- /dev/null
+# $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
--- /dev/null
+# $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"
--- /dev/null
+# $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
--- /dev/null
+# $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."
--- /dev/null
+// $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;
+}
--- /dev/null
+// $Id: ActiveScriptError.h,v 1.2 2002/04/12 02:55:27 cthuang Exp $
+#ifndef ACTIVESCRIPTERROR_H
+#define ACTIVESCRIPTERROR_H
+
+#include <activscp.h>
+#include <comdef.h>
+
+// 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
--- /dev/null
+// $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;
+}
--- /dev/null
+// $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<DISPPARAMS *>(&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
--- /dev/null
+// $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();
+}
--- /dev/null
+// $Id: ComModule.h,v 1.13 2002/04/13 03:53:56 cthuang Exp $
+#ifndef COMMODULE_H
+#define COMMODULE_H
+
+#include <map>
+#include <comdef.h>
+#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<Uuid, ComObjectFactory *> 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
--- /dev/null
+// $Id: ComObject.cpp,v 1.37 2002/05/31 04:03:06 cthuang Exp $
+#pragma warning(disable: 4786)
+#include "ComObject.h"
+#include <stdexcept>
+#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<ClientData>(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<Interface *>(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<ClientData>(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<float>(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<IUnknown *>(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<char *>(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<char *>(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<VARIANT_BOOL *>(pDest) =
+ tclObject.getBool() ? VARIANT_TRUE : VARIANT_FALSE;
+ break;
+
+ case VT_R4:
+ *static_cast<float *>(pDest) =
+ static_cast<float>(tclObject.getDouble());
+ break;
+
+ case VT_R8:
+ *static_cast<double *>(pDest) = tclObject.getDouble();
+ break;
+
+ case VT_USERDEFINED:
+ if (type.name() == "GUID") {
+ char *uuidStr = const_cast<char *>(tclObject.c_str());
+ UUID uuid;
+ UuidFromString(reinterpret_cast<unsigned char *>(uuidStr), &uuid);
+ *static_cast<UUID *>(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<IUnknown *>(pObj->internalRep.otherValuePtr);
+ } else {
+ Reference *pRef = Extension::referenceHandles.find(
+ interp, tclObject);
+ pUnknown = (pRef == 0) ? 0 : pRef->unknown();
+ }
+
+ *static_cast<IUnknown **>(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<BSTR *>(pDest) = tclObject.getBSTR();
+ break;
+
+ case VT_VARIANT:
+ {
+ // Must increment reference count of interface pointers returned
+ // from methods.
+ tclObject.toVariant(
+ static_cast<VARIANT *>(pDest),
+ Type::variant(),
+ interp,
+ true);
+ }
+ break;
+
+ default:
+ *static_cast<int *>(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<void **>(&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<char *>(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<DWORD>(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);
+}
--- /dev/null
+// $Id: ComObject.h,v 1.14 2002/04/13 03:53:56 cthuang Exp $
+#ifndef COMOBJECT_H
+#define COMOBJECT_H
+
+#include <stdarg.h>
+#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<IID, Interface *> SupportedInterfaceMap;
+ SupportedInterfaceMap m_supportedInterfaceMap;
+
+ // collection of implemented interface adapters
+ typedef HashTable<IID, InterfaceAdapter *> 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<IUnknown *>(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
--- /dev/null
+// $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<void **>(&m_pInstance));
+ if (FAILED(hr)) {
+ return hr;
+ }
+ }
+ }
+
+ return m_pInstance->QueryInterface(iid, ppvObj);
+}
--- /dev/null
+// $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
--- /dev/null
+// $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<Extension *>(clientData);
+}
+
+void
+Extension::exitProc (ClientData clientData)
+{
+ Extension *pExtension =
+ static_cast<Extension *>(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;
+}
--- /dev/null
+// $Id: Extension.h,v 1.1 2002/06/29 15:40:32 cthuang Exp $
+#ifndef EXTENSION_H
+#define EXTENSION_H
+
+#include <comdef.h>
+#include <tcl.h>
+#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<InterfaceHolder> interfaceHolderHandles;
+ static HandleSupport<Reference> referenceHandles;
+ static HandleSupport<TypeLib> 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
--- /dev/null
+// $Id: HandleSupport.cpp,v 1.15 2002/05/31 04:03:06 cthuang Exp $
+#include "HandleSupport.h"
+#include <sstream>
+#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<char *>(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<ObjToRepMap> 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> ObjToRepMap::ms_tls;
+
+void
+ObjToRepMap::exitProc (ClientData clientData)
+{
+ delete static_cast<ObjToRepMap *>(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<char *>(pObj), &isNew);
+ Tcl_SetHashValue(pEntry, pRep);
+}
+
+InternalRep *
+ObjToRepMap::find (Tcl_Obj *pObj)
+{
+ Tcl_HashEntry *pEntry = Tcl_FindHashEntry(
+ &m_hashTable, reinterpret_cast<char *>(pObj));
+ if (pEntry == 0) {
+ return 0;
+ }
+ return static_cast<InternalRep *>(Tcl_GetHashValue(pEntry));
+}
+
+void
+ObjToRepMap::erase (Tcl_Obj *pObj)
+{
+ Tcl_HashEntry *pEntry = Tcl_FindHashEntry(
+ &m_hashTable, reinterpret_cast<char *>(pObj));
+ if (pEntry != 0) {
+ Tcl_DeleteHashEntry(pEntry);
+ }
+}
+
+
+Tcl_ObjType *CmdNameType::ms_pCmdNameType;
+Tcl_ObjType CmdNameType::ms_oldCmdNameType;
+
+Singleton<CmdNameType> 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<char *>(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<HandleNameToRepMap *>(clientData);
+}
+
+void
+HandleNameToRepMap::exitProc (ClientData clientData)
+{
+ HandleNameToRepMap *pHandleNameToRepMap =
+ static_cast<HandleNameToRepMap *>(clientData);
+ Tcl_DeleteAssocData(pHandleNameToRepMap->m_interp, ASSOC_KEY);
+}
+
+HandleNameToRepMap *
+HandleNameToRepMap::instance (Tcl_Interp *interp)
+{
+ return static_cast<HandleNameToRepMap *>(
+ Tcl_GetAssocData(interp, ASSOC_KEY, 0));
+}
+
+void
+HandleNameToRepMap::clear ()
+{
+ m_map.forEach(Delete());
+ m_map.clear();
+}
--- /dev/null
+// $Id: HandleSupport.h,v 1.27 2002/04/17 21:43:07 cthuang Exp $
+#ifndef HANDLESUPPORT_H
+#define HANDLESUPPORT_H
+
+#include <tcl.h>
+#include <string>
+#include "tcomApi.h"
+#include "HashTable.h"
+#include "Singleton.h"
+
+// This class represents an association from a handle to an application object.
+// 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 AppType>
+class AppInternalRep: public InternalRep
+{
+public:
+ AppInternalRep (
+ Tcl_Interp *interp,
+ Tcl_ObjCmdProc *pCmdProc,
+ AppType *pAppObject):
+ InternalRep(interp, pCmdProc, pAppObject)
+ { }
+
+ virtual ~AppInternalRep();
+};
+
+template<class AppType>
+AppInternalRep<AppType>::~AppInternalRep ()
+{
+ delete reinterpret_cast<AppType *>(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<CmdNameType>;
+ static Singleton<CmdNameType> 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<InternalRep *> 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 AppType>
+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<class AppType>
+Tcl_Obj *
+HandleSupport<AppType>::newObj (Tcl_Interp *interp, AppType *pAppObject)
+{
+ AppInternalRep<AppType> *pRep = new AppInternalRep<AppType>(
+ interp, m_pCmdProc, pAppObject);
+ return CmdNameType::instance().newObj(interp, pRep);
+}
+
+template<class AppType>
+AppType *
+HandleSupport<AppType>::find (Tcl_Interp *interp, Tcl_Obj *pObj) const
+{
+ InternalRep *pRep = HandleNameToRepMap::instance(interp)->find(pObj);
+ if (pRep == 0) {
+ return 0;
+ }
+ return reinterpret_cast<AppType *>(pRep->clientData());
+}
+
+#endif
--- /dev/null
+// $Id: HashTable.h,v 1.21 2002/04/13 03:53:56 cthuang Exp $
+#ifndef HASHTABLE_H
+#define HASHTABLE_H
+
+#include <tcl.h>
+
+// Function object that invokes delete on its argument
+
+struct Delete
+{
+ template<typename T>
+ void operator() (T p) const
+ { delete p; }
+};
+
+// This is a base class used to implement hash tables.
+
+template<typename D>
+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<typename F>
+ 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<D>(Tcl_GetHashValue(pEntry)));
+ pEntry = pNext;
+ }
+ }
+};
+
+template<typename D>
+void
+BasicHashTable<D>::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<typename K, typename D>
+class HashTable: public BasicHashTable<D>
+{
+public:
+ typedef K key_type;
+ typedef D mapped_type;
+
+ HashTable (): BasicHashTable<D>(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<typename K, typename D>
+void
+HashTable<K,D>::insert (const K &key, D value)
+{
+ int isNew;
+ Tcl_HashEntry *pEntry = Tcl_CreateHashEntry(
+ &m_hashTable,
+ reinterpret_cast<const char *>(&key),
+ &isNew);
+ Tcl_SetHashValue(pEntry, reinterpret_cast<ClientData>(value));
+}
+
+template<typename K, typename D>
+D
+HashTable<K,D>::find (const K &key) const
+{
+ Tcl_HashEntry *pEntry = Tcl_FindHashEntry(
+ const_cast<Tcl_HashTable *>(&m_hashTable),
+ reinterpret_cast<const char *>(&key));
+ if (pEntry == 0) {
+ return 0;
+ }
+ return reinterpret_cast<D>(Tcl_GetHashValue(pEntry));
+}
+
+template<typename K, typename D>
+void
+HashTable<K,D>::erase (const K &key)
+{
+ Tcl_HashEntry *pEntry = Tcl_FindHashEntry(
+ &m_hashTable,
+ reinterpret_cast<const char *>(&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<typename D>
+class StringHashTable: public BasicHashTable<D>
+{
+public:
+ typedef const char *key_type;
+ typedef D mapped_type;
+
+ StringHashTable (): BasicHashTable<D>(TCL_STRING_KEYS)
+ { }
+
+ void insert(const char *key, D value);
+ D find(const char *key) const;
+ void erase(const char *key);
+};
+
+template<typename D>
+void
+StringHashTable<D>::insert (const char *key, D value)
+{
+ int isNew;
+ Tcl_HashEntry *pEntry = Tcl_CreateHashEntry(
+ &m_hashTable,
+ const_cast<char *>(key),
+ &isNew);
+ Tcl_SetHashValue(pEntry, reinterpret_cast<ClientData>(value));
+}
+
+template<typename D>
+D
+StringHashTable<D>::find (const char *key) const
+{
+ Tcl_HashEntry *pEntry = Tcl_FindHashEntry(
+ const_cast<Tcl_HashTable *>(&m_hashTable),
+ const_cast<char *>(key));
+ if (pEntry == 0) {
+ return 0;
+ }
+ return reinterpret_cast<D>(Tcl_GetHashValue(pEntry));
+}
+
+template<typename D>
+void
+StringHashTable<D>::erase (const char *key)
+{
+ Tcl_HashEntry *pEntry = Tcl_FindHashEntry(
+ &m_hashTable,
+ const_cast<char *>(key));
+ if (pEntry != 0) {
+ Tcl_DeleteHashEntry(pEntry);
+ }
+}
+
+#endif
--- /dev/null
+// $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);
+}
--- /dev/null
+// $Id: InterfaceAdapter.h,v 1.3 2002/02/27 01:58:45 cthuang Exp $
+#ifndef INTERFACEADAPTER_H
+#define INTERFACEADAPTER_H
+
+#include <map>
+#include <set>
+#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<short, const Method *> VtblIndexToMethodMap;
+ VtblIndexToMethodMap m_vtblIndexToMethodMap;
+
+ // dispatch member ID to method description map
+ typedef std::map<DISPID, const Method *> DispIdToMethodMap;
+ DispIdToMethodMap m_dispIdToMethodMap;
+
+ // dispatch member ID's which are actually properties
+ typedef std::set<DISPID> 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
--- /dev/null
+// $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
+};
--- /dev/null
+# $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
+|
--- /dev/null
+// $Id: Reference.cpp,v 1.69 2002/06/28 00:53:46 cthuang Exp $
+#pragma warning(disable: 4786)
+#include <string.h>
+#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<void **>(&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<void **>(&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<void **>(&pUnknown1));
+ if (FAILED(hr)) {
+ _com_issue_error(hr);
+ }
+
+ IUnknown *pUnknown2;
+ rhs.m_pUnknown->QueryInterface(
+ IID_IUnknown, reinterpret_cast<void **>(&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<void **>(&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<void **>(&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<IUnknown *>(qi.pItf);
+ }
+ }
+#else
+ hr = CoCreateInstance(
+ clsid,
+ NULL,
+ clsCtx,
+ iid,
+ reinterpret_cast<void **>(&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<void **>(&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<void **>(&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<void **>(&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<void **>(&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<void **>(&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<void **>(&pUnknown));
+ if (FAILED(hr)) {
+ pUnknown = pOrig;
+ pUnknown->AddRef();
+ }
+
+ return new Reference(pUnknown, pInterface);
+}
--- /dev/null
+// $Id: Reference.h,v 1.41 2002/06/12 02:14:08 cthuang Exp $
+#ifndef REFERENCE_H
+#define REFERENCE_H
+
+#include <vector>
+#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<Connection *> 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
--- /dev/null
+// $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<char *>(data));
+}
--- /dev/null
+// $Id: RegistryKey.h,v 1.5 2001/11/28 16:10:57 cthuang Exp $
+#ifndef REGISTRYKEY_H
+#define REGISTRYKEY_H
+
+#include <stdexcept>
+#include <string>
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+
+// 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
--- /dev/null
+// $Id: Singleton.h,v 1.9 2002/04/13 03:53:56 cthuang Exp $
+#ifndef SINGLETON_H
+#define SINGLETON_H
+
+#include <tcl.h>
+#include "mutex.h"
+
+// This template class provides code to construct and destroy a singleton.
+
+template<class T>
+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<class T>
+T *Singleton<T>::ms_pInstance = 0;
+
+template<class T>
+Mutex Singleton<T>::ms_singletonMutex;
+
+template<class T>
+void
+Singleton<T>::exitProc (ClientData clientData)
+{
+ delete reinterpret_cast<T *>(clientData);
+}
+
+template<class T>
+T &
+Singleton<T>::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
--- /dev/null
+// $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);
+}
--- /dev/null
+// $Id: SupportErrorInfo.h,v 1.3 2001/07/17 02:24:08 cthuang Exp $
+#ifndef SUPPORTERRORINFO_H
+#define SUPPORTERRORINFO_H
+
+#include <comdef.h>
+#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
--- /dev/null
+// $Id: TclInterp.cpp,v 1.12 2002/04/13 03:53:56 cthuang Exp $
+#include <sstream>
+#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<CreateInterpFunc>(
+ 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<char *>(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;
+}
--- /dev/null
+// $Id: TclInterp.h,v 1.8 2002/04/13 03:53:56 cthuang Exp $
+#ifndef TCLINTERP_H
+#define TCLINTERP_H
+
+#include <string>
+#include <tcl.h>
+
+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
--- /dev/null
+// $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();
+}
--- /dev/null
+// $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
--- /dev/null
+// $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<char *>(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<Tcl_UniChar *>(reinterpret_cast<const Tcl_UniChar *>(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<Tcl_UniChar *>(pWide), length);
+}
+#endif
+
+TclObject::TclObject (const std::string &s):
+ m_pObj(Tcl_NewStringObj(const_cast<char *>(s.data()), s.size()))
+{ Tcl_IncrRefCount(m_pObj); }
+
+TclObject::TclObject (bool value):
+ m_pObj(Tcl_NewBooleanObj(static_cast<int>(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<void **>(&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<void **>(&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<char *>(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<UUID *>(V_BYREF(pSrc)));
+ m_pObj = Tcl_NewStringObj(
+ const_cast<char *>(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<Tcl_UniChar *>(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<IUnknown *>(
+ 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<VARIANT_BOOL *>(pData)[i] =
+ value.getBool() ? VARIANT_TRUE : VARIANT_FALSE;
+ break;
+
+ case VT_R4:
+ static_cast<float *>(pData)[i] =
+ static_cast<float>(value.getDouble());
+ break;
+
+ case VT_R8:
+ static_cast<double *>(pData)[i] = value.getDouble();
+ break;
+
+ case VT_BSTR:
+ static_cast<BSTR *>(pData)[i] = value.getBSTR();
+ break;
+
+ case VT_VARIANT:
+ {
+ VARIANT *pDest = static_cast<VARIANT *>(pData) + i;
+ VariantInit(pDest);
+ value.toVariant(pDest, elementType, interp);
+ }
+ break;
+
+ default:
+ static_cast<int *>(pData)[i] = value.getLong();
+ }
+ }
+
+ hr = SafeArrayUnaccessData(psa);
+ if (FAILED(hr)) {
+ _com_issue_error(hr);
+ }
+
+ V_VT(pDest) = VT_ARRAY | elementType.vartype();
+ 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<void **>(&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<void **>(&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<const wchar_t *>(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
--- /dev/null
+// $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 <tcl.h>
+#include <string>
+#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<Tcl_Obj *>(m_pObj); }
+
+ // Get UTF-8 string representation of the object.
+ const char *c_str () const
+ { return Tcl_GetStringFromObj(const_cast<Tcl_Obj *>(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<const wchar_t *>(
+ Tcl_GetUnicode(const_cast<Tcl_Obj *>(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
--- /dev/null
+// $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<void **>(&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<void **>(&pDispatch));
+ if (FAILED(hr)) {
+ _com_issue_error(hr);
+ }
+
+ // Get the DISPID of the name.
+ wchar_t *wideSubItemName = const_cast<wchar_t *>(
+ 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);
+}
--- /dev/null
+# 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
--- /dev/null
+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;
+ };
+};
--- /dev/null
+// $Id: TclScriptVersion.rc,v 1.3 2002/04/27 18:15:24 cthuang Exp $
+#include <winres.h>
+#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
--- /dev/null
+// $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<typename T>
+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<typename T>
+ThreadLocalStorage<T>::ThreadLocalStorage ()
+{
+ LOCK_MUTEX(m_mutex)
+
+ if (!m_initialized) {
+ m_index = TlsAlloc();
+ m_initialized = true;
+ }
+}
+
+template<typename T>
+ThreadLocalStorage<T>::~ThreadLocalStorage ()
+{
+ LOCK_MUTEX(m_mutex)
+
+ if (m_initialized) {
+ TlsFree(m_index);
+ m_initialized = false;
+ }
+}
+
+template<typename T>
+T &
+ThreadLocalStorage<T>::instance () const
+{
+ T *pValue = static_cast<T *>(TlsGetValue(m_index));
+ if (pValue == 0) {
+ pValue = new T;
+ TlsSetValue(m_index, pValue);
+ }
+ return *pValue;
+}
+
+#endif
--- /dev/null
+// $Id: TypeInfo.cpp,v 1.58 2002/04/20 06:11:32 cthuang Exp $
+#pragma warning(disable: 4786)
+#include <sstream>
+#include <map>
+#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<VARTYPE, std::string>
+{
+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<std::string, VARTYPE>
+{
+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> 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);
+ }
+}
--- /dev/null
+// $Id: TypeInfo.h,v 1.41 2002/04/20 06:11:32 cthuang Exp $
+#ifndef TYPEINFO_H
+#define TYPEINFO_H
+
+#include <vector>
+#include <string>
+#include <comdef.h>
+#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<Parameter> 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<Method> Methods;
+ typedef std::vector<Property> 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<IID, Interface *> IidToInterfaceDescMap;
+ IidToInterfaceDescMap m_hashTable;
+
+ friend class Singleton<InterfaceManager>;
+ static Singleton<InterfaceManager> 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<const Interface *> 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
--- /dev/null
+// $Id: TypeLib.cpp,v 1.29 2002/03/09 16:40:24 cthuang Exp $
+#pragma warning(disable: 4786)
+#include <sstream>
+#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<unsigned>(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<unsigned char *>(const_cast<char *>(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;
+ }
+ }
+}
--- /dev/null
+// $Id: TypeLib.h,v 1.21 2002/03/09 16:40:24 cthuang Exp $
+#ifndef TYPELIB_H
+#define TYPELIB_H
+
+#include <vector>
+#include <map>
+#include <string>
+#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, std::string>
+{
+ 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<const Interface *> Interfaces;
+ typedef std::vector<Class> Classes;
+ typedef std::vector<Enum> 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
--- /dev/null
+// $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<UUID *>(&m_uuid), &str) != RPC_S_OK) {
+ return std::string();
+ }
+ std::string result(reinterpret_cast<char *>(str));
+ RpcStringFree(&str);
+ return result;
+}
--- /dev/null
+// $Id: Uuid.h,v 1.3 2000/04/28 19:37:53 chuang Exp $
+#ifndef UUID_H
+#define UUID_H
+
+#include <string.h>
+#include <string>
+#include <comdef.h>
+#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
--- /dev/null
+// $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<void **>(&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<void **>(&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<unsigned char *>(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;
+}
--- /dev/null
+#define BUILD_NUMBER 13
--- /dev/null
+// $Id: comsupp.cpp,v 1.2 2001/07/12 04:09:58 cthuang Exp $
+//
+// These functions are defined in comsupp.lib but Borland C++ does not include
+// that library in its distribution, so we implement them here when compiling
+// with Borland C++.
+#include <stdlib.h>
+#include <string.h>
+#include <comdef.h>
+#include <comutil.h>
+
+// This value represents a missing optional parameter.
+_variant_t vtMissing(DISP_E_PARAMNOTFOUND, VT_ERROR);
+
+// COM error handling routine
+
+void __stdcall
+_com_issue_error (HRESULT hr) throw(_com_error)
+{
+ throw _com_error(hr);
+}
+
+namespace _com_util {
+
+// Convert char * to BSTR
+
+BSTR __stdcall
+ConvertStringToBSTR (const char* pSrc) throw(_com_error)
+{
+ if (pSrc == 0) {
+ return SysAllocString(0);
+ }
+
+ // Guess the number of wide characters needed.
+ size_t destLen = strlen(pSrc) + 1;
+ wchar_t *pDest = new wchar_t[destLen];
+ mbstowcs(pDest, pSrc, destLen);
+ BSTR result = SysAllocString(pDest);
+ delete[] pDest;
+ return result;
+}
+
+// Convert BSTR to char *
+
+char* __stdcall
+ConvertBSTRToString (BSTR pSrc) throw(_com_error)
+{
+ if (pSrc == 0) {
+ char *pDest = new char[1];
+ *pDest = '\0';
+ return pDest;
+ }
+
+ // Guess the number of bytes needed.
+ size_t destLen = wcslen(pSrc) * 3 + 1;
+ char *pDest = new char[destLen];
+ wcstombs(pDest, pSrc, destLen);
+ return pDest;
+}
+
+} //namespace
--- /dev/null
+// $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<Extension *>(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;
+}
--- /dev/null
+// $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;
+}
--- /dev/null
+LIBRARY tcominproc.dll
+
+EXPORTS
+ DllCanUnloadNow PRIVATE
+ DllGetClassObject PRIVATE
--- /dev/null
+# 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
--- /dev/null
+// $Id: dllserverVersion.rc,v 1.5 2002/04/27 18:15:24 cthuang Exp $
+#include <winres.h>
+#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
--- /dev/null
+// $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<ExeModule *>(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;
+}
--- /dev/null
+# 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
--- /dev/null
+// $Id: exeserverVersion.rc,v 1.5 2002/04/27 18:15:24 cthuang Exp $
+#include <winres.h>
+#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
--- /dev/null
+// $Id: foreachCmd.cpp,v 1.10 2002/05/31 04:03:06 cthuang Exp $
+#include "Extension.h"
+#include <sstream>
+#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<void **>(&pEnumVARIANT));
+ if (SUCCEEDED(hr)) {
+ enumKind = ENUM_VARIANT;
+ } else {
+ hr = pUnk->QueryInterface(
+ IID_IEnumUnknown, reinterpret_cast<void **>(&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<char *>(oss.str().c_str()), -1);
+ break;
+ } else if (completionCode != TCL_OK) {
+ break;
+ }
+ }
+
+ if (completionCode == TCL_OK) {
+ Tcl_ResetResult(interp);
+ }
+ return completionCode;
+}
--- /dev/null
+// $Id: importCmd.cpp,v 1.26 2002/05/31 04:03:06 cthuang Exp $
+#pragma warning(disable: 4786)
+#include "Extension.h"
+#include <sstream>
+#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<const Interface *>(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<unsigned char *>(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<Interface *>(
+ InterfaceManager::instance().find(iid));
+ if (pInterface == 0) {
+ Tcl_AppendResult(interp, "unknown IID ", iidStr, NULL);
+ return TCL_ERROR;
+ }
+ }
+
+ Tcl_CreateObjCommand(
+ interp,
+ name,
+ interfaceObjCmd,
+ reinterpret_cast<ClientData>(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<Class *>(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<Class *>(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<unsigned char *>(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<unsigned char *>(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<unsigned char *>(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<Class *>(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<const Interface *>(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<Extension *>(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<char *>(script.str().c_str()),
+ -1,
+ TCL_EVAL_GLOBAL);
+#else
+ Tcl_Eval(interp, const_cast<char *>(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<char *>(fullyQualifiedName.c_str()),
+ interfaceObjCmd,
+ const_cast<Interface *>(*pInterface),
+ 0);
+ }
+
+ // Create class commands.
+ for (pClass = classes.begin(); pClass != classes.end(); ++pClass) {
+ std::string fullyQualifiedName =
+ fullyQualifiedNamespace + "::" + pClass->name();
+
+ Tcl_CreateObjCommand(
+ interp,
+ const_cast<char *>(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;
+}
--- /dev/null
+// $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<InterfaceHolder> 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<char *>(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<char *>(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<char *>(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<const InterfaceHolder *>(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<char *>(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;
+}
--- /dev/null
+// $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);
+}
--- /dev/null
+// $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 <windows.h>
+
+// 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 &>(mutex));
+#else
+#define LOCK_MUTEX(mutex)
+#endif
+
+#endif
--- /dev/null
+// $Id: naCmd.cpp,v 1.6 2002/04/27 18:15:24 cthuang Exp $
+#include "Extension.h"
+#include <string.h>
+
+// 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;
+}
--- /dev/null
+// $Id: nullCmd.cpp,v 1.9 2002/04/27 18:15:24 cthuang Exp $
+#include "Extension.h"
+#include <string.h>
+
+// 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;
+}
--- /dev/null
+// $Id: objectCmd.cpp,v 1.30 2002/04/27 18:15:24 cthuang Exp $
+#pragma warning(disable: 4786)
+#include "Extension.h"
+#include <sstream>
+#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<Extension *>(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;
+}
--- /dev/null
+// $Id: refCmd.cpp,v 1.43 2002/06/12 02:14:08 cthuang Exp $
+#pragma warning(disable: 4786)
+#include "Extension.h"
+#include <sstream>
+#include "Reference.h"
+#include "TypeInfo.h"
+#include "TclObject.h"
+#include "Arguments.h"
+
+static int referenceObjCmd(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []);
+HandleSupport<Reference> 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<void **>(&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<const wchar_t *>(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<LPWSTR>(&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<char *>(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<Reference *>(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<unsigned char *>(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<Extension *>(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<unsigned char *>(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;
+}
--- /dev/null
+//{{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
--- /dev/null
+// $Id: shortPathNameCmd.cpp,v 1.3 2002/04/13 03:53:57 cthuang Exp $
+#include "Extension.h"
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+
+// 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;
+}
--- /dev/null
+// $Id: tclRunTime.h,v 1.1 2002/07/15 04:03:54 cthuang Exp $
+#ifndef TCLRUNTIME_H
+#define TCLRUNTIME_H
+
+#include <tcl.h>
+
+// 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
--- /dev/null
+# 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
--- /dev/null
+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>
+{{{
+}}}
+
+###############################################################################
+
--- /dev/null
+// $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
--- /dev/null
+// $Id: tcomVersion.rc,v 1.5 2002/04/27 18:15:24 cthuang Exp $
+#include <winres.h>
+#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
--- /dev/null
+// $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<TypeLib> 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<const TypeLib *>(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<char *>(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<char *>(pClass->clsidString().c_str()));
+
+ // Append name of default interface.
+ Tcl_AppendElement(
+ interp,
+ const_cast<char *>(
+ pClass->defaultInterface()->name().c_str()));
+
+ // Append name of source interface.
+ if (pClass->sourceInterface() != 0) {
+ Tcl_AppendElement(
+ interp,
+ const_cast<char *>(
+ 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<char *>(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<char *>(p->first.c_str()));
+ Tcl_AppendElement(interp,
+ const_cast<char *>(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<char *>(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<char *>((*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;
+}
--- /dev/null
+// $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
--- /dev/null
+# $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
--- /dev/null
+# $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
--- /dev/null
+# $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
--- /dev/null
+# $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
projects / tcom / commitdiff
