--- /dev/null
+<!DOCTYPE html PUBLIC "-//IETF//DTD HTML 2.0//EN">
+<HTML>
+<HEAD>
+<TITLE>GNU General Public License - GNU Project - Free Software Foundation (FSF)</TITLE>
+<LINK REV="made" HREF="mailto:webmasters@www.gnu.org">
+</HEAD>
+<BODY BGCOLOR="#FFFFFF" TEXT="#000000" LINK="#1F00FF" ALINK="#FF0000" VLINK="#9900DD">
+<H1>GNU General Public License</H1>
+
+
+<P>
+
+<HR>
+
+<P>
+
+<H2>Table of Contents</H2>
+<UL>
+<LI><A NAME="TOC1" HREF="gpl.html#SEC1">GNU GENERAL PUBLIC LICENSE</A>
+<UL>
+<LI><A NAME="TOC2" HREF="gpl.html#SEC2">Preamble</A>
+<LI><A NAME="TOC3" HREF="gpl.html#SEC3">TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION</A>
+<LI><A NAME="TOC4" HREF="gpl.html#SEC4">How to Apply These Terms to Your New Programs</A>
+
+</UL>
+</UL>
+
+<P>
+
+<HR>
+
+<P>
+
+
+
+<H2><A NAME="SEC1" HREF="gpl.html#TOC1">GNU GENERAL PUBLIC LICENSE</A></H2>
+<P>
+Version 2, June 1991
+
+</P>
+
+<PRE>
+Copyright (C) 1989, 1991 Free Software Foundation, Inc.
+59 Temple Place - Suite 330, Boston, MA 02111-1307, USA
+
+Everyone is permitted to copy and distribute verbatim copies
+of this license document, but changing it is not allowed.
+</PRE>
+
+
+
+<H2><A NAME="SEC2" HREF="gpl.html#TOC2">Preamble</A></H2>
+
+<P>
+ The licenses for most software are designed to take away your
+freedom to share and change it. By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it. (Some other Free Software Foundation software is covered by
+the GNU Library General Public License instead.) You can apply it to
+your programs, too.
+
+</P>
+<P>
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+</P>
+<P>
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+</P>
+<P>
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must show them these terms so they know their
+rights.
+
+</P>
+<P>
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+</P>
+<P>
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+</P>
+<P>
+ Finally, any free program is threatened constantly by software
+patents. We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary. To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+</P>
+<P>
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+</P>
+
+
+<H2><A NAME="SEC3" HREF="gpl.html#TOC3">TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION</A></H2>
+
+
+<P>
+
+<STRONG>0.</STRONG>
+ This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License. The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language. (Hereinafter, translation is included without limitation in
+the term "modification".) Each licensee is addressed as "you".
+<P>
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope. The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+<P>
+
+<STRONG>1.</STRONG>
+ You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+<P>
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+<P>
+
+<STRONG>2.</STRONG>
+ You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+<P>
+
+<UL>
+
+<LI><STRONG>a)</STRONG>
+ You must cause the modified files to carry prominent notices
+ stating that you changed the files and the date of any change.
+
+<P>
+<LI><STRONG>b)</STRONG>
+ You must cause any work that you distribute or publish, that in
+ whole or in part contains or is derived from the Program or any
+ part thereof, to be licensed as a whole at no charge to all third
+ parties under the terms of this License.
+
+<P>
+<LI><STRONG>c)</STRONG>
+ If the modified program normally reads commands interactively
+ when run, you must cause it, when started running for such
+ interactive use in the most ordinary way, to print or display an
+ announcement including an appropriate copyright notice and a
+ notice that there is no warranty (or else, saying that you provide
+ a warranty) and that users may redistribute the program under
+ these conditions, and telling the user how to view a copy of this
+ License. (Exception: if the Program itself is interactive but
+ does not normally print such an announcement, your work based on
+ the Program is not required to print an announcement.)
+</UL>
+
+These requirements apply to the modified work as a whole. If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works. But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+<P>
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+<P>
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+<P>
+
+<STRONG>3.</STRONG>
+ You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+
+<!-- we use this doubled UL to get the sub-sections indented, -->
+<!-- while making the bullets as unobvious as possible. -->
+<UL>
+
+<LI><STRONG>a)</STRONG>
+ Accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of Sections
+ 1 and 2 above on a medium customarily used for software interchange; or,
+
+<P>
+<LI><STRONG>b)</STRONG>
+ Accompany it with a written offer, valid for at least three
+ years, to give any third party, for a charge no more than your
+ cost of physically performing source distribution, a complete
+ machine-readable copy of the corresponding source code, to be
+ distributed under the terms of Sections 1 and 2 above on a medium
+ customarily used for software interchange; or,
+
+<P>
+<LI><STRONG>c)</STRONG>
+ Accompany it with the information you received as to the offer
+ to distribute corresponding source code. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form with such
+ an offer, in accord with Subsection b above.)
+</UL>
+
+The source code for a work means the preferred form of the work for
+making modifications to it. For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable. However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+<P>
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+<P>
+
+<STRONG>4.</STRONG>
+ You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License. Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+<P>
+
+<STRONG>5.</STRONG>
+ You are not required to accept this License, since you have not
+signed it. However, nothing else grants you permission to modify or
+distribute the Program or its derivative works. These actions are
+prohibited by law if you do not accept this License. Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+<P>
+
+<STRONG>6.</STRONG>
+ Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions. You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+<P>
+
+<STRONG>7.</STRONG>
+ If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all. For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+<P>
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+<P>
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices. Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+<P>
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+<P>
+
+<STRONG>8.</STRONG>
+ If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded. In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+<P>
+
+<STRONG>9.</STRONG>
+ The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+<P>
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+<P>
+
+
+<STRONG>10.</STRONG>
+ If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+
+
+<P><STRONG>NO WARRANTY</STRONG></P>
+
+<P>
+
+<STRONG>11.</STRONG>
+ BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+<P>
+
+<STRONG>12.</STRONG>
+ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+<P>
+
+
+<H2>END OF TERMS AND CONDITIONS</H2>
+
+
+
+<H2><A NAME="SEC4" HREF="gpl.html#TOC4">How to Apply These Terms to Your New Programs</A></H2>
+
+<P>
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+</P>
+<P>
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+</P>
+
+<PRE>
+<VAR>one line to give the program's name and an idea of what it does.</VAR>
+Copyright (C) <VAR>yyyy</VAR> <VAR>name of author</VAR>
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+</PRE>
+
+<P>
+Also add information on how to contact you by electronic and paper mail.
+
+</P>
+<P>
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+</P>
+
+<PRE>
+Gnomovision version 69, Copyright (C) <VAR>yyyy</VAR> <VAR>name of author</VAR>
+Gnomovision comes with ABSOLUTELY NO WARRANTY; for details
+type `show w'. This is free software, and you are welcome
+to redistribute it under certain conditions; type `show c'
+for details.
+</PRE>
+
+<P>
+The hypothetical commands <SAMP>`show w'</SAMP> and <SAMP>`show c'</SAMP> should show
+the appropriate parts of the General Public License. Of course, the
+commands you use may be called something other than <SAMP>`show w'</SAMP> and
+<SAMP>`show c'</SAMP>; they could even be mouse-clicks or menu items--whatever
+suits your program.
+
+</P>
+<P>
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here is a sample; alter the names:
+
+</P>
+
+<PRE>
+Yoyodyne, Inc., hereby disclaims all copyright
+interest in the program `Gnomovision'
+(which makes passes at compilers) written
+by James Hacker.
+
+<VAR>signature of Ty Coon</VAR>, 1 April 1989
+Ty Coon, President of Vice
+</PRE>
+
+<P>
+This General Public License does not permit incorporating your program into
+proprietary programs. If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library. If this is what you want to do, use the GNU Library General
+Public License instead of this License.
+
+<HR>
+
+Return to <A HREF="/home.html">GNU's home page</A>.
+<P>
+FSF & GNU inquiries & questions to
+<A HREF="mailto:gnu@gnu.org"><EM>gnu@gnu.org</EM></A>.
+Other <A HREF="/home.html#ContactInfo">ways to contact</A> the FSF.
+<P>
+Comments on these web pages to
+<A HREF="mailto:webmasters@www.gnu.org"><EM>webmasters@www.gnu.org</EM></A>,
+send other questions to
+<A HREF="mailto:gnu@gnu.org"><EM>gnu@gnu.org</EM></A>.
+<P>
+Copyright notice above.<BR>
+Free Software Foundation, Inc.,
+59 Temple Place - Suite 330, Boston, MA 02111, USA
+<P>
+Updated:
+<!-- hhmts start -->
+16 Feb 1998 tower
+<!-- hhmts end -->
+<HR>
+</BODY>
+</HTML>
--- /dev/null
+OpTcl v3.0 build 04
+-------------------
+
+Licencing
+---------
+Use of this software indicates an agreement to the GNU Public Licence under which,
+this software is provided.
+
+Documentation
+-------------
+Please open the default.html file in the 'docs' directory for installation instructions
+and documentation.
+
+
+
+I welcome any comments, suggestions and bug reports:
+fuzz@sys.uea.ac.uk
+
+
--- /dev/null
+<html>
+
+<head>
+<meta http-equiv="Content-Type"
+content="text/html; charset=iso-8859-1">
+<title>OpTcl Documentation</title>
+</head>
+
+<frameset cols="180,*" border="0" frameborder="NO"
+framespacing="0">
+ <frame src="index.html" name="index">
+ <frame src="optcl.html" name="mainframe">
+ <noframes>
+ <body>
+ </body>
+ </noframes>
+</frameset>
+</html>
--- /dev/null
+<html>
+
+<head>
+<meta http-equiv="Content-Type"
+content="text/html; charset=iso-8859-1">
+<title>Index</title>
+</head>
+
+<body bgcolor="#FFFFFF">
+
+<h3>Index</h3>
+
+<h4><a href="optcl.html" target="mainframe">About</a></h4>
+
+<h4><a href="optcltypes.html" target="mainframe">Types</a></h4>
+
+<h4><a href="optcltypelibaccess.html" target="mainframe">Type
+Library Access</a></h4>
+
+<h4><a href="optclobjects.html" target="mainframe">Objects</a></h4>
+
+<p><strong></strong> </p>
+</body>
+</html>
--- /dev/null
+<html>
+
+<head>
+<meta http-equiv="Content-Type"
+content="text/html; charset=iso-8859-1">
+<meta name="GENERATOR" content="Microsoft FrontPage Express 2.0">
+<title>OpTcl Documentation</title>
+</head>
+
+<body bgcolor="#FFFFFF">
+
+<p align="center"><img src="optcl_large.gif" width="172"
+height="176"><br>
+<font size="2" face="Arial"><strong>version 3.0 build 04</strong></font></p>
+
+<p align="center"><a href="mailto:fuzz@sys.uea.ac.uk">Farzad
+Pezeshkpour</a></p>
+
+<p align="center">August 1999</p>
+
+<p>This software is freely distributed under the GNU Public
+Licence. I've include this in this distribution as an HTML file.</p>
+
+<p>Gosh! So much to document here, and so little time. This is a
+preliminary, and rather informal document - a better version is
+on its way!</p>
+
+<h1>The Distribution</h1>
+
+<p>The following is a description of the directory structure for
+the distribution:</p>
+
+<table border="0" cellpadding="4" cellspacing="4">
+ <tr>
+ <td><strong>install</strong></td>
+ <td>Holds the installer script and two versions of the
+ DLL - one for Tcl 8.0.5 (no stubs), and one with stubs
+ enabled, built for Tcl 8.2 libraries.</td>
+ </tr>
+ <tr>
+ <td><strong>docs</strong></td>
+ <td>Documentation.</td>
+ </tr>
+ <tr>
+ <td><strong>src</strong></td>
+ <td>The source for OpTcl with Visual C++ v6.0 (sp3)
+ workspace.</td>
+ </tr>
+ <tr>
+ <td><strong>tests</strong></td>
+ <td>A couple of test scripts using MS Word, and the
+ Calendar Control.</td>
+ </tr>
+</table>
+
+<p>To install, run the install script <em>optcl_install.tcl</em>.
+This will autodetect your version and location of your Tcl and
+select the appropriate installation settings. The installer
+copies the suitable DLL <tcl_lib>/../optcl/optcl.dll, and <em>pkg_mkIndex</em>
+is applied to that directory.</p>
+
+<p>The package can now be used by loaded using the command:</p>
+
+<pre> package require optcl</pre>
+
+<h1>Things To Do</h1>
+
+<ul>
+ <li>Distribute example files.</li>
+ <li>Implement array parameters.</li>
+ <li>Implement default parameter values.</li>
+ <li>Test <em>out</em>-flagged parameters (I haven't found a
+ server to do this, yet).</li>
+ <li>Implement <em>in/out</em>-flagged parameters for events.</li>
+ <li>Use Type Libraries on the type conversion of an event-handlers
+ result.</li>
+ <li>Test with DCOM. (does anyone have a setup that can do
+ this?)</li>
+ <li>Write an ActiveScripting engine interface.</li>
+ <li>In some cases perhaps, reconsider syntax.</li>
+</ul>
+
+<h1>Known Bugs/Limitations</h1>
+
+<ul>
+ <li>Not thread-safe.</li>
+ <li>Can't set parameters by their name, à la Visual Basic.</li>
+ <li>Microsoft Forms ActiveX objects can't be fully in-place
+ activated.</li>
+</ul>
+
+<h1>Credits</h1>
+
+<p>This work uses ideas developed by Jacob Levy in his Taxi
+specification. I am very grateful for his helpful comments and
+encouragement.</p>
+
+<p><font size="1">Copyright (c) 1999, Farzad Pezeshkpour</font></p>
+</body>
+</html>
--- /dev/null
+<html>
+
+<head>
+<meta http-equiv="Content-Type"
+content="text/html; charset=iso-8859-1">
+<title>Optcl Objects</title>
+</head>
+
+<body bgcolor="#FFFFFF">
+
+<p align="center"><img
+src="optcl_large.gif" width="172"
+height="176"></p>
+
+<h1 align="center">Objects</h1>
+
+<p align="left">The manipulation of objects in OpTcl is performed
+with commands defined in the <em>optcl</em> namespace. The
+following is the synopsis of this namespace.</p>
+
+<dl>
+ <dd><a href="#optcl::new"><strong>optcl::new</strong></a> ?-start?
+ ?-window <em>windowname</em>? <em>CLSID_ProgID_DocumentURL_HTML</em></dd>
+ <dd><a href="#Reference Management"><strong>optcl::lock</strong></a>
+ <em>objid</em></dd>
+ <dd><a href="#Reference Management"><strong>optcl::unlock</strong></a><em>
+ objid</em> ?<em>objid</em> ...?</dd>
+ <dd><a href="#optcl::isobject"><strong>optcl::isobject</strong></a>
+ <em>objid</em></dd>
+ <dd><a href="#optcl::interface"><strong>optcl::interface</strong></a>
+ <em>objid </em>?<em>new_interface_name</em>?</dd>
+ <dd><a href="#optcl::class"><strong>optcl::class</strong></a>
+ <em>objid</em></dd>
+ <dd><a href="#optcl::bind"><strong>optcl::bind</strong></a> <em>objid
+ eventname tcl_procedure</em></dd>
+ <dd><a href="#Object Command"><em>objid</em></a> ?-with <em>subobj</em>?
+ <em>methodname </em>?<em>arg</em> ...?</dd>
+ <dd><a href="#Object Command"><em>objid</em></a> ?-with <em>subobj</em>?
+ <strong>:</strong> <em>propname</em> ?<em>new_value</em>?</dd>
+ <dd><a href="#Object Command"><em>objid</em></a> ?-with <em>subobj</em>?
+ <strong>:</strong> <em>propname(index</em>?, <em>index</em>
+ ...?) ?<em>new_value</em>?</dd>
+</dl>
+
+<h2>Description</h2>
+
+<h3><a name="optcl::new">optcl::new</a></h3>
+
+<p>The <strong>optcl::new</strong> command creates or attaches to
+existing COM objects, returning a unique object identifier, if
+successful. The -start flag is used to indicate that the call
+should always create a new instance of the object. The -window
+option creates with the COM object, a Tk widget that will attempt
+to in-place activate the user interface of the object. Not all
+COM objects provide a user interface, and not all objects with
+user-interfaces will in-place activate. </p>
+
+<p>The final parameter of the command is an identifier for the
+COM class of the object. This can take four different forms:
+CLSID, ProgID, document path or raw HTML. Currently, the latter
+two only work with the -window option. A CLSID is a string
+representation of a COM Globally Unique IDentifer (GUID for short).
+CLSIDs uniquely identify the location of a COM class server
+through the system registry. To successfully create an instance
+of the COM class, the server must be correctly registered with
+the system registery. An example of a CLSID is <em>{8E27C92B-1264-101C-8A2F-040224009C02}</em>
+(the CLSID for the Calendar Control). In order to pass a CLSID
+correctly to the <strong>optcl::new</strong> command, the CLSID
+must be wrapped in an extra pair of braces. This will ensure that
+the bracing surrounding the CLSID is not stripped by the Tcl
+interpreter. For example, <em>{{8E27C92B-1264-101C-8A2F-040224009C02}}</em>.
+A ProgID (programmatic identifier) is a human readable name that
+performs the same job as a CLSID. For example, <em>MSCAL.Calendar.7</em>.
+</p>
+
+<p>Additionally, the command can take two further forms of
+identifer. A URL to a document with a correctly registered
+document server, or an inline HTML. Both these options are only
+available currently with in-place activation only (-window option)
+and require the installation of Internet Explorer 4.0 or above.
+To use inline HTML, the source string must begin with the
+characters "mshtml:".</p>
+
+<h3><a name="Reference Management">Reference Management</a></h3>
+
+<p>At the time of writing, OpTcl cannot provide a robust
+automatic handling of object lifetimes. So for now, the <strong>optcl::lock</strong>
+and <strong>optcl::unlock</strong> commands provide explicit
+means for respectively incrementing or decrementing the reference
+count on an object. On creation, the reference count of an object
+is one. If, the reference count of an object becomes zero, the
+object is destroyed, together with its Tk container window, if
+one exists. Furthermore, the destruction of a container window,
+will immediately destroy its related object.</p>
+
+<h3><a name="optcl::isobject">optcl::isobject</a></h3>
+
+<p>The <strong>optcl::isobject</strong> command returns true if
+and only if its only parameter is an OpTcl object.</p>
+
+<h3><a name="optcl::interface">optcl::interface</a></h3>
+
+<p>The <strong>optcl::interface</strong> command performs the
+role of querying the current interface name of an OpTcl object,
+or setting it to a new interface type. COM objects are
+polymorphic, in that they can (and often do) support multiple
+interfaces. In OpTcl an interface name is a <a
+href="optcltypes.html">properly formed type</a>, and hence can be
+browsed with the <a href="optcltypelibaccess.html">Type Library
+Access functionality</a> of OpTcl. One can discover the supported
+interfaces of an object by <a href="#optcl::class">finding</a>
+and viewing details of its <a
+href="optcltypelibaccess.html#class">COM class</a>. The initial
+interface of an object, is its default interface.</p>
+
+<h3><a name="optcl::class">optcl::class</a></h3>
+
+<p>The <strong>optcl::class</strong> command returns the <a
+href="optcltypelibaccess.html#class">class name</a> of the object.
+If no class name information is provided, the command returns
+'???'.</p>
+
+<h3><a name="optcl::bind">optcl::bind</a></h3>
+
+<p>The <strong>optcl::bind</strong> command binds an event from
+an object to a Tcl procedure name. The event can either be the
+name of an event on the default interface, or the name of an
+event on another event interface. The latter must take the form <em>lib.eventinterface.event</em>.
+The Tcl procedure will be called with the first parameter being
+the object identifier of the OpTcl object raising the event,
+followed by the parameters of the event itself.</p>
+
+<h3><a name="Object Command">Object Command</a></h3>
+
+<p>The object identifer returned from <a href="#optcl::new"><strong>optcl::new</strong></a>,
+is also a Tcl command for the lifetime of the object. Using the
+command, we can invoke the object's methods, and properties. As a
+means to improving efficiency, both forms of member access can be
+applied to a <a href="#Sub-Objects">sub-object</a> of the invoked
+OpTcl object. Methods can be invoked on an object, by appending
+to the object command (with a possible sub-object), the method
+name and its <a href="optcltypelibaccess.html#Parameters">parameters</a>.
+</p>
+
+<p>Access to properties of an OpTcl object are differentiated
+from method invocations by the placement of a <strong>:</strong>
+prior the property name, with white space seperating it from the
+name. For example to set the <em>visible</em> property of an
+object to true, we would use the following syntax:</p>
+
+<pre> $myobj : visible 1</pre>
+
+<p>And to retrieve it:</p>
+
+<pre> $myobj : visible
+ <em>==> 1</em></pre>
+
+<p>If the property is indexed, then its index can be specified
+within matching braces as a comma-seperated list. For example:</p>
+
+<pre> $myobj : grid(3,4) "foo"</pre>
+
+<h3><a name="Sub-Objects">Sub-Objects</a></h3>
+
+<p>COM objects often have deep hierarchies of objects, reachable
+from the created object. In many cases it may be inefficient to
+represent several of these objects within the hierarchy as OpTcl
+objects, in order to access a single object. For this purpose,
+the object command can take the -with option. This is a dot
+seperated list of sub-objects that it has to traverse before
+invoking the method or property. For example:</p>
+
+<pre> $app -with documents(1) save
+ $xl -with workbooks(1).worksheets(sheet1).range(a1,b2) : value 15</pre>
+
+<p><font size="1">Copyright (c) 1999, Farzad Pezeshkpour</font></p>
+</body>
+</html>
--- /dev/null
+<html>
+
+<head>
+<meta http-equiv="Content-Type"
+content="text/html; charset=iso-8859-1">
+<title>Type Library Access</title>
+</head>
+
+<body bgcolor="#FFFFFF">
+
+<p align="center"><img
+src="optcl_large.gif" width="172"
+height="176"></p>
+
+<h1 align="center">Type Library Access</h1>
+
+<p>OpTcl provides two means of accessing the type information
+stored in a Type Library - graphical or command-line based, with
+the graphical version being built on top of the command-line
+commands. </p>
+
+<h2 align="left">Command Line Access of Type Libraries</h2>
+
+<p align="left">The command line access to type libraries is
+implemented with the <em>typelib</em> namespace. Here's its
+synopsis:</p>
+
+<dl>
+ <dd><a href="#typelib::alllibs"><strong>typelib::alllibs</strong></a></dd>
+ <dd><a href="#typelib::updatelibs"><strong>typelib::updatelibs</strong></a></dd>
+ <dd><a href="#typelib::libdetail"><strong>typelib::libdetail</strong></a><strong>
+ </strong><em>fulllibname </em></dd>
+ <dd><a href="#typelib::load"><strong>typelib::load</strong></a>
+ <em>fulllibname</em></dd>
+ <dd><a href="#typelib::unload"><strong>typelib::unload</strong></a>
+ <em>fulllibname</em></dd>
+ <dd><a href="#typelib::isloaded"><strong>typelib::isloaded</strong></a>
+ <em>fulllibname</em></dd>
+ <dd><a href="#typelib::loaded"><strong>typelib::loaded</strong></a></dd>
+ <dd><a href="#typelib::types"><strong>typelib::types</strong></a>
+ <em>libname</em></dd>
+ <dd><a href="#typelib::typeinfo"><strong>typelib::typeinfo</strong></a>
+ <em>libname.type </em>?<em>element</em>?</dd>
+ <dt> </dt>
+</dl>
+
+<h3>Description</h3>
+
+<h4><a name="typelib::alllibs">typelib::alllibs</a></h4>
+
+<p>The <strong>typelib::alllibs</strong> command returns a list
+of registered libraries by their human readable names.</p>
+
+<h4><a name="typelib::updatelibs">typelib::updatelibs</a></h4>
+
+<p>The <strong>typelib::updatelibs</strong> command update OpTcl's
+internal list of registered libraries from the system registry.</p>
+
+<h4><a name="typelib::libdetail">typelib::libdetail</a></h4>
+
+<p>The <strong>typelib::libdetail</strong> command returns a list
+of three elements - the unique identifier for the library, its
+major version number, and its minor version number.</p>
+
+<h4><a name="typelib::load">typelib::load</a></h4>
+
+<p>The <strong>typelib::load</strong> takes as its only parameter,
+the human readable name of a registered Type Library. If
+successful in loading the library, the command returns the
+programmatic name for the library. Otherwise, the function
+returns an error.</p>
+
+<h4><a name="typelib::unload">typelib::unload</a></h4>
+
+<p>The <strong>typelib::unload</strong> command takes as its only
+parameter, the human readable library name of a registered Type
+Library. If the library has been loaded, it is subsequently
+unloaded.</p>
+
+<h4><a name="typelib::isloaded">typelib::isloaded</a></h4>
+
+<p>The <strong>typelib::isloaded</strong> command returns true if
+and only if its only argument is the user readable name of a
+library that is currently loaded.</p>
+
+<h4><a name="typelib::loaded">typelib::loaded</a></h4>
+
+<p>The <strong>typelib::loaded</strong> command returns a list of
+the currently loaded libraries, in terms of their programmatic
+names.</p>
+
+<h4><a name="typelib::types">typelib::types</a></h4>
+
+<p>The <strong>typelib::types</strong> command takes as its only
+required parameter, a programmatic name for a loaded library. It
+returns as its result a list of types defined in the library.
+Each element of this list is composed of two elements: a type
+category followed by the <a href="optcltypes.html">name of the
+type</a>. Types fall into one of the following categories.</p>
+
+<table border="0" cellpadding="4" cellspacing="4">
+ <tr>
+ <td valign="top"><strong>Category</strong></td>
+ <td valign="top"><strong>Description</strong></td>
+ </tr>
+ <tr>
+ <td valign="top"><strong>enum</strong></td>
+ <td valign="top">An enumeration type.</td>
+ </tr>
+ <tr>
+ <td valign="top"><strong>struct</strong></td>
+ <td valign="top">A record/structure type.</td>
+ </tr>
+ <tr>
+ <td valign="top"><strong>union</strong></td>
+ <td valign="top">A union type. Currently OpTcl can't
+ manipulate these.</td>
+ </tr>
+ <tr>
+ <td valign="top"><strong>typedef</strong></td>
+ <td valign="top">An alias to another type.</td>
+ </tr>
+ <tr>
+ <td valign="top"><strong>module</strong></td>
+ <td valign="top">Globally declared functions (currently,
+ OpTcl cannot call these).</td>
+ </tr>
+ <tr>
+ <td valign="top"><strong>interface</strong></td>
+ <td valign="top">A collection of functions that implement
+ the objects methods, and its properties (get and set
+ functions). OpTcl cannot call these directly.</td>
+ </tr>
+ <tr>
+ <td valign="top"><strong>dispatch</strong></td>
+ <td valign="top">The same as interface, except that OpTcl
+ can call these directly. Usually a dispatch interface
+ wraps an inherited interface type.</td>
+ </tr>
+ <tr>
+ <td valign="top"><a name="class"><strong>class</strong></a></td>
+ <td valign="top">A collection of interfaces (or
+ dispatches), broken into two categories: incoming and
+ outgoing. Incoming interfaces are those that are used to
+ invoke methods or access properties of an object, whilst
+ outgoing interfaces generate events from an object. In
+ each category, a class type can specify a default
+ interface. Each OpTcl object is associated with a maximum
+ of one class type.</td>
+ </tr>
+</table>
+
+<h4><a name="typelib::typeinfo">typelib::typeinfo</a></h4>
+
+<p>The <strong>typelib::typeinfo</strong> command returns
+information for either a type (in the form <em>lib.type</em>) or,
+if provided as the last parameter, an element of a type. These
+two forms are described as follows.</p>
+
+<h5>Type Information</h5>
+
+<p>The first form returns a list with four items. The first item
+is the type's category. The second is a list of methods supported
+by the type; the third is a list of properties for the type. The
+last item is a list of <a href="optcltypes.html">fully formed
+names</a> of inherited types.</p>
+
+<h5>Element Information</h5>
+
+<p>Information of an element is stored in a list of three
+elements: the category of the element (either <em>method</em> or <em>property</em>),
+its signature, and documentation string (null, if not provided by
+the library). </p>
+
+<p>The format for an element's signature is based upon the
+elements category. <em>method</em> elements return a signature
+that is a list, with the first item being the return type of the
+method, the second being the name of the method, and the
+remaining elements being its <a href="#Parameters">parameters</a>.</p>
+
+<p>For a <em>property</em> element, the signature is a list with
+the first element being the access flags to the property (a
+combination of <em>read</em> or <em>write</em>), followed by the
+properties type and its name. The remaining list elements are the
+<a href="#Parameters">parameters</a> required to access an
+indexed property.</p>
+
+<h4><a name="Parameters">Parameters</a></h4>
+
+<p>A parameter description in OpTcl is a list with three required
+members and one optional. </p>
+
+<p>The first list element is a collection of flags describing the
+direction of information flow for the parameter. This can either
+be <em>in</em>, <em>out</em>, or both together. A parameter
+flagged as <em>in</em> indicates that information flows from the
+caller to the callee (by value call). A parameter flagged with <em>out</em>
+indicates that information flows from the callee to the caller.
+In the case of both flags being present, the information flow is
+bi-directional (call by reference). It is important to note the
+significance of this when operating with COM objects from OpTcl.
+A parameter that is <em>out</em> or <em>inout</em> requires the
+name of a Tcl variable to hold the value of the parameter. In the
+case of <em>inout</em> the variable must exist prior to the
+method call. Currently, OpTcl doesn't make full use of type
+information for event handling. All parameters of an event are
+passed to Tcl by-value only, for the time being.</p>
+
+<p>The second list element is the <a href="optcltypes.html">correctly
+formed type-name</a> of the parameter. The third list element is
+the parameters name. The final optional list element is either a
+question mark, '?', indicating that the parameter is optional, or
+some other value, denoting a default value. OpTcl currently does
+not fill-in missing parameters with their default values.</p>
+
+<h2>Graphical Method for Accessing Type Libraries</h2>
+
+<p>For this OpTcl defines the <em>tlview</em> namespace. Here is
+a synopsis of the commands defined within it:</p>
+
+<dl>
+ <dd><a href="#tlview::refview"><strong>tlview::refview</strong></a>
+ <em>windowpath</em> </dd>
+ <dd><a href="#tlview::loadedlibs"><strong>tlview::loadedlibs</strong></a>
+ <em>windowpath</em> </dd>
+ <dd><a href="#tlview::viewlib"><strong>tlview::viewlib</strong></a>
+ <em>libname</em> </dd>
+ <dd><a href="#tlview::viewtype"><strong>tlview::viewtype</strong></a>
+ <em>libname.typename</em> </dd>
+</dl>
+
+<h3>Description</h3>
+
+<h4><a name="tlview::refview">tlview::refview</a></h4>
+
+<p>The <strong>tlview::refview</strong> command creates a
+toplevel window that displays a list of system-registered
+typelibraries. Here's a screen-shot:</p>
+
+<p><img src="refview.gif" width="406" height="367"></p>
+
+<p>In blue are the libraries currently loaded by OpTcl; the
+others aren't loaded. The Refresh button updates the list.
+Clicking on a library, either loads or unloads it, depending on
+its currently status. At the bottom of the screen, a status bar
+informs of result of the most recent operation.</p>
+
+<h4><a name="tlview::loadedlibs">tlview::loadedlibs</a></h4>
+
+<p>Once a library is loaded, it is referenced within OpTcl using
+a programmatic identifier; in fact, this is true for any client
+of COM's type-libraries - e.g. Visual Basic. The <strong>tlview::loadedlibs</strong>
+command creates a toplevel window, hosting a list of currently
+loaded libraries, in terms of their programmatic id. Heres's a
+screen-shot:</p>
+
+<p align="left"><img src="loadedlibs.gif" width="203"
+height="154"></p>
+
+<h4 align="left"><a name="tlview::viewlib">tlview::viewlib</a></h4>
+
+<p align="left">The list is automatically updated, every time the
+window receives mouse focus. Here's where the fun begins. Each
+element is mouse-sensitive - clicking on one creates a browser
+window for that library. At any time, a type browser can be
+opened using <strong>tlview::viewlib</strong> command. The system
+ensures that there is only one browser per library. Here's a grab
+of browser in action:</p>
+
+<p align="left"><img src="viewlib1.gif" width="465" height="379"></p>
+
+<p align="left">The left-hand pane contains a list of types
+within the library. Clicking on any type displays its elements in
+the right-hand pane. Elements in a typelibrary are organised in
+terms of methods, properties and inherited types. The right-hand
+pane sorts the elements into these basic groups. The lower pane
+gives a description of the element last clicked. If the type
+library provides any describing text for that element that is
+also displayed. In the lower pane, if a non-primitive type is
+used to describe either a property or an element of a method,
+then that type will also be click-sensitive. For a more detailed
+explanation please read the section on accessing elements of a
+type.</p>
+
+<h4 align="left"><a name="tlview::viewtype">tlview::viewtype</a></h4>
+
+<p align="left">The <strong>tlview::viewtype</strong> command can
+call-up a browser window to view the details of a specific type
+in a Type Library.</p>
+
+<p><font size="1">Copyright (c) 1999, Farzad Pezeshkpour</font></p>
+</body>
+</html>
--- /dev/null
+<html>
+
+<head>
+<meta http-equiv="Content-Type"
+content="text/html; charset=iso-8859-1">
+<title>Types In Optcl</title>
+</head>
+
+<body bgcolor="#FFFFFF">
+
+<p align="center"><img src="optcl_large.gif" width="172"
+height="176"></p>
+
+<h1 align="center">Types</h1>
+
+<h2>Type Libraries</h2>
+
+<p>In order to precisely describe the interface and (in some
+cases!) the functionality of a COM object, COM defines a language
+independant mechanism for describing types, called Type Libraries.
+You can think of these as a machine readable superset of header
+files. Using Type Libraries, the interfaces (more about these
+later), methods, events and properties of an object can be
+accurrately described. </p>
+
+<p>Having this kind of information is very important as it can a)
+allow for the accurate type conversion between Tcl objects and
+COM types, and b) speed up an invocation on an object. </p>
+
+<p>Optcl is now type library aware - at least in terms of <a
+href="optcltypelibaccess.html">reading</a> them and being type
+sensitive in its invocations. I hope a future version will be
+able to write out Type Libraries.</p>
+
+<p>In OpTcl, types are represented as a strings comprising of the
+programmatic name for a type library and its contained typename,
+joined using a dot. So for example<em>, stdole.IFontDisp</em> is
+the <em>IFontDisp</em> type defined in the library called <em>stdole</em>.
+</p>
+
+<h2>Primitive Types</h2>
+
+<p>The only exception to the formatting rule specified above are
+primitive. These are always a single word with no '.' delimiter.
+They are listed in the following table:</p>
+
+<table border="1" cellpadding="3" cellspacing="4">
+ <tr>
+ <td><strong>Type</strong></td>
+ <td><strong>Description</strong></td>
+ <td><strong>Type</strong></td>
+ <td><strong>Description</strong></td>
+ </tr>
+ <tr>
+ <td>char</td>
+ <td>A single character</td>
+ <td>string</td>
+ <td>single byte string</td>
+ </tr>
+ <tr>
+ <td>uchar</td>
+ <td>An unsigned character</td>
+ <td>carray</td>
+ <td>C-style array - not currently supported</td>
+ </tr>
+ <tr>
+ <td>short</td>
+ <td>16 bit signed integer</td>
+ <td>decimal</td>
+ <td>96-bit number</td>
+ </tr>
+ <tr>
+ <td>ushort</td>
+ <td>16 bit unsigned integer</td>
+ <td>float</td>
+ <td>32 bit real number</td>
+ </tr>
+ <tr>
+ <td>long</td>
+ <td>32 bit signed integer</td>
+ <td>double</td>
+ <td>64 bit real number</td>
+ </tr>
+ <tr>
+ <td>ulong</td>
+ <td>32 bit unsigned integer</td>
+ <td>dispatch</td>
+ <td>Scriptable interface to an object</td>
+ </tr>
+ <tr>
+ <td>bool</td>
+ <td>boolean</td>
+ <td>interface</td>
+ <td>Non-scriptable interface to an object</td>
+ </tr>
+ <tr>
+ <td>date</td>
+ <td>Date type.</td>
+ <td>currency</td>
+ <td>Currency. Range: ±922337203685477.5807</td>
+ </tr>
+ <tr>
+ <td>any</td>
+ <td>A variant type.</td>
+ <td> </td>
+ <td> </td>
+ </tr>
+</table>
+
+<p><font size="1">Copyright (c) 1999, Farzad Pezeshkpour</font></p>
+</body>
+</html>
--- /dev/null
+
+# OpTcl Installer
+# Author: Fuzz
+# fuzz@sys.uea.ac.uk
+
+package require registry
+
+set piccy ../docs/optcl_medium.gif
+
+set installfolder [file join [info library] .. optcl]
+set installname optcl.dll
+
+puts "Install dir: $installfolder"
+set version [info tclversion]
+
+if {$version < 8.0} {
+ tk_messageBox -message "Sorry, but OpTcl needs Tcl version 8.0.5" -type ok
+ exit
+} elseif {$version < 8.1} {
+ set dll optcl80.dll
+} elseif {$version < 9.0} {
+ set dll optclstubs.dll
+} else {
+ tk_messageBox -message "Sorry, but OpTcl was compiled for Tcl major-version 8" -type ok
+}
+
+image create photo optclim -file $piccy
+
+proc updategui {} {
+ global installfolder installname
+ if [file exists [file join $installfolder $installname]] {
+ .uninstall config -state normal
+ .install config -text "Re-install for Tcl[info tclversion]"
+ } else {
+ .uninstall config -state disabled
+ .install config -text "Install for Tcl[info tclversion]"
+ }
+}
+
+proc install {} {
+ global installfolder installname dll
+ set answer [tk_messageBox -title {} -message "Okay to install $dll in $installfolder\nand register as OpTcl package?" -icon question -type yesno]
+
+ switch $answer {
+ no {}
+ yes {
+ set bad [catch {
+ file mkdir $installfolder
+ file copy -force $dll [file join $installfolder $installname]
+ pkg_mkIndex -direct $installfolder
+ } err]
+ if {$bad} {
+ tk_messageBox -type ok -message "Error: $err" -icon error
+ } else {
+ tk_messageBox -type ok -message "OpTcl successfully installed." -icon info
+ }
+ exit
+ }
+ }
+}
+
+proc uninstall {} {
+ global installfolder installname
+ set reply [tk_messageBox -type yesno -message "Delete package OpTcl located at $installfolder?" -icon question]
+ if {[string compare $reply yes] != 0} return
+ file delete [file join $installfolder $installname] [file join $installfolder pkgIndex.tcl] $installfolder
+ updategui
+}
+
+wm title . "OpTcl Installer - F2 for console"
+bind . <F2> {console show}
+bind . <Alt-F4> {exit}
+
+label .im -image optclim -relief flat -bd 0
+button .install -text Install... -command install -width 16 -height 1 -bd 2 -font {arial 8 bold}
+button .uninstall -text Uninstall -command uninstall -width 16 -height 1 -bd 2 -font {arial 8 bold}
+button .quit -text Quit -command exit -bd 2 -font {arial 8 bold} -width 5 -height 1
+
+grid .im -column 0 -row 0 -rowspan 2 -padx 2 -pady 2
+grid .install -column 1 -row 0 -padx 2 -pady 2 -sticky nsew
+grid .uninstall -column 2 -row 0 -padx 2 -pady 2 -sticky nsew
+grid .quit -column 1 -row 1 -columnspan 2 -padx 2 -pady 2 -sticky nsew
+
+
+wm resizable . 0 0
+updategui
+raise .
+focus -force .
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * container.cpp
+ * Implementation of the CContainer class, providing functionality for
+ * a Tk activex container widget.
+ * 1999-01-26 created
+ * 1999-08-25 modified for use in Optcl
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+
+
+
+#include "stdafx.h"
+#include "tbase.h"
+#include "optcl.h"
+#include "utility.h"
+#include "Container.h"
+#include "optclobj.h"
+
+
+
+const char * CContainer::m_propname = "container";
+
+//////////////////////////////////////////////////////////////////////
+// Construction/Destruction
+//////////////////////////////////////////////////////////////////////
+/*
+ *-------------------------------------------------------------------------
+ * CContainer::CContainer() --
+ * Constructor
+ * Result:
+ * None
+ * Side effects:
+ * Members set to default values - initial height and width information
+ * stored here.
+ *-------------------------------------------------------------------------
+ */
+CContainer::CContainer(OptclObj *parent) :
+m_tkWindow(NULL),
+m_widgetCmd(NULL),
+m_pInterp(NULL),
+m_height(200),
+m_width(200),
+m_windowproc(NULL),
+m_bDestroyPending(false),
+m_optclobj(parent)
+{
+ ASSERT (parent != NULL);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ * CContainer::~CContainer() --
+ * Destructor
+ * Result:
+ * None
+ * Side effects:
+ * Tk window is requested to be destroyed.
+ * COM resources release (except for the control container which is release
+ * when the Tk window is actually destroyed.
+ *-------------------------------------------------------------------------
+ */
+
+CContainer::~CContainer()
+{
+ // close down the references to the object
+ m_bDestroyPending = true;
+ m_pUnk.Release();
+ m_pObj.Release();
+ m_pSite.Release();
+ m_pInPlaceObj.Release();
+ m_pOleWnd.Release();
+ m_pUnkHost.Release();
+
+ if (m_widgetCmd != NULL) {
+ if (!Tcl_InterpDeleted(m_pInterp))
+ Tcl_DeleteCommandFromToken (m_pInterp, m_widgetCmd);
+ m_widgetCmd = NULL;
+ }
+
+ if (m_tkWindow != NULL)
+ {
+ // remove the subclass
+ SetWindowLong (m_hTkWnd, GWL_WNDPROC, (LONG)m_windowproc);
+ RemoveProp (m_hTkWnd, m_propname);
+ Tk_DestroyWindow (m_tkWindow);
+ m_tkWindow = NULL;
+ }
+
+}
+
+/*
+ *-------------------------------------------------------------------------
+ * CContainer::ContainerEventProc --
+ * Called by Tk to process events
+ * Result:
+ * None
+ * Side effects:
+ * Lifetime and size of widget affected - focus model needs working on!
+ *-------------------------------------------------------------------------
+ */
+void CContainer::ContainerEventProc (ClientData cd, XEvent *pEvent)
+{
+ CContainer *pContainer = (CContainer *)cd;
+ SIZEL s, hm;
+ RECT r;
+
+ switch (pEvent->type)
+ {
+ case Expose:
+ // Nothing required as the AxAtl window
+ // should receive its own exposure event
+ break;
+ case FocusIn:
+ if (pContainer->m_pSite)
+ pContainer->m_pSite->OnFocus(TRUE);
+ /*
+ hControl = ::GetWindow (pContainer->m_hTkWnd, GW_CHILD);
+ if (hControl)
+ ::SetFocus(hControl);
+ */
+
+ break;
+ case ConfigureNotify:
+ s.cx = Tk_Width(pContainer->m_tkWindow);
+ s.cy = Tk_Height(pContainer->m_tkWindow);
+ r.left = r.top = 0;
+ r.right = s.cx;
+ r.bottom = s.cy;
+
+
+ AtlPixelToHiMetric(&s, &hm);
+ if (pContainer->m_pObj)
+ pContainer->m_pObj->SetExtent(DVASPECT_CONTENT, &hm);
+ if (pContainer->m_pInPlaceObj)
+ pContainer->m_pInPlaceObj->SetObjectRects (&r, &r);
+
+ break;
+ case DestroyNotify:
+ if (!pContainer->m_bDestroyPending) {
+ Tcl_EventuallyFree(cd, DeleteContainer);
+ pContainer->m_tkWindow = NULL;
+ }
+ break;
+
+
+ default:
+ break;
+ }
+
+}
+
+/*
+ *-------------------------------------------------------------------------
+ * CContainer::DeleteContainer --
+ * Called by ContainerEventProc, when the Tk_Window is about to be
+ * destroyed by scripting.
+ * Result:
+ * None
+ * Side effects:
+ * Memory deallocated
+ *-------------------------------------------------------------------------
+ */
+void CContainer::DeleteContainer (char *pObject)
+{
+ CContainer *pContainer = (CContainer*)pObject;
+ pContainer->m_optclobj->ContainerWantsToDie();
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * CContainer::Create --
+ * Called by the related object in order to create the window.
+ * tkParent in a parent of the window to be created. The string
+ * pointed to by 'id' is the clsid/progid/documentpath of this object.
+ *
+ * Result:
+ * NULL iff failed to be created (pInterp will store descriptive result)
+ *
+ * Side effects:
+ * Depends on object being created.
+ *-------------------------------------------------------------------------
+ */
+IUnknown * CContainer::Create (Tcl_Interp *pInterp, Tk_Window tkParent,
+ const char * widgetpath, const char *id)
+{
+ m_pInterp = pInterp;
+ char *path;
+ if (TCL_ERROR == CreateTkWindow (tkParent, (char*)widgetpath))
+ return NULL;
+
+ path = Tk_PathName(m_tkWindow);
+
+ Tcl_VarEval (pInterp, "winfo id ", path, (char*)NULL);
+
+ int iParent;
+ Tcl_GetIntFromObj (pInterp, Tcl_GetObjResult (pInterp), &iParent);
+ m_hTkWnd = (HWND) iParent;
+ SetProp (m_hTkWnd, m_propname, (HANDLE)this);
+
+ if (!CreateControl(pInterp, id))
+ return NULL;
+
+ InitFromObject ();
+
+
+ // subclass this window (once again, since ATL has already hooked it), in order
+ // to correctly handle mouse messages and destruction
+ m_windowproc = SetWindowLong (m_hTkWnd, GWL_WNDPROC, (LONG)WidgetSubclassProc);
+
+ // Set up the height and width accordingly
+ Tk_GeometryRequest (m_tkWindow, m_width, m_height);
+
+
+ m_widgetCmd = Tcl_CreateObjCommand (m_pInterp, path, WidgetCmd,
+ (ClientData)this, NULL);
+
+ Tcl_SetResult (m_pInterp, path, TCL_STATIC);
+ return m_pUnk;
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * CContainer::WidgetCmd --
+ * Static class method that is called by Tcl when invoking the widget
+ * command.
+ * Result:
+ * TCL_OK if command execute ok; else TCL_ERROR
+ * Side effects:
+ * Dependant on the subcommand
+ *-------------------------------------------------------------------------
+ */
+int CContainer::WidgetCmd ( ClientData cd, Tcl_Interp *pInterp, int objc,
+ Tcl_Obj *CONST objv[] )
+{
+ if (objc < 2) {
+ Tcl_AppendResult (pInterp, "wrong # args: should be \"",
+ Tcl_GetStringFromObj (objv[0], NULL), " option ?arg arg ...?\"", (char*)NULL);
+ return TCL_ERROR;
+ }
+ char *szCommand = Tcl_GetStringFromObj(objv[1], NULL);
+ int nLength = strlen(szCommand);
+ CContainer *pWidget = (CContainer*)cd;
+
+ if (strncmp (szCommand, "configure", nLength) == 0) {
+ switch (objc) {
+ case 2:
+ return pWidget->ConfigInfo (pInterp);
+ break;
+ case 3:
+ return pWidget->ConfigInfo (pInterp, Tcl_GetStringFromObj(objv[2], NULL));
+ break;
+ default:
+ return pWidget->ConfigInfo (pInterp, objc - 2, objv + 2);
+ break;
+ }
+ }
+
+ if (strncmp (szCommand, "cget", nLength) == 0) {
+ if (objc == 3) {
+ return pWidget->ConfigInfo (pInterp, Tcl_GetStringFromObj(objv[2], NULL));
+ } else {
+ Tcl_AppendResult (pInterp, "wrong # args: should be \"",
+ Tcl_GetStringFromObj (objv[0], NULL), " cget arg\"", (char*)NULL);
+ return TCL_ERROR;
+ }
+ }
+
+ Tcl_AppendResult (pInterp, "urecognised command: ", szCommand, (char*)NULL);
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ * CContainer::ConfigInfo (Tcl_Interp *pInterp) --
+ * Overloaded method that returns the value of all configuration options
+ * for the widget
+ * Result:
+ * TCL_OK
+ * Side effects:
+ * New Tcl result
+ *-------------------------------------------------------------------------
+ */
+int CContainer::ConfigInfo (Tcl_Interp *pInterp)
+{
+ Tcl_DString dstring;
+ Tcl_DStringInit(&dstring);
+
+ Tcl_ResetResult(pInterp);
+ ConfigInfo (pInterp, "-width");
+ Tcl_DStringAppendElement(&dstring, Tcl_GetStringResult (pInterp));
+
+ Tcl_ResetResult(pInterp);
+ ConfigInfo (pInterp, "-height");
+ Tcl_DStringAppendElement(&dstring, Tcl_GetStringResult (pInterp));
+
+ Tcl_SetResult(pInterp, dstring.string, TCL_VOLATILE);
+ Tcl_DStringFree(&dstring);
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ * CContainer::ConfigInfo (Tcl_Interp *pInterp, char *pProperty) --
+ * Overloaded method that provides the value of a given configuration
+ * option.
+ * Result:
+ * TCL_OK iff configuration option exists; else TCL_ERROR
+ * Side effects:
+ * New Tcl result.
+ *-------------------------------------------------------------------------
+ */
+int CContainer::ConfigInfo (Tcl_Interp *pInterp, char *pProperty)
+{
+ bool bFound = false;
+ if (strcmp(pProperty, "-width")==0) {
+ bFound = true;
+ Tcl_SetObjResult (pInterp, Tcl_NewIntObj (m_width));
+ }
+
+ else if (strcmp(pProperty, "-height")==0) {
+ bFound = true;
+ Tcl_SetObjResult (pInterp, Tcl_NewIntObj (m_height));
+ }
+
+ else if (strcmp(pProperty, "-takefocus")==0) {
+ bFound = true;
+ Tcl_SetObjResult (pInterp, Tcl_NewBooleanObj(1));
+ }
+
+ if (!bFound) {
+ Tcl_ResetResult (pInterp);
+ Tcl_AppendResult (pInterp, "unknown option \"", pProperty, (char*)NULL);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ * CContainer::ConfigInfo (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST pArgs[]) --
+ * Overloaded method; used to set the value of a number of options
+ * Result:
+ * TCL_OK iff all specified options are set ok; else TCL_ERROR
+ * Side effects:
+ * Change in options may have an effect on the size and viewing of the
+ * widget
+ *-------------------------------------------------------------------------
+ */
+int CContainer::ConfigInfo (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST pArgs[])
+{
+ if (objc % 2 == 0)
+ {
+ bool bChanged = false;
+ for (int i = 0; i < objc; i += 2) {
+ if (SetProperty (pInterp, pArgs[i], pArgs[i+1], bChanged) != TCL_OK)
+ return TCL_ERROR;
+ }
+ if (bChanged)
+ {
+ Tk_GeometryRequest(m_tkWindow, m_width, m_height);
+ }
+ return TCL_OK;
+ }
+ else // # of values != # of options
+ {
+ char *szLast = Tcl_GetStringFromObj(pArgs[objc-1], NULL);
+ Tcl_ResetResult(pInterp);
+ Tcl_AppendResult (pInterp, "unknown option \"", szLast, "\"", (char*)NULL);
+ return TCL_ERROR;
+ }
+}
+
+/*
+ *-------------------------------------------------------------------------
+ * CContainer::SetProperty --
+ * Sets a single option with a new value.
+ * Result:
+ * TCL_OK iff option set ok; else TCL_ERROR
+ * Side effects:
+ * Size and other viewing factors may change for widget
+ *-------------------------------------------------------------------------
+ */
+int CContainer::SetProperty (Tcl_Interp *pInterp, Tcl_Obj *pProperty, Tcl_Obj *pValue, bool &bChanged)
+{
+ char *szProperty = Tcl_GetStringFromObj (pProperty, NULL);
+ int value;
+
+ if (strcmp(szProperty, "-width")==0) {
+ if (Tcl_GetIntFromObj (pInterp, pValue, &value) == TCL_ERROR)
+ return TCL_ERROR;
+ m_width = abs(value);
+ bChanged = true;
+ }
+
+ else if (strcmp(szProperty, "-height")==0) {
+ if (Tcl_GetIntFromObj (pInterp, pValue, &value) == TCL_ERROR)
+ return TCL_ERROR;
+ m_height = abs(value);
+ bChanged = true;
+ }
+
+ else {
+ Tcl_ResetResult (pInterp);
+ Tcl_AppendResult (pInterp, "unknown option \"", szProperty, (char*)NULL);
+ return TCL_ERROR;
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ * CContainer::WidgetSubclassProc --
+ * This is used to subclass the main window to handle proper forwarding
+ * of mouse capture, release of the control container, and the release of
+ * OLE resources.
+ * Result:
+ * The return of the subclassed window procedure
+ * Side effects:
+ * Mouse capture affected - COM interfaces destroyed, OLE uninitialised by one
+ *-------------------------------------------------------------------------
+ */
+LRESULT CALLBACK CContainer::WidgetSubclassProc (HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam)
+{
+ CContainer *pContainer = (CContainer*) GetProp (hwnd, m_propname);
+ if (pContainer == NULL) return 0;
+ WORD fwEvent = LOWORD (wParam);
+ WORD idChild = HIWORD (wParam);
+ HWND hCurrentFocus = GetFocus();
+
+ switch (uMsg) {
+ case WM_MOUSEACTIVATE:
+ return MA_ACTIVATE;
+ break;
+
+ case WM_NCCREATE:
+ pContainer->m_pHost.Release();
+ break;
+ }
+
+ return CallWindowProc ((WNDPROC)(pContainer->m_windowproc), hwnd, uMsg, wParam, lParam);
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * CContainer::InitFromObject --
+ * Initialises interface pointers to the underlying control, and site
+ * Result:
+ * None
+ * Side effects:
+ * COM memory allocation of vtables etc.
+ *-------------------------------------------------------------------------
+ */
+void CContainer::InitFromObject ()
+{
+ AtlAxGetControl(m_hTkWnd, &m_pUnk);
+ m_pObj = m_pUnk;
+ m_pInPlaceObj = m_pUnk;
+ m_pOleWnd = m_pUnk;
+ m_pSite = m_pUnkHost;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * CContainer::CreateTkWindow --
+ * Called by the Create member function to create the Tk window
+ * Result:
+ * returns TCL_OK iff window created
+ * Side effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+int CContainer::CreateTkWindow(Tk_Window tkParent, char *path)
+{
+ // create the window, specifying that it is a child
+ m_tkWindow = Tk_CreateWindowFromPath(m_pInterp, tkParent, path, NULL);
+ if (m_tkWindow == NULL)
+ return TCL_ERROR;
+
+ Tk_SetClass(m_tkWindow, "Container");
+ m_tkDisplay = Tk_Display(m_tkWindow);
+
+ Tk_CreateEventHandler (m_tkWindow,
+ StructureNotifyMask |
+ ExposureMask |
+ FocusChangeMask,
+ ContainerEventProc, (ClientData)this);
+
+ Tk_MakeWindowExist(m_tkWindow);
+ return TCL_OK;
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * CContainer::CreateControl --
+ * Using Atl, creates the control. Ensures that the children of the
+ * control can be navigated with the keyboard.
+ *
+ * Result:
+ * true iff succeeded. pInterp will hold a description of the error.
+ *
+ * Side effects:
+ * Depends on the object being created
+ *-------------------------------------------------------------------------
+ */
+bool CContainer::CreateControl (Tcl_Interp *pInterp, const char *id)
+{
+ USES_CONVERSION;
+ HRESULT hr = E_FAIL;
+ HWND hWndChild;
+ LPOLESTR oleid = A2OLE(id);
+
+ hr = AtlAxCreateControl (oleid, m_hTkWnd, NULL, &m_pUnkHost);
+ if (FAILED(hr))
+ goto error;
+
+ m_pHost = m_pUnkHost;
+
+ if (m_pHost == NULL) {
+ hr = E_NOINTERFACE;
+ goto error;
+ }
+
+
+ // check for control parent style if control has a window
+ hWndChild = ::GetWindow(m_hTkWnd, GW_CHILD);
+ if(hWndChild != NULL)
+ {
+ if(::GetWindowLong(hWndChild, GWL_EXSTYLE) & WS_EX_CONTROLPARENT)
+ {
+ DWORD dwExStyle = ::GetWindowLong(m_hTkWnd, GWL_EXSTYLE);
+ dwExStyle |= WS_EX_CONTROLPARENT;
+ ::SetWindowLong(m_hTkWnd, GWL_EXSTYLE, dwExStyle);
+ }
+ }
+ return true;
+error:
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_STATIC);
+ return false;
+}
+
+
+
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * container.cpp
+ * Declaration of the CContainer class, providing functionality for
+ * a Tk activex container widget.
+ * 1999-01-26 created
+ * 1999-08-25 modified for use in Optcl
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+
+#if !defined(AFX_CONTAINER_H__C07038C0_9445_11D2_86E7_0000B482A708__INCLUDED_)
+#define AFX_CONTAINER_H__C07038C0_9445_11D2_86E7_0000B482A708__INCLUDED_
+
+#if _MSC_VER > 1000
+#pragma once
+#endif // _MSC_VER > 1000
+
+
+class OptclObj;
+
+
+class CContainer
+{
+public: // constructors
+ CContainer(OptclObj *pObj);
+ virtual ~CContainer();
+
+public: // non-static methods
+ IUnknown * Create (Tcl_Interp *pInterp, Tk_Window tkParent, const char * path, const char *id);
+
+public: // static methods
+ static void ContainerEventProc (ClientData cd, XEvent *pEvent);
+ static void DeleteContainer (char *pObject);
+ static LRESULT CALLBACK WidgetSubclassProc (HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam);
+protected: // static methods
+ static int WidgetCmd (ClientData cd, Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST objv[]);
+
+protected: // non-static methods
+ int ConfigInfo (Tcl_Interp *pInterp);
+ int ConfigInfo (Tcl_Interp *pInterp, char *pProperty);
+ int ConfigInfo (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST pArgs[]);
+ int SetProperty (Tcl_Interp *pInterp, Tcl_Obj *pProperty, Tcl_Obj *pValue, bool &bChanged);
+ bool CreateControl (Tcl_Interp *pInterp, const char *id);
+ void InitFromObject ();
+ int CreateTkWindow(Tk_Window tkParent, char *path);
+
+protected: // members variables
+ Tk_Window m_tkWindow;
+ Tcl_Interp * m_pInterp;
+ Display * m_tkDisplay;
+ Tcl_Command m_widgetCmd;
+ HWND m_hTkWnd;
+ DWORD m_height;
+ DWORD m_width;
+ LONG m_windowproc;
+ bool m_bDestroyPending;
+ OptclObj * m_optclobj;
+
+ // Com pointers
+ CComPtr<IUnknown> m_pUnk; // pointer to the contained object
+ CComPtr<IUnknown> m_pUnkHost; // pointer to the host IUnknown
+
+ // QI ptrs that have the IDD-templatised versions
+ CComQIPtr<IOleObject> m_pObj;
+ CComQIPtr<IOleInPlaceObject> m_pInPlaceObj;
+ CComQIPtr<IOleWindow> m_pOleWnd;
+ CComQIPtr<IOleControlSite> m_pSite;
+ CComQIPtr<IAxWinHostWindow, &IID_IAxWinHostWindow> m_pHost; // pointer to the host (client site) object
+protected: // static member variables
+
+ static const char * m_propname;
+};
+
+#endif // !defined(AFX_CONTAINER_H__C07038C0_9445_11D2_86E7_0000B482A708__INCLUDED_)
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * dispparams.cpp
+ * Implementation of the DispParams class, a wrapper for the DISPPARAMS
+ * Automation type.
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+
+#include "stdafx.h"
+#include "tbase.h"
+#include "optcl.h"
+#include "DispParams.h"
+#include "utility.h"
+
+
+
+
+//////////////////////////////////////////////////////////////////////
+// Construction/Destruction
+//////////////////////////////////////////////////////////////////////
+
+/*
+ *-------------------------------------------------------------------------
+ * DispParams::DispParams --
+ * Constructor - nulls out everything.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+DispParams::DispParams()
+{
+ rgvarg = NULL;
+ rgdispidNamedArgs = NULL;
+ cArgs = 0;
+ cNamedArgs = 0;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ * DispParams::~DispParams --
+ * Destructor - releases internal data.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+DispParams::~DispParams()
+{
+ Release();
+}
+
+/*
+ *-------------------------------------------------------------------------
+ * DispParams::Release --
+ * Releases all allocated variants. Nulls out the DISPPARAMS structure.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void DispParams::Release ()
+{
+ // start releasing the variants
+ for (UINT i = 0; i < cArgs; i++)
+ {
+ ASSERT (rgvarg != NULL);
+ OptclVariantClear (rgvarg+i);
+ }
+
+ delete_ptr (rgvarg);
+ delete_ptr (rgdispidNamedArgs);
+ cArgs = 0;
+ cNamedArgs = 0;
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * DispParams::Args --
+ * Sets up the number of arguments, both name and unnamed.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * Allocates enough memory for the dispatch id's of the named arguments.
+ *
+ *-------------------------------------------------------------------------
+ */
+void DispParams::Args (UINT args, UINT named)
+{
+ UINT i;
+
+ Release();
+ if (args > 0)
+ {
+ rgvarg = new VARIANTARG[args];
+ for (i = 0; i < args; i++)
+ VariantInit(rgvarg+i);
+ cArgs = args;
+ }
+
+ if (named > 0)
+ {
+ rgdispidNamedArgs = new DISPID[named];
+ for (i = 0; i < named; i++)
+ rgdispidNamedArgs[i] = DISPID_UNKNOWN;
+ cNamedArgs = named;
+ }
+}
+
+/*
+ *-------------------------------------------------------------------------
+ * DispParams::SetDISPID --
+ * Sets the dispatch id of a named arguments. The argument is accessed using
+ * the index 'named'.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void DispParams::SetDISPID (UINT named, DISPID id)
+{
+ ASSERT (named < cNamedArgs);
+ rgdispidNamedArgs[named] = id;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * DispParams::operator[] --
+ * operator to get direct access to an argument at a certain index.
+ *
+ * Result:
+ * A reference to the argument.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+VARIANTARG &DispParams::operator[] (UINT arg)
+{
+ ASSERT (arg < cArgs);
+ return rgvarg[arg];
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * DispParams::Set --
+ *
+ * Result:
+ *
+ * Side effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+void DispParams::Set (UINT index, VARIANT * pv)
+{
+ ASSERT (pv != NULL);
+ ASSERT (index < cArgs);
+
+ V_VARIANTREF(rgvarg + index) = pv;
+ V_VT(rgvarg + index) = VT_VARIANT|VT_BYREF;
+}
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * dispparams.h
+ * Declaration of the DispParams class, a wrapper for the DISPPARAMS
+ * Automation type.
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+
+#if !defined(AFX_DISPPARAMS_H__BF3EF6CA_73B0_11D4_8004_0040055861F2__INCLUDED_)
+#define AFX_DISPPARAMS_H__BF3EF6CA_73B0_11D4_8004_0040055861F2__INCLUDED_
+
+#if _MSC_VER > 1000
+#pragma once
+#endif // _MSC_VER > 1000
+
+
+
+class DispParams : public DISPPARAMS
+{
+public:
+ DispParams();
+ virtual ~DispParams();
+
+ void Release ();
+ void Args (UINT args, UINT named = 0);
+ void SetDISPID (UINT named, DISPID id);
+ VARIANTARG &operator[] (UINT arg);
+
+
+ /*
+ *-------------------------------------------------------------------------
+ * Set --
+ * Template function that sets the value of a variant at index 'index'
+ * to a template-type value. This works because the type T should have
+ * an appropriate casting operator to fit those of VC6's _variant_t
+ * Result:
+ * None.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+ template <class T> void Set (UINT index, T value)
+ {
+ _variant_t t;
+ VARIANTARG *pref = &(operator[](index));
+ t.Attach (*pref);
+ t = value;
+ *pref = t.Detach();
+ }
+
+ void Set (UINT index, VARIANT * pv);
+};
+
+#endif // !defined(AFX_DISPPARAMS_H__BF3EF6CA_73B0_11D4_8004_0040055861F2__INCLUDED_)
+
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * eventbinding.cpp
+ * Declares classes used for implementing OpTcl's event binding.
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+
+#include "stdafx.h"
+#include "tbase.h"
+#include "EventBinding.h"
+#include "optcl.h"
+#include "utility.h"
+#include "objmap.h"
+#include "typelib.h"
+#include "optclbindptr.h"
+
+//////////////////////////////////////////////////////////////////////
+// Construction/Destruction
+//////////////////////////////////////////////////////////////////////
+
+
+/*
+ *-------------------------------------------------------------------------
+ * EventNotFound --
+ * Writes a standard error message to the interpreter, indicating
+ * that an event was not found.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void EventNotFound (Tcl_Interp *pInterp, const char * event)
+{
+ Tcl_SetResult (pInterp, "event not found: ", TCL_STATIC);
+ Tcl_AppendResult (pInterp, (char*) event, NULL);
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * EventBindings::EventBindings --
+ * Constructor - caches the parameters, and attempts to bind to ITypeComp
+ * interface. If not found, throw an HRESULT.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+EventBindings::EventBindings(OptclObj *pObj, REFGUID guid, ITypeInfo *pInfo)
+: m_ref(0), m_bindings(0), m_cookie(0)
+{
+ ASSERT (pInfo!= NULL);
+ ASSERT (pObj != NULL);
+
+ HRESULT hr;
+
+ m_pti = pInfo;
+ m_optclobj = pObj;
+ m_guid = guid;
+
+ hr = m_pti->GetTypeComp(&m_ptc);
+ CHECKHR(hr);
+ ASSERT (m_ptc != NULL);
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * EventBindings::~EventBindings --
+ * Destructor - ensures that any event bindings within this object
+ * are deleted.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+EventBindings::~EventBindings()
+{
+ DeleteTbl();
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * EventBindings::DeleteTbl --
+ * Iterates through the command table, and deletes each object
+ * before finally deleting the hash table.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void EventBindings::DeleteTbl()
+{
+ DispCmdTbl::iterator i;
+ TObjPtr p;
+
+ for (i = m_cmdtbl.begin(); i != m_cmdtbl.end(); i++)
+ {
+ BindingProps *p = *i;
+ ASSERT (p != NULL);
+ delete p;
+ }
+ m_cmdtbl.deltbl();
+ m_bindings = 0;
+}
+
+
+
+
+// IUnknown Entries
+/*
+ *-------------------------------------------------------------------------
+ * EventBindings::QueryInterface --
+ * Implements the IUnknown member. Successfull iff riid is for IUnknown,
+ * IDispatch, or the event interface that we're implementing.
+ *
+ * Result:
+ * Standard COM result.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+HRESULT STDMETHODCALLTYPE EventBindings::QueryInterface(REFIID riid, void ** ppvObject)
+{
+ HRESULT hr = S_OK;
+ if (riid == IID_IUnknown)
+ *ppvObject = (IUnknown*)this;
+ else if (riid == IID_IDispatch || riid == m_guid)
+ *ppvObject = (IDispatch*)this;
+ else
+ hr = E_NOINTERFACE;
+ if (SUCCEEDED(hr))
+ AddRef();
+
+ return hr;
+}
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * EventBindings::AddRef --
+ * Implements the IUnknown member.
+ * Result:
+ * Standard AddRef result.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+ULONG STDMETHODCALLTYPE EventBindings::AddRef( void)
+{
+ return InterlockedIncrement (&m_ref);
+}
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * EventBindings::Release --
+ * Implements the IUnknown member. In fact, this never deletes this object
+ * That responsibility is always with the optcl object. I am not sure
+ * if this approach is a good one. So beware! :o
+ *
+ * Result:
+ * Standard Release result.
+ * Side effects:
+ * None, what so ever.
+ *-------------------------------------------------------------------------
+ */
+ULONG STDMETHODCALLTYPE EventBindings::Release( void)
+{
+ // a dummy function
+ if (InterlockedDecrement (&m_ref) <= 0)
+ m_ref = 0;
+ return m_ref;
+}
+
+
+
+
+
+// IDispatch Entries
+/*
+ *-------------------------------------------------------------------------
+ * EventBindings::GetTypeInfoCount --
+ * Implements the IDispatch member. 1 if we did get a type info. The
+ * check isn't necessary at all, but I've put it there just as a reminder.
+ * Result:
+ * S_OK always.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+HRESULT STDMETHODCALLTYPE EventBindings::GetTypeInfoCount(UINT *pctinfo)
+{
+ ASSERT (m_pti != NULL);
+ *pctinfo = (m_pti!=NULL)?1:0;
+ return S_OK;
+}
+
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * EventBindings::GetTypeInfo --
+ * Implements the IDispatch member. Standard stuff.
+ * Result:
+ * Standard GetTypeInfo result.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+HRESULT STDMETHODCALLTYPE
+EventBindings::GetTypeInfo(UINT iTInfo, LCID lcid, ITypeInfo ** ppTInfo)
+{
+ ASSERT (lcid == LOCALE_SYSTEM_DEFAULT);
+ HRESULT hr = S_OK;
+ if (iTInfo != 0 || m_pti == NULL || ppTInfo == NULL)
+ hr = DISP_E_BADINDEX;
+ else {
+ (*ppTInfo) = m_pti;
+ (*ppTInfo)->AddRef();
+ }
+ return hr;
+}
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * EventBindings::GetIDsOfNames --
+ * Standard IDispatch member. Passes on the responsiblity to the type
+ * library.
+ * Result:
+ * Standard com result.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+HRESULT STDMETHODCALLTYPE
+EventBindings::GetIDsOfNames(REFIID riid, LPOLESTR *rgszNames,
+ UINT cNames, LCID lcid, DISPID *rgDispId)
+{
+ HRESULT hr = S_OK;
+ if (m_pti == NULL)
+ hr = DISP_E_UNKNOWNNAME;
+ if (lcid != LOCALE_SYSTEM_DEFAULT)
+ hr = DISP_E_UNKNOWNLCID;
+ else
+ hr = DispGetIDsOfNames (m_pti, rgszNames, cNames, rgDispId);
+ return hr;
+}
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * EventBindings::Invoke --
+ * Called by the event source when an event is raised. Attempts to
+ * find event in the event table. If not bound yet, simply returns,
+ * otherwise, asks the binding to be evaluated.
+ * Result:
+ * S_OK iff succeeded. If error and an exception info struct is available,
+ * then it is filled out.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+HRESULT STDMETHODCALLTYPE
+EventBindings::Invoke(DISPID dispIdMember, REFIID riid, LCID lcid,
+ WORD wFlags, DISPPARAMS *pDispParams, LPVARIANT pVarResult,
+ LPEXCEPINFO pExcepInfo, UINT *puArgErr)
+{
+ if (pDispParams == NULL)
+ return E_FAIL;
+
+ // look up the dispatch id in our table.
+ BindingProps *bp = NULL;
+
+
+
+ if (m_cmdtbl.find((DISPID*)dispIdMember, &bp) != NULL)
+ {
+ ASSERT (bp != NULL);
+ int res = bp->Eval(m_optclobj, pDispParams, pVarResult, pExcepInfo);
+ if (res == TCL_ERROR) {
+ if (pExcepInfo == NULL)
+ return E_FAIL;
+ else
+ return DISP_E_EXCEPTION;
+ }
+ }
+ return S_OK;
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * EventBindings::Name2Dispid --
+ * Binds a string name to a dispatch id in the implemented event interface.
+ *
+ * Result:
+ * true iff successful. pInterp will contain the error string if not.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+bool EventBindings::Name2Dispid (Tcl_Interp *pInterp, const char * name, DISPID &dispid)
+{
+ ASSERT (pInterp != NULL && name != NULL && m_ptc != NULL);
+
+ USES_CONVERSION;
+ LPOLESTR olename;
+ HRESULT hr;
+ OptclBindPtr obp;
+ bool bOk = false;
+
+ olename = A2OLE (name);
+
+ try {
+ hr = m_ptc->Bind (olename, LHashValOfName(LOCALE_SYSTEM_DEFAULT, olename),
+ INVOKE_FUNC, &obp.m_pti, &obp.m_dk, &obp.m_bp);
+ CHECKHR(hr);
+
+ if (obp.m_dk == DESCKIND_FUNCDESC) {
+ ASSERT (obp.m_bp.lpfuncdesc != NULL);
+ dispid = obp.m_bp.lpfuncdesc->memid;
+ bOk = true;
+ } else
+ EventNotFound(pInterp, name);
+ }
+ catch (HRESULT hr) {
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ }
+
+ return bOk;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ * EventBindings::TotalBindings --
+ * Returns the total number of even bindings in this collection.
+ * Result:
+ * The count.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+ULONG EventBindings::TotalBindings ()
+{
+ return m_bindings;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * EventBindings::SetBinding --
+ * Attempts to bind an event, give by name, to a tcl command (a tcl object)
+ *
+ * Result:
+ * true iff successful. Else, error string in interpreter.
+ * Side effects:
+ * Changes the count of the number of bindings.
+ *-------------------------------------------------------------------------
+ */
+bool EventBindings::SetBinding (Tcl_Interp *pInterp, const char * name, Tcl_Obj *pCommand)
+{
+ ASSERT (pInterp != NULL && name != NULL && pCommand != NULL);
+
+ DISPID dispid;
+
+ if (!Name2Dispid (pInterp, name, dispid))
+ return false;
+
+ BindingProps *pbp = NULL;
+ if (!m_cmdtbl.find ((DISPID*)(dispid), &pbp)) {
+ pbp = new BindingProps (pInterp, pCommand);
+ m_cmdtbl.set ((DISPID*)(dispid), pbp);
+ m_bindings++;
+ } else {
+ ASSERT (pbp != NULL);
+ pbp->m_pInterp = pInterp;
+ pbp->m_pScript = pCommand;
+ }
+ return true;
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * EventBindings::GetBinding --
+ * Returns within the interpreter the tcl command bound to an event.
+ * Result:
+ * true iff successful. Else, error string in interpreter.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+bool EventBindings::GetBinding (Tcl_Interp *pInterp, const char * name)
+{
+ ASSERT (pInterp != NULL && name != NULL);
+ DISPID dispid;
+
+ if (!Name2Dispid (pInterp, name, dispid))
+ return false;
+
+
+ BindingProps *pbp = NULL;
+ if (m_cmdtbl.find ((DISPID*)(dispid), &pbp)) {
+ ASSERT (pbp != NULL);
+ Tcl_SetObjResult (pInterp, pbp->m_pScript);
+ }
+ return true;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * EventBindings::DeleteBinding --
+ * Removes an event binding.
+ * Result:
+ * false iff 'name' is not the name of an existing event.
+ * Side effects:
+ * Changes the count of the number of bindings.
+ *-------------------------------------------------------------------------
+ */
+bool EventBindings::DeleteBinding (Tcl_Interp *pInterp, const char * name)
+{
+ ASSERT (pInterp != NULL && name != NULL);
+ DISPID dispid;
+
+ if (!Name2Dispid (pInterp, name, dispid))
+ return false;
+ BindingProps *pbp = NULL;
+ if (m_cmdtbl.find ((DISPID*)(dispid), &pbp)) {
+ ASSERT (pbp != NULL);
+ delete pbp;
+ m_cmdtbl.delete_entry ((DISPID*)(dispid));
+ m_bindings--;
+ }
+ return true;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * BindingProps::Eval --
+ * The guts of the event handler. Pulls out the parameters (in reverse order)
+ * and invokes that on the registered tcl handler. Note that the command
+ * line will look like:
+ * handler objid ?arg ...?
+ * where objid is the optcl identifier of the activex object that created
+ * the event.
+ *
+ * Result:
+ * Standard Tcl Result.
+ *
+ * Side effects:
+ * Depends on the tcl handler.
+ *-------------------------------------------------------------------------
+ */
+int BindingProps::Eval (OptclObj *pObj, DISPPARAMS *pDispParams, LPVARIANT pVarResult,
+ LPEXCEPINFO pExcepInfo)
+{
+ ASSERT (m_pInterp != NULL && m_pScript.isnotnull());
+ ASSERT (pDispParams != NULL);
+ ASSERT (pObj != NULL);
+
+ OptclObj ** ppObjs = NULL;
+
+ TObjPtr cmd;
+ UINT count;
+ int result = TCL_ERROR;
+
+ cmd.copy(m_pScript);
+ cmd.lappend ((const char*)(*pObj)); // cast to a string
+
+ ASSERT (pDispParams->cNamedArgs == 0);
+
+ // potentially all the parameters could result in an object, so
+ // allocate an array and set it all to nulls.
+ if (pDispParams->cArgs > 0) {
+ ppObjs = (OptclObj**)calloc(pDispParams->cArgs, sizeof (OptclObj*));
+ if (ppObjs == NULL) {
+ Tcl_SetResult (m_pInterp, "failed to allocate memory", TCL_STATIC);
+ Tcl_BackgroundError (m_pInterp);
+ return TCL_ERROR;
+ }
+ }
+
+ // temporarily increase the reference count on the object
+ // this way, if the event handler unlocks the objects, a possible
+ // destruction doesn't occur until this event has been handled
+ g_objmap.Lock (pObj);
+
+ try {
+ // convert the dispatch parameters into Tcl arguments
+ for (count = 0; count < pDispParams->cArgs; count++)
+ {
+ TObjPtr param;
+ if (!var2obj(m_pInterp, pDispParams->rgvarg[pDispParams->cArgs - count - 1], param, ppObjs+count))
+ break;
+ cmd.lappend(param, m_pInterp);
+ }
+ }
+
+ // the error will already be stored in the interpreter
+ catch (char *) {
+ }
+
+
+ // if we managed to convert all the parameters, invoke the function
+ if (count == pDispParams->cArgs)
+ result = Tcl_GlobalEvalObj (m_pInterp, cmd);
+
+
+
+ // deallocate the objects
+ for (count = 0; count < pDispParams->cArgs; count++)
+ {
+ if (ppObjs[count] != NULL)
+ g_objmap.Unlock (ppObjs[count]);
+ }
+
+ // release the object pointers
+ if (ppObjs != NULL)
+ free (ppObjs);
+
+ if (result == TCL_ERROR)
+ {
+ // do we have a exception storage
+ if (pExcepInfo != NULL)
+ {
+ // fill it in
+ _bstr_t src(Tcl_GetStringResult(m_pInterp));
+ _bstr_t name("OpTcl");
+ pExcepInfo->wCode = 1001;
+ pExcepInfo->wReserved = 0;
+ pExcepInfo->bstrSource = name.copy();
+ pExcepInfo->bstrDescription = src.copy();
+ pExcepInfo->bstrHelpFile = NULL;
+ pExcepInfo->pvReserved = NULL;
+ pExcepInfo->pfnDeferredFillIn = NULL;
+ }
+ Tcl_BackgroundError (m_pInterp);
+ }
+ else
+ {
+ // get the Tcl result and store it in the result variant
+ // currently we are limited to the basic types, until
+ // I get the time to pull the typelib stuff to this point
+ if (pVarResult != NULL)
+ {
+ TObjPtr pres(Tcl_GetObjResult (m_pInterp), false);
+ VariantInit(pVarResult);
+ obj2var (pres, *pVarResult);
+ }
+ }
+
+ // finally unlock the object
+ g_objmap.Unlock (pObj);
+ return result;
+}
+
+
+
+
+
+
+
+
+
+
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * eventbinding.h
+ * Declares classes used for implementing OpTcl's event binding.
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+
+#if !defined(AFX_EVENTBINDING_H__818C3160_57FC_11D3_86E8_0000B482A708__INCLUDED_)
+#define AFX_EVENTBINDING_H__818C3160_57FC_11D3_86E8_0000B482A708__INCLUDED_
+
+#if _MSC_VER > 1000
+#pragma once
+#endif // _MSC_VER > 1000
+
+struct BindingProps;
+class OptclObj;
+
+
+typedef THash<DISPID, BindingProps*> DispCmdTbl;
+
+
+
+struct BindingProps
+{
+ TObjPtr m_pScript;
+ Tcl_Interp * m_pInterp;
+
+ BindingProps (Tcl_Interp *pInterp, Tcl_Obj * pScript)
+ {
+ ASSERT (pInterp != NULL && pScript != NULL);
+ m_pInterp = pInterp;
+ m_pScript = pScript;
+ }
+
+ int Eval (OptclObj *pObj, DISPPARAMS *pDispParams, LPVARIANT pVarResult,
+ LPEXCEPINFO pExcepInfo);
+};
+
+
+
+class EventBindings : public IDispatch
+{
+public:
+ friend OptclObj;
+
+ EventBindings(OptclObj *pObj, REFGUID guid, ITypeInfo *pInfo);
+ virtual ~EventBindings();
+
+
+ bool SetBinding (Tcl_Interp *pInterp, const char * name, Tcl_Obj *pCommand);
+ bool GetBinding (Tcl_Interp *pInterp, const char * name);
+ bool DeleteBinding (Tcl_Interp *pInterp, const char * name);
+
+ ULONG TotalBindings ();
+
+ // IUnknown Entries
+ HRESULT STDMETHODCALLTYPE QueryInterface(REFIID riid, void ** ppvObject);
+ ULONG STDMETHODCALLTYPE AddRef( void);
+ ULONG STDMETHODCALLTYPE Release( void);
+
+ // IDispatch Entries
+ HRESULT STDMETHODCALLTYPE GetTypeInfoCount(UINT *pctinfo);
+
+ HRESULT STDMETHODCALLTYPE
+ GetTypeInfo(UINT iTInfo, LCID lcid, ITypeInfo ** ppTInfo);
+
+ HRESULT STDMETHODCALLTYPE
+ GetIDsOfNames(REFIID riid, LPOLESTR *rgszNames,
+ UINT cNames, LCID lcid, DISPID *rgDispId);
+
+ HRESULT STDMETHODCALLTYPE
+ Invoke(DISPID dispIdMember, REFIID riid, LCID lcid,
+ WORD wFlags, DISPPARAMS *pDispParams, LPVARIANT pVarResult,
+ LPEXCEPINFO pExcepInfo, UINT *puArgErr);
+
+protected:
+ void DeleteTbl();
+ bool Name2Dispid (Tcl_Interp *pInterp, const char * name, DISPID &dispid);
+
+protected:
+ LONG m_ref; // COM reference count for this event binding
+ ULONG m_bindings; // total number of bindings in this event object
+ CComPtr<ITypeInfo> m_pti; // the type information that we are going to be binding
+ CComPtr<ITypeComp> m_ptc; // fast access to members
+ DispCmdTbl m_cmdtbl; // mapping of dispatch ids to Tcl commands
+ OptclObj * m_optclobj; // the parent object of this binding
+ DWORD m_cookie; // cookie used for event advise
+ GUID m_guid; // the id for the event interface
+};
+
+#endif // !defined(AFX_EVENTBINDING_H__818C3160_57FC_11D3_86E8_0000B482A708__INCLUDED_)
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * objmap.cpp
+ * Implementation of the object table.
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+#include "stdafx.h"
+#include "tbase.h"
+#include "optcl.h"
+#include "utility.h"
+#include "objmap.h"
+
+
+
+
+// globals
+
+// the one and only object map for this extension
+// this class uses a Tcl hash table - this usually wouldn't be
+// safe, except that this hash table is initialised (courtsey of THash<>)
+// only on first uses (lazy). So it should be okay. Not sure how
+// this will behave in a multithreaded application
+
+ObjMap g_objmap;
+
+
+//////////////////////////////////////////////////////////////////////
+// Construction/Destruction
+//////////////////////////////////////////////////////////////////////
+
+
+ObjMap::ObjMap() : m_destructpending(false)
+{
+
+}
+
+ObjMap::~ObjMap()
+{
+
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ObjMap::DeleteAll --
+ * Deletes all objects in the system.
+ * Result:
+ * None.
+ * Side effects:
+ * Deletes all object commands from respective interpreters
+ *-------------------------------------------------------------------------
+ */
+void ObjMap::DeleteAll ()
+{
+ ObjNameMap::iterator i;
+ for (i = m_namemap.begin(); i != m_namemap.end(); i++) {
+ OptclObj *pobj = *i;
+ ASSERT (pobj != NULL);
+ DeleteCommand (pobj);
+ delete pobj;
+ }
+ m_namemap.deltbl();
+ m_unkmap.deltbl();
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ObjMap::Create --
+ * Creates an object for a particular interpreter. The type of the object
+ * is identified by a string representing either a CLSID or ProgId. It would
+ * be neat if it also could be the name of a file on the local system or
+ * at some URL. More on this later....
+ * If the object already exists in the object table, then we return that
+ * object. In fact, this is a limitation of the system, as objects that have
+ * been registered in one interpreter cannot be accessed from another
+ * interpreter.
+ *
+ * Result:
+ * A non-null pointer to the underlying Optcl object representation,
+ * iff successful.
+ *
+ * Side effects:
+ * Creates also the Tcl command used to invoke this object.
+ *
+ *-------------------------------------------------------------------------
+ */
+OptclObj * ObjMap::Create (Tcl_Interp *pInterp, const char * id, const char * path, bool start)
+{
+ ASSERT (id != NULL);
+ OptclObj *pObj = NULL,
+ *ptmp = NULL;
+
+ pObj = new OptclObj ();
+ if (!pObj->Create(pInterp, id, path, start)) {
+ delete pObj;
+ return NULL;
+ }
+
+ IUnknown **u = (IUnknown**)(IUnknown*)(*pObj);
+ if (m_unkmap.find(u, &ptmp) != NULL) {
+ ASSERT (ptmp != NULL);
+ delete pObj;
+ ++ptmp->m_refcount;
+ return ptmp;
+ }
+
+ m_unkmap.set (u, pObj);
+ m_namemap.set (*pObj, pObj); // implicit const char * cast
+ pObj->m_refcount = 1;
+ CreateCommand (pObj);
+ return pObj;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ObjMap::Add --
+ * Given an IUnknown pointer, this function ensures that the object table
+ * has a representation for it. If one cannot be found, then a new
+ * representation is created, and the object command is created in the
+ * specified interpreter.
+ *
+ * Result:
+ * Non-null pointer to the internal representation iff successful.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+OptclObj * ObjMap::Add (Tcl_Interp *pInterp, LPUNKNOWN punk)
+{
+ ASSERT (punk != NULL);
+ CComPtr<IUnknown> t_unk;
+ HRESULT hr;
+ OptclObj *pObj = NULL;
+
+ // get the objects pure IUnknown interface (punk can
+ // point to any interface
+
+ hr = punk->QueryInterface (IID_IUnknown, (void**)(&t_unk));
+ CHECKHR(hr);
+ IUnknown ** u = (IUnknown **)(IUnknown*)t_unk;
+
+ if (m_unkmap.find(u, &pObj) == NULL) {
+ pObj = new OptclObj();
+ if (!pObj->Attach(pInterp, punk))
+ {
+ delete pObj;
+ pObj = NULL;
+ }
+ m_namemap.set(*pObj, pObj);
+ m_unkmap.set(u, pObj);
+ pObj->m_refcount = 1;
+ CreateCommand (pObj);
+ } else {
+ ++pObj->m_refcount;
+ }
+
+ ASSERT (pObj != NULL);
+ return pObj;
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ObjMap::Find --
+ * Given and IUnknown pointer, this function attempts to bind to an
+ * existing representation within the object table.
+ *
+ * Result:
+ * A non-null pointer to the required Optcl object, iff successful.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+OptclObj *ObjMap::Find (LPUNKNOWN punk)
+{
+ ASSERT (punk != NULL);
+ CComPtr<IUnknown> t_unk;
+ HRESULT hr;
+ OptclObj *pObj = NULL;
+
+ // get the objects pure IUnknown interface (punk can
+ // point to any interface
+
+ hr = punk->QueryInterface (IID_IUnknown, (void**)(&t_unk));
+ CHECKHR(hr);
+ IUnknown **u = (IUnknown**)(IUnknown*)(t_unk);
+ m_unkmap.find (u, &pObj);
+ return pObj;
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ObjMap::Find --
+ * Finds an existing optcl object keyed on its name.
+ *
+ * Result:
+ * A non-null pointer to the required Optcl object, iff successful.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+OptclObj *ObjMap::Find (const char *name)
+{
+ ASSERT (name != NULL);
+ OptclObj *pObj = NULL;
+ m_namemap.find (name, &pObj);
+ return pObj;
+}
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ObjMap::DeleteCommand --
+ * Ensures that the object command associated with a valid Optcl object
+ * is quietly removed.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * po->m_cmdtoken is set to NULL.
+ *-------------------------------------------------------------------------
+ */
+void ObjMap::DeleteCommand (OptclObj *po)
+{
+ ASSERT (po != NULL);
+
+ if (po->m_cmdtoken == NULL)
+ return;
+
+
+ CONST84 char * cmdname = Tcl_GetCommandName (po->m_pInterp, po->m_cmdtoken);
+ if (cmdname == NULL)
+ return;
+ Tcl_CmdInfo cmdinf;
+
+ if (Tcl_GetCommandInfo (po->m_pInterp, cmdname, &cmdinf) == 0)
+ return;
+
+ // modify the command info of this command so that the callback is now disabled
+ cmdinf.deleteProc = NULL;
+ cmdinf.deleteData = NULL;
+
+ Tcl_SetCommandInfo (po->m_pInterp, cmdname, &cmdinf);
+ Tcl_DeleteCommand (po->m_pInterp, cmdname);
+ po->m_cmdtoken = NULL;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ObjMap::Delete --
+ * Deletes an Optcl object, ensuring the removal of its object command,
+ * and its entries in the object table.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+void ObjMap::Delete (OptclObj *pObj)
+{
+ ASSERT (pObj != NULL);
+
+ // first ensure that we delete the objects command
+ DeleteCommand(pObj);
+ m_namemap.delete_entry (*pObj);
+ m_unkmap.delete_entry ((IUnknown**)(IUnknown*)(*pObj));
+ delete pObj;
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ObjMap::Delete --
+ * Deletes an optcl object keyed on its name. Ensures the removal of the
+ * object command, as well as its reference in the object table.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+void ObjMap::Delete (const char * name)
+{
+ ASSERT (name != NULL);
+ OptclObj *pObj = NULL;
+
+ if (m_namemap.find (name, &pObj) == NULL)
+ return;
+ ASSERT (pObj != NULL);
+ ASSERT (strcmp(name, *pObj) == 0);
+ Delete (pObj);
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ObjMap::Lock --
+ * Increments the reference count on an optcl object.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+void ObjMap::Lock (OptclObj *po)
+{
+ ASSERT (po != NULL);
+ ++po->m_refcount;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ObjMap::Unlock --
+ * Decrements the reference count on an optcl object. If zero, the object
+ * is deleted. These functions could do with thread safety in the future.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+void ObjMap::Unlock(OptclObj *po)
+{
+ ASSERT (po != NULL);
+ if (--po->m_refcount == 0)
+ Delete (po);
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ObjMap::Lock --
+ * Increments the reference count on an optcl object, keyed on its name
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+bool ObjMap::Lock (const char *name)
+{
+ ASSERT (name != NULL);
+ OptclObj *pObj = NULL;
+ if (m_namemap.find (name, &pObj) == NULL)
+ return false;
+ Lock (pObj);
+ return true;
+}
+
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ObjMap::Unlock --
+ * Decrements the reference count of an optcl object, keyed on its name.
+ * If zero, the object is deleted.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+bool ObjMap::Unlock(const char *name)
+{
+ ASSERT (name != NULL);
+ OptclObj *pObj = NULL;
+ if (m_namemap.find (name, &pObj) == NULL)
+ return false;
+ Unlock(pObj);
+ return true;
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ObjMap::CreateCommand --
+ * Creates the command that is to be associated with an optcl object.
+ * The command is created within the interpreter referenced by the object.
+ * The command token is stored within the object.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+void ObjMap::CreateCommand(OptclObj * pObj)
+{
+ ASSERT (pObj != NULL);
+ pObj->m_cmdtoken =
+ Tcl_CreateObjCommand (pObj->m_pInterp, (char*)(const char*)(*pObj),
+ ObjMap::OnCmd, (ClientData)pObj, ObjMap::OnCmdDelete);
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ObjMap::OnCmd --
+ * Function called from tcl whenever an optcl object command is invoked.
+ * The ClientData is the pointer to the object.
+ *
+ * Result:
+ * Std Tcl results.
+ *
+ * Side effects:
+ * Anything, depending on the invocation
+ *
+ *-------------------------------------------------------------------------
+ */
+TCL_CMDEF(ObjMap::OnCmd)
+{
+ OptclObj *po = (OptclObj*)cd; // cast the client data to the underlying
+ // object
+ ASSERT (po != NULL);
+ return (po->InvokeCmd (pInterp, objc-1, objv+1))?TCL_OK:TCL_ERROR;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ObjMap::OnCmdDelete --
+ * Called when (and only when) a script deletes an object command. The
+ * referenced optcl object is also destroyed.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+void ObjMap::OnCmdDelete (ClientData cd)
+{
+ OptclObj *po = (OptclObj*) cd;
+ ASSERT (po != NULL);
+ g_objmap.Delete(po);
+}
+
+
+
+
+
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * objmap.h
+ * Definition of the object table.
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+
+#if !defined(AFX_OBJMAP_H__8A11BC00_616B_11D4_8004_0040055861F2__INCLUDED_)
+#define AFX_OBJMAP_H__8A11BC00_616B_11D4_8004_0040055861F2__INCLUDED_
+
+#if _MSC_VER > 1000
+#pragma once
+#endif // _MSC_VER > 1000
+
+#include "optcl.h"
+#include "OptclObj.h"
+
+typedef THash<char, OptclObj*> ObjNameMap;
+typedef THash<IUnknown*, OptclObj*> ObjUnkMap;
+
+class ObjMap {
+ friend OptclObj;
+protected:
+ ObjNameMap m_namemap;
+ ObjUnkMap m_unkmap;
+ bool m_destructpending;
+
+public: // constructor / destructor
+ ObjMap ();
+ virtual ~ObjMap ();
+
+ OptclObj * Create (Tcl_Interp *pInterp, const char * id, const char * path, bool start);
+ OptclObj * Add (Tcl_Interp *pInterp, LPUNKNOWN punk);
+ OptclObj * Find (LPUNKNOWN punk);
+ OptclObj * Find (const char *name);
+
+ void Delete (const char * name);
+ void DeleteAll ();
+
+ bool Lock (const char *name);
+ bool Unlock(const char *name);
+
+ void Lock (OptclObj *);
+ void Unlock(OptclObj *);
+
+
+public: // statics
+ static TCL_CMDEF(OnCmd);
+ static void OnCmdDelete (ClientData cd);
+
+protected:
+ void Delete (OptclObj *);
+ void CreateCommand (OptclObj *);
+ void DeleteCommand (OptclObj *);
+
+};
+
+
+// Global Variable Declaration!!!
+
+extern ObjMap g_objmap; // once object map per application
+
+#endif // !defined(AFX_OBJMAP_H__8A11BC00_616B_11D4_8004_0040055861F2__INCLUDED_)
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * optclbindptr.cpp
+ * Implements the class used wrapping a BINDPTR, DESCKIND and ITypeInfo
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+
+#include "stdafx.h"
+#include "typelib.h"
+#include "OptclBindPtr.h"
+
+//////////////////////////////////////////////////////////////////////
+// Construction/Destruction
+//////////////////////////////////////////////////////////////////////
+
+OptclBindPtr::OptclBindPtr()
+{
+ m_bp.lpfuncdesc = NULL;
+ m_dk = DESCKIND_NONE;
+}
+
+OptclBindPtr::~OptclBindPtr()
+{
+ ReleaseBindPtr();
+}
+
+
+void OptclBindPtr::ReleaseBindPtr ()
+{
+ ::ReleaseBindPtr(m_pti, m_dk, m_bp);
+ m_dk = DESCKIND_NONE;
+}
+
+
+
+
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * optclbindptr.h
+ * Defines the class used wrapping a BINDPTR, DESCKIND and ITypeInfo
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */#if !defined(AFX_OPTCLBINDPTR_H__2682D1C3_5EDC_11D3_86E8_0000B482A708__INCLUDED_)
+#define AFX_OPTCLBINDPTR_H__2682D1C3_5EDC_11D3_86E8_0000B482A708__INCLUDED_
+
+#if _MSC_VER > 1000
+#pragma once
+#endif // _MSC_VER > 1000
+
+
+// wrapper class for a BINDPTR, DESCKIND, and ITypeInfo
+class OptclBindPtr
+{
+public:
+ BINDPTR m_bp;
+ DESCKIND m_dk;
+ CComPtr<ITypeInfo> m_pti;
+
+public:
+ OptclBindPtr();
+ virtual ~OptclBindPtr();
+ void ReleaseBindPtr ();
+
+ // inline functions
+ MEMBERID OptclBindPtr::memid ()
+ {
+ ASSERT (m_bp.lpfuncdesc != NULL);
+
+ switch (m_dk) {
+ case DESCKIND_FUNCDESC:
+ return m_bp.lpfuncdesc->memid;
+
+ case DESCKIND_IMPLICITAPPOBJ:
+ case DESCKIND_VARDESC:
+ return m_bp.lpvardesc->memid;
+ default:
+ ASSERT (FALSE);
+ return DISPID_UNKNOWN;
+ }
+ }
+
+
+ short OptclBindPtr::cParams()
+ {
+ ASSERT (m_bp.lpfuncdesc != NULL);
+ switch (m_dk) {
+ case DESCKIND_FUNCDESC:
+ return m_bp.lpfuncdesc->cParams;
+ case DESCKIND_IMPLICITAPPOBJ:
+ case DESCKIND_VARDESC:
+ return 1;
+ default:
+ ASSERT (FALSE);
+ return 0;
+ }
+ }
+
+ short OptclBindPtr::cParamsOpt()
+ {
+ ASSERT (m_bp.lpfuncdesc != NULL);
+ switch (m_dk) {
+ case DESCKIND_FUNCDESC:
+ return m_bp.lpfuncdesc->cParamsOpt;
+ case DESCKIND_IMPLICITAPPOBJ:
+ case DESCKIND_VARDESC:
+ return 1;
+ default:
+ ASSERT (FALSE);
+ return 0;
+ }
+ }
+
+ ELEMDESC * OptclBindPtr::param(short param)
+ {
+ ASSERT (m_bp.lpfuncdesc != NULL);
+ ASSERT (param < cParams());
+
+ switch (m_dk) {
+ case DESCKIND_FUNCDESC:
+ return (m_bp.lpfuncdesc->lprgelemdescParam + param);
+ case DESCKIND_IMPLICITAPPOBJ:
+ case DESCKIND_VARDESC:
+ return (&m_bp.lpvardesc->elemdescVar);
+ default:
+ ASSERT (FALSE);
+ return 0;
+ }
+
+ }
+
+ ELEMDESC * OptclBindPtr::result()
+ {
+ ASSERT (m_bp.lpfuncdesc != NULL);
+
+ switch (m_dk) {
+ case DESCKIND_FUNCDESC:
+ return (&m_bp.lpfuncdesc->elemdescFunc);
+ case DESCKIND_IMPLICITAPPOBJ:
+ case DESCKIND_VARDESC:
+ return (&m_bp.lpvardesc->elemdescVar);
+ default:
+ ASSERT (FALSE);
+ return 0;
+ }
+ }
+};
+
+#endif // !defined(AFX_OPTCLBINDPTR_H__2682D1C3_5EDC_11D3_86E8_0000B482A708__INCLUDED_)
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * optclobj.cpp
+ * Implements the functionality for the internal representation of
+ * an optcl object.
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+
+#include "stdafx.h"
+#include <comdef.h>
+#include "tbase.h"
+#include "utility.h"
+#include "optcl.h"
+#include "OptclObj.h"
+#include "typelib.h"
+#include "ObjMap.h"
+#include "dispparams.h"
+#include "eventbinding.h"
+#include "optclbindptr.h"
+#include "optcltypeattr.h"
+
+//////////////////////////////////////////////////////////////////////
+// Construction/Destruction
+//////////////////////////////////////////////////////////////////////
+
+OptclObj::OptclObj ()
+: m_refcount(0), m_cmdtoken(NULL), m_pta(NULL),
+m_destroypending(false), m_container(this)
+{
+}
+
+bool OptclObj::Create (Tcl_Interp *pInterp, const char *strid,
+ const char * windowpath, bool start)
+{
+ m_pInterp = pInterp;
+
+ USES_CONVERSION;
+ ASSERT (strid != NULL);
+
+ if (windowpath == NULL) {
+ LPOLESTR lpolestrid = A2OLE(strid);
+ CLSID clsid;
+ HRESULT hr;
+
+ // convert strid to CLSID
+ hr = CLSIDFromString (lpolestrid, &clsid);
+ if (FAILED (hr))
+ hr = CLSIDFromProgID (lpolestrid, &clsid);
+ CHECKHR_TCL(hr, pInterp, false);
+
+ if (!start)
+ hr = GetActiveObject(clsid, NULL, &m_punk);
+ if (start || FAILED(hr))
+ hr = CoCreateInstance (clsid, NULL, CLSCTX_SERVER, IID_IUnknown, (void**)&m_punk);
+ CHECKHR_TCL(hr, pInterp, false);
+
+ }
+ else {
+ m_punk = m_container.Create(pInterp, Tk_MainWindow(pInterp), windowpath, strid);
+ if (m_punk == NULL)
+ return false;
+ }
+ try {
+ CreateName (m_punk);
+ InitialiseClassInfo(m_punk);
+ InitialisePointers (m_punk);
+ }
+ catch (HRESULT hr) {
+ CHECKHR_TCL(hr, pInterp, false);
+ }
+ return true;
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::Attach --
+ * Connects this object to an existing interface
+ * Result:
+ * true iff successful
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+bool OptclObj::Attach (Tcl_Interp *pInterp, LPUNKNOWN punk)
+{
+ ASSERT (m_punk == NULL);
+ ASSERT (punk != NULL);
+
+ m_pInterp = pInterp;
+ try {
+ CreateName (punk);
+ InitialiseUnknown(punk);
+ InitialiseClassInfo(m_punk);
+ InitialisePointers (m_punk);
+ }
+ catch (HRESULT hr) {
+ m_punk = NULL;
+ CHECKHR_TCL(hr, pInterp, false);
+ }
+ return true;
+}
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::~OptclObj --
+ * Destructor
+ * Result:
+ *
+ * Side effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+OptclObj::~OptclObj()
+{
+ m_destroypending = true;
+ ReleaseBindingTable();
+ ReleaseTypeAttr();
+}
+
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::CreateName --
+ * Creates the string representation for this object - a unique name is
+ * created from the object's IUnknown pointer.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void OptclObj::CreateName (LPUNKNOWN punk)
+{
+ ASSERT (punk != NULL);
+ char str[10];
+ sprintf (str, "%x", punk);
+ m_name = "optcl0x";
+ m_name += str;
+}
+
+
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::InitialiseClassInfo --
+ * Attempts to find the typeinfo for this object's coclass.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void OptclObj::InitialiseClassInfo (LPUNKNOWN punk)
+{
+ CComQIPtr<IProvideClassInfo> pcli;
+
+ // try to pull out the coclass information
+ pcli = punk; // implicit query interface
+ if (pcli != NULL)
+ pcli->GetClassInfo (&m_pti_class);
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::InitialiseUnknown --
+ * Initialises the OptclObj's 'true' IUnknown pointer.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * Throws HRESULT on error.
+ *-------------------------------------------------------------------------
+ */
+void OptclObj::InitialiseUnknown (LPUNKNOWN punk)
+{
+ ASSERT (punk != NULL);
+ HRESULT hr;
+
+ hr = punk->QueryInterface (IID_IUnknown, (void**)(&m_punk));
+ CHECKHR(hr);
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::InitialisePointersFromCoClass --
+ * Called when we have the coclass information for this object. The
+ * function identifies the default interface and binds to it.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+HRESULT OptclObj::InitialisePointersFromCoClass()
+{
+ ASSERT (m_pti_class != NULL);
+ TYPEATTR *pta = NULL;
+ HRESULT hr;
+
+ // retrieve the type attribute
+ hr = m_pti_class->GetTypeAttr (&pta);
+ CHECKHR(hr);
+
+ // store the number of implemented interfaces
+ WORD impcount = pta->cImplTypes;
+ m_pti_class->ReleaseTypeAttr (pta); pta = NULL;
+
+ // iterate through the type looking for the default interface
+ for (WORD i = 0; i < impcount; i++)
+ {
+ INT flags;
+ hr = m_pti_class->GetImplTypeFlags (i, &flags);
+ if (FAILED (hr))
+ return hr;
+ if (flags == IMPLTYPEFLAG_FDEFAULT)
+ break;
+ }
+
+ // if not found return an error
+ if (i == impcount)
+ return E_FAIL;
+
+ // we found the interface - now to get its iid...
+ // first retrieve the type info;
+
+ CComPtr<ITypeInfo> reftype;
+ CComPtr<ITypeLib> reftypelib;
+
+ HREFTYPE href;
+
+ hr = m_pti_class->GetRefTypeOfImplType (i, &href);
+ if (FAILED(hr))
+ return hr;
+
+ hr = m_pti_class->GetRefTypeInfo (href, &reftype);
+ if (FAILED(hr))
+ return hr;
+
+ // now set the interface from typeinfo
+ return SetInterfaceFromType (reftype);
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::GetTypeAttr --
+ * Retrieves the type attribute for the type of this object's current
+ * interface.
+ * Result:
+ * Standard HRESULT.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+HRESULT OptclObj::GetTypeAttr()
+{
+ ASSERT (m_pta == NULL);
+ ASSERT (m_pti != NULL);
+ return m_pti->GetTypeAttr(&m_pta);
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::ReleaseTypeAttr --
+ * Releases the current type attribute, and sets it to NULL.
+ * Result:
+ * None.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void OptclObj::ReleaseTypeAttr()
+{
+ if (m_pti != NULL && m_pta != NULL) {
+ m_pti->ReleaseTypeAttr(m_pta);
+ m_pta = NULL;
+ }
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::SetInterfaceFromType --
+ * Queries for the interface described in the typeinfo. The interface,
+ * if found, becomes the current interface.
+ *
+ * Result:
+ * HRESULT giving success code.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+HRESULT OptclObj::SetInterfaceFromType (ITypeInfo *reftype)
+{
+ HRESULT hr;
+ CComPtr<ITypeLib> reftypelib;
+ UINT libindex;
+ TYPEATTR *pta;
+
+ hr = reftype->GetContainingTypeLib(&reftypelib, &libindex);
+ if (FAILED(hr))
+ return hr;
+
+ hr = reftype->GetTypeAttr (&pta);
+ if (FAILED(hr))
+ return hr;
+
+ if (pta->typekind != TKIND_DISPATCH) {
+ reftype->ReleaseTypeAttr (pta);
+ return E_NOINTERFACE;
+ }
+
+ GUID guid = pta->guid;
+ reftype->ReleaseTypeAttr (pta);
+
+ hr = m_punk->QueryInterface(guid, (void**)(&m_pcurrent));
+ if (FAILED(hr))
+ return hr;
+
+
+ // nice! now we cache the result of all our hard work
+ ReleaseTypeAttr ();
+ m_pti = reftype;
+ m_ptl = reftypelib;
+ m_ptc = NULL;
+ m_pti->GetTypeComp (&m_ptc);
+ // now that we got the interface ok, retrieve the type attributes again
+ return GetTypeAttr();
+}
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::InitialisePointers --
+ * Called to initialise this objects interface pointers
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void OptclObj::InitialisePointers (LPUNKNOWN punk, ITypeLib *plib, ITypeInfo *pinfo)
+{
+ HRESULT hr;
+ ASSERT (punk != NULL);
+ CComQIPtr<IDispatch> pdisp;
+
+ ASSERT ((plib!=NULL && pinfo!=NULL) || (plib==NULL && pinfo==NULL));
+
+ if (plib != NULL && pinfo != NULL) {
+ m_pcurrent = punk;
+ m_ptl = plib;
+ m_pti = pinfo;
+ m_ptc = NULL;
+ m_pti->GetTypeComp (&m_ptc);
+ GetTypeAttr();
+ }
+
+ // else, if we have the coclass information, try building on its default
+ // interface
+ else if (m_pti_class == NULL || FAILED(InitialisePointersFromCoClass())) {
+ // failed to build using coclass information
+ // Query Interface cast to a dispatch interface
+ m_pcurrent = punk;
+ try {
+ if (m_pcurrent == NULL)
+ throw (HRESULT(0));
+ // get the type information and library.
+ hr = m_pcurrent->GetTypeInfo (0, LOCALE_SYSTEM_DEFAULT, &m_pti);
+ CHECKHR(hr);
+ UINT index;
+ hr = m_pti->GetContainingTypeLib(&m_ptl, &index);
+ CHECKHR(hr);
+ m_ptc = NULL;
+ m_pti->GetTypeComp (&m_ptc);
+ GetTypeAttr();
+ }
+
+
+ catch (HRESULT) {
+ // there isn't a interface that we can use
+ ReleaseTypeAttr();
+ m_pcurrent.Release();
+ m_pti = NULL;
+ m_ptl = NULL;
+ m_ptc = NULL;
+ return;
+ }
+ }
+ // inform the typelibrary browser system of the library
+ g_libs.EnsureCached (m_ptl);
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::operator LPUNKNOWN --
+ * Gives the 'true' IUnknown pointer for this object.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+OptclObj::operator LPUNKNOWN()
+{
+ return m_punk;
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::operator const char * --
+ * Gives the string representation for this object.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+OptclObj::operator const char * ()
+{
+ return m_name.c_str();
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * void OptclObj::CoClassName --
+ * Returns the class name in the tcl object smart ptr or ??? if unknown.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void OptclObj::CoClassName (TObjPtr &pObj)
+{
+ pObj.create();
+ if (m_pti_class == NULL)
+ pObj = "???";
+ else
+ TypeLib_GetName (NULL, m_pti_class, pObj);
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::InterfaceName --
+ * Returns the name of this objects current interface.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void OptclObj::InterfaceName (TObjPtr &pObj)
+{
+ pObj.create();
+ if (m_pti == NULL)
+ pObj = "???";
+ else
+ TypeLib_GetName (NULL, m_pti, pObj);
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::SetInterfaceName --
+ * Sets the current interface to that named by pObj.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void OptclObj::SetInterfaceName (TObjPtr &pObj)
+{
+ ASSERT (pObj.isnotnull());
+ TypeLib *ptl;
+ CComPtr<ITypeInfo> pti;
+ CComPtr<IUnknown> punk;
+ TYPEATTR ta, *pta = NULL;
+ HRESULT hr;
+
+ TypeLib_ResolveName (pObj, &ptl, &pti);
+ // we need to insert some alias type resolution here.
+
+ hr = pti->GetTypeAttr (&pta);
+ CHECKHR(hr);
+ ta = *pta;
+ pti->ReleaseTypeAttr (pta);
+
+
+ if (ta.typekind != TKIND_INTERFACE &&
+ ta.typekind != TKIND_DISPATCH)
+ throw ("type does not resolve to an interface");
+
+
+ hr = m_punk->QueryInterface (ta.guid, (void**)(&punk));
+ CHECKHR(hr);
+ InitialisePointers (punk, ptl->m_ptl, pti);
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::InvokeCmd --
+ * Called by the object map as a result of invoking the object command
+ * on this object. Format of the command is as follows
+ *
+ * obj : ?-with subprop? prop ?value? ?prop value? ...
+ * obj method ?arg? ...
+ *
+ * Result:
+ * true iff successful. Error string in interpreter.
+ *
+ * Side effects:
+ * Depends on the parameters.
+ *-------------------------------------------------------------------------
+ */
+bool OptclObj::InvokeCmd (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST objv[])
+{
+ ASSERT (pInterp != NULL);
+ CComPtr<IDispatch> pdisp;
+ CComPtr<ITypeComp> ptc;
+ CComPtr<ITypeInfo> pti;
+ TObjPtr name;
+
+ int invkind = DISPATCH_METHOD;
+
+ char * msg =
+ "\n\tobj : ?-with subprop? prop ?value? ?prop value? ..."
+ "\n\tobj method ?arg? ...";
+
+ if (objc == 0) {
+ Tcl_WrongNumArgs (pInterp, 0, NULL, msg);
+ return TCL_ERROR;
+ }
+
+ if (CheckInterface (pInterp) == false)
+ return TCL_ERROR;
+
+
+
+ // parse for a -with flag
+ name.attach(objv[0]);
+ if (strncmp (name, "-with", strlen(name)) == 0)
+ {
+ // check that we have enough parameters
+ if (objc < 3) {
+ Tcl_WrongNumArgs (pInterp, 0, NULL, msg);
+ return false;
+ }
+
+ name.attach(objv[1]);
+ if (!ResolvePropertyObject (pInterp, name, &pdisp, &pti, &ptc))
+ return false;
+ objc -= 2;
+ objv += 2;
+ }
+ else {
+ pdisp = m_pcurrent;
+ ptc = m_ptc;
+ pti = m_pti;
+ }
+
+ // check the first argument for a ':'
+ char * str = Tcl_GetStringFromObj (objv[0], NULL);
+ ASSERT (str != NULL);
+
+ if (*str == ':') {
+ objc--;
+ objv++;
+
+ if (objc == 1)
+ return GetProp (pInterp, objv[0], pdisp, pti, ptc);
+ else {
+ if (objc % 2 != 0) {
+ Tcl_SetResult (pInterp, "property set requires pairs of parameters", TCL_STATIC);
+ return false;
+ }
+ return SetProp (pInterp, objc/2, objv, pdisp, pti, ptc);
+ }
+ }
+
+ if (ptc == NULL)
+ return InvokeNoTypeInf (pInterp, invkind, objc, objv, pdisp);
+ else
+ return InvokeWithTypeInf (pInterp, invkind, objc, objv, pdisp, pti, ptc);
+}
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::CheckInterface --
+ * Checks for current interface being valid.
+ * Result:
+ * Currently, returns true iff an interface exists.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+bool OptclObj::CheckInterface (Tcl_Interp *pInterp)
+{
+ if (m_pcurrent == NULL) {
+ Tcl_SetResult (pInterp, "no interface available", TCL_STATIC);
+ return false;
+ }
+
+ /* -- not needed now that we are only working with dispatch interfaces
+
+ if (m_pta != NULL) {
+ if (m_pta->typekind == TKIND_INTERFACE && ((m_pta->wTypeFlags&TYPEFLAG_FDUAL)==0))
+ {
+ Tcl_SetResult (pInterp, "interface is a pure vtable - optcl can't call these ... yet!", TCL_STATIC);
+ return false;
+ }
+ }
+ */
+ return true;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::BuildParamsWithBindPtr --
+ * Builds the dispatch parameters using the values found in a bindptr
+ * object.
+ *
+ * Result:
+ * true iff successful - else error string in interpreter.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+bool OptclObj::BuildParamsWithBindPtr (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST objv[],
+ OptclBindPtr & bp, DispParams & dp)
+{
+ ASSERT (pInterp != NULL && objv != NULL);
+ bool con_ok = true;
+ TObjPtr obj;
+
+
+ // check for the last parameter being the return value and take
+ // this into account when checking parameter counts
+ int params = bp.cParams ();
+ if (params > 0 && bp.param(params - 1)->paramdesc.wParamFlags & PARAMFLAG_FRETVAL)
+ --params;
+
+ if (objc <= params &&
+ objc >= (params - bp.cParamsOpt()))
+ {
+ // set up the dispatch arguments - must be in reverse order
+ dp.Args (objc);
+ for (int count = objc-1; count >= 0 && con_ok; count--)
+ {
+ con_ok = false;
+ ELEMDESC *pdesc = bp.param(count);
+ ASSERT (pdesc != NULL);
+ // cases for parameters : [in] - value
+ // [inout] - reference (variable must exist)
+ // [out] - reference (variable doesn have to exist)
+
+ // is it an in* type
+ if ((pdesc->paramdesc.wParamFlags & PARAMFLAG_FIN) || (pdesc->paramdesc.wParamFlags == PARAMFLAG_NONE)) {
+ // is it [inout]?
+ if (pdesc->paramdesc.wParamFlags & PARAMFLAG_FOUT) {
+ obj.attach(Tcl_ObjGetVar2 (pInterp, objv[count], NULL, TCL_LEAVE_ERR_MSG));
+ if (obj.isnull())
+ return false;
+ }
+ else // just [in]
+ obj.attach(objv[count]);
+
+ con_ok = obj2var_ti(pInterp, obj, dp[objc - count - 1], bp.m_pti, &(pdesc->tdesc));
+ }
+
+ else if (pdesc->paramdesc.wParamFlags & PARAMFLAG_FOUT)
+ { // a pure out flag - we'll set up the type of the parameter correctly, but fill it with a null
+ con_ok = obj2var_ti(pInterp, TObjPtr(NULL), dp[objc - count - 1], bp.m_pti, &(pdesc->tdesc));
+ }
+
+ else {
+ // unknown parameter type
+ ASSERT(false);
+ }
+ }
+ }
+ else
+ {
+ Tcl_SetResult (pInterp, "wrong # args", TCL_STATIC);
+ con_ok = false;
+ }
+
+ return con_ok;
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::RetrieveOutParams --
+ * Scans the parameter types in a bind pointer and pulls out those that
+ * are either out or in/out, and sets the appropriate Tcl variable to
+ * their value.
+ *
+ * Result:
+ * true iff successful. Else, error string in interpreter.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+bool OptclObj::RetrieveOutParams (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST objv[],
+ OptclBindPtr & bp, DispParams & dp)
+
+{
+ TObjPtr presult;
+ bool bok = true;
+ // now loop through the parameters again, pulling out the [*out] values
+ for (int count = objc - 1; bok && count >= 0; count--)
+ {
+ ELEMDESC *pdesc = bp.param(count);
+ ASSERT (pdesc != NULL);
+ // is it an out parameter?
+ if (pdesc->paramdesc.wParamFlags & PARAMFLAG_FOUT)
+ {
+ // convert the value back to a tcl object
+ bok = (!var2obj (pInterp, dp[objc - count - 1], presult) ||
+ Tcl_ObjSetVar2 (pInterp, objv[count], NULL,
+ presult, TCL_LEAVE_ERR_MSG) == NULL);
+
+ }
+ }
+ return bok;
+}
+
+
+
+
+
+
+bool OptclObj::InvokeWithTypeInfVariant (Tcl_Interp *pInterp, long invokekind,
+ int objc, Tcl_Obj *CONST objv[],
+ IDispatch *pDisp, ITypeInfo *pti, ITypeComp *pCmp, VARIANT &varResult)
+{
+ USES_CONVERSION;
+ DispParams dp;
+ LPOLESTR olename;
+
+
+ DISPID dispid;
+ HRESULT hr;
+ EXCEPINFO ei;
+ UINT ea = 0;
+
+ bool bOk = false;
+ TObjPtr obj;
+ TObjPtr presult;
+ static DISPID propput = DISPID_PROPERTYPUT;
+ OptclBindPtr obp;
+ OptclTypeAttr ota;
+
+ ASSERT (objc >= 1);
+ ASSERT (pDisp != NULL);
+ ASSERT (pti != NULL);
+ ASSERT (varResult.vt == VT_EMPTY);
+ ota = pti;
+
+ ASSERT (ota->typekind == TKIND_DISPATCH || (ota->wTypeFlags & TYPEFLAG_FDUAL));
+
+ try {
+ olename = A2OLE(Tcl_GetStringFromObj (objv[0], NULL));
+ hr = pCmp->Bind (olename, LHashValOfName(LOCALE_SYSTEM_DEFAULT, olename),
+ invokekind, &obp.m_pti, &obp.m_dk, &obp.m_bp);
+ CHECKHR(hr);
+
+ if (obp.m_dk == DESCKIND_NONE) {
+ Tcl_SetResult (pInterp, "member not found: ", TCL_STATIC);
+ Tcl_AppendResult (pInterp, (char*)obj, NULL);
+ } else {
+ dispid = obp.memid();
+ // check the number of parameters
+
+ objc--; // count of parameters provided
+ objv++; // the parameters
+ if (!BuildParamsWithBindPtr (pInterp, objc, objv, obp, dp))
+ return false;
+
+ if (invokekind == DISPATCH_PROPERTYPUT) {
+ dp.cNamedArgs = 1;
+ dp.rgdispidNamedArgs = &propput;
+ }
+
+ // can't invoke through the typelibrary for local objects
+ //hr = pti->Invoke(pDisp, dispid, invokekind, &dp, &varResult, &ei, &ea);
+ hr = pDisp->Invoke(dispid, IID_NULL, LOCALE_SYSTEM_DEFAULT, invokekind,
+ &dp, &varResult, &ei, &ea);
+
+ if (invokekind == DISPATCH_PROPERTYPUT) {
+ dp.rgdispidNamedArgs = NULL;
+ }
+
+ // error check
+ if (hr == DISP_E_EXCEPTION)
+ Tcl_SetResult (pInterp, ExceptInfo2Str (&ei), TCL_DYNAMIC);
+
+ else if (hr == DISP_E_TYPEMISMATCH) {
+ TDString td("type mismatch in parameter #");
+ td << (long)(ea);
+ Tcl_SetResult (pInterp, td, TCL_VOLATILE);
+ }
+ else
+ CHECKHR_TCL(hr, pInterp, false);
+ if (FAILED(hr))
+ return false;
+
+ if (!RetrieveOutParams (pInterp, objc, objv, obp, dp))
+ return false;
+ bOk = true;
+ }
+ }
+ catch (HRESULT hr)
+ {
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ }
+ return bOk;
+}
+
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::InvokeWithTypeInf --
+ * Performs a method invocation, given a dispatch interface and a
+ * ITypeComp interface for typing.
+ *
+ * Result:
+ * true iff successful. Error string in interpreter.
+ * Side effects:
+ * Depends on the method being invoked.
+ *-------------------------------------------------------------------------
+ */
+bool OptclObj::InvokeWithTypeInf (Tcl_Interp *pInterp, long invokekind,
+ int objc, Tcl_Obj *CONST objv[],
+ IDispatch *pDisp, ITypeInfo *pti, ITypeComp *pCmp)
+{
+ VARIANT varResult;
+ VariantInit(&varResult);
+ TObjPtr presult;
+
+ bool bok;
+ bok = InvokeWithTypeInfVariant (pInterp, invokekind, objc, objv, pDisp, pti, pCmp, varResult);
+
+ // set the result of the operation to the return value of the function
+ if (bok && (bok = var2obj(pInterp, varResult, presult)))
+ Tcl_SetObjResult (pInterp, presult);
+ VariantClear(&varResult);
+ return bok;
+}
+
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::InvokeNoTypeInf --
+ * Performs a member invocation without any type information on an
+ * IDispatch interface.
+ *
+ * Result:
+ * true iff successful. Else, error string in interpreter.
+ * Side effects:
+ * Depends on the methods being invoked.
+ *-------------------------------------------------------------------------
+ */
+
+bool OptclObj::InvokeNoTypeInf( Tcl_Interp *pInterp, long invokekind,
+ int objc, Tcl_Obj *CONST objv[],
+ IDispatch *pDisp)
+{
+ VARIANT var;
+ VariantInit (&var);
+ TObjPtr presult;
+ bool bok;
+
+ if (bok = InvokeNoTypeInfVariant (pInterp, invokekind, objc, objv, pDisp, var)) {
+ if (bok = var2obj(pInterp, var, presult))
+ Tcl_SetObjResult (pInterp, presult);
+ VariantClear(&var);
+ }
+
+ return bok;
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::InvokeNoTypeInfVariant --
+ * The same as InvokeNoTypeInf, but instead of placing the result in
+ * the interpreter, returns within a variant.
+ * Result:
+ * true iff successful. Else, error string in interpreter
+ * Side effects:
+ * Depends on member being invoked
+ *-------------------------------------------------------------------------
+ */
+bool OptclObj::InvokeNoTypeInfVariant ( Tcl_Interp *pInterp, long invokekind,
+ int objc, Tcl_Obj *CONST objv[],
+ IDispatch *pDisp, VARIANT &varResult)
+{
+ ASSERT (varResult.vt == VT_EMPTY);
+
+ DispParams dp;
+ DISPID dispid;
+ HRESULT hr;
+ TObjPtr obj;
+ EXCEPINFO ei;
+ UINT ea = 0;
+ bool bOk = false;
+
+ ASSERT (objc >= 1);
+ ASSERT (pDisp != NULL);
+
+ obj.attach(objv[0]);
+ dispid = Name2ID(pDisp, obj);
+ if (dispid == DISPID_UNKNOWN) {
+ Tcl_SetResult (pInterp, "member not found: ", TCL_STATIC);
+ Tcl_AppendResult (pInterp, obj, NULL);
+ } else {
+ objc--; // count of parameters
+ // set up the dispatch arguments - must be in reverse order
+ dp.Args (objc);
+ for (int i = objc-1; i >= 0; i--)
+ {
+ obj.attach(objv[i+1]);
+ obj2var(obj, dp[i]);
+ }
+
+ hr = pDisp->Invoke(dispid, IID_NULL, LOCALE_SYSTEM_DEFAULT, invokekind,
+ &dp, &varResult, &ei, &ea);
+ if (hr == DISP_E_EXCEPTION)
+ Tcl_SetResult (pInterp, ExceptInfo2Str (&ei), TCL_DYNAMIC);
+ else if (hr == DISP_E_TYPEMISMATCH) {
+ TDString td("type mismatch in parameter #");
+ td << (long)(ea);
+ Tcl_SetResult (pInterp, td, TCL_VOLATILE);
+ }
+ else if (FAILED(hr))
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ else {
+ }
+ }
+
+ return bOk;
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::GetProp --
+ * Called to get the value of a property (a property can be indexed)
+ * If type information is provided, then it will be used in the invocation
+ * Result:
+ * true iff ok. Else, error string in interpreter
+ * Side effects:
+ * Depends on the property and its value.
+ *-------------------------------------------------------------------------
+ */
+bool OptclObj::GetProp (Tcl_Interp *pInterp, Tcl_Obj *name,
+ IDispatch *pdisp, ITypeInfo *pti, ITypeComp *ptc)
+{
+ ASSERT (pInterp != NULL && name != NULL && pdisp != NULL);
+ TObjPtr params;
+ bool bok;
+
+ if (bok = SplitBrackets (pInterp, name, params)) {
+ int length = params.llength();
+ ASSERT (length >= 1);
+ Tcl_Obj ** pplist = (Tcl_Obj **)malloc(sizeof(Tcl_Obj*) * length);
+ if (pplist == NULL) {
+ Tcl_SetResult (pInterp, "out of memory", TCL_STATIC);
+ return false;
+ }
+
+ for (int p = 0; p < length; p++)
+ pplist[p] = params.lindex(p);
+
+ if (pti != NULL) {
+ ASSERT (ptc != NULL);
+ bok = InvokeWithTypeInf(pInterp, DISPATCH_PROPERTYGET, length, pplist, pdisp, pti, ptc);
+ }
+ else {
+ bok = InvokeNoTypeInf (pInterp, DISPATCH_PROPERTYGET, length, pplist, pdisp);
+ }
+
+ free(pplist);
+ }
+ return bok;
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::GetIndexedVariant --
+ * Called to get the value of a property or the return type of method, with
+ * bracket indexing.
+ * If type information is provided, then it will be used in the invocation
+ * Result:
+ * true iff ok. Else, error string in interpreter
+ * Side effects:
+ * Depends on the property and its value.
+ *-------------------------------------------------------------------------
+ */
+bool OptclObj::GetIndexedVariant (Tcl_Interp *pInterp, Tcl_Obj *name,
+ IDispatch *pdisp, ITypeInfo *pti, ITypeComp *ptc, VARIANT &varResult)
+{
+ ASSERT (pInterp != NULL && name != NULL && pdisp != NULL);
+ ASSERT (varResult.vt == VT_EMPTY);
+
+ TObjPtr params;
+ TObjPtr presult;
+ bool bok;
+ static const int invkind = DISPATCH_PROPERTYGET|DISPATCH_METHOD;
+ if (bok = SplitBrackets (pInterp, name, params)) {
+ int length = params.llength();
+ ASSERT (length >= 1);
+ Tcl_Obj ** pplist = (Tcl_Obj **)malloc(sizeof(Tcl_Obj*) * length);
+ if (pplist == NULL) {
+ Tcl_SetResult (pInterp, "out of memory", TCL_STATIC);
+ return false;
+ }
+
+ for (int p = 0; p < length; p++)
+ pplist[p] = params.lindex(p);
+
+ if (pti != NULL) {
+ ASSERT (ptc != NULL);
+ bok = InvokeWithTypeInfVariant (pInterp, invkind, length, pplist, pdisp, pti, ptc, varResult);
+ }
+ else {
+ bok = InvokeNoTypeInfVariant (pInterp, invkind, length, pplist, pdisp, varResult);
+ }
+ free(pplist);
+ }
+ return bok;
+}
+
+bool OptclObj::SetProp (Tcl_Interp *pInterp,
+ int paircount, Tcl_Obj * CONST namevalues[],
+ IDispatch *pdisp, ITypeInfo *pti, ITypeComp *ptc)
+{
+ bool bok = true;
+ ASSERT (pInterp != NULL && paircount > 0 && namevalues != NULL && pdisp != NULL);
+ for (int i = 0; bok && i < paircount; i++)
+ {
+ TObjPtr params;
+ if (bok = SplitBrackets (pInterp, namevalues[0], params)) {
+ params.lappend(namevalues[1]);
+ int length = params.llength();
+ ASSERT (length >= 1);
+ Tcl_Obj ** pplist = (Tcl_Obj **)malloc(sizeof(Tcl_Obj*) * length);
+ if (pplist == NULL) {
+ Tcl_SetResult (pInterp, "out of memory", TCL_STATIC);
+ return false;
+ }
+
+
+ for (int p = 0; p < length; p++)
+ pplist[p] = params.lindex(p);
+
+ if (pti != NULL) {
+ ASSERT (ptc != NULL);
+ bok = InvokeWithTypeInf(pInterp, DISPATCH_PROPERTYPUT, length, pplist, pdisp, pti, ptc);
+ }
+ else {
+ bok = InvokeNoTypeInf (pInterp, DISPATCH_PROPERTYPUT, length, pplist, pdisp);
+ }
+ namevalues += 2;
+ free(pplist);
+ }
+ }
+ if (bok)
+ Tcl_ResetResult (pInterp);
+ return true;
+}
+
+
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::GetPropVariantDispatch --
+ * Retrieves the value of property as a variant, relative to a dispatch
+ * interface.
+ *
+ * Result:
+ * true iff successful.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+bool OptclObj::GetPropVariantDispatch (Tcl_Interp *pInterp, const char*name,
+ IDispatch* pcurrent, VARIANT &varResult)
+
+{
+ USES_CONVERSION;
+
+ ASSERT (pcurrent != NULL && pInterp != NULL);
+
+ DISPID dispid;
+ HRESULT hr;
+ DISPPARAMS dispparamsNoArgs; SETNOPARAMS (dispparamsNoArgs);
+ EXCEPINFO ei;
+ bool bOk = false;
+
+ dispid = Name2ID (pcurrent, name);
+ if (dispid == DISPID_UNKNOWN) {
+ Tcl_SetResult (pInterp, "property not found: ", TCL_STATIC);
+ Tcl_AppendResult (pInterp, name, NULL);
+ return false;
+ }
+
+ hr = pcurrent->Invoke (dispid, IID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_PROPERTYGET,
+ &dispparamsNoArgs, &varResult, &ei, NULL);
+ if (hr == DISP_E_EXCEPTION)
+ Tcl_SetResult (pInterp, ExceptInfo2Str (&ei), TCL_DYNAMIC);
+ else if (FAILED(hr))
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ else
+ bOk = true;
+
+ return bOk;
+}
+
+
+
+
+
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ResolvePropertyObject --
+ * Resolves a property list of objects in the dot format
+ * e.g. application.documents(1).pages(2)
+ * Result:
+ * true iff successful to bind the ppunk parameter to a valid
+ * Side effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+bool OptclObj::ResolvePropertyObject (Tcl_Interp *pInterp, const char *sname,
+ IDispatch **ppdisp, ITypeInfo **ppinfo, ITypeComp **ppcmp /* = NULL*/)
+{
+ USES_CONVERSION;
+ ASSERT (pInterp != NULL && ppdisp != NULL && sname != NULL);
+ // copy the string onto the stack
+ char * szname;
+ char * seps = ".";
+ char * szprop = NULL;
+ _variant_t varobj;
+ VARIANT varResult;
+
+ HRESULT hr;
+
+ TObjPtr pcmd;
+ TObjPtr plist;
+ TObjPtr pokstring;
+
+ szname = (char*)_alloca (strlen (sname) + 1);
+ strcpy (szname, sname);
+ szprop = strtok(szname, seps);
+ CComQIPtr <IDispatch> current;
+ CComPtr <ITypeInfo> pti;
+ CComPtr <ITypeComp> pcmp;
+
+ UINT typecount = 0;
+
+ current = m_pcurrent;
+ pti = m_pti;
+ pcmp = m_ptc;
+
+ pcmd.create();
+
+ VariantInit (&varResult);
+
+ try {
+ while (szprop != NULL)
+ {
+ TObjPtr prop(szprop);
+
+ VariantClear(&varResult);
+ if (!GetIndexedVariant (pInterp, prop, current, pti, pcmp, varResult))
+ break;
+
+ // check that it's an object
+ if (varResult.vt != VT_DISPATCH && varResult.vt != VT_UNKNOWN)
+ {
+ Tcl_SetResult (pInterp, "'", TCL_STATIC);
+ Tcl_AppendResult (pInterp, szprop, "' is not an object", NULL);
+ break;
+ }
+
+ else
+ {
+ current = varResult.punkVal;
+ if (current == NULL)
+ {
+ Tcl_SetResult (pInterp, "'", TCL_STATIC);
+ Tcl_AppendResult (pInterp, szprop, "' is not a dispatchable object", NULL);
+ break;
+ }
+ typecount = 0;
+ pti = NULL;
+ pcmp = NULL;
+
+ current->GetTypeInfoCount (&typecount);
+ if (typecount > 0) {
+ hr = current->GetTypeInfo (0, LOCALE_SYSTEM_DEFAULT, &pti);
+ if (SUCCEEDED(hr)) {
+ g_libs.EnsureCached (pti);
+ }
+ pti->GetTypeComp(&pcmp);
+ }
+ }
+
+ // get the next property
+ szprop = strtok(NULL, seps);
+ }
+
+ *ppinfo = pti.Detach();
+ *ppcmp = pcmp.Detach();
+ *ppdisp = current.Detach ();
+ }
+
+ catch (HRESULT hr)
+ {
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ }
+
+ catch (char * error)
+ {
+ Tcl_SetResult (pInterp, error, TCL_STATIC);
+ }
+ VariantClear(&varResult);
+ return (szprop == NULL);
+}
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::GetBinding --
+ * Retrieves the current binding, if any for a properly formed event.
+ * Event is in the form of either
+ * 'event_name' on default interface
+ * 'lib.type.event_name'
+ *
+ * Result:
+ * true iff successful. Error in interpreter.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+bool OptclObj::GetBinding (Tcl_Interp *pInterp, char *pname)
+{
+ ASSERT (pInterp != NULL && pname != NULL);
+
+ EventBindings * pbinding = NULL;
+ GUID guid;
+ CComPtr<ITypeInfo>
+ pti;
+ int ne;
+ TObjPtr name(pname);
+ TObjPtr sr;
+
+
+ // split the name
+ sr.create();
+ if (!SplitObject(pInterp, name, ".", &sr))
+ return false;
+
+ ne = sr.llength();
+ if (ne <= 0)
+ return false;
+
+ // check for a split on strings ending with a token
+ if ((*(char*)(sr.lindex(ne - 1))) == '\0') {
+ if (--ne <= 0)
+ return false;
+ }
+
+ if (ne != 1 && ne != 3) {
+ Tcl_SetResult (pInterp, "wrong event format: should be either 'eventname' or 'lib.type.eventname'", TCL_STATIC);
+ return NULL;
+ }
+
+ if (ne == 1 && !FindDefaultEventInterface(pInterp, &pti, &guid))
+ return false;
+ else if (ne == 3 && FindEventInterface (pInterp, sr.lindex(0), sr.lindex(1), &pti, &guid))
+ return false;
+
+ if (m_bindings.find(&guid, &pbinding) == NULL) {
+ Tcl_ResetResult (pInterp);
+ return true;
+ }
+ else
+ return pbinding->GetBinding (pInterp, name);
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::SetBinding --
+ * Sets an event binding for the event pointed by 'pname' to the tcl command
+ * stored in 'pcmd'.
+ * Result:
+ * true iff successful. Else error in interpreter.
+ * Side effects:
+ * Any earlier binding for this event will be removed.
+ *-------------------------------------------------------------------------
+ */
+bool OptclObj::SetBinding (Tcl_Interp *pInterp, char *pname, Tcl_Obj *pcmd)
+{
+ ASSERT (pInterp != NULL && pname != NULL && pcmd != NULL);
+ ASSERT (m_punk != NULL);
+
+ TObjPtr name(pname);
+ TObjPtr cmd(pcmd, false);
+
+ TObjPtr sr; // split result
+ int ne; // name elements
+ GUID guid; // id of the event interface
+ HRESULT hr;
+
+ CComPtr<ITypeInfo>
+ pti; // typeinfo for the event interface
+
+ EventBindings * // the bindings for this interface
+ pbinding = NULL;
+
+
+ // split the name
+ sr.create();
+ if (!SplitObject(pInterp, name, ".", &sr))
+ return false;
+
+ ne = sr.llength();
+ if (ne <= 0)
+ return false;
+
+ // check for a split on strings ending with a token
+ if ((*(char*)(sr.lindex(ne - 1))) == '\0') {
+ if (--ne <= 0)
+ return false;
+ }
+
+ if (ne != 1 && ne != 3) {
+ Tcl_SetResult (pInterp, "wrong event format: should be either 'eventname' or 'lib.type.eventname'", TCL_STATIC);
+ return NULL;
+ }
+
+ if (ne == 1 && !FindDefaultEventInterface(pInterp, &pti, &guid))
+ return false;
+ else if (ne == 3 && !FindEventInterface (pInterp, sr.lindex(0), sr.lindex(1), &pti, &guid))
+ return false;
+
+
+ if (m_bindings.find(&guid, &pbinding) == NULL)
+ {
+ pbinding = new EventBindings (this, guid, pti);
+ // initiate the advise
+ hr = m_punk.Advise((IUnknown*)(pbinding), guid, &(pbinding->m_cookie));
+ if (FAILED(hr)) {
+ delete pbinding;
+ Tcl_SetResult (pInterp, HRESULT2Str (hr), TCL_DYNAMIC);
+ return false;
+ }
+ m_bindings.set(&guid, pbinding);
+ }
+
+ // deleting a single event binding
+ if ((*(char*)cmd) == '\0') {
+ if (!pbinding->DeleteBinding (pInterp, sr.lindex(ne==1?0:2)))
+ return false;
+ // total number of bindings for this interface is now zero?
+ if (pbinding->TotalBindings() == 0) {
+ // unadvise - CComPtr doesn't have this!!
+ CComQIPtr<IConnectionPointContainer> pcpc;
+ CComPtr<IConnectionPoint> pcp;
+ pcpc = m_punk;
+ ASSERT (pcpc != NULL);
+ pcpc->FindConnectionPoint (guid, &pcp);
+ ASSERT (pcp != NULL);
+ pcp->Unadvise (pbinding->m_cookie);
+ m_bindings.delete_entry(&guid);
+ delete pbinding;
+ }
+ }
+ else if (!pbinding->SetBinding (pInterp, sr.lindex(ne==1?0:2), pcmd))
+ return false;
+
+ return true;
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::FindDefaultEventInterface --
+ * Retrieves the default event interface for this object.
+ * Result:
+ * true iff successful. Else, error string in interpreter.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+bool OptclObj::FindDefaultEventInterface (Tcl_Interp *pInterp, ITypeInfo **ppinfo, GUID *pguid)
+{
+ ASSERT (pInterp != NULL && ppinfo != NULL && pguid != NULL);
+ ASSERT (m_punk != NULL);
+
+ bool bOk = false;
+ TYPEATTR * pattr = NULL;
+ HRESULT hr;
+ USHORT impltypes;
+ CComPtr<ITypeInfo> peti;
+
+
+ if (m_pti_class == NULL)
+ Tcl_SetResult (pInterp, "class-less object doesn't have a default event interface", TCL_STATIC);
+ else
+ {
+ hr = m_pti_class->GetTypeAttr (&pattr);
+ CHECKHR_TCL(hr, pInterp, false);
+ impltypes = pattr->cImplTypes;
+ m_pti_class->ReleaseTypeAttr(pattr); pattr = NULL;
+
+ for (USHORT i = 0; i < impltypes; i++)
+ {
+ INT flags;
+ HREFTYPE href;
+ if (SUCCEEDED(m_pti_class->GetImplTypeFlags (i, &flags))
+ && (flags & IMPLTYPEFLAG_FDEFAULT) // default interface and ..
+ && (flags & IMPLTYPEFLAG_FSOURCE) // an event source
+ && SUCCEEDED(m_pti_class->GetRefTypeOfImplType(i, &href))
+ && SUCCEEDED(m_pti_class->GetRefTypeInfo (href, &peti)))
+ {
+ i = impltypes; // quits this loop
+ // while we're here, we'll make sure that this type is cached
+ g_libs.EnsureCached(peti);
+ }
+ }
+
+ if (peti != NULL)
+ {
+ hr = peti->GetTypeAttr (&pattr);
+ CHECKHR_TCL(hr, pInterp, false);
+ *pguid = pattr->guid;
+ peti->ReleaseTypeAttr(pattr); pattr = NULL;
+ *ppinfo = peti;
+ (*ppinfo)->AddRef();
+ bOk = true;
+ }
+ }
+ return bOk;
+}
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::FindEventInterface --
+ * Called to find an event type info and guid given library and type of
+ * event interface.
+ *
+ * Result:
+ * true iff successful. Else, error string in interpreter.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+bool OptclObj::FindEventInterface (Tcl_Interp *pInterp, const char * lib, const char *type,
+ ITypeInfo **ppinfo, GUID * pguid)
+{
+
+ ASSERT (pInterp != NULL && lib != NULL && type != NULL && ppinfo != NULL);
+ ASSERT (pguid != NULL);
+ ASSERT (m_punk != NULL);
+
+ USES_CONVERSION;
+ CComPtr<ITypeInfo> peti;
+ CComPtr<ITypeLib> petl;
+
+ bool bOk = false;
+ TYPEATTR * pattr = NULL;
+ BSTR bType = NULL;
+ BSTR bLib = NULL;
+ HRESULT hr;
+ UINT dummy;
+
+
+ if (m_pti_class == NULL) {
+ // we don't have any class information
+ // try going through the typelibraries
+ try {
+ TypeLib_ResolveName (lib, type, NULL, &peti);
+ if (peti == NULL)
+ Tcl_SetResult (pInterp, "binding through typelib for class-less object failed", TCL_STATIC);
+ }
+
+ catch (char *err) {
+ Tcl_SetResult (pInterp, err, TCL_VOLATILE);
+ }
+
+ catch (HRESULT hr) {
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ }
+ }
+
+ else
+ {
+ // we do have class information
+ // this will ensure that even if the type library for the event
+ // interface is not loaded (yes, it can be different to that of the
+ // object that's using it, it will still be found.
+
+ // convert the event interface name to a bstring
+ bType = A2BSTR(type);
+ bLib = A2BSTR(lib);
+ // get the number of implemented types
+ hr = m_pti_class->GetTypeAttr (&pattr);
+ CHECKHR_TCL(hr, pInterp, false); // beware, conditional return here
+ USHORT types = pattr->cImplTypes;
+ m_pti_class->ReleaseTypeAttr (pattr); pattr = NULL;
+
+ // loop throught the implemented types
+ for (USHORT intf = 0; intf < types; intf++)
+ {
+ INT flags;
+ HREFTYPE href;
+ CComBSTR btypename,
+ blibname;
+
+ // if we the implementation flags is an event source and
+ // the name of the referenced type is the same
+ if (SUCCEEDED(m_pti_class->GetImplTypeFlags (intf, &flags))
+ && (flags&IMPLTYPEFLAG_FSOURCE)
+ && SUCCEEDED(m_pti_class->GetRefTypeOfImplType (intf, &href))
+ && SUCCEEDED(m_pti_class->GetRefTypeInfo (href, &peti))
+ && SUCCEEDED(peti->GetContainingTypeLib(&petl, &dummy))
+ && SUCCEEDED(peti->GetDocumentation(MEMBERID_NIL, &btypename, NULL, NULL, NULL))
+ && SUCCEEDED(petl->GetDocumentation(-1, &blibname, NULL, NULL, NULL)))
+ {
+ if ((btypename == bType) && (blibname == bLib)) {
+ intf = types; // quits this loop
+ // while we're at it, lets make sure that this typelibrary is
+ // registered.
+ g_libs.EnsureCached(petl);
+ }
+ }
+ else {
+ peti = NULL;
+ petl = NULL;
+ }
+ btypename.Empty();
+ blibname.Empty();
+ }
+
+ if (peti == NULL)
+ Tcl_SetResult (pInterp, "couldn't find event interface", TCL_STATIC);
+ }
+
+ if (peti != NULL) {
+ // if we've got a typeinfo, find the GUID
+ hr = peti->GetTypeAttr (&pattr);
+ CHECKHR_TCL (hr, pInterp, false);
+ *pguid = pattr->guid;
+ peti->ReleaseTypeAttr(pattr); pattr = NULL;
+ *ppinfo = peti;
+ (*ppinfo)->AddRef();
+ bOk = true;
+ }
+ return bOk;
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::ReleaseBindingTable --
+ * Releases the bindings withing the event bindings hash table.
+ * It's probably very important that this isn't called within the
+ * evaluation of an event.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void OptclObj::ReleaseBindingTable()
+{
+ CComQIPtr<IConnectionPointContainer> pcpc;
+ EventBindings * pbinding;
+ CComPtr<IConnectionPoint> pcp;
+
+
+ pcpc = m_punk;
+ if (pcpc == NULL)
+ return;
+
+ EventBindingsTbl::iterator i;
+ for (i = m_bindings.begin(); i != m_bindings.end(); i++)
+ {
+ pbinding = *i;
+ pcpc->FindConnectionPoint (*(i.key()), &pcp);
+ if (pcp != NULL) {
+ pcp->Unadvise(pbinding->m_cookie);
+ pcp = NULL;
+ }
+ else {
+ // this case occurs when the com object has been destroyed
+ // before this object is destroyed
+ }
+ delete pbinding;
+ }
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::GetState --
+ * This is some prelim code for persistence support - yanked out of the
+ * old container code - more soon!
+ *
+ * Result:
+ *
+ * Side effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+bool OptclObj::GetState (Tcl_Interp *pInterp)
+{
+ ASSERT (pInterp != NULL);
+ USES_CONVERSION;
+
+ CComPtr<IStream> pStream;
+ CComQIPtr<IPersistStream> pPS;
+ CComQIPtr<IPersistStreamInit> pPSI;
+
+ HGLOBAL hMem; // handle to memory
+ LPVOID pMem; // pointer to memory
+ HRESULT hr;
+ DWORD dwSize; // size of memory used
+ TObjPtr pObjs[2]; // objects to automanage the tcl_obj lifetimes
+ Tcl_Obj * pResult; // pointers used to create the result list
+ CLSID clsid;
+ LPOLESTR lpOleStr;
+
+
+ pPS = m_punk;
+ pPSI = m_punk;
+ if (!pPS && !pPSI) {
+ Tcl_SetResult (pInterp, "object does not support stream persistance model", TCL_STATIC);
+ return false;
+ }
+
+ hMem = GlobalAlloc (GHND, 0);
+ if (hMem == NULL) {
+ Tcl_SetResult (pInterp, "unable to initialise global memory", TCL_STATIC);
+ return false;
+ }
+
+ hr = CreateStreamOnHGlobal (hMem, TRUE, &pStream);
+ if (FAILED(hr)) {
+ GlobalFree (hMem);
+ Tcl_SetResult (pInterp, "unable to create a stream on global memory", TCL_STATIC);
+ return false;
+ }
+
+ if (pPS)
+ hr = pPS->Save (pStream, TRUE);
+ else
+ hr = pPSI->Save(pStream, TRUE);
+
+
+ if (FAILED(hr)) {
+ if (hr == STG_E_CANTSAVE)
+ Tcl_SetResult (pInterp, "failed to save object", TCL_STATIC);
+ else if (hr == STG_E_MEDIUMFULL)
+ Tcl_SetResult (pInterp, "failed to aquire enough memory", TCL_STATIC);
+ return false;
+ }
+ dwSize = GlobalSize(hMem);
+ pMem = GlobalLock (hMem);
+
+ ATLASSERT (pMem);
+ pObjs[1] = Tcl_NewStringObj ((char*)pMem, dwSize);
+ GlobalUnlock (hMem);
+
+ // now get the clsid
+ if (pPS)
+ hr = pPS->GetClassID (&clsid);
+ else
+ hr = pPSI->GetClassID (&clsid);
+
+ if (FAILED(hr))
+ {
+ Tcl_SetResult (pInterp, "failed to retrieve the clsid", TCL_STATIC);
+ return false;
+ }
+
+ hr = StringFromCLSID (clsid, &lpOleStr);
+ if (FAILED(hr)) {
+ Tcl_SetResult (pInterp, "failed to convert clsid to a string", TCL_STATIC);
+ return false;
+ }
+ pObjs[0] = Tcl_NewStringObj (OLE2A(lpOleStr), -1);
+ pResult = Tcl_NewListObj (0, NULL);
+ Tcl_ListObjAppendElement (NULL, pResult, pObjs[0]);
+ Tcl_ListObjAppendElement (NULL, pResult, pObjs[1]);
+ Tcl_SetObjResult (pInterp, pResult);
+ return true;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::ContainerWantsToDie --
+ * Called by the Tk widget container, when it is about to be destroyed.
+ * If we are not currently destroying this object, then instigate it.
+ *
+ * Result:
+ * None.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void OptclObj::ContainerWantsToDie ()
+{
+ if (!m_destroypending)
+ g_objmap.Delete(this);
+}
+
+
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * optclobj.cpp
+ * Declares the functionality for the internal representation of
+ * an optcl object.
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+
+#if !defined(AFX_OPTCLOBJ_H__8A11BC04_616B_11D4_8004_0040055861F2__INCLUDED_)
+#define AFX_OPTCLOBJ_H__8A11BC04_616B_11D4_8004_0040055861F2__INCLUDED_
+
+#if _MSC_VER > 1000
+#pragma once
+#endif // _MSC_VER > 1000
+
+// forward declarations of used classes
+#include "container.h"
+#include <string>
+
+class ObjMap;
+class EventBindings;
+class OptclBindPtr;
+class DispParams;
+
+typedef THash<GUID, EventBindings*> EventBindingsTbl;
+
+
+class OptclObj {
+friend ObjMap;
+friend CContainer;
+
+
+public:
+ OptclObj ();
+ virtual ~OptclObj ();
+
+ bool Create (Tcl_Interp *pInterp, const char *strid, const char *windowpath, bool start);
+ bool Attach (Tcl_Interp *pInterp, LPUNKNOWN punk);
+
+ operator LPUNKNOWN();
+ operator const char * ();
+
+ void CoClassName (TObjPtr &pObj);
+ void InterfaceName (TObjPtr &pObj);
+ void SetInterfaceName (TObjPtr &pObj);
+
+ bool InvokeCmd (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST objv[]);
+
+ bool OptclObj::ResolvePropertyObject (Tcl_Interp *pInterp, const char *sname,
+ IDispatch **ppdisp, ITypeInfo **ppinfo, ITypeComp **ppcmp);
+
+ bool GetBinding (Tcl_Interp *pInterp, char *name);
+ bool SetBinding (Tcl_Interp *pInterp, char *name, Tcl_Obj *command);
+
+ bool GetState (Tcl_Interp *pInterp);
+
+
+
+protected: // methods
+ void CreateName (LPUNKNOWN punk);
+ void InitialiseUnknown (LPUNKNOWN punk);
+ void InitialiseClassInfo (LPUNKNOWN punk);
+ void InitialisePointers (LPUNKNOWN punk, ITypeLib *pLib = NULL, ITypeInfo *pinfo = NULL);
+ void CreateCommand();
+ HRESULT InitialisePointersFromCoClass ();
+ HRESULT SetInterfaceFromType (ITypeInfo *pinfo);
+ HRESULT GetTypeAttr();
+ void ReleaseTypeAttr();
+ void ReleaseBindingTable();
+
+
+
+ bool BuildParamsWithBindPtr (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST objv[],
+ OptclBindPtr & bp, DispParams & dp);
+ bool RetrieveOutParams (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST objv[],
+ OptclBindPtr & bp, DispParams & dp);
+
+ bool InvokeNoTypeInfVariant (Tcl_Interp *pInterp, long ik, int objc, Tcl_Obj *CONST objv[],
+ IDispatch *pDisp, VARIANT &varResult);
+ bool InvokeNoTypeInf (Tcl_Interp *pInterp, long ik, int objc, Tcl_Obj *CONST objv[],
+ IDispatch *pDisp);
+
+ bool InvokeWithTypeInfVariant (Tcl_Interp *pInterp, long invokekind,
+ int objc, Tcl_Obj *CONST objv[],
+ IDispatch *pDisp, ITypeInfo *pti, ITypeComp *pCmp, VARIANT &varResult);
+ bool InvokeWithTypeInf (Tcl_Interp *pInterp, long ik, int objc, Tcl_Obj *CONST objv[],
+ IDispatch *pDisp, ITypeInfo *pti, ITypeComp *pcmp);
+
+ bool CheckInterface (Tcl_Interp *pInterp);
+
+ bool SetProp (Tcl_Interp *pInterp, int paircount, Tcl_Obj * CONST namevalues[],
+ IDispatch *pdisp, ITypeInfo *pti, ITypeComp *ptc);
+
+ bool GetProp (Tcl_Interp *pInterp, Tcl_Obj *name, IDispatch *pDisp, ITypeInfo *pti, ITypeComp *ptc);
+ bool GetIndexedVariant (Tcl_Interp *pInterp, Tcl_Obj *name,
+ IDispatch *pdisp, ITypeInfo *pti, ITypeComp *ptc, VARIANT &varResult);
+
+ bool GetPropVariantDispatch (Tcl_Interp *pInterp, const char*name,
+ IDispatch * pcurrent, VARIANT &varResult);
+
+ bool FindEventInterface (Tcl_Interp *pInterp, const char * lib, const char * type,
+ ITypeInfo **ppinfo, GUID * pguid);
+
+ bool FindDefaultEventInterface (Tcl_Interp *pInterp, ITypeInfo **ppinfo, GUID *pguid);
+
+ void ContainerWantsToDie ();
+protected: // properties
+ CComQIPtr<IDispatch> m_pcurrent; // Current interface
+ CComPtr<IUnknown> m_punk; // the 'true' IUnknown; reference purposes only
+ CComPtr<ITypeLib> m_ptl; // the type library for this object
+ CComPtr<ITypeInfo> m_pti; // the type interface for the current interface
+ CComPtr<ITypeComp> m_ptc; // the type info's compiler interface
+ CComPtr<ITypeInfo> m_pti_class;// the type interface for the this coclass
+ TYPEATTR * m_pta; // the type attribute for the current typeinfo
+
+ std::string m_name;
+ unsigned long m_refcount; // reference count of this optcl object
+ Tcl_Interp * m_pInterp; // interpreter that created this object
+ Tcl_Command m_cmdtoken; // command token of the tcl command within the above interpreter
+ EventBindingsTbl m_bindings; // bindings for event interfaces of this object
+ CContainer m_container;// container
+ bool m_destroypending; // true during a final delete operation
+};
+
+
+#endif // !defined(AFX_OPTCLOBJ_H__8A11BC04_616B_11D4_8004_0040055861F2__INCLUDED_)
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * optcltypeattr.cpp
+ * Implementation of the OptclTypeAttr class, a wrapper for the TYPEATTR
+ * pointer type.
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+
+#include "stdafx.h"
+#include "tbase.h"
+#include "optcl.h"
+#include "utility.h"
+#include "OptclTypeAttr.h"
+
+//////////////////////////////////////////////////////////////////////
+// Construction/Destruction
+//////////////////////////////////////////////////////////////////////
+
+OptclTypeAttr::OptclTypeAttr() : m_pattr(NULL)
+{
+
+}
+
+OptclTypeAttr::~OptclTypeAttr()
+{
+ ReleaseTypeAttr();
+}
+
+
+HRESULT OptclTypeAttr::GetTypeAttr ()
+{
+ HRESULT hr = S_OK;
+ // only get if we haven't already
+ if (m_pattr == NULL) {
+ ASSERT (m_pti != NULL);
+ hr = m_pti->GetTypeAttr (&m_pattr);
+ }
+ return hr;
+}
+
+
+void OptclTypeAttr::ReleaseTypeAttr ()
+{
+ if (m_pattr != NULL)
+ {
+ ASSERT (m_pti != NULL);
+ m_pti->ReleaseTypeAttr(m_pattr);;
+ m_pattr = NULL;
+ }
+}
+
+
+OptclTypeAttr & OptclTypeAttr::operator= (ITypeInfo *pti)
+{
+ ReleaseTypeAttr();
+ m_pti = pti;
+ if (m_pti != NULL)
+ GetTypeAttr();
+ return *this;
+}
+
+
+TYPEATTR * OptclTypeAttr::operator -> ()
+{
+ ASSERT (m_pattr != NULL);
+ return m_pattr;
+}
+
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * optcltypeattr.h
+ * Definition of the OptclTypeAttr class, a wrapper for the TYPEATTR
+ * pointer type.
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+
+#if !defined(AFX_OPTCLTYPEATTR_H__5826EED2_5FA7_11D3_86E8_0000B482A708__INCLUDED_)
+#define AFX_OPTCLTYPEATTR_H__5826EED2_5FA7_11D3_86E8_0000B482A708__INCLUDED_
+
+#if _MSC_VER > 1000
+#pragma once
+#endif // _MSC_VER > 1000
+
+class OptclTypeAttr
+{
+public:
+ CComPtr<ITypeInfo> m_pti;
+ TYPEATTR * m_pattr;
+
+public:
+ OptclTypeAttr();
+ virtual ~OptclTypeAttr();
+ HRESULT GetTypeAttr ();
+ void ReleaseTypeAttr ();
+ OptclTypeAttr & operator= (ITypeInfo *pti);
+ TYPEATTR * operator -> ();
+};
+
+#endif // !defined(AFX_OPTCLTYPEATTR_H__5826EED2_5FA7_11D3_86E8_0000B482A708__INCLUDED_)
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * stdafx.cpp
+ * source file that includes just the standard includes
+ * optcl.pch will be the pre-compiled header
+ * stdafx.obj will contain the pre-compiled type information
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+
+
+#include "stdafx.h"
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * stdafx.cpp
+ * include file for standard system include files, or project specific
+ * include files that are used frequently, but are changed infrequently
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+
+
+// stdafx.h : include file for standard system include files,
+// or project specific include files that are used frequently, but
+// are changed infrequently
+//
+
+#if !defined(AFX_STDAFX_H__1363E007_C12C_11D2_8003_0040055861F2__INCLUDED_)
+#define AFX_STDAFX_H__1363E007_C12C_11D2_8003_0040055861F2__INCLUDED_
+
+#if _MSC_VER > 1000
+#pragma once
+#endif // _MSC_VER > 1000
+
+
+// Insert your headers here
+//#define WIN32_LEAN_AND_MEAN // Exclude rarely-used stuff from Windows headers
+
+#include <Atlbase.h>
+extern CComModule _Module;
+#include <atlcom.h>
+#include <atlhost.h>
+#include <atlwin.h>
+
+#include <windows.h>
+#include <comdef.h>
+#include <tcl.h>
+#include <tk.h>
+
+//{{AFX_INSERT_LOCATION}}
+// Microsoft Visual C++ will insert additional declarations immediately before the previous line.
+
+#endif // !defined(AFX_STDAFX_H__1363E007_C12C_11D2_8003_0040055861F2__INCLUDED_)
--- /dev/null
+Conversion
+ VT_EMPTY = 0, // 0
+ VT_VOID = 24, // 0
+ VT_NULL = 1, // 0
+
+
+ VT_VARIANT = 12, // VARIANT * - decode by reference
+
+ VT_ERROR = 10, // short
+ VT_I2 = 2, // short
+ VT_UI1 = 17, // short
+
+ VT_I4 = 3, // long
+ VT_UI2 = 18, // long
+ VT_INT = 22, // long
+
+ VT_R4 = 4, // float
+ VT_R8 = 5, // real
+
+ VT_BOOL = 11, // boolean
+
+ VT_UNKNOWN = 13, // object
+ VT_DISPATCH = 9, // object
+
+ VT_I1 = 16, // char
+
+
+ *** VT_DECIMAL = 14, // can't - string? no
+ *** VT_CARRAY = 28, // ?
+
+
+ VT_CY = 6, // string
+ VT_DATE = 7, // string
+ VT_BSTR = 8, // string
+
+ VT_UI4 = 19, // string
+ VT_I8 = 20, // string
+ VT_UI8 = 21, // string
+ VT_UINT = 23, // string
+
+ VT_HRESULT = 25, // HRESULT2Str
+ VT_SAFEARRAY = 27, // tcl list
+ VT_USERDEFINED = 29, // type info require
+ VT_RECORD = 36, // tcl list? - creating might be a bit hard
+ VT_VECTOR = 0x1000, // tcl list?
+ VT_ARRAY = 0x2000, // tcl list
+ VT_BYREF = 0x4000, // pointer to value - eek
+
+
+convert an object to a variant using type k
+template <class T> f (VARIANT *p
\ No newline at end of file
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * initonce.cpp
+ * This file is used to correctly perform the one-time initialisation
+ * of standard GUIDs.
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+
+#include <objbase.h>
+#include <initguid.h>
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * optcl.cpp
+ * Tcl gateway functions are placed here. De/Initialisation
+ * of the object map occurs here, together with registration of many of
+ * optcl's commands.
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+
+
+#include "stdafx.h"
+#include "tbase.h"
+#include "utility.h"
+#include "optcl.h"
+#include "resource.h"
+#include "optclobj.h"
+#include "objmap.h"
+#include "dispparams.h"
+#include "typelib.h"
+
+//----------------------------------------------------------------
+HINSTANCE ghDll = NULL;
+CComModule _Module;
+CComPtr<IMalloc> g_pmalloc;
+
+//----------------------------------------------------------------
+
+// Function declarations
+void Optcl_Exit (ClientData);
+
+
+TCL_CMDEF(OptclNewCmd);
+TCL_CMDEF(OptclLockCmd);
+TCL_CMDEF(OptclUnlockCmd);
+TCL_CMDEF(OptclClassCmd);
+TCL_CMDEF(OptclInterfaceCmd);
+TCL_CMDEF(OptclBindCmd);
+TCL_CMDEF(OptclIsObjectCmd);
+TCL_CMDEF(OptclInvokeLibFunction);
+
+
+//----------------------------------------------------------------
+
+/*
+ *-------------------------------------------------------------------------
+ * DllMain --
+ * Windows entry point - ensures that ATL's ax containement are
+ * initialised.
+ *
+ * Result:
+ * TRUE.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+BOOL WINAPI DllMain (HINSTANCE hinstDLL, DWORD fdwReason, LPVOID lpvReserved)
+{
+#ifdef _DEBUG
+ int tmpFlag;
+#endif // _DEBUG
+
+ switch (fdwReason)
+ {
+ case DLL_PROCESS_ATTACH:
+ ghDll = hinstDLL;
+ _Module.Init (NULL, (HINSTANCE)hinstDLL);
+ AtlAxWinInit();
+
+ #ifdef _DEBUG
+ // memory leak detection - only in the debug build
+ tmpFlag = _CrtSetDbgFlag( _CRTDBG_REPORT_FLAG );
+ tmpFlag |= _CRTDBG_LEAK_CHECK_DF;
+ _CrtSetDbgFlag( tmpFlag );
+ #endif // _DEBUG
+ break;
+ case DLL_PROCESS_DETACH:
+ _Module.Term();
+ break;
+ }
+
+ return TRUE;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * Optcl_Exit --
+ * Called by Tcl pending exit. Removes all optcl objects. Uninits OLE.
+ * Result:
+ * None.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void Optcl_Exit (ClientData)
+{
+ // remove all the elements of the table
+ g_objmap.DeleteAll ();
+ g_pmalloc.Release();
+ OleUninitialize();
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclNewCmd --
+ * Implements the optcl::new command. Format of this command currently is:
+ * ?-start? ?-window path? ProgIdOrClsidOrDocument
+ * For the time being, documents require the -window option to be used
+ * as this code relies on ATL containement to locate the document server.
+ * This constraint is not ensured by this code.
+ * This can easily be implemented for documents that are not to be contained.
+ *
+ * Result:
+ * Standard Tcl result.
+ * Side effects:
+ * Depends on parameters.
+ *-------------------------------------------------------------------------
+ */
+TCL_CMDEF(OptclNewCmd)
+{
+ OptclObj *pObj = NULL;
+ TObjPtr id;
+ Tcl_Obj ** old = (Tcl_Obj**)objv;
+
+ char *path = NULL;
+ bool start = false;
+ static const char * err = "?-start? ?-window path? ProgIdOrClsidOrDocument";
+ static const char * errcreate = "error in creating object";
+
+ if (objc < 2 || objc > 5) {
+ Tcl_WrongNumArgs (pInterp, 1, objv, (char*)err);
+ return TCL_ERROR;
+ }
+
+ // do we have flags?
+ // process each one
+ while (objc >= 3)
+ {
+ TObjPtr element;
+ element.attach(objv[1]);
+ int len = strlen(element);
+ if (strncmp (element, "-start", len) == 0) {
+ start = true;
+ }
+ else if (strncmp (element, "-window", len) == 0) {
+ if (--objc <= 0) {
+ Tcl_SetResult (pInterp, "expected path after -window", TCL_STATIC);
+ return TCL_ERROR;
+ }
+ objv++;
+ element.attach(objv[1]);
+ path = (char*)element;
+ }
+ else {
+ Tcl_SetResult (pInterp, "unknown flag: ", TCL_STATIC);
+ Tcl_AppendResult (pInterp, (char*)element, NULL);
+ return TCL_ERROR;
+ }
+ if (--objc <= 0) {
+ Tcl_WrongNumArgs (pInterp, 1, old, (char*) err);
+ return TCL_ERROR;
+ }
+ objv++;
+ }
+
+ id.attach (objv[1]);
+
+ try {
+ // try creating the object
+ pObj = g_objmap.Create (pInterp, id, path, start);
+ if (pObj == NULL)
+ Tcl_SetResult (pInterp, (char*)errcreate, TCL_STATIC);
+ }
+
+ catch (HRESULT hr) {
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ }
+
+ catch (char *err) {
+ Tcl_SetResult (pInterp, err, TCL_VOLATILE);
+ }
+
+ catch (...)
+ {
+ Tcl_SetResult (pInterp, (char*)errcreate, TCL_STATIC);
+ }
+
+ if (pObj != NULL) {
+ Tcl_SetResult (pInterp, (char*)(const char*)(*pObj), TCL_VOLATILE);
+ return TCL_OK;
+ }
+ else
+ return TCL_ERROR;
+}
+
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclLockCmd --
+ * Implements the optcl::lock command.
+ * Result:
+ * Standard Tcl result
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+TCL_CMDEF(OptclLockCmd)
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs (pInterp, 1, objv, "object");
+ return TCL_ERROR;
+ }
+ TObjPtr name;
+ name.attach(objv[1]);
+ if (!g_objmap.Lock(name)) {
+ return ObjectNotFound(pInterp, name);
+ }
+ return TCL_OK;
+}
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclUnlockCmd --
+ * Implements the optcl::unlock command.
+ *
+ * Result:
+ * Standard Tcl result.
+ *
+ * Side effects:
+ * If the reference count of the object hits zero, then the object will be
+ * deleted, together with its Tcl command and its container window, if it
+ * exists.
+ *-------------------------------------------------------------------------
+ */
+TCL_CMDEF(OptclUnlockCmd)
+{
+ if (objc < 2) {
+ Tcl_WrongNumArgs (pInterp, 1, objv, "object ...");
+ return TCL_ERROR;
+ }
+
+ TObjPtr name;
+ for (int i = 1; i < objc; i++) {
+ name.attach(objv[1]);
+ g_objmap.Unlock(name);
+ }
+ return TCL_OK;
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclInvokeLibFunction --
+ * Wild and useless attempt at calling ITypeInfo declared static DLL
+ * functions. Sigh!
+ * Result:
+ *
+ * Side effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+TCL_CMDEF(OptclInvokeLibFunction)
+{
+ USES_CONVERSION;
+ DispParams dp;
+ LPOLESTR olename;
+ TObjPtr name,
+ presult;
+ CComPtr<ITypeInfo> pinfo;
+ CComPtr<ITypeInfo> pti;
+ CComPtr<ITypeComp> pcmp;
+ HRESULT hr;
+ DESCKIND dk; dk = DESCKIND_NONE;
+ BINDPTR bp; bp.lpfuncdesc = NULL;
+ DISPID dispid;
+ EXCEPINFO ei;
+ UINT ea = 0;
+ VARIANT varResult;
+ bool bOk = false;
+ VOID * pFunc = NULL;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs (pInterp, 1, objv, "typename function args...");
+ return TCL_ERROR;
+ }
+
+ try {
+ // attempt to resolve the type
+ name.attach(objv[1]);
+ TypeLib_ResolveName (name, NULL, &pinfo);
+
+ hr = pinfo->GetTypeComp (&pcmp);
+ CHECKHR_TCL(hr, pInterp, TCL_ERROR);
+
+ name.attach(objv[2]);
+ olename = A2OLE(name);
+ hr = pcmp->Bind (olename, LHashValOfName(LOCALE_SYSTEM_DEFAULT, olename),
+ INVOKE_FUNC, &pti, &dk, &bp);
+
+ CHECKHR(hr);
+ if (dk != DESCKIND_FUNCDESC || bp.lpfuncdesc->funckind != FUNC_STATIC) {
+ Tcl_SetResult (pInterp, "static method not found: ", TCL_STATIC);
+ Tcl_AppendResult (pInterp, (char*)name, NULL);
+ } else {
+ ASSERT (bp.lpfuncdesc != NULL);
+ dispid = bp.lpfuncdesc->memid;
+ hr = pinfo->AddressOfMember (dispid, INVOKE_FUNC, &pFunc);
+ CHECKHR_TCL(hr, pInterp, TCL_ERROR);
+ int params = objc - 3;
+
+ // check for the last parameter being the return value and take
+ // this into account when checking parameter counts
+ int reqparams = bp.lpfuncdesc->cParams;
+ if (reqparams > 0 && bp.lpfuncdesc->lprgelemdescParam[reqparams - 1].paramdesc.wParamFlags & PARAMFLAG_FRETVAL)
+ --reqparams;
+
+
+ if (params <= reqparams &&
+ params >= (reqparams -bp.lpfuncdesc->cParamsOpt))
+ {
+ VariantInit (&varResult);
+
+ // set up the dispatch arguments - must be in reverse order
+ dp.Args (params);
+ for (int i = params-1; i >= 0; i--)
+ {
+ bool con_ok;
+ LPVARIANT pv;
+
+ name.attach(objv[i+3]);
+ // are we dealing with referenced parameter?
+ if (bp.lpfuncdesc->lprgelemdescParam[i].tdesc.vt == VT_PTR) {
+ ASSERT (bp.lpfuncdesc->lprgelemdescParam[i].tdesc.lptdesc != NULL);
+
+ // allocate a variant to store the *value*
+ pv = new VARIANT;
+ VariantInit (pv);
+ con_ok = obj2var_ti(pInterp, name, *pv, pti, &(bp.lpfuncdesc->lprgelemdescParam[i].tdesc));
+ // we'll now set it as a reference for the dispatch parameters array
+ // on destruction, the array will take care of clearing the variant
+ dp.Set(params - i - 1, pv);
+ }
+
+ else
+ con_ok = obj2var_ti(pInterp, name, dp[params - i - 1], pti, &(bp.lpfuncdesc->lprgelemdescParam[i].tdesc));
+
+
+ if (!con_ok)
+ {
+ ReleaseBindPtr (pti, dk, bp);
+ return false; // error in type conversion
+ }
+ }
+ hr = pinfo->Invoke (pFunc, dispid, DISPATCH_METHOD, &dp, &varResult, &ei, &ea);
+ //hr = pDisp->Invoke(dispid, IID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_METHOD,
+ // &dp, &varResult, &ei, &ea);
+
+ if (hr == DISP_E_EXCEPTION)
+ Tcl_SetResult (pInterp, ExceptInfo2Str (&ei), TCL_DYNAMIC);
+ else if (hr == DISP_E_TYPEMISMATCH) {
+ TDString td("type mismatch in parameter #");
+ td << (long)(ea);
+ Tcl_SetResult (pInterp, td, TCL_VOLATILE);
+ }
+ else
+ CHECKHR_TCL(hr, pInterp, TCL_ERROR);
+ if (FAILED(hr))
+ return TCL_ERROR;
+ if (bOk = var2obj(pInterp, varResult, presult))
+ Tcl_SetObjResult (pInterp, presult);
+ VariantClear(&varResult);
+ }
+ else
+ {
+ Tcl_SetResult (pInterp, "wrong # args", TCL_STATIC);
+ }
+ }
+ }
+
+ catch (HRESULT hr) {
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ }
+ return bOk?TCL_OK:TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclClassCmd --
+ * Implements the optcl::class command.
+ *
+ * Result:
+ * Standard Tcl result
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+TCL_CMDEF(OptclClassCmd)
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs (pInterp, 1, objv, "object");
+ return TCL_ERROR;
+ }
+ OptclObj *pObj = NULL;
+ TObjPtr name;
+ TObjPtr classname;
+
+ name.attach (objv[1]);
+ pObj = g_objmap.Find (name);
+ if (pObj == NULL)
+ return ObjectNotFound (pInterp, name);
+ try {
+ pObj->CoClassName(classname);
+ }
+
+ catch (HRESULT hr) {
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult (pInterp, classname);
+ return TCL_OK;
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclInterfaceCmd --
+ * Implements the optcl::interface command. Will either retrieve the
+ * current active interface or set it:
+ * optcl::interface objid ?newinterface?
+ *
+ * The new interface must be a proper typename. i.e. lib.type
+ * Result:
+ * Standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+TCL_CMDEF(OptclInterfaceCmd)
+{
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs (pInterp, 1, objv, "object ?interface?");
+ return TCL_ERROR;
+ }
+
+ OptclObj *pObj = NULL;
+ TObjPtr name;
+ TObjPtr intfname;
+
+ name.attach (objv[1]);
+ pObj = g_objmap.Find (name);
+ if (pObj == NULL)
+ return ObjectNotFound (pInterp, name);
+ try {
+ if (objc == 2) // get the current interface name
+ pObj->InterfaceName(intfname);
+ else // we are setting the interface
+ {
+ intfname.attach(objv[2]);
+ pObj->SetInterfaceName(intfname);
+ }
+ }
+
+ catch (HRESULT hr) {
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ return TCL_ERROR;
+ }
+ catch (char *error) {
+ Tcl_SetResult (pInterp, error, TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult (pInterp, intfname);
+ return TCL_OK;
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclBindCmd --
+ * Implements the optcl::bind command. This enables the setting, unsetting
+ * and retrieving of a binding to an objects event, either on its default
+ * interface (in which case the interface type is not required) or on
+ * a non-default event interface. e.g.
+ * optcl::bind $obj NewDoc OnNewDocTclhandler
+ * optcl::bind $obj NewDoc ==> OnNewDocTclhandler
+ * optcl::bind $obj ICustomInterface.Foo FooHandler
+ *
+ * The tcl command is then called when the specified event is fired.
+ * The parameter list of the event is prepended with the identifier
+ * object that fired event. If a parameter of an event is an object,
+ * it's lifetime is only within the duration of the execution of the
+ * tcl handler. To allow for the object to persist after the handler has
+ * completed, the tcl script must call optcl::lock on the object.
+ *
+ * Result:
+ * Standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+TCL_CMDEF(OptclBindCmd)
+{
+ if (objc != 3 && objc != 4)
+ {
+ Tcl_WrongNumArgs (pInterp, 1, objv, "object event_name ?tcl_command?");
+ return TCL_ERROR;
+ }
+
+ OptclObj *pObj = NULL;
+ TObjPtr name;
+ TObjPtr value;
+ bool bOk = false;
+
+ name.attach (objv[1]);
+ pObj = g_objmap.Find (name);
+ if (pObj == NULL)
+ return ObjectNotFound (pInterp, name);
+
+ name.attach(objv[2]); // the event name
+ if (objc == 3) // get the current binding (if any) for an event
+ bOk = pObj->GetBinding (pInterp, name);
+ else // we are setting the interface
+ {
+ value.attach(objv[3]);
+ if (bOk = pObj->SetBinding(pInterp, name, value))
+ Tcl_SetObjResult (pInterp, value);
+ }
+ return (bOk?TCL_OK:TCL_ERROR);
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclIsObjectCmd --
+ * Returns a boolean in the interpreter - true iff the only parameter
+ * for this command is an object.
+ *
+ * Result:
+ * TCL_OK always for the correct number of parameters.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+TCL_CMDEF(OptclIsObjectCmd)
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs (pInterp, 1, objv, "object");
+ return TCL_ERROR;
+ }
+ TObjPtr name(objv[1], false);
+ TObjPtr found(false, false);
+ if (g_objmap.Find (name))
+ {
+ found = true;
+ }
+ Tcl_SetObjResult (pInterp, found);
+ return TCL_OK;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * Optcl_Init --
+ * Tcl's first entry point. Initialises ole, sets up the exit handler,
+ * invokes the startup script (stored in a windows resource) and setsup
+ * the optcl namespace. Finally, it initialises the type library system.
+ *
+ * Result:
+ * Standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+int Optcl_Init (Tcl_Interp *pInterp)
+{
+ Tcl_CmdInfo *pinfo = NULL;
+
+#ifdef USE_TCL_STUBS
+#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION >= 1)
+ // initialise the Tcl stubs - failure is very bad
+ if (Tcl_InitStubs (pInterp, "8.0", 0) == NULL)
+ return TCL_ERROR;
+
+ // if Tk is loaded then initialise the Tk stubs
+ if (Tcl_Eval (pInterp, "package present Tk") != TCL_ERROR) {
+ // initialise the Tk stubs - failure
+ if (Tk_InitStubs (pInterp, "8.0", 0) == NULL)
+ return TCL_ERROR;
+ }
+#else
+#error Wrong Tcl version for Stubs
+#endif // (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION >= 1)
+#endif // USE_TCL_STUBS
+
+ HRESULT hr;
+ OleInitialize(NULL);
+ hr = CoGetMalloc(1, &g_pmalloc);
+ CHECKHR_TCL(hr, pInterp, TCL_ERROR);
+
+ Tcl_CreateExitHandler (Optcl_Exit, NULL);
+ HRSRC hrsrc = FindResource (ghDll, MAKEINTRESOURCE(IDR_TYPELIB), _T("TCL_SCRIPT"));
+ if (hrsrc == NULL) {
+ Tcl_SetResult (pInterp, "failed to locate internal script", TCL_STATIC);
+ return TCL_ERROR;
+ }
+ HGLOBAL hscript = LoadResource (ghDll, hrsrc);
+ if (hscript == NULL) {
+ Tcl_SetResult (pInterp, "failed to load internal script", TCL_STATIC);
+ return TCL_ERROR;
+ }
+
+ ASSERT (hscript != NULL);
+ char *szscript = (char*)LockResource (hscript);
+
+ ASSERT (szscript != NULL);
+ if (Tcl_GlobalEval (pInterp, szscript) == TCL_ERROR)
+ return TCL_ERROR;
+
+ Tcl_CreateObjCommand (pInterp, "optcl::new", OptclNewCmd, NULL, NULL);
+ Tcl_CreateObjCommand (pInterp, "optcl::lock", OptclLockCmd, NULL, NULL);
+ Tcl_CreateObjCommand (pInterp, "optcl::unlock", OptclUnlockCmd, NULL, NULL);
+ Tcl_CreateObjCommand (pInterp, "optcl::class", OptclClassCmd, NULL, NULL);
+ Tcl_CreateObjCommand (pInterp, "optcl::interface", OptclInterfaceCmd, NULL, NULL);
+ Tcl_CreateObjCommand (pInterp, "optcl::bind", OptclBindCmd, NULL, NULL);
+ Tcl_CreateObjCommand (pInterp, "optcl::module", OptclInvokeLibFunction, NULL, NULL);
+ Tcl_CreateObjCommand (pInterp, "optcl::isobject", OptclIsObjectCmd, NULL, NULL);
+
+
+ /// TESTS ///
+ Tcl_CreateObjCommand (pInterp, "optcl::vartest", Obj2VarTest, NULL, NULL);
+
+ return TypeLib_Init(pInterp);
+}
+
--- /dev/null
+# Microsoft Developer Studio Project File - Name="optcl" - Package Owner=<4>
+# Microsoft Developer Studio Generated Build File, Format Version 6.00
+# ** DO NOT EDIT **
+
+# TARGTYPE "Win32 (x86) Dynamic-Link Library" 0x0102
+
+CFG=optcl - Win32 Debug_NoStubs
+!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 "optcl.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 "optcl.mak" CFG="optcl - Win32 Debug_NoStubs"
+!MESSAGE
+!MESSAGE Possible choices for configuration are:
+!MESSAGE
+!MESSAGE "optcl - Win32 Release" (based on "Win32 (x86) Dynamic-Link Library")
+!MESSAGE "optcl - Win32 Debug" (based on "Win32 (x86) Dynamic-Link Library")
+!MESSAGE "optcl - Win32 Release_NoStubs" (based on "Win32 (x86) Dynamic-Link Library")
+!MESSAGE "optcl - Win32 Debug_NoStubs" (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)" == "optcl - 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 "OPTCL_EXPORTS" /YX /FD /c
+# ADD CPP /nologo /MT /W3 /GX /O2 /Ob2 /I "c:\progra~1\tcl\include" /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "OPTCL_EXPORTS" /D "USE_TCL_STUBS" /D "USE_TK_STUBS" /FR /Yu"stdafx.h" /FD /c
+# ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32
+# ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32
+# ADD BASE RSC /l 0x809 /d "NDEBUG"
+# ADD RSC /l 0x809 /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 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib tclstub82.lib tkstub82.lib /nologo /dll /machine:I386 /out:"../install/optclstubs.dll" /libpath:"c:\progra~1\tcl\lib"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 1
+# PROP BASE Output_Dir "optcl___Win32_Debug"
+# PROP BASE Intermediate_Dir "optcl___Win32_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 "OPTCL_EXPORTS" /YX /FD /GZ /c
+# ADD CPP /nologo /MTd /W3 /Gm /Gi /GX /ZI /Od /I "c:\progra~1\tcl\include" /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "OPTCL_EXPORTS" /D "USE_TCL_STUBS" /D "USE_TK_STUBS" /FR /Yu"stdafx.h" /FD /GZ /c
+# ADD BASE MTL /nologo /D "_DEBUG" /mktyplib203 /win32
+# ADD MTL /nologo /D "_DEBUG" /mktyplib203 /win32
+# ADD BASE RSC /l 0x809 /d "_DEBUG"
+# ADD RSC /l 0x809 /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 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib tclstub84.lib tkstub84.lib /nologo /dll /debug /machine:I386 /out:"../install/optclstubs.dll" /pdbtype:sept /libpath:"c:\progra~1\tcl\lib"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 0
+# PROP BASE Output_Dir "optcl___Win32_Release_NoStubs"
+# PROP BASE Intermediate_Dir "optcl___Win32_Release_NoStubs"
+# PROP BASE Ignore_Export_Lib 0
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 0
+# PROP Output_Dir "Release_NoStubs"
+# PROP Intermediate_Dir "Release_NoStubs"
+# PROP Ignore_Export_Lib 0
+# PROP Target_Dir ""
+# ADD BASE CPP /nologo /MT /W3 /GX /O2 /Ob2 /I "c:\progra~1\tcl\include" /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "OPTCL_EXPORTS" /D "USE_TCL_STUBS" /D "USE_TK_STUBS" /FR /Yu"stdafx.h" /FD /c
+# ADD CPP /nologo /MT /W3 /GX /O2 /Ob2 /I "c:\progra~1\tcl\include" /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "OPTCL_EXPORTS" /FR /Yu"stdafx.h" /FD /c
+# ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32
+# ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32
+# ADD BASE RSC /l 0x809 /d "NDEBUG"
+# ADD RSC /l 0x809 /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 tclstub82.lib tkstub82.lib /nologo /dll /machine:I386 /libpath:"c:\progra~1\tcl\lib"
+# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib tcl80.lib tk80.lib /nologo /dll /machine:I386 /out:"../install/optcl80.dll" /libpath:"c:\progra~1\tcl\lib"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 1
+# PROP BASE Output_Dir "optcl___Win32_Debug_NoStubs"
+# PROP BASE Intermediate_Dir "optcl___Win32_Debug_NoStubs"
+# PROP BASE Ignore_Export_Lib 0
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 1
+# PROP Output_Dir "Debug_NoStubs"
+# PROP Intermediate_Dir "Debug_NoStubs"
+# PROP Ignore_Export_Lib 0
+# PROP Target_Dir ""
+# ADD BASE CPP /nologo /MTd /W3 /Gm /Gi /GX /ZI /Od /I "c:\progra~1\tcl\include" /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "OPTCL_EXPORTS" /D "USE_TCL_STUBS" /D "USE_TK_STUBS" /FR /Yu"stdafx.h" /FD /GZ /c
+# ADD CPP /nologo /MTd /W3 /Gm /Gi /GX /ZI /Od /I "c:\progra~1\tcl\include" /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "OPTCL_EXPORTS" /FR /Yu"stdafx.h" /FD /GZ /c
+# ADD BASE MTL /nologo /D "_DEBUG" /mktyplib203 /win32
+# ADD MTL /nologo /D "_DEBUG" /mktyplib203 /win32
+# ADD BASE RSC /l 0x809 /d "_DEBUG"
+# ADD RSC /l 0x809 /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 tclstub82.lib tkstub82.lib /nologo /dll /debug /machine:I386 /pdbtype:sept /libpath:"c:\progra~1\tcl\lib"
+# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib tcl80.lib tk80.lib /nologo /dll /debug /machine:I386 /out:"../install/optcl80.dll" /pdbtype:sept /libpath:"c:\progra~1\tcl\lib"
+
+!ENDIF
+
+# Begin Target
+
+# Name "optcl - Win32 Release"
+# Name "optcl - Win32 Debug"
+# Name "optcl - Win32 Release_NoStubs"
+# Name "optcl - Win32 Debug_NoStubs"
+# Begin Group "Source"
+
+# PROP Default_Filter "cpp"
+# Begin Source File
+
+SOURCE=.\Container.cpp
+
+!IF "$(CFG)" == "optcl - Win32 Release"
+
+# ADD CPP /Yu"StdAfx.h"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs"
+
+# ADD BASE CPP /Yu"StdAfx.h"
+# ADD CPP /Yu"StdAfx.h"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs"
+
+!ENDIF
+
+# End Source File
+# Begin Source File
+
+SOURCE=.\DispParams.cpp
+
+!IF "$(CFG)" == "optcl - Win32 Release"
+
+# ADD CPP /Yu"stdafx.h"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
+
+# ADD CPP /Yu"StdAfx.h"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs"
+
+# ADD BASE CPP /Yu"stdafx.h"
+# ADD CPP /Yu"stdafx.h"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs"
+
+# ADD BASE CPP /Yu"StdAfx.h"
+# ADD CPP /Yu"StdAfx.h"
+
+!ENDIF
+
+# End Source File
+# Begin Source File
+
+SOURCE=.\EventBinding.cpp
+
+!IF "$(CFG)" == "optcl - Win32 Release"
+
+# ADD CPP /Yu"stdafx.h"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs"
+
+# ADD BASE CPP /Yu"stdafx.h"
+# ADD CPP /Yu"stdafx.h"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs"
+
+!ENDIF
+
+# End Source File
+# Begin Source File
+
+SOURCE=.\initonce.cpp
+# SUBTRACT CPP /YX /Yc /Yu
+# End Source File
+# Begin Source File
+
+SOURCE=.\ObjMap.cpp
+
+!IF "$(CFG)" == "optcl - Win32 Release"
+
+# ADD CPP /Yu"stdafx.h"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
+
+# ADD CPP /Yu"StdAfx.h"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs"
+
+# ADD BASE CPP /Yu"stdafx.h"
+# ADD CPP /Yu"stdafx.h"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs"
+
+# ADD BASE CPP /Yu"StdAfx.h"
+# ADD CPP /Yu"StdAfx.h"
+
+!ENDIF
+
+# End Source File
+# Begin Source File
+
+SOURCE=.\optcl.cpp
+
+!IF "$(CFG)" == "optcl - Win32 Release"
+
+# ADD CPP /Yu"stdafx.h"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
+
+# ADD CPP /Yu"StdAfx.h"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs"
+
+# ADD BASE CPP /Yu"stdafx.h"
+# ADD CPP /Yu"stdafx.h"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs"
+
+# ADD BASE CPP /Yu"StdAfx.h"
+# ADD CPP /Yu"StdAfx.h"
+
+!ENDIF
+
+# End Source File
+# Begin Source File
+
+SOURCE=.\OptclBindPtr.cpp
+# End Source File
+# Begin Source File
+
+SOURCE=.\OptclObj.cpp
+
+!IF "$(CFG)" == "optcl - Win32 Release"
+
+# ADD CPP /Yu"stdafx.h"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
+
+# ADD CPP /Yu"StdAfx.h"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs"
+
+# ADD BASE CPP /Yu"stdafx.h"
+# ADD CPP /Yu"stdafx.h"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs"
+
+# ADD BASE CPP /Yu"StdAfx.h"
+# ADD CPP /Yu"StdAfx.h"
+
+!ENDIF
+
+# End Source File
+# Begin Source File
+
+SOURCE=.\OptclTypeAttr.cpp
+# End Source File
+# Begin Source File
+
+SOURCE=.\StdAfx.cpp
+# ADD CPP /Yc"StdAfx.h"
+# End Source File
+# Begin Source File
+
+SOURCE=.\typelib.cpp
+# ADD CPP /Yu"StdAfx.h"
+# End Source File
+# Begin Source File
+
+SOURCE=.\utility.cpp
+# ADD CPP /Yu"StdAfx.h"
+# End Source File
+# End Group
+# Begin Group "Header"
+
+# PROP Default_Filter "h"
+# Begin Source File
+
+SOURCE=.\Container.h
+# End Source File
+# Begin Source File
+
+SOURCE=.\DispParams.h
+# End Source File
+# Begin Source File
+
+SOURCE=.\EventBinding.h
+# End Source File
+# Begin Source File
+
+SOURCE=.\ObjMap.h
+# End Source File
+# Begin Source File
+
+SOURCE=.\optcl.h
+# End Source File
+# Begin Source File
+
+SOURCE=.\OptclBindPtr.h
+# End Source File
+# Begin Source File
+
+SOURCE=.\OptclObj.h
+# End Source File
+# Begin Source File
+
+SOURCE=.\OptclTypeAttr.h
+# End Source File
+# Begin Source File
+
+SOURCE=.\resource.h
+# End Source File
+# Begin Source File
+
+SOURCE=.\StdAfx.h
+# End Source File
+# Begin Source File
+
+SOURCE=.\tbase.h
+# End Source File
+# Begin Source File
+
+SOURCE=.\typelib.h
+# End Source File
+# Begin Source File
+
+SOURCE=.\utility.h
+# End Source File
+# End Group
+# Begin Group "Resource"
+
+# PROP Default_Filter ""
+# Begin Source File
+
+SOURCE=.\resource.rc
+# End Source File
+# Begin Source File
+
+SOURCE=.\typelib.tcl
+# End Source File
+# End Group
+# Begin Source File
+
+SOURCE=.\test.tcl
+
+!IF "$(CFG)" == "optcl - Win32 Release"
+
+# PROP Exclude_From_Build 1
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
+
+# PROP Exclude_From_Build 1
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs"
+
+# PROP BASE Exclude_From_Build 1
+# PROP Exclude_From_Build 1
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs"
+
+# PROP BASE Exclude_From_Build 1
+# PROP Exclude_From_Build 1
+
+!ENDIF
+
+# End Source File
+# End Target
+# End Project
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * optcl.cpp
+ * Declares the OpTcl's main entry points.
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+
+#ifndef _OPTCL_H_B229D2A0_616A_11d4_8004_0040055861F2
+#define _OPTCL_H_B229D2A0_616A_11d4_8004_0040055861F2
+
+
+
+// debugging symbols
+#ifdef _DEBUG
+#define _ATL_DEBUG_INTERFACES
+#define _ATL_DEBUG_REFCOUNT
+#define _ATL_DEBUG_QI
+#endif
+
+
+
+extern "C" DLLEXPORT int Optcl_Init (Tcl_Interp *pInterp);
+extern "C" DLLEXPORT BOOL WINAPI DllMain (HINSTANCE hinstDLL, DWORD fdwReason, LPVOID lpvReserved);
+int TypeLib_Init (Tcl_Interp *pInterp);
+
+
+extern CComPtr<IMalloc> g_pmalloc;
+
+#endif// _OPTCL_H_B229D2A0_616A_11d4_8004_0040055861F2
\ No newline at end of file
--- /dev/null
+//{{NO_DEPENDENCIES}}
+// Microsoft Developer Studio generated include file.
+// Used by resource.rc
+//
+#define IDR_TCL_SCRIPT1 101
+#define IDR_TYPELIB 101
+
+// Next default values for new objects
+//
+#ifdef APSTUDIO_INVOKED
+#ifndef APSTUDIO_READONLY_SYMBOLS
+#define _APS_NEXT_RESOURCE_VALUE 103
+#define _APS_NEXT_COMMAND_VALUE 40001
+#define _APS_NEXT_CONTROL_VALUE 1000
+#define _APS_NEXT_SYMED_VALUE 101
+#endif
+#endif
--- /dev/null
+//Microsoft Developer Studio generated resource script.
+//
+#include "resource.h"
+
+#define APSTUDIO_READONLY_SYMBOLS
+/////////////////////////////////////////////////////////////////////////////
+//
+// Generated from the TEXTINCLUDE 2 resource.
+//
+#include "afxres.h"
+
+/////////////////////////////////////////////////////////////////////////////
+#undef APSTUDIO_READONLY_SYMBOLS
+
+/////////////////////////////////////////////////////////////////////////////
+// English (U.K.) resources
+
+#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_ENG)
+#ifdef _WIN32
+LANGUAGE LANG_ENGLISH, SUBLANG_ENGLISH_UK
+#pragma code_page(1252)
+#endif //_WIN32
+
+/////////////////////////////////////////////////////////////////////////////
+//
+// TCL_SCRIPT
+//
+
+IDR_TYPELIB TCL_SCRIPT DISCARDABLE "typelib.tcl"
+
+#ifdef APSTUDIO_INVOKED
+/////////////////////////////////////////////////////////////////////////////
+//
+// TEXTINCLUDE
+//
+
+1 TEXTINCLUDE DISCARDABLE
+BEGIN
+ "resource.h\0"
+END
+
+2 TEXTINCLUDE DISCARDABLE
+BEGIN
+ "#include ""afxres.h""\r\n"
+ "\0"
+END
+
+3 TEXTINCLUDE DISCARDABLE
+BEGIN
+ "\r\n"
+ "\0"
+END
+
+#endif // APSTUDIO_INVOKED
+
+
+#ifndef _MAC
+/////////////////////////////////////////////////////////////////////////////
+//
+// Version
+//
+
+VS_VERSION_INFO VERSIONINFO
+ FILEVERSION 1,0,0,1
+ PRODUCTVERSION 1,0,0,1
+ FILEFLAGSMASK 0x3fL
+#ifdef _DEBUG
+ FILEFLAGS 0x29L
+#else
+ FILEFLAGS 0x28L
+#endif
+ FILEOS 0x40004L
+ FILETYPE 0x2L
+ FILESUBTYPE 0x0L
+BEGIN
+ BLOCK "StringFileInfo"
+ BEGIN
+ BLOCK "080904b0"
+ BEGIN
+ VALUE "Comments", "Requires Tcl/Tk major version 8, minor version >= 1\0"
+ VALUE "CompanyName", "University of East Anglia\0"
+ VALUE "FileDescription", "A Tcl extension for manipulating COM objects.\0"
+ VALUE "FileVersion", "3,0,0,2\0"
+ VALUE "InternalName", "optcl\0"
+ VALUE "LegalCopyright", "Copyright © 1999\0"
+ VALUE "LegalTrademarks", "-\0"
+ VALUE "OriginalFilename", "optcl.dll\0"
+ VALUE "PrivateBuild", "-\0"
+ VALUE "ProductName", "OpTcl\0"
+ VALUE "ProductVersion", "3,0,0,2\0"
+ VALUE "SpecialBuild", "-\0"
+ END
+ END
+ BLOCK "VarFileInfo"
+ BEGIN
+ VALUE "Translation", 0x809, 1200
+ END
+END
+
+#endif // !_MAC
+
+#endif // English (U.K.) resources
+/////////////////////////////////////////////////////////////////////////////
+
+
+
+#ifndef APSTUDIO_INVOKED
+/////////////////////////////////////////////////////////////////////////////
+//
+// Generated from the TEXTINCLUDE 3 resource.
+//
+
+
+/////////////////////////////////////////////////////////////////////////////
+#endif // not APSTUDIO_INVOKED
+
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * tbase.h
+ * C++ Wrapper classes for common Tcl types.
+ *
+ * Updated: 1999.03.08 - Removed a few bugs from TObjPtr
+ * Updated: 1999.07.11 - Added isnull and isnotnull to TObjPtr
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+
+
+#ifndef _3CC705E0_BA28_11d2_8003_0040055861F2_
+#define _3CC705E0_BA28_11d2_8003_0040055861F2_
+
+
+#include <tcl.h>
+#include <stdlib.h>
+#include <string.h>
+
+
+#ifndef ASSERT
+# ifdef _DEBUG
+# include <crtdbg.h>
+# define ASSERT(x) _ASSERTE(x)
+# else
+# define ASSERT(x)
+# endif
+#endif
+
+
+
+
+class TObjPtr
+{
+protected:
+ Tcl_Obj *m_po;
+ bool m_ba;
+public:
+ TObjPtr() : m_po(NULL), m_ba(true)
+ {
+ }
+
+ TObjPtr (int i, Tcl_Obj *const objs[], bool bauto = true) : m_po (NULL), m_ba(bauto)
+ {
+ ASSERT (i >= 0 && (i == 0 || objs!=NULL));
+ m_po = Tcl_NewListObj (i, objs);
+ if (m_ba)
+ incr();
+ }
+
+ TObjPtr(Tcl_Obj *ptr, bool bauto =true) : m_po(ptr), m_ba(bauto)
+ {
+ if (m_ba)
+ incr();
+ }
+
+ TObjPtr(const TObjPtr &src, bool bauto=false) : m_po(NULL), m_ba(bauto)
+ {
+ copy (src, bauto);
+ }
+
+ TObjPtr(const char *string, bool bauto=true) : m_po(NULL), m_ba(bauto)
+ {
+ m_po = Tcl_NewStringObj ((char*)string, -1);
+ if (m_po==NULL)
+ throw ("failed to create string object");
+ if (m_ba)
+ incr();
+ }
+
+ TObjPtr(const long l, bool bauto=true) : m_po(NULL), m_ba(bauto)
+ {
+ m_po = Tcl_NewLongObj (l);
+ if (m_po==NULL)
+ throw ("failed to create long tcl object");
+ if (m_ba)
+ incr();
+ }
+
+
+ TObjPtr(const int i, bool bauto=true) : m_po(NULL), m_ba(bauto)
+ {
+ m_po = Tcl_NewIntObj (i);
+ if (m_po==NULL)
+ throw ("failed to create int tcl object");
+ if (m_ba)
+ incr();
+ }
+
+ TObjPtr(const bool b, bool bauto=true) : m_po(NULL), m_ba(bauto)
+ {
+ m_po = Tcl_NewBooleanObj (b);
+ if (m_po==NULL)
+ throw ("failed to create long tcl object");
+ if (m_ba)
+ incr();
+ }
+
+ TObjPtr(const double d, bool bauto=true) : m_po(NULL), m_ba(bauto)
+ {
+ m_po = Tcl_NewDoubleObj (d);
+ if (m_po==NULL)
+ throw ("failed to create double object");
+ if (m_ba)
+ incr();
+ }
+
+
+ virtual ~TObjPtr()
+ {
+ if (m_ba!=NULL && m_po != NULL) {
+ if (m_po->refCount == 0)
+ incr();
+ decr();
+ }
+ m_po = NULL;
+ }
+
+ Tcl_Obj* create (bool bauto=true)
+ {
+ if (m_ba!=NULL && m_po != NULL) {
+ if (m_po->refCount == 0)
+ incr();
+ decr();
+ }
+ m_ba = bauto;
+ m_po = Tcl_NewObj ();
+ if (m_ba)
+ incr();
+ return m_po;
+ }
+
+
+ void incr()
+ {
+ if (m_po)
+ Tcl_IncrRefCount(m_po);
+ }
+
+ void decr()
+ {
+ if (m_po)
+ Tcl_DecrRefCount(m_po);
+ }
+
+ bool isnull ()
+ {
+ return (m_po == NULL);
+ }
+
+ bool isnotnull()
+ {
+ return (m_po != NULL);
+ }
+
+ void attach (Tcl_Obj *ptr, bool bauto=false)
+ {
+ if (m_ba)
+ decr();
+ m_po = ptr;
+ m_ba = bauto;
+ }
+
+ Tcl_Obj *detach ()
+ {
+ Tcl_Obj *p = m_po;
+ m_po = NULL;
+ return p;
+ }
+
+ void copy (const Tcl_Obj *src, bool bauto = true)
+ {
+ ASSERT (src!=NULL);
+ if (m_ba)
+ decr();
+
+ m_po = Tcl_DuplicateObj((Tcl_Obj*)src);
+ ASSERT (m_po);
+ m_ba = bauto;
+ if (m_ba)
+ incr();
+ }
+
+ int llength (Tcl_Interp *pInterp = NULL)
+ {
+ ASSERT (m_po!=NULL);
+ int length;
+ if (TCL_OK != Tcl_ListObjLength (pInterp, m_po, &length)) {
+ if (pInterp != NULL)
+ throw (Tcl_GetStringResult (pInterp));
+ else
+ throw ("failed to get length of list");
+ }
+ return length;
+ }
+
+
+ TObjPtr lindex (int index, Tcl_Interp *pInterp = NULL)
+ {
+ ASSERT (m_po);
+ Tcl_Obj *pObj = NULL;
+ if (TCL_OK != Tcl_ListObjIndex (pInterp, m_po, index, &pObj)) {
+ if (pInterp != NULL)
+ throw (Tcl_GetStringResult (pInterp));
+ else
+ throw ("failed to get list item");
+ }
+ return TObjPtr(pObj, false);
+ }
+
+
+ TObjPtr& lappend (TObjPtr &pObj, Tcl_Interp *pInterp = NULL)
+ {
+ return lappend ((Tcl_Obj*)pObj, pInterp);
+ }
+
+ TObjPtr& lappend (Tcl_Obj *pObj, Tcl_Interp *pInterp = NULL)
+ {
+ ASSERT (pObj!=NULL && m_po!=NULL);
+ if (TCL_OK != Tcl_ListObjAppendElement (pInterp, m_po, pObj)) {
+ if (pInterp != NULL)
+ throw (Tcl_GetStringResult (pInterp));
+ else
+ throw ("failed to add element to list");
+ }
+ return *this;
+ }
+
+ TObjPtr& lappend(const char *string, Tcl_Interp *pInterp = NULL)
+ {
+ ASSERT (string!=NULL && m_po != NULL);
+ return lappend (TObjPtr(string), pInterp);
+ }
+
+ TObjPtr& lappend(const int i, Tcl_Interp *pInterp = NULL)
+ {
+ ASSERT (m_po != NULL);
+ return lappend (TObjPtr(i), pInterp);
+ }
+
+ TObjPtr& lappend(const long l, Tcl_Interp *pInterp = NULL)
+ {
+ ASSERT (m_po != NULL);
+ return lappend (TObjPtr (l), pInterp);
+ }
+
+ TObjPtr& lappend(const double d, Tcl_Interp *pInterp = NULL)
+ {
+ ASSERT (m_po != NULL);
+ return lappend (TObjPtr (d), pInterp);
+ }
+
+ TObjPtr& lappend(const bool b, Tcl_Interp *pInterp = NULL)
+ {
+ ASSERT (m_po != NULL);
+ return lappend (TObjPtr (b), pInterp);
+ }
+
+
+ operator int()
+ {
+ ASSERT (m_po != NULL);
+ int n;
+ if (TCL_OK != Tcl_GetIntFromObj (NULL, m_po, &n))
+ // perform a cast
+ n = (int) double (*this);
+ return n;
+ }
+
+
+ operator long()
+ {
+ long n;
+ ASSERT (m_po != NULL);
+ if (TCL_OK != Tcl_GetLongFromObj (NULL, m_po, &n))
+ // perform a cast
+ n = (long) double (*this);
+ return n;
+ }
+
+
+ operator bool()
+ {
+ int b;
+ ASSERT (m_po != NULL);
+ if (TCL_OK != Tcl_GetBooleanFromObj (NULL, m_po, &b))
+ throw ("failed to convert object to bool");
+ return (b!=0);
+ }
+
+ operator double ()
+ {
+ double d;
+ ASSERT (m_po != NULL);
+ if (TCL_OK != Tcl_GetDoubleFromObj (NULL, m_po, &d))
+ throw ("failed to convert object to double");
+ return d;
+ }
+
+ operator char*() const
+ {
+ if (m_po == NULL) return NULL;
+ return Tcl_GetStringFromObj(m_po, NULL);
+ }
+
+ operator Tcl_Obj*() const
+ {
+ return m_po;
+ }
+
+
+ TObjPtr &operator= (Tcl_Obj *ptr)
+ {
+ attach(ptr, true); // automatically sets reference management
+ if (m_po != NULL)
+ incr();
+ return *this;
+ }
+
+ TObjPtr &operator= (const char *string)
+ {
+ ASSERT(string!=NULL && m_po != NULL);
+ Tcl_SetStringObj (m_po, (char*)string, -1);
+ return *this;
+ }
+
+ TObjPtr &operator= (const long l)
+ {
+ ASSERT (m_po != NULL);
+ Tcl_SetLongObj (m_po, l);
+ return *this;
+ }
+
+ TObjPtr &operator= (const int i)
+ {
+ ASSERT (m_po != NULL);
+ Tcl_SetIntObj (m_po, i);
+ return *this;
+ }
+
+ TObjPtr &operator= (const bool b)
+ {
+ ASSERT (m_po != NULL);
+ Tcl_SetBooleanObj (m_po, b?1:0);
+ return *this;
+ }
+
+ TObjPtr &operator= (const double d)
+ {
+ ASSERT (m_po != NULL);
+ Tcl_SetDoubleObj (m_po, d);
+ return *this;
+ }
+
+
+ bool operator== (Tcl_Obj *ptr)
+ {
+ return (ptr == m_po);
+ }
+
+
+ TObjPtr &operator+= (const char *string)
+ {
+ ASSERT (string && m_po);
+ Tcl_AppendToObj(m_po, (char*)string, -1);
+ return *this;
+ }
+
+ TObjPtr& operator+= (Tcl_Obj *pObj)
+ {
+ ASSERT (m_po != NULL);
+ return lappend (pObj);
+ }
+
+ TObjPtr &operator+= (TObjPtr &pObj)
+ {
+ ASSERT (m_po != NULL);
+ return lappend (pObj);
+ }
+
+ TObjPtr &operator+= (int i)
+ {
+ ASSERT (m_po != NULL);
+ (*this) = int(*this) + i;
+ return *this;
+ }
+
+ TObjPtr &operator+= (long l)
+ {
+ ASSERT (m_po != NULL);
+ (*this) = long(*this) + l;
+ return *this;
+ }
+
+
+ TObjPtr &operator+= (double d)
+ {
+ ASSERT (m_po != NULL);
+ (*this) = double(*this) + d;
+ return *this;
+ }
+
+ TObjPtr &operator-= (Tcl_Obj *pObj)
+ {
+ ASSERT (m_po != NULL && pObj != NULL);
+ Tcl_Obj ** objv;
+ int objc;
+ char *sObj = Tcl_GetStringFromObj (pObj, NULL),
+ *sTemp;
+
+ if (sObj == NULL)
+ return *this;
+
+ Tcl_ListObjGetElements (NULL, m_po, &objc, &objv);
+ for (int i = 0; i < objc; i++)
+ {
+ if (objv[i] != NULL) {
+ sTemp = Tcl_GetStringFromObj (objv[i], NULL);
+ if (sTemp != NULL && strcmp (sObj, sTemp) == 0)
+ Tcl_ListObjReplace ( NULL, m_po, i, 1, 0, NULL);
+ }
+ }
+ return *this;
+ }
+
+ TObjPtr &operator-= (TObjPtr &obj)
+ {
+ return operator-=((Tcl_Obj*)obj);
+ }
+
+ TObjPtr &operator-= (int i)
+ {
+ return operator=(int(*this) - i);
+ }
+
+ TObjPtr &operator-= (long l)
+ {
+ return operator=(long(*this) - l);
+ }
+
+ TObjPtr &operator-= (double d)
+ {
+ return operator=(double(*this) - d);
+ }
+
+ TObjPtr &operator *= (double d)
+ {
+ return operator=(double(*this) * d);
+ }
+
+ TObjPtr &operator *= (int i)
+ {
+ return operator=(int(*this) * i);
+ }
+
+ TObjPtr &operator *= (long l)
+ {
+ return operator=(long(*this) * l);
+ }
+
+
+ TObjPtr &operator /= (double d)
+ {
+ return operator=(double(*this) / d);
+ }
+
+ TObjPtr &operator /= (int i)
+ {
+ return operator=(int(*this) / i);
+ }
+
+ TObjPtr &operator /= (long l)
+ {
+ return operator=(long(*this) / l);
+ }
+
+ Tcl_Obj **operator &()
+ {
+ return &m_po;
+ }
+
+
+ Tcl_Obj *operator ->() const
+ {
+ return m_po;
+ }
+
+ bool operator!= (Tcl_Obj *p)
+ {
+ return (m_po != p);
+ }
+
+};
+
+
+
+
+
+
+
+template <class K, class V>
+class THashIterator
+{
+protected:
+ Tcl_HashTable *m_pt;
+ Tcl_HashEntry *m_pe;
+ Tcl_HashSearch m_s;
+
+public:
+ THashIterator () : m_pt(NULL),
+ m_pe(NULL)
+ {}
+
+ THashIterator (Tcl_HashTable *pTable) :
+ m_pt(pTable)
+ {
+ ASSERT (m_pt!=NULL);
+ m_pe = Tcl_FirstHashEntry (m_pt, &m_s);
+ }
+
+ THashIterator (THashIterator<K,V> &src)
+ {
+ *this = src;
+ }
+
+ virtual ~THashIterator ()
+ {}
+
+ V operator * ()
+ {
+ if (m_pe == NULL)
+ throw ("null hash iterator");
+ return (V)Tcl_GetHashValue (m_pe);
+ }
+
+ THashIterator &operator ++ ()
+ {
+ if (m_pe != NULL)
+ m_pe = Tcl_NextHashEntry (&m_s);
+ return *this;
+ }
+
+
+ THashIterator &operator ++ (int)
+ {
+ if (m_pe != NULL)
+ m_pe = Tcl_NextHashEntry (&m_s);
+ return *this;
+ }
+
+ operator Tcl_HashEntry* ()
+ {
+ return m_pe;
+ }
+
+ bool operator!= (Tcl_HashEntry *pEntry)
+ {
+ return m_pe != pEntry;
+ }
+
+ bool operator== (Tcl_HashEntry *pEntry)
+ {
+ return m_pe == pEntry;
+ }
+
+ K* key () {
+ ASSERT (m_pt != NULL);
+ if (m_pe == NULL)
+ throw ("null hash iterator");
+ return (K*)Tcl_GetHashKey (m_pt, m_pe);
+ }
+
+ THashIterator<K,V> &operator = (THashIterator<K,V> &i)
+ {
+ m_pt = i.m_pt;
+ m_pe = i.m_pe;
+ m_s = i.m_s;
+ return *this;
+ }
+};
+
+
+
+
+template <class K, class V, int Size=sizeof(K)/sizeof(int)>
+class THash
+{
+public:
+ typedef THashIterator<K,V> iterator;
+protected:
+ int m_keytype;
+ bool m_bCreated;
+ Tcl_HashTable m_tbl;
+public:
+ THash ():
+ m_keytype(Size),
+ m_bCreated(false)
+ {
+ }
+
+ ~THash ()
+ {
+ deltbl();
+ }
+
+
+
+ iterator begin ()
+ {
+ createtbl();
+ iterator i(&m_tbl);
+ return i;
+ }
+
+ iterator end ()
+ {
+ createtbl();
+ iterator i;
+ return i;
+ }
+
+
+ Tcl_HashEntry *find (const K *key, V *value = NULL)
+ {
+ Tcl_HashEntry *p = NULL;
+ createtbl();
+
+ p = Tcl_FindHashEntry (&m_tbl, (char*)key);
+ if (value != NULL && p!=NULL)
+ *value = (V)Tcl_GetHashValue (p);
+ return p;
+ }
+
+
+ bool delete_entry (const K *key)
+ {
+ Tcl_HashEntry *p = find (key);
+ if (p!=NULL)
+ Tcl_DeleteHashEntry (p);
+ return (p!=NULL);
+ }
+
+
+ Tcl_HashEntry * create_entry (const K *key, int *created = NULL)
+ {
+ ASSERT (key != NULL);
+ createtbl();
+
+ int c;
+ Tcl_HashEntry *p;
+
+ if (created == NULL)
+ p = Tcl_CreateHashEntry (&m_tbl, (char*)key, &c);
+ else
+ p = Tcl_CreateHashEntry (&m_tbl, (char*)key, created);
+ return p;
+ }
+
+ Tcl_HashEntry * set (const K *key, const V &value)
+ {
+ ASSERT (key != NULL);
+ createtbl();
+
+ Tcl_HashEntry *p = create_entry (key);
+ if (p!=NULL)
+ Tcl_SetHashValue (p, (ClientData)value);
+ return p;
+ }
+
+ K *key (const Tcl_HashEntry *p)
+ {
+ ASSERT (p!=NULL);
+ if (!m_bCreated) return NULL;
+ return (K*)Tcl_GetHashKey (&m_tbl, p);
+ }
+
+ operator Tcl_HashTable*()
+ {
+ return &m_tbl;
+ }
+
+ void deltbl ()
+ {
+ if (m_bCreated) {
+ Tcl_DeleteHashTable (&m_tbl);
+ m_bCreated = false;
+ }
+ }
+
+ void createtbl ()
+ {
+ if (!m_bCreated) {
+ Tcl_InitHashTable (&m_tbl, m_keytype);
+ m_bCreated = true;
+ }
+ }
+
+};
+
+
+
+class TDString {
+protected:
+ Tcl_DString ds;
+public:
+ TDString ()
+ {
+ Tcl_DStringInit(&ds);
+ }
+
+ TDString (const char *init)
+ {
+ Tcl_DStringInit(&ds);
+ append(init);
+ }
+
+ ~TDString ()
+ {
+ Tcl_DStringFree(&ds);
+ }
+
+ TDString& set (const char *string = "")
+ {
+ ASSERT (string != NULL);
+ Tcl_DStringFree (&ds);
+ Tcl_DStringInit(&ds);
+ append(string);
+ return *this;
+ }
+
+ char *append (const char *string, int length = -1)
+ {
+ ASSERT (string != NULL);
+ return Tcl_DStringAppend (&ds, (char*)string, length);
+ }
+
+ TDString& operator<< (const char *string)
+ {
+ ASSERT (string!=NULL);
+ append(string);
+ return *this;
+ }
+
+ TDString& operator<< (const long val)
+ {
+ TObjPtr p(val);
+ append((char*)p);
+ return *this;
+ }
+
+ TDString& operator<< (const int val)
+ {
+ TObjPtr p(val);
+ append((char*)p);
+ return *this;
+ }
+
+ TDString& operator<< (const double fval)
+ {
+ TObjPtr d(fval);
+ append((char*)d);
+ return *this;
+ }
+
+ operator const char*()
+ {
+ return value();
+ }
+
+ // type unsafe, as the string still belongs to this object
+ operator char*()
+ {
+ return (char*)(value());
+ }
+
+ TDString& operator= (TDString & src)
+ {
+ set (src.value());
+ return *this;
+ }
+
+ char *append_element(char *string)
+ {
+ ASSERT (string != NULL);
+ return Tcl_DStringAppendElement (&ds, (char*)string);
+ }
+
+ void start_sublist ()
+ {
+ Tcl_DStringStartSublist (&ds);
+ }
+
+ void end_sublist ()
+ {
+ Tcl_DStringEndSublist (&ds);
+ }
+
+ int length ()
+ {
+ return Tcl_DStringLength (&ds);
+ }
+
+ const char *value ()
+ {
+ return Tcl_DStringValue (&ds);
+ }
+
+ void set_result (Tcl_Interp *pInterp)
+ {
+ Tcl_DStringResult (pInterp, &ds);
+ }
+
+ void get_result (Tcl_Interp *pInterp)
+ {
+ Tcl_DStringGetResult (pInterp, &ds);
+ }
+};
+
+
+
+#endif // _3CC705E0_BA28_11d2_8003_0040055861F2_
--- /dev/null
+console show
+load optcl
+
+
+
+proc ie_test {} {
+ global ie
+ set ie [optcl::new -window .ie {{8856F961-340A-11D0-A96B-00C04FD705A2}}]
+ pack .ie
+ $ie navigate www.wired.com
+}
+
+proc vrml_test {} {
+ global vrml
+ set vrml [optcl::new -window .vrml {{4B6E3013-6E45-11D0-9309-0020AFE05CC8}}]
+ pack .vrml
+}
+
+proc tree_test {} {
+ global tv
+ set tv [optcl::new -window .tv {{C74190B6-8589-11D1-B16A-00C0F0283628}}]
+ pack .tv
+ set n1 [$tv -with nodes add]
+ $n1 : text "Node 1" key "1 Node"
+ optcl::unlock $n1
+ set n2 [$tv -with nodes add "1 Node" 4 "2 Node" "Node 2"]
+ $n2 : text "Node 2.5"
+ optcl::unlock $n2
+}
+
+proc dp_test {} {
+ global dp
+ destroy .date
+ set dp [optcl::new -window .date MSComCtl2.DTPicker]
+ .date config -width 100 -height 20
+ pack .date
+ tlview::viewtype [optcl::class $dp]
+}
+
+proc cal_test {} {
+ global cal
+ destroy .cal
+ set cal [optcl::new -window .cal MSCAL.Calendar]
+ pack .cal
+}
+
+
+proc pb_test {} {
+ global pb mousedown
+
+ proc PBMouseDown {obj args} {
+ global mousedown
+ set mousedown $obj
+ }
+
+ proc PBMouseUp {args} {
+ global mousedown
+ set mousedown {}
+ }
+
+ proc PBMouseMove {obj button shift x y} {
+ global mousedown
+ if {$mousedown == {}} return
+ if {[string compare $mousedown $obj]==0} {
+ $obj : value $x
+ }
+ }
+ destroy .pb
+ set pb [optcl::new -window .pb MSComctlLib.ProgCtrl]
+ pack .pb
+ .pb config -width 100 -height 10
+ optcl::bind $pb MouseDown PBMouseDown
+ optcl::bind $pb MouseUp PBMouseUp
+ optcl::bind $pb MouseMove PBMouseMove
+}
+
+
+
+
+proc word_test {} {
+ global word
+
+ set word [optcl::new word.application]
+ $word : visible 1
+}
+
+
+proc tl_test {} {
+ typelib::load {Microsoft Shell Controls And Automation (Ver 1.0)}
+ tlview::refview .r
+ tlview::loadedlibs .l
+}
+
+
+
+proc cosmo_test {} {
+ global co
+ set co [optcl::new -window .co SGI.CosmoPlayer.2]
+ pack .co
+}
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * typelib.cpp
+ * Implements access to typelibraries. Currently this only includes
+ * browsing facilities. In the future, this may contain typelib building
+ * functionality.
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+
+
+
+#include "stdafx.h"
+#include "tbase.h"
+#include "utility.h"
+#include "optcl.h"
+#include "typelib.h"
+#include "objmap.h"
+#include "optclbindptr.h"
+
+
+//----------------------------------------------------------------
+// \/\/\/\/\/\ Declarations /\/\/\/\/\/\/
+
+
+void TypeLib_Exit (ClientData);
+const char *TYPEKIND2Str (TYPEKIND tkind);
+void FUNCDESC2Obj (ITypeInfo *pti, FUNCDESC *pfd, TObjPtr &fdesc);
+void VARDESC2Obj (ITypeInfo *pti, VARDESC *pdesc, TObjPtr &presult);
+bool TYPEDESC2Obj (ITypeInfo *pti, TYPEDESC *pdesc, TObjPtr &pobj);
+
+void VariantToObj (VARIANT *pvar, TObjPtr &obj);
+
+inline void ReleaseTypeAttr (ITypeInfo *pti, TYPEATTR *&pta);
+
+void Guid2LibName (GUID &guid, TObjPtr &plibname);
+
+void TypeLib_GetImplTypes (ITypeInfo *pti, TObjPtr &inherited);
+void TypeLib_ProcessFunctions (ITypeInfo *pti, TObjPtr &methods, TObjPtr &properties);
+void TypeLib_ProcessVariables (ITypeInfo *pti, TObjPtr &properties);
+void TypeLib_GetVariable (ITypeInfo *pti, UINT index, TObjPtr &properties);
+
+HRESULT BindTypeInfo (ITypeComp *, const char *, ITypeInfo **);
+
+TCL_CMDEF(TypeLib_LoadedLibs);
+TCL_CMDEF(TypeLib_LoadLib);
+TCL_CMDEF(TypeLib_UnloadLib);
+TCL_CMDEF(TypeLib_IsLibLoaded);
+TCL_CMDEF(TypeLib_TypesInLib);
+TCL_CMDEF(TypeLib_TypeInfo);
+
+
+//// TEST CODE ////
+TCL_CMDEF(TypeLib_ResolveConstantTest);
+
+//----------------------------------------------------------------
+// \/\/\/\/\/\/ Globals \/\/\/\/\/\/\/
+
+// this class uses a Tcl hash table - this usually wouldn't be
+// safe, except that this hash table is initialised (courtsey of THash<>)
+// only on first uses (lazy). So it should be okay. Not sure how
+// this will behave in a multithreaded application
+
+TypeLibsTbl g_libs;
+
+//----------------------------------------------------------------
+// Implementation for TypeLibsTbl class
+
+TypeLibsTbl::TypeLibsTbl () : THash<char, TypeLib*> ()
+{
+
+}
+
+
+TypeLibsTbl::~TypeLibsTbl ()
+{
+ DeleteAll();
+}
+
+void TypeLibsTbl::DeleteAll ()
+{
+ for (iterator i = begin(); i != end(); i++)
+ {
+ ASSERT ((*i) != NULL);
+ delete (*i);
+ }
+ deltbl();
+}
+
+
+ITypeLib * TypeLibsTbl::LoadLib (Tcl_Interp *pInterp, const char *fullname)
+{
+ USES_CONVERSION;
+ CComPtr<ITypeLib> pLib;
+ CComPtr<ITypeComp> pComp;
+
+ TObjPtr cmd, // used to build up a command string
+ result, // attaches to the result of the above commands' execution
+ progname; // the programmatic name of the library
+ GUID guid;
+ int maj, min;
+ HRESULT hr;
+
+ Tcl_HashEntry *pEntry = NULL;
+ TypeLib *ptl;
+
+ if (m_loadedlibs.find(fullname, &pEntry) != NULL) {
+ ASSERT (pEntry != NULL);
+ ptl = (TypeLib *)Tcl_GetHashValue (pEntry);
+ ASSERT (ptl != NULL);
+ Tcl_SetResult (pInterp, Tcl_GetHashKey (&m_tbl, pEntry), TCL_VOLATILE);
+ pLib = ptl->m_ptl;
+ ASSERT (pLib != NULL);
+ return pLib;
+ }
+
+
+ try {
+ // get the guid, max and min version numbers
+ cmd.create();
+ cmd = "typelib::libdetail";
+ cmd.lappend (fullname);
+ if (Tcl_GlobalEvalObj (pInterp, cmd) == TCL_ERROR) return NULL;
+ result.attach(Tcl_GetObjResult(pInterp), false);
+ if (result.llength() != 3)
+ throw ("expected three elements in the library description");
+
+ maj = result.lindex (1);
+ min = result.lindex (2);
+ hr = CLSIDFromString (A2OLE(result.lindex(0)), &guid);
+ if (FAILED(hr))
+ throw ("failed to convert identifier");
+
+ // load the library
+ hr = LoadRegTypeLib (guid, maj, min, LOCALE_SYSTEM_DEFAULT, &pLib);
+ CHECKHR(hr);
+ if (pLib == NULL)
+ throw ("failed to bind to a type library");
+
+ // get the programmatic name of the library
+ TypeLib_GetName (pLib, NULL, progname);
+
+ hr = pLib->GetTypeComp(&pComp);
+ if (FAILED(hr))
+ throw ("failed to get the compiler interface for library");
+
+ Cache (progname, fullname, pLib, pComp);
+ Tcl_SetResult (pInterp, (char*)(const char*)progname, TCL_VOLATILE);
+ }
+
+ catch (char *error) {
+ Tcl_SetResult (pInterp, error, TCL_VOLATILE);
+ }
+ catch (HRESULT hr) {
+ Tcl_SetResult (pInterp, (char*)HRESULT2Str(hr), TCL_DYNAMIC);
+ }
+
+ return pLib;
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLibsTbl::Cache --
+ * Called in order to cache a library.
+ * Pre: The library does *not* exist in the cache
+ *
+ * Result:
+ * A standard OLE HRESULT
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+TypeLib* TypeLibsTbl::Cache (const char *szname, const char *szfullname, ITypeLib *ptl, ITypeComp *ptc)
+{
+ ASSERT(szname != NULL && szfullname != NULL);
+ ASSERT (ptl != NULL && ptc != NULL);
+ TypeLib *pLib = NULL;
+ Tcl_HashEntry *pEntry = NULL;
+
+ pLib = new TypeLib (ptl, ptc);
+ pEntry = set(szname, pLib);
+ ASSERT (pEntry != NULL);
+
+ m_loadedlibs.set (szfullname, pEntry);
+ return pLib;
+}
+
+
+bool TypeLibsTbl::IsLibLoaded (const char *fullname)
+{
+ ASSERT (fullname != NULL);
+ return (m_loadedlibs.find (fullname) != NULL);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLibsTbl::UnloadLib --
+ * Given the fullname of a library, the routine unloads it, if it is
+ * loaded.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void TypeLibsTbl::UnloadLib (Tcl_Interp *pInterp, const char *fullname)
+{
+ Tcl_HashEntry *pEntry = NULL;
+ TypeLib *ptl = NULL;
+
+ if (!m_loadedlibs.find (fullname, &pEntry))
+ return;
+
+ ASSERT (pEntry != NULL);
+ ptl = (TypeLib*)Tcl_GetHashValue (pEntry);
+ ASSERT (ptl != NULL);
+ delete ptl;
+ m_loadedlibs.delete_entry(fullname);
+ Tcl_DeleteHashEntry (pEntry);
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLibsTbl::EnsureCached --
+ * Given a typelibrary, the routine ensures that it is stored in the cache.
+ *
+ * Result:
+ * A pointer to the caches TypeLib object.
+ *
+ * Side effects:
+ * Throws HRESULT.
+ *-------------------------------------------------------------------------
+ */
+TypeLib *TypeLibsTbl::EnsureCached (ITypeLib *ptl)
+{
+ USES_CONVERSION;
+
+ ASSERT (ptl != NULL);
+ TDString verfullname;
+ TypeLib *pLib = NULL;
+ TLIBATTR *pattr = NULL;
+ HRESULT hr;
+ BSTR name = NULL,
+ fullname = NULL;
+ char *szname, *szfullname;
+ Tcl_HashEntry *pEntry = NULL;
+ CComPtr<ITypeComp> ptc;
+
+ // get the libraries different names
+ hr = ptl->GetDocumentation(-1, &name, &fullname, NULL, NULL);
+ CHECKHR(hr);
+ szname = W2A(name);
+ szfullname = W2A(fullname);
+ FreeBSTR(name);
+ FreeBSTR(fullname);
+ if (find(szname, &pLib))
+ return pLib; // cached already
+
+ // build the fullname+version string
+ hr = ptl->GetLibAttr(&pattr);
+ CHECKHR(hr);
+ verfullname.set (szfullname) << " (Ver " << short(pattr->wMajorVerNum) << "." <<
+ short(pattr->wMinorVerNum) << ")";
+ ptl->ReleaseTLibAttr (pattr); pattr = NULL;
+
+ // get the compiler interface
+ hr = ptl->GetTypeComp (&ptc);
+ CHECKHR(hr);
+ // now cache the lot
+ pLib = Cache (szname, verfullname, ptl, ptc);
+ return pLib;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLibsTbl::EnsureCached --
+ * Sames as EnsureChached(ITypeLib *), but uses a type info.
+ *
+ * Result:
+ * Non NULL iff successful - result points to the cached TypeLib structure.
+ *
+ * Side effects:
+ * Throws HRESULT.
+ *-------------------------------------------------------------------------
+ */
+TypeLib *TypeLibsTbl::EnsureCached (ITypeInfo *pInfo)
+{
+ ASSERT (pInfo != NULL);
+ CComPtr<ITypeLib> pLib;
+ UINT tmp;
+ HRESULT hr;
+ hr = pInfo->GetContainingTypeLib(&pLib, &tmp);
+ CHECKHR(hr);
+ return EnsureCached (pLib);
+}
+
+
+
+
+
+
+
+// ------------------- TypeLib initialisation and shutdown routines -------------------------
+int TypeLib_Init (Tcl_Interp *pInterp)
+{
+ OleInitialize(NULL);
+ Tcl_CreateExitHandler (TypeLib_Exit, NULL);
+ Tcl_CreateObjCommand (pInterp, "typelib::loaded", TypeLib_LoadedLibs, NULL, NULL);
+ Tcl_CreateObjCommand (pInterp, "typelib::load", TypeLib_LoadLib, NULL, NULL);
+ Tcl_CreateObjCommand (pInterp, "typelib::unload", TypeLib_UnloadLib, NULL, NULL);
+ Tcl_CreateObjCommand (pInterp, "typelib::types", TypeLib_TypesInLib, NULL, NULL);
+ Tcl_CreateObjCommand (pInterp, "typelib::typeinfo", TypeLib_TypeInfo, NULL, NULL);
+ Tcl_CreateObjCommand (pInterp, "typelib::isloaded", TypeLib_IsLibLoaded, NULL, NULL);
+
+ //// TESTS ////
+ Tcl_CreateObjCommand (pInterp, "typelib::resolveconst", TypeLib_ResolveConstantTest, NULL, NULL);
+
+ return TCL_OK;
+}
+
+
+
+void TypeLib_Exit (ClientData)
+{
+ g_libs.DeleteAll ();
+ OleUninitialize();
+}
+// ------------------------------------------------------------------------------------------
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ReleaseTypeAttr --
+ * Release at type attribute from the specified type info.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+inline void ReleaseTypeAttr (ITypeInfo *pti, TYPEATTR *&pta)
+{
+ ASSERT (pti != NULL);
+ if (pta != NULL) {
+ pti->ReleaseTypeAttr(pta);
+ pta = NULL;
+ }
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ReleaseBindPtr --
+ * Releases a bind ptr (if not null), according to its type description.
+ * Sets the value of the pointer to null.
+ *
+ * Result:
+ * None
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void ReleaseBindPtr (ITypeInfo *pti, DESCKIND dk, BINDPTR &ptr)
+{
+ if (ptr.lpfuncdesc != NULL) {
+ switch (dk) {
+ case DESCKIND_FUNCDESC:
+ ASSERT (pti != NULL);
+ pti->ReleaseFuncDesc (ptr.lpfuncdesc);
+ ptr.lpfuncdesc = NULL;
+ break;
+ case DESCKIND_IMPLICITAPPOBJ: // same as a vardesc
+ case DESCKIND_VARDESC:
+ ASSERT (pti != NULL);
+ pti->ReleaseVarDesc (ptr.lpvardesc);
+ ptr.lpvardesc = NULL;
+ break;
+ case DESCKIND_TYPECOMP:
+ ptr.lptcomp->Release();
+ ptr.lptcomp = NULL;
+ break;
+ }
+ }
+}
+
+
+
+const char *TYPEKIND2Str (TYPEKIND tkind)
+{
+ switch (tkind)
+ {
+ case TKIND_ENUM:
+ return "enum";
+ case TKIND_RECORD:
+ return "struct";
+ case TKIND_MODULE:
+ return "module";
+ case TKIND_INTERFACE:
+ return "interface";
+ case TKIND_DISPATCH:
+ return "dispatch";
+ case TKIND_COCLASS:
+ return "class";
+ case TKIND_ALIAS:
+ return "typedef";
+ case TKIND_UNION:
+ return "union";
+ default:
+ return "???";
+ }
+}
+
+
+
+
+
+
+const char *VARTYPE2Str (VARTYPE vt)
+{
+ vt = vt & ~VT_ARRAY & ~VT_BYREF;
+ switch (vt) {
+ case VT_EMPTY:
+ case VT_NULL:
+ return "_null_";
+ case VT_I1:
+ return "char";
+ case VT_UI1:
+ return "uchar";
+ case VT_I2:
+ return "short";
+ case VT_UI2:
+ return "ushort";
+ case VT_INT:
+ case VT_I4:
+ case VT_ERROR:
+ return "long";
+ case VT_UI4:
+ case VT_UINT:
+ return "ulong";
+ case VT_I8:
+ return "super_long";
+ case VT_UI8:
+ return "usuper_long";
+ case VT_R4:
+ return "float";
+ case VT_R8:
+ return "double";
+ case VT_CY:
+ return "currency";
+ case VT_DATE:
+ return "date";
+ case VT_BSTR:
+ return "string";
+ case VT_DISPATCH:
+ return "dispatch";
+ case VT_BOOL:
+ return "bool";
+ case VT_VARIANT:
+ return "any";
+ case VT_UNKNOWN:
+ return "interface";
+ case VT_DECIMAL:
+ return "decimal";
+ case VT_VOID:
+ return "void";
+ case VT_HRESULT:
+ return "scode";
+ case VT_LPSTR:
+ case VT_LPWSTR:
+ return "string";
+ case VT_CARRAY:
+ return "carray";
+ default:
+ return "???";
+ }
+}
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * TYPEDESC2Obj --
+ *
+ * Result:
+ *
+ * Side effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+bool TYPEDESC2Obj (ITypeInfo *pti, TYPEDESC *pdesc, TObjPtr &pobj)
+{
+ USES_CONVERSION;
+ ASSERT (pdesc != NULL && pti != NULL);
+ bool array = ((pdesc->vt & VT_ARRAY) != 0);
+ pdesc->vt = pdesc->vt & ~VT_ARRAY;
+ HRESULT hr;
+
+ if (pdesc->vt == VT_USERDEFINED) {
+ // resolve the referenced type
+ CComPtr<ITypeInfo> prefti;
+ TYPEATTR *pta = NULL;
+ WORD flags;
+ hr = pti->GetRefTypeInfo (pdesc->hreftype, &prefti);
+ CHECKHR(hr);
+ hr = prefti->GetTypeAttr (&pta);
+ CHECKHR(hr);
+ flags = pta->wTypeFlags;
+
+ ReleaseTypeAttr (prefti, pta);
+ if ((flags & TYPEFLAG_FRESTRICTED)) {
+ pobj.create();
+ pobj = "!!!"; // unaccessable type
+ return false;
+ }
+ g_libs.EnsureCached(prefti);
+ TypeLib_GetName (NULL, prefti, pobj);
+ } else if ((pdesc->vt == VT_SAFEARRAY) || (pdesc->vt == VT_PTR)) {
+ if (!TYPEDESC2Obj (pti, pdesc->lptdesc, pobj))
+ return false;
+ ASSERT (pobj.isnotnull());
+ if (pdesc->vt == VT_SAFEARRAY)
+ pobj += " []";
+ } else {
+ pobj.create();
+ pobj = VARTYPE2Str(pdesc->vt);
+ }
+
+ return true;
+}
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLib_GetName --
+ * Converts a library or type to a name stored in a Tcl_Obj. If pLib
+ * is not NULL and pInfo is, then the name is the name of the library.
+ * Otherwise, pInfo must be non-null (pLib can always be derived from pInfo)
+ * The result is stored in pname.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void TypeLib_GetName (ITypeLib *pLib, ITypeInfo *pInfo, TObjPtr &pname)
+{
+ ASSERT (pLib!=NULL || pInfo!=NULL);
+
+ USES_CONVERSION;
+ BSTR progname = NULL,
+ typname = NULL;
+ HRESULT hr;
+
+ UINT tmp;
+ bool bLibcreate = false;
+
+ // ensure we have a library to work with
+ if (pLib == NULL) {
+ hr = pInfo->GetContainingTypeLib(&pLib, &tmp);
+ CHECKHR(hr);
+ bLibcreate = true;
+ }
+ // get the library programmatic name
+ hr = pLib->GetDocumentation (-1, &progname, NULL, NULL, NULL);
+ CHECKHR(hr);
+
+ if (pInfo == NULL) {
+ pname.create();
+ pname = W2A(progname);
+ } else {
+ hr = pInfo->GetDocumentation(MEMBERID_NIL, &typname, NULL, NULL, NULL);
+ CHECKHR(hr);
+ TDString str;
+ str.set(W2A(progname)) << "." << W2A(typname);
+ pname.create();
+ pname = str;
+ }
+
+ FreeBSTR(progname);
+ FreeBSTR(typname);
+ if (bLibcreate)
+ pLib->Release();
+}
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * BindTypeInfo --
+ * Given a type compiling interface (ptc) and a typename (szTypeName),
+ * resolves to a ITypeInfo interface (stored in ppti).
+ *
+ * Result:
+ * Returns a standard OLE HRESULT.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+HRESULT BindTypeInfo (ITypeComp *ptc, const char *szTypeName, ITypeInfo **ppti)
+{
+ USES_CONVERSION;
+ LPOLESTR oleTypename = NULL;
+ UINT hash;
+ ASSERT (ptc != NULL && ppti != NULL);
+ CComPtr<ITypeComp> ptemp;
+ oleTypename = A2OLE(szTypeName);
+ hash = LHashValOfName(LOCALE_SYSTEM_DEFAULT, oleTypename);
+ return ptc->BindType (oleTypename, hash, ppti, &ptemp);
+}
+
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * FUNCDESC2Obj --
+ *
+ * Result:
+ *
+ * Side effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+void FUNCDESC2Obj (ITypeInfo *pti, FUNCDESC *pfd, TObjPtr &fdesc)
+{
+ ASSERT (pfd != NULL && pti != NULL);
+ ASSERT (!(pfd->wFuncFlags & FUNCFLAG_FRESTRICTED));
+ USES_CONVERSION;
+ BSTR * fnames = NULL;
+ char * szfname = NULL;
+ HRESULT hr;
+ UINT totalread = 0;
+ UINT total = 0;
+ TObjPtr type;
+ TObjPtr flags;
+ TObjPtr param;
+ TObjPtr optionparam;
+
+ fdesc.create();
+
+ try {
+ // get the names
+ total = pfd->cParams + 1;
+ fnames = new BSTR[total];
+ hr = pti->GetNames(pfd->memid, fnames, total, &totalread);
+ CHECKHR(hr);
+ if (totalread != total)
+ throw ("couldn't retrieve all the parameter names");
+
+
+
+ TYPEDESC2Obj(pti, &(pfd->elemdescFunc.tdesc), type);
+ fdesc.lappend (type); // return type
+ fdesc.lappend (W2A(fnames[0])); // the function name
+
+
+ // now build up the parameters
+ for (SHORT index = 0; index < pfd->cParams; index++)
+ {
+ ELEMDESC *pdesc = pfd->lprgelemdescParam + index;
+ flags.create();
+ if ((pdesc->paramdesc.wParamFlags & PARAMFLAG_FIN) ||
+ (pdesc->paramdesc.wParamFlags == PARAMFLAG_NONE))
+ flags.lappend("in");
+ if (pdesc->paramdesc.wParamFlags & PARAMFLAG_FOUT)
+ flags.lappend("out");
+ if (pdesc->paramdesc.wParamFlags & PARAMFLAG_FRETVAL)
+ flags.lappend("retval");
+
+ // type of parameter
+ TYPEDESC2Obj(pti, &(pdesc->tdesc), type);
+
+ // setup the result
+ param.create();
+ param.lappend(flags).lappend(type).lappend(W2A(fnames[index+1]));
+
+
+ // is it optional and does it have a default value
+ if ((pdesc->paramdesc.wParamFlags & PARAMFLAG_FHASDEFAULT)
+ && (pdesc->paramdesc.wParamFlags & PARAMFLAG_FOPT)) {
+ VariantToObj (&(pdesc->paramdesc.pparamdescex->varDefaultValue), optionparam);
+ param.lappend(optionparam);
+ }
+ else
+ if ((pfd->cParams - index)<=pfd->cParamsOpt)
+ param.lappend ("?");
+
+ fdesc.lappend(param);
+ }
+
+
+ FreeBSTRArray (fnames, totalread);
+ delete fnames;
+ }
+
+ catch (char *error) {
+ FreeBSTRArray (fnames, totalread);
+ delete fnames;
+ throw (error);
+ }
+
+ catch (HRESULT hr) {
+ FreeBSTRArray (fnames, totalread);
+ delete fnames;
+ throw (hr);
+ }
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * VARDESC2Obj --
+ *
+ * Result:
+ *
+ * Side effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+void VARDESC2Obj (ITypeInfo *pti, VARDESC *pdesc, TObjPtr &presult)
+{
+ ASSERT (pti != NULL && pdesc != NULL);
+
+ USES_CONVERSION;
+ HRESULT hr;
+ BSTR name = NULL;
+ char * szname = NULL;
+ TObjPtr tdesc; // stores the description of the type
+ TObjPtr tflags;// read write flags for this variable
+
+ hr = pti->GetDocumentation(pdesc->memid, &name, NULL, NULL, NULL);
+ CHECKHR(hr);
+ szname = W2A (name);
+ FreeBSTR (name);
+
+ TYPEDESC2Obj (pti, &(pdesc->elemdescVar.tdesc), tdesc);
+ tflags.create();
+ if (pdesc->wVarFlags & VARFLAG_FREADONLY)
+ tflags = "read";
+ else
+ tflags = "read write";
+
+ presult.create();
+ presult.lappend (tflags).lappend(tdesc).lappend(szname);
+ if (pdesc->varkind == VAR_CONST) { // its a constant
+ TObjPtr cnst;
+ VariantToObj (pdesc->lpvarValue, cnst);
+ presult.lappend (cnst);
+ }
+}
+
+
+void VariantToObj (VARIANT *pvar, TObjPtr &obj)
+{
+ ASSERT (pvar != NULL);
+
+ USES_CONVERSION;
+
+ VARTYPE vt = pvar->vt;
+ CComVariant var;
+ HRESULT hr;
+
+ vt = vt & ~VT_BYREF;
+ obj.create();
+
+ if (vt == VT_UNKNOWN || vt == VT_DISPATCH)
+ obj = "object";
+ else if ((vt & VT_ARRAY) == VT_ARRAY)
+ obj = "array";
+ else {
+ hr = var.Copy (pvar);
+ CHECKHR(hr);
+ var.ChangeType(VT_BSTR);
+ ASSERT (var.bstrVal != NULL);
+ obj = W2A (var.bstrVal);
+ }
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ImplFlags2Obj --
+ *
+ * Converts implementation flags to a tcl object.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * Uses TObjPtr functions, and hence throws (char *) in case of any errors.
+ *-------------------------------------------------------------------------
+ */
+void ImplFlags2Obj (UINT implflags, TObjPtr &flags)
+{
+ flags.create();
+ if (implflags & IMPLTYPEFLAG_FDEFAULT)
+ flags.lappend("default");
+ if (implflags & IMPLTYPEFLAG_FSOURCE)
+ flags.lappend("source");
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLib_DescOfRefType --
+ *
+ * Called to describe a referenced type from another type. If bclassinfo
+ * is true, the function prepends additional flags to describe the role of
+ * the referenced type to the class type.
+ *
+ * Result:
+ * return true iff successful.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+bool TypeLib_DescOfRefType (ITypeInfo *pti, UINT index, TObjPtr &desc, bool bclassinf)
+{
+ ASSERT (pti != NULL);
+
+ HRESULT hr;
+ TObjPtr name;
+ TObjPtr flags;
+ CComPtr <ITypeInfo> ptmp;
+ HREFTYPE href;
+ INT implflags;
+ TYPEATTR * pta = NULL;
+ WORD typeflags;
+
+ hr = pti->GetRefTypeOfImplType (index , &href);
+ CHECKHR(hr);
+
+ hr = pti->GetRefTypeInfo (href, &ptmp);
+ CHECKHR(hr);
+
+ g_libs.EnsureCached(ptmp);
+ hr = pti->GetImplTypeFlags(index, &implflags);
+ CHECKHR(hr);
+
+ hr = ptmp->GetTypeAttr (&pta);
+ CHECKHR(hr);
+ typeflags = pta->wTypeFlags;
+ ReleaseTypeAttr(pti, pta);
+
+ if ((typeflags & TYPEFLAG_FRESTRICTED) ||
+ (implflags & IMPLTYPEFLAG_FRESTRICTED))
+ return false;
+
+
+ TypeLib_GetName (NULL, ptmp, name);
+ if (bclassinf) {
+ ImplFlags2Obj (implflags, flags);
+ } else {
+ flags.create();
+ }
+
+ desc.create();
+ desc.lappend(flags).lappend(name);
+ return true;
+}
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLib_GetImplTypes --
+ * Compiles a list of inherited interfaces from a type information pointer.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * throws char * and HRESULT.
+ *-------------------------------------------------------------------------
+ */
+void TypeLib_GetImplTypes (ITypeInfo *pti, TObjPtr &inherited)
+{
+ ASSERT (pti!=NULL && inherited.isnotnull());
+
+ HRESULT hr;
+ TYPEATTR * pattr = NULL;
+ WORD count; // total number of references
+ TObjPtr desc;
+ TYPEKIND tkind;
+
+
+ hr = pti->GetTypeAttr (&pattr);
+ CHECKHR(hr);
+
+ count = pattr->cImplTypes;
+ tkind = pattr->typekind;
+ ReleaseTypeAttr (pti, pattr);
+
+ for (WORD index = 0; index < count; index++)
+ {
+ if (TypeLib_DescOfRefType (pti, index, desc, (tkind == TKIND_COCLASS)))
+ inherited.lappend(desc);
+ }
+}
+
+
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLib_GetVariable --
+ * Gets the description for a variable (VARDESC) property, based on an
+ * index.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * Throws HRESULT and char *.
+ *-------------------------------------------------------------------------
+ */
+void TypeLib_GetVariable (ITypeInfo *pti, UINT index, TObjPtr &properties)
+{
+ USES_CONVERSION;
+
+ ASSERT (pti != NULL && properties.isnotnull());
+ VARDESC * pDesc;
+ HRESULT hr;
+ BSTR name = NULL;
+ char * szName = NULL;
+
+ try {
+ hr = pti->GetVarDesc(index, &pDesc);
+ CHECKHR(hr);
+
+ ASSERT (pDesc != NULL);
+
+ if (!(pDesc->wVarFlags & VARFLAG_FHIDDEN)) // not a hidden variable
+ {
+ hr = pti->GetDocumentation(pDesc->memid, &name, NULL, NULL, NULL);
+ CHECKHR(hr);
+
+ szName = W2A(name);
+ FreeBSTR(name);
+ properties.lappend(szName);
+ }
+ pti->ReleaseVarDesc(pDesc);
+ }
+
+ catch (HRESULT hr) {
+ if (pDesc != NULL) {
+ pti->ReleaseVarDesc(pDesc);
+ pDesc = NULL;
+ }
+ throw (hr);
+ }
+
+ catch (char *error) {
+ if (pDesc != NULL) {
+ pti->ReleaseVarDesc(pDesc);
+ pDesc = NULL;
+ }
+ throw (error);
+ }
+}
+
+
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLib_ProcessVariables --
+ * Appends to a tcl list object, a the set of VARDESC defined properties.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * Uses functions that throw HRESULT and char *
+ *-------------------------------------------------------------------------
+ */
+void TypeLib_ProcessVariables (ITypeInfo *pti, TObjPtr &properties)
+{
+ ASSERT (pti != NULL && properties.isnotnull());
+ TYPEATTR *pattr = NULL;
+ HRESULT hr;
+ UINT count;
+
+ hr = pti->GetTypeAttr(&pattr);
+ CHECKHR(hr);
+ count = pattr->cVars;
+ ReleaseTypeAttr (pti, pattr);
+
+ for (UINT index = 0; index < count; index++) {
+ TypeLib_GetVariable (pti, index, properties);
+ }
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLib_ProcessFunctions --
+ * Scans the functions within the type and separates them into two lists:
+ * Methods functions, and property functions. Read/Write access to
+ * properties are not determined here.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * Can throw HRESULT and char *.
+ *-------------------------------------------------------------------------
+ */
+void TypeLib_ProcessFunctions (ITypeInfo *pti, TObjPtr &methods, TObjPtr &properties)
+{
+ USES_CONVERSION;
+ ASSERT (pti != NULL && properties.isnotnull() && methods.isnotnull());
+
+ HRESULT hr;
+ TYPEATTR * pattr = NULL;
+ WORD count;
+ FUNCDESC * pfd = NULL;
+ BSTR name;
+ char * szname;
+ THash<char, int> proptbl;
+
+ hr = pti->GetTypeAttr (&pattr);
+ CHECKHR(hr);
+
+ count = pattr->cFuncs;
+ ReleaseTypeAttr (pti, pattr);
+
+
+ try {
+ for (WORD index = 0; index < count; index++)
+ {
+ hr = pti->GetFuncDesc (index, &pfd);
+ CHECKHR(hr);
+ // if the function shouldn't be shown, skip this iteration
+ if ((pfd->wFuncFlags & FUNCFLAG_FRESTRICTED)) {
+ pti->ReleaseFuncDesc (pfd); pfd = NULL;
+ continue;
+ }
+
+ hr = pti->GetDocumentation(pfd->memid, &name, NULL, NULL, NULL);
+ CHECKHR(hr);
+
+ szname = W2A (name);
+ FreeBSTR (name);
+ if (pfd->invkind == INVOKE_FUNC) {
+ methods.lappend(szname);
+ } else {
+ proptbl.set(szname, 0);
+ }
+ pti->ReleaseFuncDesc (pfd); pfd = NULL;
+ }
+ // now process the properties
+ for (THash<char,int>::iterator e = proptbl.begin(); e != proptbl.end(); e++)
+ properties.lappend(e.key());
+ }
+
+ catch (char *error) {
+ if (pfd != NULL) {
+ pti->ReleaseFuncDesc (pfd); pfd = NULL;
+ }
+ throw (error);
+ }
+ catch (HRESULT hr) {
+ if (pfd != NULL) {
+ pti->ReleaseFuncDesc (pfd); pfd = NULL;
+ }
+ throw (hr);
+ }
+}
+
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLib_DescribeTypeInfo --
+ * Describe the type info in terms of the types kind, its methods,
+ * properties and inherited types.
+ *
+ * Result:
+ * Std Tcl return.
+ *
+ * Side effects:
+ * Can throw either HRESULT and char *. These probably can be removed
+ * and returned directly in the interpreter. I've left them to be
+ * picked up by the calling procedure, as that has its own exception
+ * handling code.
+ *-------------------------------------------------------------------------
+ */
+int TypeLib_DescribeTypeInfo (Tcl_Interp *pInterp, ITypeInfo *pti)
+{
+ int cmdresult = TCL_ERROR;
+ USES_CONVERSION;
+
+ ASSERT (pti != NULL && pInterp != NULL);
+ TYPEATTR *pta = NULL;
+ HRESULT hr;
+ TObjPtr presult,
+ inherited,
+ methods,
+ properties;
+ BSTR bdoc = NULL;
+
+ hr = pti->GetTypeAttr(&pta);
+ CHECKHR(hr);
+
+ try {
+ if (pta->typekind == TKIND_ALIAS) {
+ presult.create ();
+ presult.lappend("typedef").lappend("").lappend("");
+
+ //TypeLib_GetImplTypes (pti, inherited);
+ TYPEDESC2Obj (pti, &(pta->tdescAlias), inherited);
+ presult.lappend (inherited);
+ cmdresult = TCL_OK;
+ }
+
+ else {
+ inherited.create();
+ methods.create();
+ properties.create();
+ TypeLib_GetImplTypes (pti, inherited);
+ TypeLib_ProcessFunctions (pti, methods, properties);
+ TypeLib_ProcessVariables (pti, properties);
+
+ presult.create();
+ switch (pta->typekind)
+ {
+ case TKIND_ENUM:
+ presult = "enum"; break;
+ case TKIND_RECORD:
+ presult = "struct"; break;
+ case TKIND_MODULE:
+ presult = "module"; break;
+ case TKIND_INTERFACE:
+ presult = "interface"; break;
+ case TKIND_DISPATCH:
+ presult = "dispatch"; break;
+ case TKIND_COCLASS:
+ presult = "class"; break;
+ case TKIND_UNION:
+ presult = "union"; break;
+ default:
+ presult = "???"; break;
+ }
+
+ presult.lappend(methods).lappend(properties).lappend(inherited);
+ cmdresult = TCL_OK;
+ }
+ ReleaseTypeAttr (pti, pta);
+ }
+ catch (HRESULT hr) {
+ ReleaseTypeAttr (pti, pta);
+ throw (hr);
+ }
+ catch (char *error) {
+ ReleaseTypeAttr (pti, pta);
+ throw (error);
+ }
+
+ if (cmdresult == TCL_OK) {
+ if (SUCCEEDED(pti->GetDocumentation (MEMBERID_NIL, NULL, &bdoc, NULL, NULL)) && bdoc != NULL)
+ {
+ presult.lappend (OLE2A(bdoc));
+ SysFreeString (bdoc);
+ }
+ else
+ presult.lappend ("");
+
+ Tcl_SetObjResult (pInterp, presult);
+ }
+
+ return cmdresult;
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * DescPropertyFuncDesc --
+ * Helper function to provides a description in a tcl object,
+ * of a accessor based property. The property name, hash, typeinfo,
+ * compiler interface, funcdesc are already provided. The function evaluates
+ * the read/write priviliges, and type of the property, before building the
+ * resultant list.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * throws HRESULT or char*
+ *-------------------------------------------------------------------------
+ */
+void DescPropertyFuncDesc (BSTR name, ULONG hash, ITypeInfo *pti,
+ ITypeComp *pcmp, FUNCDESC *pfd, TObjPtr &pdesc)
+{
+ ASSERT (pti != NULL && pcmp != NULL);
+
+ USES_CONVERSION;
+
+ bool bRead = false,
+ bWrite = false;
+ BSTR * fnames = NULL;
+ char * szname = NULL;
+ OptclBindPtr obp;
+ HRESULT hr;
+
+ UINT totalread = 0;
+ UINT total = 0;
+ TObjPtr fdesc, param, type, optionparam, flags;
+
+ try {
+ // find out read/write access of this property
+ bWrite = (pfd->invkind==INVOKE_PROPERTYPUT ||
+ pfd->invkind==INVOKE_PROPERTYPUTREF);
+
+ // assertion: due to the order of computation,
+ // if bWrite is TRUE, then bRead will be false
+ bRead = !bWrite;
+
+ if (!bWrite) {
+ hr = pcmp->Bind (name, hash, INVOKE_PROPERTYPUT | INVOKE_PROPERTYPUTREF,
+ &obp.m_pti, &obp.m_dk, &obp.m_bp);
+ bWrite = SUCCEEDED(hr) && (obp.m_bp.lpfuncdesc->invkind==INVOKE_PROPERTYPUT ||
+ obp.m_bp.lpfuncdesc->invkind==INVOKE_PROPERTYPUTREF);
+ }
+
+ total = pfd->cParams + 1;
+ fnames = new BSTR[total];
+ hr = pti->GetNames(pfd->memid, fnames, total, &totalread);
+ CHECKHR(hr);
+ if (totalread != total)
+ throw ("couldn't retrieve all the parameter names");
+
+ pdesc.create();
+ flags.create();
+ if (bRead)
+ flags.lappend ("read");
+ if (bWrite)
+ flags.lappend ("write");
+ if (bRead) { // its a propertyget - use the return value of the function as the type
+ TYPEDESC2Obj (pti, &(pfd->elemdescFunc.tdesc), type);
+ } else { // its a propertyput only - use the first parameter
+ TYPEDESC2Obj (pti, &(pfd->lprgelemdescParam->tdesc), type);
+ }
+ pdesc.lappend(flags).lappend(type).lappend(W2A(fnames[0]));
+
+
+ // now build up the parameters
+ for (SHORT index = 0; index < pfd->cParams; index++)
+ {
+ ELEMDESC *elemdesc = pfd->lprgelemdescParam + index;
+
+ flags.create();
+ if (elemdesc->paramdesc.wParamFlags & PARAMFLAG_FIN)
+ flags.lappend("in");
+ if (elemdesc->paramdesc.wParamFlags & PARAMFLAG_FOUT)
+ flags.lappend("out");
+ if (elemdesc->paramdesc.wParamFlags & PARAMFLAG_FRETVAL)
+ flags.lappend("retval");
+
+ // type of parameter
+ TYPEDESC2Obj(pti, &(elemdesc->tdesc), type);
+
+ // setup the result
+ param.create();
+ param.lappend(flags).lappend(type).lappend(W2A(fnames[index+1]));
+
+ // is it optional and does it have a default value
+ if ((elemdesc->paramdesc.wParamFlags & PARAMFLAG_FHASDEFAULT)
+ && (elemdesc->paramdesc.wParamFlags & PARAMFLAG_FOPT)) {
+ VariantToObj (&(elemdesc->paramdesc.pparamdescex->varDefaultValue), optionparam);
+ param.lappend(optionparam);
+ }
+ else
+ if ((pfd->cParams - index)<=pfd->cParamsOpt)
+ param.lappend ("?");
+
+ pdesc.lappend(param);
+ }
+
+ FreeBSTRArray (fnames, totalread);
+ delete fnames;
+ }
+ catch (char *error) {
+ FreeBSTRArray (fnames, totalread);
+ delete fnames;
+ throw (error);
+ }
+
+ catch (HRESULT hr) {
+ FreeBSTRArray (fnames, totalread);
+ delete fnames;
+ throw (hr);
+ }
+}
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLib_DescribeTypeInfoElement --
+ * Called to describe an element of a type information pointer. Identifies
+ * it's role (currently only property or method), and retrieves a
+ * description.
+ *
+ * Result:
+ * Std Tcl result.
+ *
+ * Side effects:
+ * Throws HRESULT and char *.
+ *-------------------------------------------------------------------------
+ */
+int TypeLib_DescribeTypeInfoElement (Tcl_Interp *pInterp, ITypeInfo *pti,
+ const char *elem)
+{
+ ASSERT (pInterp != NULL && pti != NULL && elem != NULL);
+
+ USES_CONVERSION;
+
+ int cmdresult = TCL_ERROR;
+ HRESULT hr;
+ OptclBindPtr bp;
+ ULONG hash;
+ LPOLESTR name = A2OLE(elem);
+ CComPtr<ITypeComp> pcmp;
+ TObjPtr presult,
+ pdesc;
+ BSTR bdoc;
+
+ try {
+ hr = pti->GetTypeComp (&pcmp);
+ CHECKHR(hr);
+
+ hash = LHashValOfName (LOCALE_SYSTEM_DEFAULT, name);
+ hr = pcmp->Bind (name, hash, INVOKE_FUNC | INVOKE_PROPERTYGET, &bp.m_pti, &bp.m_dk, &bp.m_bp);
+ if (FAILED(hr) || (bp.m_dk == DESCKIND_NONE)) {
+ bp.ReleaseBindPtr();
+ hr = pcmp->Bind (name, hash, INVOKE_PROPERTYPUT | INVOKE_PROPERTYPUTREF, &bp.m_pti, &bp.m_dk, &bp.m_bp);
+ }
+
+ CHECKHR(hr);
+
+
+ cmdresult = TCL_OK;
+ switch (bp.m_dk) {
+ case DESCKIND_FUNCDESC:
+ // check access restrictions on the function
+ if (bp.m_bp.lpfuncdesc->wFuncFlags & FUNCFLAG_FRESTRICTED) {
+ Tcl_SetResult(pInterp, "you aren't allowed to view: '", TCL_STATIC);
+ Tcl_AppendResult (pInterp, (char*)elem, "'", NULL);
+ cmdresult = TCL_ERROR;
+ } else {
+ presult.create();
+ if (bp.m_bp.lpfuncdesc->invkind == INVOKE_FUNC) {// its a standard function
+ FUNCDESC2Obj (bp.m_pti, bp.m_bp.lpfuncdesc, pdesc);
+ presult.lappend ("method").lappend(pdesc);
+ }
+ else {// its an implicit variable with accessor function
+ DescPropertyFuncDesc(name, hash, bp.m_pti, pcmp, bp.m_bp.lpfuncdesc, pdesc);
+ presult.lappend ("property").lappend(pdesc);
+ }
+ }
+ break;
+
+ case DESCKIND_VARDESC:
+ if ((bp.m_bp.lpvardesc->wVarFlags & VARFLAG_FRESTRICTED)) {
+ Tcl_SetResult (pInterp, "you aren't allowed to view: '", TCL_STATIC);
+ Tcl_AppendResult (pInterp, (char*)elem, "'", NULL);
+ cmdresult = TCL_ERROR;
+ } else {
+ VARDESC2Obj (bp.m_pti, bp.m_bp.lpvardesc, pdesc);
+ presult.create();
+ presult.lappend ("property").lappend(pdesc);
+ }
+ break;
+
+ case DESCKIND_TYPECOMP: // don't know how to handle these ones at the moment
+ Tcl_SetResult (pInterp, "typecomp", TCL_STATIC);
+ break;
+
+ case DESCKIND_IMPLICITAPPOBJ: // don't know how to handle these ones at the moment
+ Tcl_SetResult (pInterp, "appobj", TCL_STATIC);
+ break;
+
+ case DESCKIND_NONE:
+ default:
+ Tcl_SetResult (pInterp, "can't find a description for '", TCL_STATIC);
+ Tcl_AppendResult (pInterp, (char*)elem, "'", NULL);
+ cmdresult = TCL_ERROR;
+ }
+ }
+ catch (HRESULT hr) {
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ cmdresult = TCL_ERROR;
+ }
+ catch (char *err) {
+ Tcl_SetResult (pInterp, err, TCL_VOLATILE);
+ cmdresult = TCL_ERROR;
+ }
+
+ // get the documentation string
+
+ if (cmdresult == TCL_OK && (bp.m_dk == DESCKIND_FUNCDESC || bp.m_dk == DESCKIND_VARDESC)) {
+ if (SUCCEEDED(
+ bp.m_pti->GetDocumentation (bp.m_dk==DESCKIND_FUNCDESC?bp.m_bp.lpfuncdesc->memid:bp.m_bp.lpvardesc->memid,
+ NULL, &bdoc, NULL, NULL)) && bdoc != NULL)
+ {
+ presult.lappend(OLE2A(bdoc));
+ SysFreeString (bdoc);
+ }
+ else
+ {
+ presult.lappend ("");
+ }
+ Tcl_SetObjResult (pInterp, presult);
+ }
+
+ return cmdresult;
+}
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLib_LoadedLibs --
+ * Lists the currently loaded libraries
+ * Result:
+ * TCL_OK iff ok.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+TCL_CMDEF(TypeLib_LoadedLibs)
+{
+ if (objc != 1) {
+ Tcl_WrongNumArgs (pInterp, 1, objv, "");
+ return TCL_ERROR;
+ }
+ TObjPtr presult;
+ presult.create(false);
+ try {
+ for (TypeLibsTbl::iterator i = g_libs.begin();i != g_libs.end(); i++)
+ presult.lappend(i.key(), pInterp);
+ }
+ catch (char *error) {
+ Tcl_SetResult (pInterp, error, TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult (pInterp, presult);
+ return TCL_OK;
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLib_LoadLib --
+ * Ensures that a given library is loaded. A library is described in terms
+ * of its full human-readable name.
+ *
+ * Result:
+ * TCL_OK iff successful.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+TCL_CMDEF(TypeLib_LoadLib)
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs (pInterp, 1, objv, "full_libname");
+ return TCL_ERROR;
+ }
+ TObjPtr libname;
+ libname.attach(objv[1], false);
+ if (g_libs.LoadLib (pInterp, libname) != NULL)
+ return TCL_OK;
+ else
+ return TCL_ERROR;
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLib_UnloadLib --
+ * Unloads a loaded library, specified in its human readable description.
+ * Perhaps this could be extended to take multiple arguments.
+ *
+ * Result:
+ * Always TCL_OK
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+TCL_CMDEF(TypeLib_UnloadLib)
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs (pInterp, 1, objv, "full_libname");
+ return TCL_ERROR;
+ }
+ TObjPtr libname;
+ libname.attach(objv[1], false);
+ g_libs.UnloadLib (pInterp, libname);
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLib_IsLibLoaded --
+ * Returns true in the interpreter if the library (specifed in the first
+ * parameter) is correct.
+ * Result:
+ * TCL_OK iff # of params ok
+ * Side effects:
+ * None
+ *-------------------------------------------------------------------------
+ */
+TCL_CMDEF(TypeLib_IsLibLoaded)
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs (pInterp, 1, objv, "fullname_library");
+ return TCL_ERROR;
+ }
+ TObjPtr name;
+ TObjPtr value;
+ value.create(false);
+ name.attach(objv[1]);
+ value = g_libs.IsLibLoaded(name);
+ Tcl_SetObjResult (pInterp, value);
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLib_TypesInLib --
+ * Returns a list in the interpreter holding the name and typekind of each
+ * type described in the library referenced by the first parameter to this
+ * command.
+ * Result:
+ * Std Tcl return results.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+TCL_CMDEF (TypeLib_TypesInLib)
+{
+ USES_CONVERSION;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (pInterp, 1, objv, "programmatic_libname");
+ return TCL_ERROR;
+ }
+
+
+ TypeLib *ptl = NULL;
+ TObjPtr name, typedesc, types, tname;
+ HRESULT hr;
+ TYPEKIND tkind;
+ CComPtr<ITypeInfo> pti;
+ int retresult = TCL_ERROR;
+ TYPEATTR *pta = NULL;
+ ULONG flags;
+
+
+
+ types.create();
+ name.attach(objv[1]);
+ if (!g_libs.find(name, &ptl)) {
+ Tcl_SetResult (pInterp, "can't find library name: ", TCL_STATIC);
+ Tcl_AppendResult (pInterp, (char*)name, NULL);
+ return TCL_ERROR;
+ }
+
+ ASSERT (ptl != NULL && ptl->m_ptl != NULL);
+ UINT count = ptl->m_ptl->GetTypeInfoCount();
+ try {
+ for (UINT index = 0; index < count; index++) {
+
+
+ // get the type of the typeinfo
+ hr = ptl->m_ptl->GetTypeInfoType (index, &tkind);
+ CHECKHR(hr);
+
+ // get the next typeifo
+ pti = NULL; // free the last typeinfo
+ hr = ptl->m_ptl->GetTypeInfo (index, &pti);
+ CHECKHR(hr);
+
+ ASSERT (pti != NULL);
+
+ // check whether this is a restricted type
+ hr = pti->GetTypeAttr (&pta);
+ CHECKHR(hr);
+ flags = pta->wTypeFlags;
+ ReleaseTypeAttr(pti, pta);
+
+ if (flags & TYPEFLAG_FRESTRICTED)
+ continue; // it is so skip the rest of this iteration
+ TypeLib_GetName(ptl->m_ptl, pti, tname);
+
+ typedesc.create();
+ typedesc.lappend (TYPEKIND2Str(tkind)).lappend(tname);
+ types.lappend (typedesc);
+ }
+ Tcl_SetObjResult (pInterp, types);
+ retresult = TCL_OK;
+ }
+
+ catch (char *error) {
+ Tcl_SetResult (pInterp, error, TCL_VOLATILE);
+ }
+ catch (HRESULT hr) {
+ Tcl_SetResult (pInterp, (char*)HRESULT2Str(hr), TCL_DYNAMIC);
+ }
+
+ return retresult;
+}
+
+
+
+
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLib_TypeInfo --
+ * Implements the typelib::typeinfo command.
+ *
+ * Result:
+ * Std Tcl result.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+TCL_CMDEF(TypeLib_TypeInfo)
+{
+ USES_CONVERSION;
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs (pInterp, 1, objv, "typename ?type_element_name?");
+ return TCL_ERROR;
+ }
+
+ TObjPtr tname;
+ TypeLib *ptl = NULL;
+ BSTR bsTypename = NULL;
+
+ CComPtr <ITypeInfo> pti;
+ CComPtr <ITypeComp> ptc;
+ int cmdresult = TCL_ERROR;
+
+ try {
+ tname.attach(objv[1]);
+ TypeLib_ResolveName (tname, &ptl, &pti);
+
+
+ if (objc == 2) { // describing the entire type
+ cmdresult = TypeLib_DescribeTypeInfo (pInterp, pti);
+ } else { // describing a single element within the type
+ TObjPtr item;
+ item.attach (objv[2]);
+ cmdresult = TypeLib_DescribeTypeInfoElement (pInterp, pti, item);
+ }
+ }
+
+ catch (char *error) {
+ if (error != NULL)
+ Tcl_SetResult (pInterp, error, TCL_VOLATILE);
+ }
+
+ catch (HRESULT hr) {
+ Tcl_SetResult (pInterp, (char*)HRESULT2Str(hr), TCL_DYNAMIC);
+ }
+
+ return cmdresult;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLib_ResolveName --
+ * Resolves a library name and type name to a typeinfo.
+ * if pptl is not NULL then the TypeLib structure for this type is provided
+ * as the result, also.
+ * May throw an HRESULT or char*.
+ *
+ * Result:
+ * None.
+ * Side effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+void TypeLib_ResolveName (const char * lib, const char * type,
+ TypeLib **pptl, ITypeInfo **ppinfo)
+{
+ ASSERT (lib != NULL && type != NULL && ppinfo != NULL);
+ HRESULT hr;
+
+ TypeLib * ptl = NULL;
+
+ // bind to the library
+ if (g_libs.find (lib, &ptl) == NULL)
+ throw ("failed to bind to library");
+
+ ASSERT (ptl != NULL && ptl->m_ptl != NULL);
+ if (ptl->m_ptc == NULL)
+ throw("library doesn't provide a compiling interface");
+ if (pptl != NULL)
+ *pptl = ptl;
+
+ // find the type info if required
+ if (ppinfo != NULL && type != NULL) {
+ hr = BindTypeInfo(ptl->m_ptc, type, ppinfo);
+ CHECKHR(hr);
+ if (*ppinfo == NULL)
+ throw ("failed to bind to type");
+ }
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLib_ResolveName --
+ * Resolves a fully formed type name (ie lib.type) to its type info.
+ * if pptl is not NULL then the TypeLib structure for this type is provided
+ * as the result, also.
+ * Throws HRESULT or (char*) in case of error. Apologies for this error style -
+ * I know that its predominant in this file - I was simply experimenting :)
+ *
+ * Result:
+ * None.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void TypeLib_ResolveName (const char *name, TypeLib **pptl, ITypeInfo **ppinfo)
+{
+ ASSERT (name != NULL);
+ char * lib = NULL,
+ * type = NULL;
+ char * copy = new char [strlen (name) + 1];
+ strcpy (copy, name);
+
+ try {
+ lib = strtok (copy, ".");
+ type = strtok (NULL, ".");
+ if (type == NULL && ppinfo != NULL)
+ throw ("string is not properly formatted");
+ TypeLib_ResolveName (lib, type, pptl, ppinfo);
+ delete_ptr (copy);
+ }
+
+ catch (HRESULT hr) {
+ delete_ptr (copy);
+ throw (hr);
+ }
+
+ catch (char * error) {
+ delete_ptr (copy);
+ throw (error);
+ }
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLib_ResolveConstant --
+ *
+ * Result:
+ *
+ * Side effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+bool TypeLib_ResolveConstant (Tcl_Interp *pInterp, ITypeInfo *pti,
+ const char *member, TObjPtr &pObj)
+{
+ ASSERT (pInterp != NULL && pti != NULL && member != NULL);
+
+ USES_CONVERSION;
+ CComPtr<ITypeComp> ptc;
+ CComPtr<ITypeInfo> ptmpti;
+ DESCKIND dk;
+ BINDPTR bp; bp.lpvardesc = NULL;
+ HRESULT hr;
+ LPOLESTR cnst = A2OLE (member);
+
+#ifdef _DEBUG
+ // *** TypeInfo must be an enumeration
+ TYPEATTR * pattr;
+ hr = pti->GetTypeAttr (&pattr);
+ CHECKHR(hr);
+ ASSERT (pattr->typekind == TKIND_ENUM);
+ pti->ReleaseTypeAttr (pattr);
+#endif
+
+
+ try {
+ hr = pti->GetTypeComp (&ptc);
+ CHECKHR(hr);
+
+ hr = ptc->Bind (cnst, LHashValOfName (LOCALE_SYSTEM_DEFAULT, cnst),
+ DISPATCH_PROPERTYGET, &ptmpti, &dk, &bp);
+ CHECKHR(hr);
+ if (dk == DESCKIND_NONE)
+ throw ("can't find constant");
+ ASSERT (dk == DESCKIND_VARDESC || dk == DESCKIND_IMPLICITAPPOBJ);
+
+ if (bp.lpvardesc->varkind != VAR_CONST)
+ throw ("member is not a constant");
+ ASSERT (bp.lpvardesc->lpvarValue != NULL);
+ if (bp.lpvardesc->lpvarValue == NULL)
+ throw ("constant didn't have a associated value!");
+ var2obj (pInterp, *(bp.lpvardesc->lpvarValue), pObj);
+ pti->ReleaseVarDesc (bp.lpvardesc);
+ return true;
+ }
+
+ catch (char *e) {
+ if (bp.lpvardesc != NULL)
+ pti->ReleaseVarDesc (bp.lpvardesc);
+
+ Tcl_SetResult (pInterp, (char*)member, TCL_VOLATILE);
+ Tcl_AppendResult (pInterp, ": ", e, NULL);
+ }
+
+ catch (HRESULT hr) {
+ if (bp.lpvardesc != NULL)
+ pti->ReleaseVarDesc (bp.lpvardesc);
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ }
+ return false;
+}
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * TypeLib_ResolveConstant --
+ * Attempts to resolve the name of a constant to its value, to be stored
+ * in pObj. An optional type info constrains the binding.
+ * Result:
+ * true iff successful. Else error in interpreter.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+bool TypeLib_ResolveConstant (Tcl_Interp *pInterp, char *szname,
+ TObjPtr &pObj, ITypeInfo *pTypeInfo /* = NULL */)
+{
+ ASSERT (pInterp != NULL && szname != NULL);
+
+ const char *token = ".";
+ char *name;
+ char *szfirst;
+ TypeLib * ptl;
+ CComPtr<ITypeInfo> pti;
+
+ try {
+ if (pTypeInfo == NULL)
+ {
+ // we'll use the stack for our allocation - saves on clean-up code
+ name = (char*)alloca (strlen(szname) + 1);
+ if (name == NULL) throw (HRESULT(E_OUTOFMEMORY));
+
+ strcpy (name, szname);
+ SplitTypedString (name, &szfirst);
+ if (szfirst == NULL)
+ throw ("badly formed constant");
+
+ // at this point, name points to the name of the type, and
+ // szfirst points to the name of the constant
+
+ // retrieve the typelibrary, info and compiler interfaces
+ TypeLib_ResolveName (name, &ptl, &pti);
+ return TypeLib_ResolveConstant (pInterp, pti, szfirst, pObj);
+ } else {
+ return TypeLib_ResolveConstant (pInterp, pTypeInfo, szname, pObj);
+ }
+
+
+ }
+
+ catch (char *e) {
+ Tcl_SetResult (pInterp, szname, TCL_VOLATILE);
+ Tcl_AppendResult (pInterp, ": ", e, NULL);
+ }
+
+ catch (HRESULT hr) {
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ }
+
+ return false;
+}
+
+
+
+///// TEST CODE /////
+
+
+TCL_CMDEF(TypeLib_ResolveConstantTest)
+{
+ if (objc != 2 && objc != 3)
+ {
+ Tcl_WrongNumArgs (pInterp, 1, objv, "lib.type.member or lib.type member");
+ return TCL_ERROR;
+ }
+
+ TObjPtr result;
+ TObjPtr p1;
+ TObjPtr p2;
+ bool bOk;
+
+ if (objc == 2) {
+ p1.attach(objv[1]);
+ bOk = TypeLib_ResolveConstant(pInterp, p1, result, NULL);
+ } else {
+ CComPtr<ITypeInfo> pti;
+ TypeLib * ptl;
+
+ p1.attach(objv[1]);
+ p2.attach(objv[2]);
+
+ TypeLib_ResolveName (p1, &ptl, &pti);
+ bOk = TypeLib_ResolveConstant (pInterp, p2, result, pti);
+ }
+ if (bOk) {
+ Tcl_SetObjResult (pInterp, result);
+ return TCL_OK;
+ } else
+ return TCL_ERROR;
+}
+
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * typelib.h
+ * Declares a collection of function for accessing typelibraries.
+ * Currently this only includes browsing facilities.
+ * In the future, this may contain typelib building functionality.
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+
+
+#ifndef _TYPELIB_H_62518A80_624A_11d4_8004_0040055861F2
+#define _TYPELIB_H_62518A80_624A_11d4_8004_0040055861F2
+
+#include "tbase.h"
+
+// TypeLib provides the structure that holds the main pointer to the library ITypeLib
+// interface, together with its compiler interface
+struct TypeLib {
+ CComPtr<ITypeLib> m_ptl;
+ CComPtr<ITypeComp> m_ptc;
+
+ TypeLib (ITypeLib *ptl, ITypeComp *ptc) {
+ m_ptl = ptl;
+ m_ptc = ptc;
+ }
+};
+
+
+
+// TypeLibsTbl - a hash table mapping library programmatic name to a TypeLib structure
+// Internally it also holds a mapping from the a libraries human readable name to
+// the same structure
+class TypeLibsTbl : public THash<char, TypeLib*>
+{
+public:
+ TypeLibsTbl ();
+ virtual ~TypeLibsTbl ();
+ void DeleteAll ();
+ ITypeLib* LoadLib (Tcl_Interp *pInterp, const char *fullname);
+ void UnloadLib (Tcl_Interp *pInterp, const char *fullname);
+ bool IsLibLoaded (const char *fullname);
+ TypeLib* EnsureCached (ITypeLib *pLib);
+ TypeLib* EnsureCached (ITypeInfo *pInfo);
+protected: // methods
+ TypeLib* Cache (const char *szname, const char *szfullname, ITypeLib *ptl, ITypeComp *ptc);
+
+protected: // properties
+ THash <char, Tcl_HashEntry*> m_loadedlibs; // by name
+};
+
+// globals
+extern TypeLibsTbl g_libs;
+
+
+void TypeLib_GetName (ITypeLib *, ITypeInfo *, TObjPtr &pname);
+void TypeLib_ResolveName (const char *name, TypeLib **pptl, ITypeInfo **ppinfo);
+void TypeLib_ResolveName (const char * lib, const char * type, TypeLib **pptl, ITypeInfo **ppinfo);
+void ReleaseBindPtr (ITypeInfo *pti, DESCKIND dk, BINDPTR &ptr);
+bool TypeLib_ResolveConstant (Tcl_Interp *pInterp, char *fullformatname,
+ TObjPtr &pObj, ITypeInfo *pInfo = NULL);
+bool TypeLib_ResolveConstant (Tcl_Interp *pInterp, ITypeInfo *pti,
+ const char *member, TObjPtr &pObj);
+
+
+#endif // _TYPELIB_H_62518A80_624A_11d4_8004_0040055861F2
\ No newline at end of file
--- /dev/null
+package require registry
+package provide optcl 3.0
+
+namespace eval typelib {
+ variable syslibs
+ variable syslibguids
+ array set syslibs {}
+ array set syslibguids {}
+
+
+ # -----------------------------------------------------------------------------
+
+ # updatelibs -- called to enumerate and store the system libraries
+ proc updatelibs {} {
+
+ variable syslibs;
+ catch {unset syslibs}
+ array set syslibs {}
+
+
+ set root {HKEY_CLASSES_ROOT\TypeLib}
+ foreach id [registry keys $root] {
+ catch {
+ foreach v [registry keys $root\\$id] {
+ scan $v "%d.%d" maj min;
+ if [catch {
+ set flags [registry get $root\\$id\\$v\\FLAGS {}];
+ }] { set flags 0;}
+
+ # check for restricted or hidden libraries
+ if {[expr ($flags & 1) || ($flags & 4)]} {
+ continue;
+ }
+
+ set name "[registry get $root\\$id\\$v {}] (Ver $maj.$min)"
+ set syslibs($name) [list $id $maj $min]
+ }
+ }
+ }
+ }
+
+ # -----------------------------------------------------------------------------
+
+ # categories -- returns the component categories
+ proc categories {} {
+
+ set alldata {}
+ set k "HKEY_CLASSES_ROOT\\Component Categories"
+ set cats [registry keys $k]
+
+ foreach cat $cats {
+ set values [registry values $k\\$cat]
+ set data {}
+ foreach value $values {
+ lappend data [registry get $k\\$cat $value]
+ }
+ lappend alldata $data
+ }
+
+ return $alldata
+ }
+
+
+
+
+ # -----------------------------------------------------------------------------
+
+ # libdetail -- returns a the id, maj and min version number
+ # in a list if it exists, else throws an error
+ proc libdetail {name} {
+ variable syslibs
+
+ if {[array names syslibs $name] == {}} {
+ error "could not find the library '$name'"
+ }
+
+ return [lindex [array get syslibs $name] 1]
+ }
+
+
+ #------------------------------------------------------------------------------
+
+ # alllibs -- returns all the registered libraries by name
+ proc alllibs {} {
+ variable syslibs
+ return [array names syslibs]
+ }
+
+ proc defaultinterface {classtype} {
+ set desc [typelib::typeinfo $classtype]
+ if {[llength $desc] != 3} {
+ error "$classtype is not a class"
+ }
+ set implintf [lindex $desc 2]
+ foreach intf $implintf {
+ if {[lsearch -exact [lindex $intf 0] default] >= 0} {
+ return [lindex $intf 1]
+ }
+ }
+ error "object doesn't have a default interface"
+ }
+
+ #------------------------------------------------------------------------------
+ updatelibs
+
+}
+
+
+
+
+
+if {[info commands tk] != {}} {
+ namespace eval tlview {
+ catch {font delete tlviewertext}
+ catch {font delete tlviewerhigh}
+ catch {font delete tlviewerbold}
+ font create tlviewertext -family Arial -size 9 -weight normal
+ font create tlviewerhigh -family Arial -size 9 -weight bold
+ font create tlviewerbold -family Arial -size 9 -weight bold
+
+ variable bgcolor white
+ variable textcolor black
+ variable highlightcolor blue
+ variable selectcolor red
+ variable labelcolor red
+
+ array set viewedtypes {}
+
+ #------------------------------------------------------------------------------
+ proc scrltxt {w {sb {x y}}} {
+ variable bgcolor;
+ frame $w -bd 2 -relief sunken;
+
+ text $w.t -bg $bgcolor -bd 0 -relief flat -cursor arrow -width 40 -height 20
+ grid $w.t -column 0 -row 0 -sticky nsew;
+
+ if {[lsearch $sb x] >= 0} {
+ scrollbar $w.x -orient horizontal -command [list $w.t xview]
+ $w.t config -xscrollcommand [list $w.x set] -wrap none
+ grid $w.x -column 0 -row 1 -sticky ew;
+ }
+ if {[lsearch $sb y] >= 0} {
+ scrollbar $w.y -orient vertical -command [list $w.t yview]
+ $w.t config -yscrollcommand [list $w.y set]
+ grid $w.y -column 1 -row 0 -sticky ns;
+ }
+
+ grid columnconfigure $w 0 -weight 1;
+ grid rowconfigure $w 0 -weight 1;
+ }
+
+
+ #------------------------------------------------------------------------------
+ proc cl_list {w} {
+ variable bgcolor
+ frame $w -bd 2 -relief sunken
+ canvas $w.c -yscrollcommand "$w.v set" -xscrollcommand "$w.h set" -bd 0 -relief flat -cursor arrow -bg $bgcolor -highlightthickness 0
+ scrollbar $w.h -orient horizontal -command "$w.c xview"
+ scrollbar $w.v -orient vertical -command "$w.c yview"
+
+ grid $w.c -column 0 -row 0 -sticky news
+ grid $w.h -column 0 -row 1 -sticky ew
+ grid $w.v -column 1 -row 0 -sticky ns
+ grid columnconfigure $w 0 -weight 1
+ grid rowconfigure $w 0 -weight 1
+ bind $w.c <1> { focus %W }
+ bind $w.c <Prior> { %W yview scroll -1 pages}
+ bind $w.c <Next> { %W yview scroll 1 pages}
+ return $w
+ }
+
+
+
+ proc cl_list_update {w} {
+ variable ::typelib::syslibs
+ variable bgcolor
+
+ if {![winfo exists $w]} {
+ error "expected to find a TypeLib list widget: $w"
+ }
+
+ set c $w.c
+ $c delete all
+
+ foreach tl [lsort [array names ::typelib::syslibs]] {
+ cl_list_addlib $w $tl
+ }
+ }
+
+
+
+ proc cl_list_addlib {w tl} {
+ variable bgcolor
+
+ set c $w.c
+ set bbox [$c bbox entry]
+ if {$bbox == {}} {set bbox {0 0 10 10}}
+ set bottom [lindex $bbox 3]
+ set bottom [expr int($bottom) + 3]
+ set tag [$c create text 10 $bottom -anchor nw -fill black -font tlviewertext -justify left -text $tl -tags entry]
+ $c bind $tag <1> [namespace code "cl_list_press $w $tag"]
+ cl_list_updatetag $w $tag
+
+ set bbox [$c bbox entry]
+ set sr [list 0 0 [lindex $bbox 2] [expr $bottom + 20]]
+ $c config -scrollregion $sr
+ }
+
+
+ proc cl_list_updatetag {w tag} {
+ variable textcolor
+ variable highlightcolor
+
+ set c $w.c
+ set tl [$c itemcget $tag -text]
+
+ if {![typelib::isloaded $tl]} {
+ $c itemconfig $tag -fill $textcolor -font tlviewertext
+ } else {
+ $c itemconfig $tag -fill $highlightcolor -font tlviewerhigh
+ }
+ }
+
+
+ proc cl_list_press {w tag} {
+ set c $w.c
+ set tl [$c itemcget $tag -text]
+ set parent [winfo parent $w]
+
+ if {![typelib::isloaded $tl]} {
+ # loading typelib
+ if {[catch {typelib::load $tl} progname]} {
+ puts $progname
+ $parent.error config -text [string trim $progname]
+ } else {
+ puts "loaded $progname"
+ $parent.error config -text "loaded $progname"
+ loadedlibs_updateall
+ }
+ } else {
+ typelib::unload $tl
+ puts "unloaded $tl"
+ $parent.error config -text "unloaded $tl"
+ loadedlibs_updateall
+ }
+
+ cl_list_updatetag $w $tag
+ }
+
+
+
+ proc refview {w} {
+ toplevel $w
+ wm title $w "Referenced Type Libraries"
+ bind $w <Alt-F4> "destroy $w"
+ bind $w <Alt-c> "$w.close invoke"
+ bind $w <Alt-r> "$w.refresh config -relief sunken; update; $w.refresh invoke; $w.refresh config -relief raised"
+ button $w.close -text Close -width 7 -command "destroy $w" -underline 0
+ button $w.refresh -text Refresh -width 7 -command [namespace code "cl_list_update $w.list"] -underline 0
+ label $w.error -bd 1 -relief sunken
+
+ grid [cl_list $w.list] -column 0 -row 0 -columnspan 2 -sticky nsew
+ grid $w.close -column 0 -row 1 -padx 5 -pady 5
+ grid $w.refresh -column 1 -row 1 -padx 5 -pady 5
+ grid $w.error -column 0 -row 2 -columnspan 2 -sticky nsew
+
+ grid columnconfig $w 0 -weight 1
+ grid columnconfig $w 1 -weight 1
+ grid rowconfig $w 0 -weight 1
+
+ cl_list_update $w.list
+ return $w
+ }
+
+
+
+ #------------------------------------------------------------------------------
+
+ proc loadedlibs_updateall {} {
+ foreach w [winfo child .] {
+ if {[string compare [winfo class $w] TLLoadedTypeLibs] == 0} {
+ loadedlibs_update $w
+ }
+ }
+ }
+
+ proc loadedlibs_update {w} {
+ variable bgcolor
+ variable textcolor
+ variable highlightcolor
+
+ $w.l.t config -state normal
+ $w.l.t delete 1.0 end
+ foreach lib [lsort [typelib::loaded]] {
+ $w.l.t tag configure tag$lib -foreground $highlightcolor -font tlviewertext -underline 0
+ $w.l.t insert end "$lib\n" tag$lib
+ $w.l.t tag bind tag$lib <1> [namespace code "viewlib $lib"]
+ $w.l.t tag bind tag$lib <Enter> "$w.l.t config -cursor hand2; $w.l.t tag config tag$lib -underline 1"
+ $w.l.t tag bind tag$lib <Leave> "$w.l.t config -cursor arrow; $w.l.t tag config tag$lib -underline 0"
+ }
+ $w.l.t config -state disabled
+ }
+
+ proc loadedlibs {w} {
+ toplevel $w -class TLLoadedTypeLibs
+
+ wm title $w "Loaded Libraries"
+ scrltxt $w.l
+
+ grid $w.l -column 0 -row 0 -sticky nsew
+ grid columnconfig $w 0 -weight 1
+ grid rowconfig $w 0 -weight 1
+ loadedlibs_update $w
+ bind $w <FocusIn> [namespace code "loadedlibs_update $w"]
+ }
+
+ #------------------------------------------------------------------------------
+ proc viewlib_onenter {txt tag} {
+ $txt config -cursor hand2
+ $txt tag config $tag -underline 1
+ }
+
+ proc viewlib_onleave {txt tag} {
+ $txt config -cursor arrow
+ $txt tag config $tag -underline 0
+ }
+
+ proc viewlib_unselect {txt lib} {
+ variable viewedtypes
+ variable textcolor
+ if {[array name viewedtypes $lib] != {}} {
+ set type $viewedtypes($lib)
+ $txt tag config tag$type -foreground $textcolor -font tlviewertext
+ set viewedtypes($lib) {}
+ }
+ }
+
+
+
+ proc viewlib_select {fulltype } {
+ variable viewedtypes
+ variable highlightcolor
+
+ puts $fulltype
+ set sp [split $fulltype .]
+ if {[llength $sp] != 2} {
+ return
+ }
+
+ set lib [lindex $sp 0]
+ set type [lindex $sp 1]
+
+ set w [viewlib $lib]
+ set txt $w.types.t
+
+ viewlib_unselect $txt $lib
+ $txt tag config tag$type -foreground $highlightcolor -font tlviewerhigh
+
+ $txt see [lindex [$txt tag ranges tag$type] 0]
+ set viewedtypes($lib) $type
+ viewlib_readelems $w $lib $type;
+ }
+
+
+ proc viewlib_selectelem {w fulltype element} {
+ variable viewedtypes
+ variable highlightcolor
+
+ puts "$fulltype $element"
+ set sp [split $fulltype .]
+ set lib [lindex $sp 0]
+ set type [lindex $sp 1]
+
+ set txt $w.elems.t
+
+ viewlib_unselect $txt $fulltype
+ $txt tag config tag$element -foreground $highlightcolor -font tlviewerhigh
+ $txt see [lindex [$txt tag ranges tag$element] 0]
+ set viewedtypes($fulltype) $element
+ viewlib_readdesc $w $lib $type $element
+ }
+
+ ###
+ # creates a list of types in some library
+ proc viewlib_readtypes {w lib} {
+ variable textcolor
+ set txt $w.types.t
+
+ $txt config -state normal
+ $txt del 1.0 end
+
+ foreach tdesc [lsort [typelib::types $lib]] {
+ $txt insert end "[lindex $tdesc 0]\t"
+ set full [lindex $tdesc 1]
+ set type [lindex [split $full .] 1]
+ $txt tag configure tag$type -foreground $textcolor -font tlviewertext -underline 0
+ $txt insert end "$type\n" tag$type
+ $txt tag bind tag$type <1> [namespace code "
+ viewlib_select $full;
+ "]
+
+ $txt tag bind tag$type <Enter> [namespace code "viewlib_onenter $txt tag$type"]
+ $txt tag bind tag$type <Leave> [namespace code "viewlib_onleave $txt tag$type"]
+ }
+ $txt config -state disabled
+ }
+
+
+ proc viewlib_writetype {txt fulltype} {
+ variable highlightcolor
+ if {[llength [split $fulltype .]] > 1} {
+ $txt tag configure tag$fulltype -foreground $highlightcolor -font tlviewertext -underline 0
+ $txt tag bind tag$fulltype <Enter> [namespace code "viewlib_onenter $txt tag$fulltype"]
+ $txt tag bind tag$fulltype <Leave> [namespace code "viewlib_onleave $txt tag$fulltype"]
+ $txt tag bind tag$fulltype <1> [namespace code "viewlib_select $fulltype"]
+ $txt insert end "$fulltype" tag$fulltype
+ } else {
+ $txt insert end "$fulltype"
+ }
+ }
+
+
+ ###
+ # displays the elements for a type of some library
+ proc viewlib_readelems {w lib type} {
+ variable labelcolor
+ variable textcolor
+ variable highlightcolor
+
+ set txt $w.elems.t
+ $txt config -state normal
+ $txt del 1.0 end
+ set elems [typelib::typeinfo $lib.$type]
+ loadedlibs_updateall
+
+ $txt tag configure label -font tlviewerhigh -underline 1 -foreground $labelcolor
+
+ if {[string compare "typedef" [lindex $elems 0]] == 0} {
+ # --- we are working with a typedef
+ set t [lindex $elems 3]
+ $txt insert end "Typedef\n\t" label
+ viewlib_writetype $txt $t
+ } else {
+ if {[llength [lindex $elems 1]] != 0} {
+ $txt insert end "Methods\n" label
+ }
+
+ foreach method [lsort [lindex $elems 1]] {
+ $txt tag configure tag$method -foreground $textcolor -font tlviewertext -underline 0
+ $txt tag bind tag$method <Enter> [namespace code "viewlib_onenter $txt tag$method"]
+ $txt tag bind tag$method <Leave> [namespace code "viewlib_onleave $txt tag$method"]
+ $txt tag bind tag$method <1> [namespace code "viewlib_selectelem $w $lib.$type $method"]
+ $txt insert end "\t$method\n" tag$method
+ }
+
+ if {[llength [lindex $elems 2]] != 0} {
+ $txt insert end "Properties\n" label
+ }
+
+ foreach prop [lsort [lindex $elems 2]] {
+ $txt tag configure tag$prop -foreground $textcolor -font tlviewertext -underline 0
+ $txt tag bind tag$prop <Enter> [namespace code "viewlib_onenter $txt tag$prop"]
+ $txt tag bind tag$prop <Leave> [namespace code "viewlib_onleave $txt tag$prop"]
+ $txt tag bind tag$prop <1> [namespace code "viewlib_selectelem $w $lib.$type $prop"]
+ $txt insert end "\t$prop\n" tag$prop
+ }
+
+ if {[llength [lindex $elems 3]] != 0} {
+ $txt insert end "Inherited Types\n" label
+ }
+
+ foreach impl [lsort -index 1 [lindex $elems 3]] {
+ # implemented interfaces
+ set t [lindex $impl 1]
+ set flags [lindex $impl 0]
+ if {[lsearch -exact $flags default] != -1} {
+ $txt insert end "*"
+ }
+
+ if {[lsearch -exac $flags source] != -1} {
+ $txt insert end "event"
+ }
+ $txt insert end "\t"
+
+ $txt tag configure itag$t -foreground $highlightcolor -font tlviewertext -underline 0
+ $txt tag bind itag$t <Enter> [namespace code "viewlib_onenter $txt itag$t"]
+ $txt tag bind itag$t <Leave> [namespace code "viewlib_onleave $txt itag$t"]
+ $txt tag bind itag$t <1> [namespace code "viewlib_select $t"]
+
+ $txt insert end "$t\n" itag$t
+ }
+ }
+ $txt config -state disabled
+ viewlib_settypedoc $w [lindex $elems 4]
+ }
+
+
+ proc viewlib_settypedoc {w doc} {
+ set txt $w.desc.t
+ $txt config -state normal
+ $txt delete 1.0 end
+ $txt insert end $doc
+ $txt config -state disabled
+ }
+
+
+ ###
+ # retrieves the description for an element
+ proc viewlib_readdesc {w lib type elem} {
+ variable labelcolor
+
+ set txt $w.desc.t
+ $txt config -state normal
+ $txt delete 1.0 end
+
+ $txt tag configure label -font tlviewerhigh -underline 1 -foreground $labelcolor
+ $txt tag configure element -font tlviewerbold
+ $txt tag bind element <Enter> [namespace code "viewlib_onenter $txt element"]
+ $txt tag bind element <Leave> [namespace code "viewlib_onleave $txt element"]
+
+ $txt tag bind element <1> [namespace code "viewlib_select $lib.$type; viewlib_selectelem $w $lib.$type $elem"]
+
+ set desc [typelib::typeinfo $lib.$type $elem]
+ set kind [lindex $desc 0]
+ switch $kind {
+ property {
+ $txt insert end "Property" label
+ $txt insert end "\t[lindex $desc 2]\n"
+
+ set p [lindex $desc 1]
+ # insert the flags
+ $txt insert end "[lindex $p 0]\t"
+ viewlib_writetype $txt [lindex $p 1]
+ $txt insert end " "
+ $txt insert end "[lindex $p 2]" element
+
+ set params [lrange $p 3 end]
+
+ foreach param $params {
+ $txt insert end "\n\t"
+
+ if {[llength $param] == 3} {
+ $txt insert end "[lindex $param 0]\t"
+ set param [lrange $param 1 end]
+ }
+ viewlib_writetype $txt [lindex $param 0]
+ $txt insert end " [lrange $param 1 end]"
+ }
+ }
+
+ method {
+ set m [lindex $desc 1]
+ $txt insert end "Method" label
+ $txt insert end "\t[lindex $desc 2]\n"
+ viewlib_writetype $txt [lindex $m 0]
+ $txt insert end " "
+ $txt insert end "[lindex $m 1]" element
+ set params [lrange $m 2 end]
+
+ foreach param $params {
+ $txt insert end "\n\t"
+
+ if {[llength $param] == 3} {
+ $txt insert end "[lindex $param 0]\t"
+ set param [lrange $param 1 end]
+ }
+ viewlib_writetype $txt [lindex $param 0]
+ $txt insert end " [lrange $param 1 end]"
+ }
+ }
+ }
+
+ puts [lindex $desc 1]
+ $txt config -state disabled
+ }
+
+
+ ####
+ # Creates a viewer for library
+ proc viewlib {lib} {
+ set w ._tlview$lib
+ if [winfo exists $w] {
+ raise $w
+ return $w
+ }
+ toplevel $w -class tlview_$lib
+ wm title $w "Type Library: $lib"
+
+ label $w.tl -text Types;
+ label $w.el -text Elements;
+ label $w.dl -text Description;
+
+ scrltxt $w.types;
+ scrltxt $w.elems
+ scrltxt $w.desc y
+ $w.desc.t config -height 5
+ $w.desc.t config -state disabled
+ $w.elems.t config -state disabled
+ $w.types.t config -state disabled
+
+ grid $w.tl -column 0 -row 0 -sticky nw
+ grid $w.types -column 0 -row 1 -sticky news -padx 2 -pady 2
+ grid $w.el -column 1 -row 0 -sticky nw
+ grid $w.elems -column 1 -row 1 -sticky news -padx 2 -pady 2
+ grid $w.dl -column 0 -row 2 -sticky nw
+ grid $w.desc -column 0 -row 3 -columnspan 2 -sticky news -padx 2 -pady 2
+
+ grid columnconfigure $w 0 -weight 1
+ grid columnconfigure $w 1 -weight 1
+ grid rowconfigure $w 1 -weight 1
+ #grid rowconfigure $w 3 -weight 1
+
+ viewlib_readtypes $w $lib
+ return $w
+ }
+
+
+ proc viewtype {fullname} {
+ viewlib_select $fullname
+ }
+ }
+}
\ No newline at end of file
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * utility.cpp
+ * Implements a collection of often used, general purpose functions.
+ * I've also placed the variant/Tcl_Obj conversion functions here.
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+
+
+#include "stdafx.h"
+#include "tbase.h"
+#include "utility.h"
+#include "optcl.h"
+#include "objmap.h"
+#include "typelib.h"
+#include "optclobj.h"
+#include "optcltypeattr.h"
+
+#ifdef _DEBUG
+/*
+ *-------------------------------------------------------------------------
+ * OptclTrace --
+ * Performs a debugging service similar to printf. Works only under debug.
+ * #defined to TRACE(formatstring, ....)
+ * Result:
+ * None.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void OptclTrace(LPCTSTR lpszFormat, ...)
+{
+ va_list args;
+ va_start(args, lpszFormat);
+
+ int nBuf;
+ TCHAR szBuffer[512];
+
+ nBuf = _vsntprintf(szBuffer, _countof(szBuffer), lpszFormat, args);
+
+ // was there an error? was the expanded string too long?
+ ASSERT(nBuf >= 0);
+
+ OutputDebugString (szBuffer);
+ va_end(args);
+}
+#endif //_DEBUG
+
+
+/*
+ *-------------------------------------------------------------------------
+ * HRESULT2Str --
+ * Converts an HRESULT to a Tcl allocated string.
+ *
+ * Result:
+ * The string if not null.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+char * HRESULT2Str (HRESULT hr)
+{
+
+ USES_CONVERSION;
+
+ LPTSTR szMessage;
+ char *message;
+ char *tclmessage;
+
+ if (HRESULT_FACILITY(hr) == FACILITY_WINDOWS)
+ hr = HRESULT_CODE(hr);
+
+ FormatMessage(
+ FORMAT_MESSAGE_ALLOCATE_BUFFER |
+ FORMAT_MESSAGE_FROM_SYSTEM,
+ NULL,
+ hr,
+ MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), //The user default language
+ (LPTSTR)&szMessage,
+ 0,
+ NULL );
+
+ // conversion to char * if unicode
+ message = T2A (szMessage);
+ tclmessage = Tcl_Alloc(strlen(message)+1);
+ strcpy(tclmessage, message);
+ for (char *i = tclmessage; *i != 0; i++)
+ if (*i == '\r') *i = ' ';
+ LocalFree(szMessage);
+ return tclmessage;
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * FreeBSTR --
+ * If not NULL, releases the BSTR and sets it to NULL.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void FreeBSTR (BSTR &bstr)
+{
+ if (bstr != NULL) {
+ SysFreeString (bstr);
+ bstr = NULL;
+ }
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * FreeBSTRArray --
+ * Releases an array of BSTR and sets them to NULL, if not already.
+ *
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void FreeBSTRArray (BSTR * bstr, UINT count)
+{
+ if (bstr == NULL) return;
+ for (UINT index = 0; index < count; index++)
+ {
+ FreeBSTR (bstr[index]);
+ }
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ExceptInfo2Str --
+ * Converts an EXCEPINFO structure to a Tcl allocated string.
+ *
+ * Result:
+ * The string if not null.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+char * ExceptInfo2Str (EXCEPINFO *pe)
+{
+ USES_CONVERSION;
+
+ ASSERT (pe != NULL);
+ char * str = NULL;
+ HRESULT hr;
+
+ char* stderror = "unknown error";
+
+ if (pe->bstrDescription == NULL) {
+ if (pe->pfnDeferredFillIn != NULL) {
+ hr = (pe->pfnDeferredFillIn)(pe);
+ if (FAILED (hr) || pe->bstrDescription==NULL)
+ return HRESULT2Str(hr);
+ }
+ else
+ {
+ str = Tcl_Alloc (strlen(stderror)+1);
+ strcpy (str, stderror);
+ return str;
+ }
+ }
+
+ TDString s;
+ s.set("error - ");
+
+ if (pe->bstrSource != NULL)
+ s << "source: \"" << W2A(pe->bstrSource) << "\" ";
+ s << "description: \"" << W2A(pe->bstrDescription) << "\"";
+ str = Tcl_Alloc(s.length () + 1);
+ strcpy (str, s);
+ return str;
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * Name2ID --
+ * Converts a name of a dispatch member to an id.
+ * Result:
+ * Either DISPID_UNKNOWN if failed or the dispid.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+DISPID Name2ID (IDispatch *pdisp, const char *name)
+{
+ USES_CONVERSION;
+ ASSERT (pdisp != NULL && name != NULL);
+ LPOLESTR olestr = A2OLE ((char*)name);
+ DISPID dispid = DISPID_UNKNOWN;
+
+ pdisp->GetIDsOfNames (IID_NULL, &olestr, 1, LOCALE_SYSTEM_DEFAULT, &dispid);
+ return dispid;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * Name2ID --
+ * Converts a name (OLE string) of a dispatch member to an id.
+ * Result:
+ * Either DISPID_UNKNOWN if failed or the dispid.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+DISPID Name2ID (IDispatch *pdisp, const LPOLESTR olename)
+{
+ DISPID dispid = DISPID_UNKNOWN;
+ pdisp->GetIDsOfNames (IID_NULL, (LPOLESTR*)&olename, 1, LOCALE_SYSTEM_DEFAULT, &dispid);
+ return dispid;
+}
+
+
+
+void OptclVariantClear (VARIANT *pvar)
+{
+ ASSERT (pvar != NULL);
+ if ((pvar->vt & VT_BYREF) || pvar->vt == VT_VARIANT) {
+ switch (pvar->vt & (~VT_BYREF)) {
+ case VT_VARIANT:
+ OptclVariantClear (pvar->pvarVal);
+ g_pmalloc->Free (pvar->pvarVal);
+ break;
+ case VT_ERROR:
+ case VT_I2:
+ case VT_UI1:
+ g_pmalloc->Free (pvar->piVal);
+ break;
+ // long
+ case VT_HRESULT:
+ case VT_I4:
+ case VT_UI2:
+ case VT_INT:
+ g_pmalloc->Free (pvar->plVal);
+ break;
+ // float
+ case VT_R4:
+ g_pmalloc->Free (pvar->pfltVal);
+ break;
+
+ // double
+ case VT_R8:
+ g_pmalloc->Free (pvar->pdblVal);
+ break;
+
+ // boolean
+ case VT_BOOL:
+ g_pmalloc->Free (pvar->pboolVal);
+ break;
+ // object
+ case VT_UNKNOWN:
+ case VT_DISPATCH:
+ if (pvar->ppunkVal != NULL) {
+ (*(pvar->ppunkVal))->Release();
+ g_pmalloc->Free (pvar->ppunkVal);
+ }
+ break;
+ case VT_CY:
+ g_pmalloc->Free (pvar->pcyVal);
+ break;
+ case VT_DATE:
+ g_pmalloc->Free (pvar->pdate);
+ break;
+ case VT_BSTR:
+ if (pvar->pbstrVal != NULL) {
+ SysFreeString (*(pvar->pbstrVal));
+ g_pmalloc->Free (pvar->pbstrVal);
+ }
+ break;
+ case VT_RECORD:
+ case VT_VECTOR:
+ case VT_ARRAY:
+ case VT_SAFEARRAY:
+ ASSERT (FALSE); // case not handled yet
+ break;
+
+ default:
+ ASSERT (FALSE); // unknown type
+ }
+ }
+ else
+ VariantClear (pvar);
+}
+
+
+
+
+bool var2obj_byref (Tcl_Interp *pInterp, VARIANT &var, TObjPtr &presult, OptclObj **ppObj)
+{
+ ASSERT (var.ppunkVal != NULL);
+
+ USES_CONVERSION;
+
+ bool bOk = false;
+ BSTR bstr = NULL;
+ HRESULT hr = S_OK;
+ OptclObj * pObj = NULL;
+
+
+ presult.create();
+ if (var.ppunkVal == NULL) {
+ presult = 0;
+ return true;
+ }
+ try {
+ switch (var.vt & ~VT_BYREF)
+ {
+ case VT_DISPATCH:
+ case VT_UNKNOWN:
+ if (*var.ppunkVal != NULL) {
+ pObj = g_objmap.Add (pInterp, *var.ppunkVal);
+ presult = (const char*)(*pObj); // cast to char*
+ if (ppObj != NULL)
+ *ppObj = pObj;
+ }
+ else
+ presult = 0;
+ break;
+ case VT_BOOL:
+ presult = (bool)(*var.pboolVal != 0);
+ break;
+
+ case VT_ERROR:
+ case VT_I2:
+ presult = *var.piVal;
+ break;
+
+ case VT_HRESULT:
+ case VT_I4:
+ case VT_UI2:
+ case VT_INT:
+ presult = *var.plVal;
+ break;
+ case VT_R4:
+ presult = (double)(*var.pfltVal);
+ break;
+ case VT_R8:
+ presult = (double)(*var.pdblVal);
+ break;
+ case VT_BSTR:
+ presult = OLE2A(*var.pbstrVal);
+ break;
+ case VT_CY:
+ hr = VarBstrFromCy (*var.pcyVal, LOCALE_SYSTEM_DEFAULT, NULL, &bstr);
+ CHECKHR_TCL(hr, pInterp, false);
+ break;
+ case VT_DATE:
+ hr = VarBstrFromDate (*var.pdblVal, LOCALE_SYSTEM_DEFAULT, NULL, &bstr);
+ CHECKHR_TCL(hr, pInterp, false);
+ break;
+ case VT_VARIANT:
+ if (var.pvarVal == NULL) {
+ Tcl_SetResult (pInterp, "pointer to null", TCL_STATIC);
+ bOk = false;
+ } else {
+ bOk = var2obj (pInterp, *var.pvarVal, presult, ppObj);
+ }
+ break;
+ default:
+ presult = "?unhandledtype?";
+ }
+ bOk = true;
+ if (bstr != NULL) {
+ presult = OLE2A(bstr);
+ SysFreeString (bstr); bstr = NULL;
+ }
+ }
+ catch (char *err) {
+ Tcl_SetResult (pInterp, err, TCL_VOLATILE);
+ }
+ return bOk;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * var2obj --
+ * Converts a variant to a Tcl_Obj without type information.
+ * Result:
+ * true iff successful, else interpreter holds error string.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+bool var2obj (Tcl_Interp *pInterp, VARIANT &var, TObjPtr &presult, OptclObj **ppObj /* = NULL*/)
+{
+ USES_CONVERSION;
+
+ ASSERT (pInterp != NULL);
+ ASSERT (ppObj == NULL || *ppObj == NULL);
+
+
+ OptclObj * pObj = NULL;
+ _variant_t comvar;
+ HRESULT hr = S_OK;
+ _bstr_t name;
+ bool bOk = false;
+
+
+ if ((var.vt & VT_ARRAY) || (var.vt & VT_VECTOR)) {
+ Tcl_SetResult (pInterp, "can't handle arrays or vectors for now", TCL_STATIC);
+ return false;
+ }
+
+ if (var.vt == VT_VARIANT) {
+ ASSERT (var.pvarVal != NULL);
+ return var2obj (pInterp, *(var.pvarVal), presult, ppObj);
+ }
+
+ if (var.vt & VT_BYREF)
+ return var2obj_byref (pInterp, var, presult, ppObj);
+
+ presult.create();
+
+ try {
+ switch (var.vt)
+ {
+ case VT_DISPATCH:
+ case VT_UNKNOWN:
+ if (var.punkVal != NULL) {
+ pObj = g_objmap.Add (pInterp, var.punkVal);
+ presult = (const char*)(*pObj); // cast to char*
+ if (ppObj != NULL)
+ *ppObj = pObj;
+ }
+ else
+ presult = 0;
+ break;
+ case VT_BOOL:
+ presult = (bool)(var.boolVal != 0);
+ break;
+ case VT_I2:
+ presult = var.iVal;
+ break;
+ case VT_I4:
+ presult = var.lVal;
+ break;
+ case VT_R4:
+ presult = (double)(var.fltVal);
+ break;
+ case VT_R8:
+ presult = (double)(var.dblVal);
+ break;
+ default: // standard string conversion required
+ comvar = var;
+ name = comvar;
+ presult = (char*)name;
+ }
+ bOk = true;
+ }
+
+ catch (HRESULT hr) {
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ }
+ catch (_com_error ce) {
+ Tcl_SetResult (pInterp, T2A((TCHAR*)ce.ErrorMessage()), TCL_VOLATILE);
+ }
+ catch (char *err) {
+ Tcl_SetResult (pInterp, err, TCL_VOLATILE);
+ }
+
+ return bOk;
+}
+
+
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * obj2var_ti --
+ * converts a Tcl_Obj to a variant using type information.
+ *
+ * Result:
+ * true iff successful, else interpreter holds error string.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+// nb - pInfo is the context for pdesc
+bool obj2var_ti (Tcl_Interp *pInterp, TObjPtr &obj, VARIANT &var,
+ ITypeInfo *pInfo, TYPEDESC *pdesc)
+{
+ ASSERT ((pInfo == NULL && pdesc == NULL) || (pInfo != NULL && pdesc != NULL));
+ ASSERT (pInterp != NULL);
+
+ OptclTypeAttr ota;
+ CComPtr<ITypeInfo> pcurrent;
+ CComPtr<IUnknown> ptmpunk;
+ HRESULT hr;
+ TObjPtr ptmp;
+ bool bOk = false;
+ OptclObj * pOptclObj = NULL;
+ long lValue;
+
+ // if no type description has been provided, do a simple conversion
+ if (pdesc == NULL) {
+ obj2var (obj, var);
+ bOk = true;
+ }
+
+ // a simple type
+ else if (pdesc->vt != VT_USERDEFINED && pdesc->vt != VT_SAFEARRAY) {
+ if (pdesc->vt != VT_PTR)
+ return obj2var_vt (pInterp, obj, var, pdesc->vt);
+ else {
+ ASSERT (pdesc->lptdesc->vt != VT_PTR &&
+ pdesc->lptdesc->vt != VT_USERDEFINED &&
+ pdesc->lptdesc->vt != VT_SAFEARRAY);
+
+ if (pdesc->lptdesc->vt == VT_PTR ||
+ pdesc->lptdesc->vt == VT_USERDEFINED ||
+ pdesc->lptdesc->vt == VT_SAFEARRAY)
+ {
+ Tcl_SetResult (pInterp, "can't convert - optcl doesn't support level of de-referencing", TCL_STATIC);
+ return false;
+ }
+ return obj2var_vt_byref (pInterp, obj, var, pdesc->lptdesc->vt);
+ }
+ }
+
+ // arrays - should be easy to do - not enough time right now...
+ else if (pdesc->vt == VT_SAFEARRAY) {
+ // wont do arrays for now.
+ Tcl_SetResult (pInterp, "optcl doesn't currently handle array types", TCL_STATIC);
+ }
+
+ else {
+ // type information provided and it refers to a user defined type
+ // resolve the initial type
+
+ hr = pInfo->GetRefTypeInfo (pdesc->hreftype, &ota.m_pti);
+ CHECKHR(hr);
+ g_libs.EnsureCached (ota.m_pti);
+ hr = ota.GetTypeAttr();
+ CHECKHR(hr);
+ ASSERT (ota.m_pattr != NULL);
+ pcurrent = pInfo;
+
+ while (ota->typekind == TKIND_ALIAS &&
+ ota->tdescAlias.vt == VT_USERDEFINED)
+ {
+ HREFTYPE href = ota->tdescAlias.hreftype;
+ pcurrent = ota.m_pti;
+ ota = NULL; // release the type attribute and type info
+ pcurrent->GetRefTypeInfo (href, &ota.m_pti);
+ hr = ota.GetTypeAttr();
+ CHECKHR(hr);
+ }
+
+ // we've now climbed back up the alias chain and have one of the following:
+ // enum, record, module, interface, dispatch, coclass, union or alias to a basic type
+ // The following we can't (currently) do anything useful with: record, union, module.
+
+ if (ota.m_pattr->typekind == TKIND_ALIAS)
+ return obj2var_ti (pInterp, obj, var, pcurrent, &(ota->tdescAlias));
+
+
+ TYPEKIND tk = ota->typekind; // the metaclass
+ GUID intfguid = ota->guid;
+
+
+ switch (tk)
+ {
+ case TKIND_ENUM:
+ if (bOk = (Tcl_GetLongFromObj (NULL, obj, &lValue) == TCL_OK))
+ obj2var(obj, var);
+ else if (bOk = TypeLib_ResolveConstant (pInterp, obj, ptmp, ota.m_pti))
+ obj2var (ptmp, var);
+ break;
+
+ case TKIND_DISPATCH:
+ case TKIND_INTERFACE:
+ // both these case require an object with the correct interface
+ pOptclObj = g_objmap.Find (obj);
+ if (pOptclObj != NULL) {
+ ptmpunk = (IUnknown*)(*pOptclObj);
+ ASSERT (ptmpunk != NULL);
+ hr = ptmpunk->QueryInterface (intfguid, (void**)&(var.punkVal));
+ CHECKHR(hr);
+ V_VT(&var) = VT_UNKNOWN;
+ bOk = true;
+ } else
+ ObjectNotFound (pInterp, obj);
+ break;
+
+ case TKIND_COCLASS:
+ pOptclObj = g_objmap.Find (obj);
+ if (pOptclObj != NULL) {
+ var.punkVal = (IUnknown*)(*pOptclObj);
+ var.punkVal->AddRef();
+ V_VT(&var) = VT_UNKNOWN;
+ bOk = true;
+ } else
+ ObjectNotFound (pInterp, obj);
+ break;
+
+ case TKIND_ALIAS:
+ ASSERT (FALSE); // should be hanlded above.
+ break;
+
+ // can't handle these types
+ case TKIND_MODULE:
+ case TKIND_RECORD:
+ case TKIND_UNION:
+ obj2var (obj, var);
+ bOk = true;
+ break;
+
+ default:
+ break;
+ }
+ }
+
+ return bOk;
+}
+
+
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * obj2var --
+ * Converts a Tcl object to a variant without type information.
+ * If the Tcl object is null, then sets the value to zero.
+ * Result:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void obj2var (TObjPtr &obj, VARIANT &var)
+{
+ _variant_t v;
+ ASSERT (var.vt == VT_EMPTY);
+ try {
+ if (obj.isnull()) {
+ var.lVal = 0;
+ var.vt = VT_I4;
+ } else {
+
+ if (Tcl_GetLongFromObj (NULL, obj, &V_I4(&var)) == TCL_OK)
+ V_VT(&var) = VT_I4;
+
+ else if (Tcl_GetDoubleFromObj (NULL, obj, &V_R8(&var)) == TCL_OK)
+ V_VT(&var) = VT_R8;
+
+ else {
+ v.Attach (var);
+ v = (char*)(obj);
+ var = v.Detach();
+ }
+
+ #if _DEBUG
+ if (obj->typePtr != NULL) {
+ TRACE ("%s\n", obj->typePtr->name);
+ }
+ #endif // _DEBUG
+ }
+ }
+
+ catch (_com_error ce) {
+ throw (HRESULT(ce.Error()));
+ }
+}
+
+
+static char memerr[] = "out of memory";
+
+#define CHECKMEM_TCL(x, interp, action) if ((x) == NULL) { \
+ Tcl_SetResult (interp, memerr, TCL_STATIC); \
+ action; \
+}
+
+bool obj2var_vt_byref (Tcl_Interp *pInterp, TObjPtr &obj, VARIANT &var, VARTYPE vt)
+{
+ USES_CONVERSION;
+
+ ASSERT ((vt & VT_BYREF) == 0); // we know that this is a BYREF variant - we don't want it in the vt
+ OptclObj * pOptclObj = NULL;
+ bool bok = true;
+ IUnknown * pUnk= NULL;
+ VARIANT temp;
+
+
+ if (vt == VT_VARIANT) {
+ var.pvarVal = (VARIANT*)g_pmalloc->Alloc (sizeof(VARIANT));
+ CHECKMEM_TCL(var.pvarVal, pInterp, return false);
+ VariantInit (var.pvarVal);
+ if (!obj2var_vt (pInterp, obj, *var.pvarVal, vt)) {
+ g_pmalloc->Free(var.pvarVal);
+ var.pvarVal = NULL;
+ return false;
+ }
+ var.vt = vt | VT_BYREF;
+ return true;
+ }
+
+
+ VariantInit(&temp);
+ // perform the conversion into a temporary variant
+ if (!obj2var_vt (pInterp, obj, temp, vt))
+ return false;
+
+
+ switch (temp.vt) {
+ // short
+ case VT_ERROR:
+ case VT_I2:
+ case VT_UI1:
+ var.piVal = (short*)g_pmalloc->Alloc (sizeof(short));
+ CHECKMEM_TCL(var.pvarVal, pInterp, bok = false);
+ if (bok) *var.piVal = temp.iVal;
+ break;
+
+ // long
+ case VT_HRESULT:
+ case VT_I4:
+ case VT_UI2:
+ case VT_INT:
+ var.plVal = (long*)g_pmalloc->Alloc (sizeof(long));
+ CHECKMEM_TCL(var.plVal, pInterp, bok = false);
+ if (bok) *var.plVal = temp.lVal;
+ break;
+
+ // float
+ case VT_R4:
+ var.pfltVal = (float*)g_pmalloc->Alloc(sizeof(float));
+ CHECKMEM_TCL(var.pfltVal, pInterp, bok = false);
+ if (bok) *var.pfltVal = temp.fltVal;
+ break;
+
+ // double
+ case VT_R8:
+ var.pdblVal = (double*)g_pmalloc->Alloc(sizeof(double));
+ CHECKMEM_TCL(var.pdblVal, pInterp, bok = false);
+ if (bok) *var.pdblVal = temp.dblVal;
+ break;
+
+ // boolean
+ case VT_BOOL:
+ var.pboolVal = (VARIANT_BOOL*)g_pmalloc->Alloc(sizeof(VARIANT_BOOL));
+ CHECKMEM_TCL(var.pboolVal, pInterp, bok = false);
+ if (bok) *var.pboolVal = temp.boolVal;
+ break;
+
+ // object
+ case VT_UNKNOWN:
+ case VT_DISPATCH:
+ // now allocate the memory
+ var.ppunkVal = (LPUNKNOWN*)g_pmalloc->Alloc(sizeof (LPUNKNOWN));
+ CHECKMEM_TCL(var.ppunkVal, pInterp, bok = false);
+ if (bok) {
+ *var.ppunkVal = temp.punkVal;
+ if (*var.ppunkVal != NULL)
+ (*var.ppunkVal)->AddRef();
+ }
+ break;
+
+ case VT_CY:
+ var.pcyVal = (CY*)g_pmalloc->Alloc(sizeof(CY));
+ CHECKMEM_TCL(var.pcyVal, pInterp, bok = false);
+ if (bok) *var.pcyVal = temp.cyVal;
+ break;
+ case VT_DATE:
+ var.pdate = (DATE*)g_pmalloc->Alloc(sizeof(DATE));
+ CHECKMEM_TCL(var.pdate, pInterp, bok = false);
+ if (bok) *var.pdate = temp.date;
+ break;
+ case VT_BSTR:
+ var.pbstrVal = (BSTR*)g_pmalloc->Alloc(sizeof(BSTR));
+ CHECKMEM_TCL(var.pdate, pInterp, bok = false);
+ if (bok) {
+ *var.pbstrVal = SysAllocStringLen (temp.bstrVal, SysStringLen(temp.bstrVal));
+ if (*var.pbstrVal == NULL) {
+ g_pmalloc->Free (var.pbstrVal); var.pbstrVal = NULL;
+ Tcl_SetResult (pInterp, memerr, TCL_STATIC);
+ bok = false;
+ }
+ }
+
+ break;
+ case VT_RECORD:
+ case VT_VECTOR:
+ case VT_ARRAY:
+ case VT_SAFEARRAY:
+ ASSERT (FALSE); // case not handled yet
+ break;
+
+ default:
+ ASSERT (FALSE); // should never get here.
+ }
+
+ var.vt = temp.vt | VT_BYREF;
+ VariantClear(&temp);
+ return bok;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * obj2var_vt --
+ * Converts a Tcl object to a variant of a certain type.
+ * Result:
+ * None.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+bool obj2var_vt (Tcl_Interp *pInterp, TObjPtr &obj, VARIANT &var, VARTYPE vt)
+{
+ ASSERT ((vt & VT_BYREF) == 0); // house rules: no by-reference variants here!
+
+ OptclObj *pOptclObj = NULL;
+ IUnknown * ptmpunk = NULL;
+ bool bOk = true;
+ HRESULT hr;
+
+ switch (vt)
+ {
+ case VT_DISPATCH:
+ case VT_UNKNOWN:
+ V_VT(&var) = vt;
+ if (obj.isnull())
+ var.punkVal = NULL;
+ else {
+ // attempt to cast from an optcl object
+ pOptclObj = g_objmap.Find (obj);
+
+
+ if (pOptclObj != NULL) { // found it?
+ ptmpunk = (IUnknown*)(*pOptclObj); // pull out the IUnknown pointer
+ ASSERT (ptmpunk != NULL);
+ if (vt == VT_DISPATCH) { // query to IDispatch iff required
+ hr = ptmpunk->QueryInterface (IID_IDispatch, (VOID**)&ptmpunk);
+ CHECKHR_TCL(hr, pInterp, false);
+ }
+ else
+ ptmpunk->AddRef(); // if not IDispatch, make sure we incr the refcount
+ var.punkVal = ptmpunk;
+ }
+ else {
+ ObjectNotFound (pInterp, obj);
+ bOk = false;
+ }
+ }
+ break;
+ default:
+ obj2var (obj, var);
+ if (vt != VT_VARIANT) {
+ HRESULT hr = VariantChangeType (&var, &var, NULL, vt);
+ if (FAILED (hr)) {
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ bOk = false;
+ }
+ }
+ break;
+ }
+ return bOk;
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ObjectNotFound --
+ * Standard error message when an optcl object is not found.
+ * Result:
+ * TCL_ERROR always.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+int ObjectNotFound (Tcl_Interp *pInterp, const char *name)
+{
+ Tcl_SetResult (pInterp, "could not find object '", TCL_STATIC);
+ Tcl_AppendResult (pInterp, (char*)name, "'", NULL);
+ return TCL_ERROR;
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * SplitTypedString --
+ * If pstr is of the format "a.b.c" then it is modified such that
+ * pstr == "a.b" and *ppsecond = "c"
+ * Otherwise, pstr will point to the original string and *ppsecond will
+ * be NULL.
+ * Result:
+ * None.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void SplitTypedString (char *pstr, char ** ppsecond)
+{
+ const char * token = ".";
+ ASSERT (pstr != NULL && ppsecond != NULL);
+
+ char *p = pstr;
+ while (*p != '.' && *p != '\0') p++;
+ if (*p == '\0') {
+ *ppsecond = NULL;
+ return;
+ }
+
+ pstr = strtok (pstr, token);
+ pstr[strlen(pstr)] = '.';
+
+ for (short i = 0; i < 2; i++)
+ {
+ *ppsecond = strtok (NULL, token);
+ if (*ppsecond == NULL)
+ break;
+ }
+}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * SplitObject --
+ * Splits a string held within a Tcl object (pObj) into its constituent
+ * objects (ppResult), using a collection tokens.
+ *
+ * Result:
+ * true iff successful. Else, error string in interpreter.
+ * Side effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+bool SplitObject (Tcl_Interp *pInterp, Tcl_Obj *pObj,
+ const char * tokens, Tcl_Obj **ppResult)
+{
+ ASSERT (pInterp != NULL && pObj != NULL && tokens != NULL && ppResult != NULL);
+ TObjPtr cmd;
+ cmd.create();
+ cmd = "split";
+ cmd.lappend (pObj);
+ cmd.lappend(tokens);
+ if (Tcl_EvalObj (pInterp, cmd) == TCL_ERROR)
+ return false;
+ *ppResult = Tcl_GetObjResult (pInterp);
+ Tcl_IncrRefCount (*ppResult);
+ return true;
+}
+
+
+bool SplitBrackets (Tcl_Interp *pInterp, Tcl_Obj *pObj,
+ TObjPtr & result)
+{
+ ASSERT (pInterp != NULL && pObj != NULL);
+ TObjPtr pcmd ("regexp -nocase {^([^\\(\\)])+(\\([^\\(\\)]+\\))?$} ");
+ pcmd.lappend(pObj);
+
+ if (Tcl_EvalObj (pInterp, pcmd) == TCL_ERROR)
+ return false;
+
+ CONST84 char * okstr = Tcl_GetStringResult (pInterp);
+ if (okstr[0] == '0') {
+ Tcl_SetResult (pInterp, "property format is incorrect: ", TCL_STATIC);
+ Tcl_AppendResult (pInterp, Tcl_GetStringFromObj(pObj, NULL), NULL);
+ return false;
+ }
+
+ pcmd = "split";
+ pcmd.lappend (pObj).lappend("(),");
+ if (Tcl_EvalObj (pInterp, pcmd) == TCL_ERROR)
+ return false;
+ result.copy(Tcl_GetObjResult (pInterp));
+
+ // the last element will be a null string
+ char *str = Tcl_GetStringFromObj (pObj, NULL);
+ if (str[strlen (str) - 1] == ')')
+ Tcl_ListObjReplace (NULL, result, result.llength() - 1, 1, 0, NULL);
+ return true;
+}
+
+/// Tests
+TCL_CMDEF (Obj2VarTest)
+{
+ if (objc < 2) {
+ Tcl_WrongNumArgs(pInterp, 1, objv, "value");
+ return TCL_ERROR;
+ }
+
+ VARIANT var;
+ VARIANT * pvar;
+ HRESULT hr;
+
+ pvar = (VARIANT*)CoTaskMemAlloc(sizeof(VARIANT));
+
+ VariantInit(pvar);
+ var.vt = VT_VARIANT;
+ var.pvarVal = pvar;
+
+ TObjPtr ptr(objv[1], false);
+
+ obj2var (ptr, *pvar);
+ CoTaskMemFree((LPVOID)pvar);
+ hr = VariantClear(&var);
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ return FAILED(hr)?TCL_ERROR:TCL_OK;
+}
+
+
--- /dev/null
+/*
+ *------------------------------------------------------------------------------
+ * utility.cpp
+ * Declares a collection of often used, general purpose functions.
+ * I've also placed the variant/Tcl_Obj conversion functions here.
+ *
+ * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *------------------------------------------------------------------------------
+ */
+#ifndef UTILITY_418A3400_56FC_11d3_86E8_0000B482A708
+#define UTILITY_418A3400_56FC_11d3_86E8_0000B482A708
+
+
+#ifndef ASSERT
+# ifdef _DEBUG
+# include <crtdbg.h>
+# define ASSERT(x) _ASSERTE(x)
+# else
+# define ASSERT(x)
+# endif
+#endif
+
+
+
+// TRACE functionality - works like printf, only in debug mode
+// - output to the debug console
+#ifdef _DEBUG
+# define TRACE OptclTrace
+void OptclTrace(LPCTSTR lpszFormat, ...);
+#else
+# define TRACE
+#endif
+
+#define TCL_CMDEF(fname) int fname (ClientData cd, Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST objv[])
+#define CHECKHR(hr) if (FAILED(hr)) throw(hr)
+#define CHECKHR_TCL(hr, i, v) if (FAILED(hr)) {Tcl_SetResult (i, HRESULT2Str(hr), TCL_DYNAMIC); return v;}
+
+#define SETDISPPARAMS(dp, numArgs, pvArgs, numNamed, pNamed) \
+ {\
+ (dp).cArgs=numArgs;\
+ (dp).rgvarg=pvArgs;\
+ (dp).cNamedArgs=numNamed;\
+ (dp).rgdispidNamedArgs=pNamed;\
+ }
+
+#define SETNOPARAMS(dp) SETDISPPARAMS(dp, 0, NULL, 0, NULL)
+
+#define _countof(x) (sizeof(x)/sizeof(x[0]))
+
+
+template <class T> void delete_ptr (T* &ptr)
+{
+ if (ptr != NULL) {
+ delete ptr;
+ ptr = NULL;
+ }
+}
+
+
+template <class T> T* delete_array (T *&ptr) {
+ if (ptr != NULL) {
+ delete []ptr;
+ ptr = NULL;
+ }
+ return ptr;
+}
+
+
+
+class OptclObj;
+
+bool var2obj (Tcl_Interp *pInterp, VARIANT &var, TObjPtr &presult, OptclObj **ppObj = NULL);
+bool obj2var_ti (Tcl_Interp *pInterp, TObjPtr &obj, VARIANT &var, ITypeInfo *pInfo, TYPEDESC *pdesc);
+bool obj2var_vt (Tcl_Interp *pInterp, TObjPtr &obj, VARIANT &var, VARTYPE vt);
+bool obj2var_vt_byref (Tcl_Interp *pInterp, TObjPtr &obj, VARIANT &var, VARTYPE vt);
+void obj2var (TObjPtr &obj, VARIANT &var);
+
+
+void OptclVariantClear (VARIANT *pvar);
+
+
+char * HRESULT2Str (HRESULT hr);
+void FreeBSTR (BSTR &bstr);
+void FreeBSTRArray (BSTR * bstr, UINT count);
+char * ExceptInfo2Str (EXCEPINFO *pe);
+DISPID Name2ID (IDispatch *, const LPOLESTR name);
+DISPID Name2ID (IDispatch *, const char *name);
+int ObjectNotFound (Tcl_Interp *pInterp, const char *name);
+void SplitTypedString (char *pstr, char ** ppsecond);
+bool SplitObject (Tcl_Interp *pInterp, Tcl_Obj *pObj,
+ const char * tokens, Tcl_Obj **ppResult);
+bool SplitBrackets (Tcl_Interp *pInterp, Tcl_Obj *pObj,
+ TObjPtr & result);
+
+/// TESTS
+TCL_CMDEF (Obj2VarTest);
+
+#endif // UTILITY_418A3400_56FC_11d3_86E8_0000B482A708
\ No newline at end of file
--- /dev/null
+#####################################################
+# This file demonstrates the Calendar control being
+# integrated within a Tk widget, and bound to a
+# an event handler
+#####################################################
+
+
+# in case we want to do some debugging
+bind . <F2> {console show}
+
+
+# optcl load happens here
+package require optcl
+
+
+##
+# called when an AfterUpdate event is raised.
+# the first parameter is the object that raised
+# the event
+proc onupdate {obj} {
+ global currentdate
+ set currentdate [$obj : value]
+}
+
+
+
+# main script------
+
+
+# create a status bar to show the current date
+label .cd -bd 1 -relief sunken -textvariable currentdate
+pack .cd -side bottom -fill x
+
+# create the calendar object
+set cal [optcl::new -window .cal MSCAL.Calendar]
+.cal config -width 300 -height 300
+pack .cal
+
+# bind to the calendar AfterUpdate event
+# routing it to the tcl procedure onupdate
+#
+optcl::bind $cal AfterUpdate onupdate
+
+
+# get the current value
+set currentdate [$cal : value]
+
+
+# make a button to view the type information of
+# the calendar
+button .b -text TypeInfo -command {tlview::viewtype [optcl::class $cal]}
+pack .b -side bottom -anchor se
+
+
--- /dev/null
+
+
+package require optcl
+bind . <F2> {console show}
+
+wm title . {PDF Document in Tk}
+set pdf [optcl::new -window .pdf {d:/program files/adobe/acrobat3/acrobat.pdf}]
+.pdf config -width 500 -height 300
+pack .pdf -fill both -expand 1
+
+# to view the type information for the control
+pack [button .b -text "View TypeLibrary for IE container" -command {
+ tlview::viewtype [ optcl::class $pdf ]
+ } ] -side bottom
+
+# can't execute these until the document has loaded...
+#set doc [$pdf : document]
+#tlview::viewtype [ optcl::class $doc ]
--- /dev/null
+################################################################
+# This file demonstrates the automation MS Word
+################################################################
+
+
+# for debuggin
+bind . <F2> {console show}
+
+#load optcl
+package require optcl
+
+
+
+# with this procedure, closing the document closes wish
+proc onclose {obj} {
+ # if the document is closing then exit
+ # but we can't call exit here as we are processing an event
+ # so set up a timer on this
+ after 500 {exit}
+}
+
+set word [optcl::new word.application]
+$word : visible 1
+
+# create a new doc
+set doc [$word -with documents add]
+
+# bind to its close event of the document
+optcl::bind $doc Close onclose
+
+
+# gui
+
+button .st -text "Set Text" -command {$doc -with content : text [.f.t get 1.0 end]; $doc : saved 1}
+pack .st
+
+frame .f -bd 1 -relief sunken
+pack .f -side top -fill both -expand 1
+scrollbar .f.ys -orient vertical -command {.f.t yview}
+pack .f.ys -side right -fill y
+text .f.t -yscrollcommand {.f.ys set} -bd 0 -relief flat
+pack .f.t -fill both -expand 1
+
+.f.t insert end "Please type your text here and press 'Set Text'"
+
projects / optcl / commitdiff
