From: Pat Thoyts <patthoyts@users.sourceforge.net>
Date: Fri, 13 Jun 2008 16:30:39 +0000 (+0100)
Subject: optcl-3010 import
X-Git-Url: http://www.privyetmir.co.uk/gitweb?a=commitdiff_plain;ds=inline;p=optcl
optcl-3010 import
---
diff --git a/GNU_Public_Licence.html b/GNU_Public_Licence.html
deleted file mode 100644
index ee2d7f1..0000000
--- a/GNU_Public_Licence.html
+++ /dev/null
@@ -1,525 +0,0 @@
-<!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>
diff --git a/Images/class.gif b/Images/class.gif
new file mode 100644
index 0000000..5b9ab9e
Binary files /dev/null and b/Images/class.gif differ
diff --git a/Images/copy.gif b/Images/copy.gif
new file mode 100644
index 0000000..849f210
Binary files /dev/null and b/Images/copy.gif differ
diff --git a/Images/dispatch.gif b/Images/dispatch.gif
new file mode 100644
index 0000000..3f6fe40
Binary files /dev/null and b/Images/dispatch.gif differ
diff --git a/Images/down.xbm b/Images/down.xbm
new file mode 100644
index 0000000..c867fce
--- /dev/null
+++ b/Images/down.xbm
@@ -0,0 +1,6 @@
+/* Created with The GIMP */
+#define C__Program_Files_Tcl_lib_width 12
+#define C__Program_Files_Tcl_lib_height 12
+static unsigned char C__Program_Files_Tcl_lib_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x80, 0x00, 0xc0, 0x00, 0xe0, 0x00, 0xf0, 0x00,
+ 0xe0, 0x00, 0xc0, 0x00, 0x80, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 };
diff --git a/Images/enum.gif b/Images/enum.gif
new file mode 100644
index 0000000..7e48ce0
Binary files /dev/null and b/Images/enum.gif differ
diff --git a/Images/find.gif b/Images/find.gif
new file mode 100644
index 0000000..4802a6c
Binary files /dev/null and b/Images/find.gif differ
diff --git a/Images/find.xbm b/Images/find.xbm
new file mode 100644
index 0000000..03267a1
--- /dev/null
+++ b/Images/find.xbm
@@ -0,0 +1,9 @@
+/* Created with The GIMP */
+#define C__Program_Files_Tcl_lib_width 17
+#define C__Program_Files_Tcl_lib_height 18
+static unsigned char C__Program_Files_Tcl_lib_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x70, 0x1c, 0x00, 0x50, 0x1c, 0x00,
+ 0x50, 0x1c, 0x00, 0x70, 0x1c, 0x00, 0xf8, 0x3e, 0x00, 0xe8, 0x3a, 0x00,
+ 0xfc, 0x7f, 0x00, 0x7e, 0xfb, 0x00, 0x7e, 0xfb, 0x00, 0xfe, 0xfb, 0x00,
+ 0xfe, 0xfe, 0x00, 0x3a, 0xe8, 0x00, 0x3a, 0xe8, 0x00, 0x3e, 0xf8, 0x00,
+ 0x3e, 0xf8, 0x00, 0x00, 0x00, 0x00 };
diff --git a/Images/hide.xbm b/Images/hide.xbm
new file mode 100644
index 0000000..11e2008
--- /dev/null
+++ b/Images/hide.xbm
@@ -0,0 +1,9 @@
+/* Created with The GIMP */
+#define C__Program_Files_Tcl_lib_width 17
+#define C__Program_Files_Tcl_lib_height 17
+static unsigned char C__Program_Files_Tcl_lib_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x80, 0x01, 0x00, 0x40, 0x02, 0x00, 0x20, 0x04, 0x00, 0x10, 0x08, 0x00,
+ 0x80, 0x01, 0x00, 0x40, 0x02, 0x00, 0x20, 0x04, 0x00, 0x10, 0x08, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00 };
diff --git a/Images/interface.gif b/Images/interface.gif
new file mode 100644
index 0000000..40548e6
Binary files /dev/null and b/Images/interface.gif differ
diff --git a/Images/libselect.gif b/Images/libselect.gif
new file mode 100644
index 0000000..ded2e77
Binary files /dev/null and b/Images/libselect.gif differ
diff --git a/Images/libselect.xbm b/Images/libselect.xbm
new file mode 100644
index 0000000..4602777
--- /dev/null
+++ b/Images/libselect.xbm
@@ -0,0 +1,9 @@
+/* Created with The GIMP */
+#define c__program_files_tcl_lib_width 17
+#define c__program_files_tcl_lib_height 17
+static unsigned char c__program_files_tcl_lib_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xf4, 0x3f, 0x00,
+ 0x00, 0x00, 0x00, 0xf4, 0x3f, 0x00, 0x00, 0x00, 0x00, 0xf0, 0x3f, 0x00,
+ 0x00, 0x00, 0x00, 0xf0, 0x3f, 0x00, 0x00, 0x00, 0x00, 0xf4, 0x3f, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00 };
diff --git a/Images/method.gif b/Images/method.gif
new file mode 100644
index 0000000..4835497
Binary files /dev/null and b/Images/method.gif differ
diff --git a/Images/module.gif b/Images/module.gif
new file mode 100644
index 0000000..09b5e0b
Binary files /dev/null and b/Images/module.gif differ
diff --git a/Images/noselect.gif b/Images/noselect.gif
new file mode 100644
index 0000000..9623a07
Binary files /dev/null and b/Images/noselect.gif differ
diff --git a/Images/property.gif b/Images/property.gif
new file mode 100644
index 0000000..1e0af13
Binary files /dev/null and b/Images/property.gif differ
diff --git a/Images/right.xbm b/Images/right.xbm
new file mode 100644
index 0000000..9a8a5f0
--- /dev/null
+++ b/Images/right.xbm
@@ -0,0 +1,6 @@
+/* Created with The GIMP */
+#define c__program_files_tcl_lib_width 12
+#define c__program_files_tcl_lib_height 12
+static unsigned char c__program_files_tcl_lib_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
+ 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 };
diff --git a/Images/select.gif b/Images/select.gif
new file mode 100644
index 0000000..9b6a0bf
Binary files /dev/null and b/Images/select.gif differ
diff --git a/Images/show.xbm b/Images/show.xbm
new file mode 100644
index 0000000..e9d8548
--- /dev/null
+++ b/Images/show.xbm
@@ -0,0 +1,9 @@
+/* Created with The GIMP */
+#define C__Program_Files_Tcl_lib_width 17
+#define C__Program_Files_Tcl_lib_height 17
+static unsigned char C__Program_Files_Tcl_lib_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x10, 0x08, 0x00, 0x20, 0x04, 0x00, 0x40, 0x02, 0x00,
+ 0x80, 0x01, 0x00, 0x10, 0x08, 0x00, 0x20, 0x04, 0x00, 0x40, 0x02, 0x00,
+ 0x80, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00 };
diff --git a/Images/struct.gif b/Images/struct.gif
new file mode 100644
index 0000000..2b8c789
Binary files /dev/null and b/Images/struct.gif differ
diff --git a/Images/typedef.gif b/Images/typedef.gif
new file mode 100644
index 0000000..1faec02
Binary files /dev/null and b/Images/typedef.gif differ
diff --git a/Images/union.gif b/Images/union.gif
new file mode 100644
index 0000000..06e042f
Binary files /dev/null and b/Images/union.gif differ
diff --git a/ReadMe.txt b/ReadMe.txt
index 310352f..b2ead57 100644
--- a/ReadMe.txt
+++ b/ReadMe.txt
@@ -1,19 +1,27 @@
-OpTcl v3.0 build 04
+
+OpTcl v3.0 build 10
-------------------
+PRE PRE ALPHA RELEASE (Friends and Family only)
+
+What's New
+----------
+Areas with Bug Fixes: Reference counting, Query Interfacing, (in/)out parameters; -with optimisation.
+
+New Features: Can now call custom interfaces. Handles COM's record structures. Library browser has search and history facilities. OpTcl works with COM better than ever before! :-)
Licencing
---------
-Use of this software indicates an agreement to the GNU Public Licence under which,
-this software is provided.
+Ignore any references to LGPL. I hereby renounce this license for one which is in-line with the BSD license. Please read the enclosed license.txt for details.
Documentation
-------------
-Please open the default.html file in the 'docs' directory for installation instructions
-and documentation.
+This is a beta release so the docs aren't there yet ... I've included the old ones just for comparison. A lot of the previous functionality and syntax is identical. A few things however have changed dramatically.
+To start things off try the following
+package require optcl
+tlview::viewlib .l
+I welcome any comments, suggestions and bug reports. Enjoy!
-I welcome any comments, suggestions and bug reports:
+Farzad.
fuzz@sys.uea.ac.uk
-
-
diff --git a/docs/optcl.html b/docs/optcl.html
index 206a2d5..a1b76dc 100644
--- a/docs/optcl.html
+++ b/docs/optcl.html
@@ -3,7 +3,7 @@
<head>
<meta http-equiv="Content-Type"
content="text/html; charset=iso-8859-1">
-<meta name="GENERATOR" content="Microsoft FrontPage Express 2.0">
+<meta name="GENERATOR" content="Microsoft FrontPage 4.0">
<title>OpTcl Documentation</title>
</head>
@@ -18,12 +18,8 @@ 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>
+<p>This software is freely distributed under the GNU Lesser General Public License. I've include this in this distribution as an
+<a href="../GNU_LGPL.html"> HTML file</a>.</p>
<h1>The Distribution</h1>
@@ -33,9 +29,11 @@ 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>
+ <td>Holds the installer script and the debug and release versions of the
+ stubbed DLLs for Tcl8.2 and above. I also wanted to build a
+ distribution for Tcl8.0.5+ without stubs, but no matter were I
+ downloaded the Tcl installer from, it failed half way through the
+ installation.</td>
</tr>
<tr>
<td><strong>docs</strong></td>
@@ -49,7 +47,8 @@ the distribution:</p>
<tr>
<td><strong>tests</strong></td>
<td>A couple of test scripts using MS Word, and the
- Calendar Control.</td>
+ Calendar Control. Need to put an example of scripting DirectX - should
+ nicely show off what OpTcl can really do! :-)</td>
</tr>
</table>
@@ -69,15 +68,14 @@ is applied to that directory.</p>
<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>
+ <li>Remove explicit reference counting - I can't do this until Scriptics
+ patch the Tcl core to enable 'precious' objects.</li>
</ul>
<h1>Known Bugs/Limitations</h1>
@@ -87,6 +85,8 @@ is applied to that directory.</p>
<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>
+ <li>Lack of reference counting means that objects within records need to be
+ explicitly unlocked.</li>
</ul>
<h1>Credits</h1>
diff --git a/docs/optcltypelibaccess.html b/docs/optcltypelibaccess.html
index f83e0b8..7527b88 100644
--- a/docs/optcltypelibaccess.html
+++ b/docs/optcltypelibaccess.html
@@ -41,7 +41,6 @@ synopsis:</p>
<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>
diff --git a/docs/optcltypes.html b/docs/optcltypes.html
index 55bcdb6..54dd225 100644
--- a/docs/optcltypes.html
+++ b/docs/optcltypes.html
@@ -27,10 +27,11 @@ accurrately described. </p>
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
+<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>
+sensitive in its invocations. I have a test version that can write out new
+libraries, and wrap Tcl scripts as fully-fledged ActiveX objects - more about
+this later...</p>
<p>In OpTcl, types are represented as a strings comprising of the
programmatic name for a type library and its contained typename,
diff --git a/install/optcl80.dll b/install/optcl80.dll
deleted file mode 100644
index a45c51a..0000000
Binary files a/install/optcl80.dll and /dev/null differ
diff --git a/install/optcl_Install.tcl b/install/optcl_Install.tcl
deleted file mode 100644
index 0b04ace..0000000
--- a/install/optcl_Install.tcl
+++ /dev/null
@@ -1,88 +0,0 @@
-
-# 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 .
diff --git a/install/optclstubs.dll b/install/optclstubs.dll
deleted file mode 100644
index 516434b..0000000
Binary files a/install/optclstubs.dll and /dev/null differ
diff --git a/license.txt b/license.txt
new file mode 100644
index 0000000..363ea12
--- /dev/null
+++ b/license.txt
@@ -0,0 +1,38 @@
+This software is copyrighted by Farzad Pezeshkpour.
+The following terms apply to all files associated with the software
+unless explicitly disclaimed in individual files.
+
+The authors hereby grant permission to use, copy, modify, distribute,
+and license this software and its documentation for any purpose, provided
+that existing copyright notices are retained in all copies and that this
+notice is included verbatim in any distributions. No written agreement,
+license, or royalty fee is required for any of the authorized uses.
+Modifications to this software may be copyrighted by their authors
+and need not follow the licensing terms described here, provided that
+the new terms are clearly indicated on the first page of each file where
+they apply.
+
+IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+
+THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
+IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
+NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+MODIFICATIONS.
+
+GOVERNMENT USE: If you are acquiring this software on behalf of the
+U.S. government, the Government shall have only "Restricted Rights"
+in the software and related documentation as defined in the Federal
+Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
+are acquiring the software on behalf of the Department of Defense, the
+software shall be classified as "Commercial Computer Software" and the
+Government shall have only "Restricted Rights" as defined in Clause
+252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
+authors grant the U.S. Government and others acting in its behalf
+permission to use and distribute the software in accordance with the
+terms specified in this license.
diff --git a/src/ComRecordInfoImpl.cpp b/src/ComRecordInfoImpl.cpp
new file mode 100644
index 0000000..d393911
--- /dev/null
+++ b/src/ComRecordInfoImpl.cpp
@@ -0,0 +1,1162 @@
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ComRecordInfoImpl.cpp
+ * Implements an IRecordInfo, that unlike the one shipped by MS, isn't
+ * reliant on the presence of a GUID for any structure.
+ * Copyright (C) 2000 Farzad Pezeshkpour
+ *
+ * Email: fuzz@sys.uea.ac.uk
+ * Date: 6th April 2000
+ *
+ * Licence:
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library 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
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ *-------------------------------------------------------------------------
+ */
+
+
+
+#include "stdafx.h"
+#include <atlbase.h>
+#include <atlcom.h>
+#include "ComRecordInfoImpl.h"
+
+/*
+ *-------------------------------------------------------------------------
+ * Class CComRecordInfoImpl --
+ * Declaration of the class that implements the new IRecord Info.
+ *-------------------------------------------------------------------------
+ */
+class CComRecordInfoImpl :
+public CComObjectRoot, public IRecordInfo
+{
+public:
+ BEGIN_COM_MAP(CComRecordInfoImpl)
+ COM_INTERFACE_ENTRY(IRecordInfo)
+ END_COM_MAP()
+
+
+ CComRecordInfoImpl();
+ virtual ~CComRecordInfoImpl();
+
+ HRESULT SetTypeInfo (ITypeInfo *pti);
+ void FinalRelease ();
+
+ STDMETHOD(RecordInit)(PVOID pvNew);
+ STDMETHOD(RecordClear)(PVOID pvExisting);
+ STDMETHOD(RecordCopy)(PVOID pvExisting, PVOID pvNew);
+ STDMETHOD(GetGuid)(GUID *pguid);
+ STDMETHOD(GetName)(BSTR *pbstrName);
+ STDMETHOD(GetSize)(ULONG *pcbSize);
+ STDMETHOD(GetTypeInfo)(ITypeInfo * *ppTypeInfo);
+ STDMETHOD(GetField)(PVOID pvData, LPCOLESTR szFieldName, VARIANT *pvarField);
+ STDMETHOD(GetFieldNoCopy)(PVOID pvData, LPCOLESTR szFieldName, VARIANT *pvarField, PVOID *ppvDataCArray);
+ STDMETHOD(PutField)(ULONG wFlags, PVOID pvData, LPCOLESTR szFieldName, VARIANT *pvarField);
+ STDMETHOD(PutFieldNoCopy)(ULONG wFlags, PVOID pvData, LPCOLESTR szFieldName, VARIANT *pvarField);
+ STDMETHOD(GetFieldNames)(ULONG *pcNames, BSTR *rgBstrNames);
+ BOOL STDMETHODCALLTYPE IsMatchingType(IRecordInfo *pRecordInfo);
+ PVOID STDMETHODCALLTYPE RecordCreate(void);
+ STDMETHOD(RecordCreateCopy)(PVOID pvSource, PVOID *ppvDest);
+ STDMETHOD(RecordDestroy)(PVOID pvRecord);
+
+protected:
+ STDMETHODIMP GetFieldNoCopy(PVOID pvData, VARDESC *pvd, VARIANT *pvarField, PVOID *ppvDataCArray);
+ STDMETHODIMP PutFieldNoCopy(ULONG wFlags, PVOID pvData, VARDESC *pvd, VARIANT *pvarField);
+protected:
+ void ReleaseTypeAttr ();
+
+protected:
+ CComPtr<ITypeInfo> m_pti; // type info we're implementing
+ TYPEATTR * m_pta; // type attribute for the type
+ CComBSTR m_name; // name of the this record type
+};
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * Class: CVarDesc
+ * Implements a wrapper for the VARDESC data type, and its retrieval from
+ * an ITypeInfo interface pointer.
+ *-------------------------------------------------------------------------
+ */
+class CVarDesc {
+protected:
+ CComPtr<ITypeInfo> m_pti; // reference to the ITypeInfo parent of the VARDESC
+public:
+ VARDESC * m_pvd; // the vardesc itself
+public:
+ // constructor / destructor
+ CVarDesc () : m_pvd(NULL) {}
+
+ virtual ~CVarDesc () {
+ Release();
+ }
+
+
+ // operator overloads to make this object look more like a VARDESC...
+
+ // pointer de-reference
+ VARDESC * operator-> () {
+ ATLASSERT (m_pvd != NULL);
+ return m_pvd;
+ }
+
+ // castin operator
+ operator VARDESC* () {
+ ATLASSERT (m_pvd != NULL);
+ return m_pvd;
+ }
+
+ /*
+ *-------------------------------------------------------------------------
+ * Release --
+ * Releases the VARDESC if it has been allocated.
+ * Releases reference to the ITypeInfo.
+ *
+ * Result:
+ * None.
+ *
+ * Side Effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+ void Release () {
+ if (m_pvd != NULL) {
+ ATLASSERT(m_pti != NULL);
+ m_pti->ReleaseVarDesc(m_pvd);
+ m_pti.Release();
+ m_pvd = NULL;
+ }
+ }
+
+
+ /*
+ *-------------------------------------------------------------------------
+ * Set --
+ * Sets the VARDESC based on an index into the ITypeInfo parameter.
+ *
+ * Result:
+ * S_OK iff succeeded.
+ *
+ * Side Effects:
+ * Any previous VARDESC is released.
+ *-------------------------------------------------------------------------
+ */
+ HRESULT Set (ITypeInfo *pti, ULONG index) {
+ Release();
+ m_pti = pti;
+ HRESULT hr;
+ hr = m_pti->GetVarDesc (index, &m_pvd);
+ return hr;
+ }
+
+
+ /*
+ *-------------------------------------------------------------------------
+ * Set --
+ * Sets the VARDESC based on the variable name within the ITypeInfo parameter.
+ *
+ * Result:
+ * S_OK iff succeeded.
+ *
+ * Side Effects:
+ * Any previous VARDESC is released.
+ *-------------------------------------------------------------------------
+ */
+ HRESULT Set (ITypeInfo *pti, LPCOLESTR name) {
+ CComPtr<ITypeComp> ptc;
+ HRESULT hr;
+ hr = pti->GetTypeComp (&ptc);
+ if (FAILED(hr))
+ return hr;
+ CComPtr<ITypeInfo> pti2;
+ DESCKIND dk;
+ BINDPTR bp;
+ hr = ptc->Bind ((LPOLESTR)name, 0, INVOKE_PROPERTYPUT | INVOKE_PROPERTYPUTREF, &pti2, &dk, &bp);
+ if (FAILED(hr))
+ return hr;
+ if (dk != DESCKIND_VARDESC) {
+ ReleaseBindPtr(dk, bp);
+ return E_FAIL;
+ } else {
+ Release();
+ m_pvd = bp.lpvardesc;
+ m_pti = pti;
+ return S_OK;
+ }
+ }
+
+
+private:
+ /*
+ *-------------------------------------------------------------------------
+ * ReleaseBindPtr --
+ * Releases the bind ptr according to its type.
+ *
+ * Result:
+ * None.
+ *
+ * Side Effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+ void ReleaseBindPtr (DESCKIND dk, BINDPTR bp) {
+ if (bp.lptcomp == NULL)
+ return;
+
+ switch (dk) {
+ case DESCKIND_FUNCDESC:
+ m_pti->ReleaseFuncDesc(bp.lpfuncdesc);
+ break;
+ case DESCKIND_TYPECOMP:
+ bp.lptcomp->Release();
+ break;
+ default:
+ ATLASSERT(FALSE);
+ break;
+ }
+ }
+};
+
+
+//------------------ IRecordInfo Implementation ---------------------------
+
+
+/*
+ *-------------------------------------------------------------------------
+ * GetRecordInfoFromTypeInfo2 --
+ * Creates a valid IRecordInfo interface for the give ITypeInfo interface.
+ * The only criteria is that the type info must be of the type TKIND_RECORD
+ * The type info does not have to provide a GUID.
+ *
+ * Result:
+ * S_OK iff successful.
+ *
+ * Side Effects:
+ * A CComRecordInfo object is created on the heap.
+ *
+ *-------------------------------------------------------------------------
+ */
+HRESULT GetRecordInfoFromTypeInfo2 (ITypeInfo *pti, IRecordInfo **ppri)
+{
+ ATLASSERT (pti != NULL && ppri != NULL);
+ CComObject<CComRecordInfoImpl> *pri = NULL;
+ CComPtr<IRecordInfo> ptmpri;
+ HRESULT hr = CComObject<CComRecordInfoImpl>::CreateInstance (&pri);
+ if (FAILED (hr))
+ return hr;
+ hr = pri->QueryInterface (&ptmpri);
+ if (FAILED(hr))
+ return hr;
+ hr = pri->SetTypeInfo (pti);
+ if (FAILED (hr))
+ return hr;
+ return ptmpri.CopyTo(ppri);
+}
+
+
+
+
+
+//////////////////////////////////////////////////////////////////////
+// Construction/Destruction
+//////////////////////////////////////////////////////////////////////
+
+CComRecordInfoImpl::CComRecordInfoImpl() : m_pta(NULL)
+{
+
+}
+
+CComRecordInfoImpl::~CComRecordInfoImpl()
+{
+
+}
+
+/*
+ *-------------------------------------------------------------------------
+ * FinalRelease --
+ * Called by the ATL framework when the object is about to be destroyed.
+ *
+ * Result:
+ * None.
+ *
+ * Side Effects:
+ * Releases the TYPEATTR for this Record Info.
+ *-------------------------------------------------------------------------
+ */
+void CComRecordInfoImpl::FinalRelease () {
+ ReleaseTypeAttr();
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * SetTypeInfo --
+ * Sets the current TypeInfo that this RecordInfo is implementing.
+ *
+ * Result:
+ * S_OK iff successful.
+ *
+ * Side Effects:
+ * Releases any previous type info reference and attributes.
+ *
+ *-------------------------------------------------------------------------
+ */
+HRESULT CComRecordInfoImpl::SetTypeInfo (ITypeInfo *pti)
+{
+ TYPEATTR *pta = NULL;
+ // retrieve the type attribute for the
+ try {
+ if (FAILED(pti->GetTypeAttr(&pta)))
+ throw false;
+ if (pta->typekind != TKIND_RECORD)
+ throw false;
+ ReleaseTypeAttr();
+ m_pti = pti;
+ m_pta = pta;
+ pti->GetDocumentation(-1, &m_name, NULL, NULL, NULL);
+ return S_OK;
+ } catch (...) {
+ if (pta != NULL)
+ pti->ReleaseTypeAttr(pta);
+ return E_INVALIDARG;
+ }
+}
+
+/*
+ *-------------------------------------------------------------------------
+ * ReleaseTypeAttr --
+ * Releases the TYPEATTR if any.
+ *
+ * Result:
+ * None.
+ *
+ * Side Effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void CComRecordInfoImpl::ReleaseTypeAttr ()
+{
+ ATLASSERT (m_pta == NULL || m_pti != NULL);
+
+ if (m_pta != NULL && m_pti != NULL) {
+ m_pti->ReleaseTypeAttr(m_pta);
+ m_pta = NULL;
+ }
+}
+
+
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * RecordInit --
+ * Initiliases the contents of a created record structure. All existing
+ * values are ignored.
+ *
+ * Result:
+ * S_OK iff successfull.
+ *
+ * Side Effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+STDMETHODIMP CComRecordInfoImpl::RecordInit(PVOID pvNew)
+{
+ HRESULT hr;
+ for (WORD iVar = 0; iVar < m_pta->cVars; iVar++) {
+
+ CVarDesc vd;
+ PVOID pvField;
+ CComPtr<ITypeInfo> pRefInfo;
+ CComPtr<IRecordInfo> pRefRecInfo;
+
+
+ hr = vd.Set(m_pti, iVar);
+ if (FAILED(hr))
+ return hr;
+ ATLASSERT ( (vd->elemdescVar.tdesc.vt & VT_BYREF) == NULL);
+
+
+ pvField = (BYTE*)pvNew + vd->oInst;
+
+
+ switch (vd->elemdescVar.tdesc.vt) {
+ case VT_USERDEFINED:
+ hr = m_pti->GetRefTypeInfo(vd->elemdescVar.tdesc.hreftype, &pRefInfo);
+ if (FAILED(hr)) return hr;
+
+ hr = GetRecordInfoFromTypeInfo2 (pRefInfo, &pRefRecInfo);
+ if (FAILED(hr)) return hr;
+
+ hr = pRefRecInfo->RecordInit(pvField);
+ if (FAILED(hr))
+ return hr;
+ break;
+
+ case VT_BSTR:
+ // is this correct?
+ *((BSTR*)pvField) = SysAllocString (L"");
+ break;
+
+ case VT_DATE:
+ *((DATE*)pvField) = 0;
+ break;
+
+ case VT_CY:
+ ((CY*)pvField)->int64 = 0;
+ break;
+
+ // generic 8bit data types
+ case VT_I1:
+ case VT_UI1:
+ *((BYTE*)pvField) = 0;
+ break;
+
+ // generic 16bit data types
+ case VT_I2:
+ case VT_UI2:
+ *((SHORT*)pvField) = 0;
+ break;
+
+ // generic 32 bit data types
+ case VT_I4:
+ case VT_UI4:
+ case VT_R4:
+ case VT_UNKNOWN:
+ case VT_DISPATCH:
+ case VT_ERROR:
+ *((ULONG*)pvField) = 0;
+ break;
+
+ // platform specific: INT
+ case VT_INT:
+ case VT_UINT:
+ *((INT*)pvField) = 0;
+ break;
+
+ // boolean
+ case VT_BOOL:
+ *((VARIANT_BOOL*)pvField) = VARIANT_FALSE;
+ break;
+
+ // double
+ case VT_R8:
+ *((DOUBLE*)pvField) = double(0);
+ break;
+
+ default:
+ // is it an array?
+ if (vd->elemdescVar.tdesc.vt & VT_ARRAY) {
+ *((SAFEARRAY**)pvField) = NULL;
+ }
+ }
+
+ }
+ return S_OK;
+}
+
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * CComRecordInfoImpl::RecordClear --
+ * Iterates through the existing record, clearing all referenced resources,
+ * and setting to zero.
+ *
+ * Result:
+ * Standard COM result.
+ *
+ * Side Effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+STDMETHODIMP CComRecordInfoImpl::RecordClear(PVOID pvExisting)
+{
+ HRESULT hr;
+ for (WORD iVar = 0; iVar < m_pta->cVars; iVar++) {
+
+ CVarDesc vd;
+ PVOID pvField;
+ CComPtr<ITypeInfo> pRefInfo;
+ CComPtr<IRecordInfo> pRefRecInfo;
+
+
+ hr = vd.Set(m_pti, iVar);
+ if (FAILED(hr))
+ return hr;
+ ATLASSERT ( (vd->elemdescVar.tdesc.vt & VT_BYREF) == NULL);
+
+ pvField = (BYTE*)pvExisting + vd->oInst;
+
+ if (vd->elemdescVar.tdesc.vt & VT_ARRAY) {
+ SafeArrayDestroy (*((SAFEARRAY**)pvField));
+ *((SAFEARRAY**)pvField) = NULL;
+ } else {
+ switch (vd->elemdescVar.tdesc.vt) {
+ case VT_USERDEFINED:
+ hr = m_pti->GetRefTypeInfo(vd->elemdescVar.tdesc.hreftype, &pRefInfo);
+ if (FAILED(hr)) return hr;
+
+ hr = GetRecordInfoFromTypeInfo2 (pRefInfo, &pRefRecInfo);
+ if (FAILED(hr)) return hr;
+
+ hr = pRefRecInfo->RecordClear(pvField);
+ if (FAILED(hr))
+ return hr;
+ break;
+ /* strings */
+ case VT_BSTR:
+ SysFreeString(*( (BSTR*)pvField ));
+ *( (BSTR*)pvField ) = NULL;
+ break;
+ /* interface types */
+ case VT_DISPATCH:
+ case VT_UNKNOWN:
+ (*((IUnknown**)pvField))->Release();
+ (*((IUnknown**)pvField)) = NULL;
+ break;
+ }
+ }
+ }
+ return S_OK;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * CComRecordInfoImpl::RecordCopy --
+ * Makes a copy of the existing record to the new record.
+ *
+ * Result:
+ * Standard COM result.
+ *
+ * Side Effects:
+ * Performs a deep copy on all references.
+ *-------------------------------------------------------------------------
+ */
+STDMETHODIMP CComRecordInfoImpl::RecordCopy(PVOID pvExisting, PVOID pvNew)
+{
+ HRESULT hr;
+ for (WORD iVar = 0; iVar < m_pta->cVars; iVar++) {
+ PVOID pvSrc, pvDst;
+ CVarDesc vd;
+ CComPtr<ITypeInfo> refInfo;
+ CComPtr<IRecordInfo> refrecInfo;
+
+ hr = vd.Set (m_pti, iVar);
+ if (FAILED(hr)) return hr;
+
+ pvSrc = (BYTE*)pvExisting + vd->oInst;
+ pvDst = (BYTE*)pvNew + vd->oInst;
+
+ ATLASSERT ( (vd->elemdescVar.tdesc.vt & VT_BYREF) == 0);
+ if (vd->elemdescVar.tdesc.vt & VT_ARRAY != 0) {
+ hr = SafeArrayCopyData (*((SAFEARRAY**)pvSrc), *((SAFEARRAY**)pvDst));
+ if (FAILED(hr)) return hr;
+ } else {
+ switch (vd->elemdescVar.tdesc.vt) {
+ // interfaces ...
+ case VT_UNKNOWN:
+ case VT_DISPATCH:
+ *((IUnknown**)pvDst) = *((IUnknown**)pvSrc);
+ (*((IUnknown**)pvDst))->AddRef();
+ break;
+ // string
+ case VT_BSTR:
+ *((BSTR*)pvDst) = SysAllocString (*((BSTR*)pvSrc));
+ break;
+ // 8 bit copy
+ case VT_I1:
+ case VT_UI1:
+ *((BYTE*)pvDst) = *((BYTE*)pvSrc);
+ break;
+ // 16 bit copy
+ case VT_I2:
+ case VT_UI2:
+ *((SHORT*)pvDst) = *((SHORT*)pvSrc);
+ break;
+ // 32 bit copy
+ case VT_I4:
+ case VT_UI4:
+ case VT_R4:
+ case VT_ERROR:
+ *((ULONG*)pvDst) = *((ULONG*)pvSrc);
+ break;
+ // doubles (64 bit)
+ case VT_R8:
+ *((DOUBLE*)pvDst) = *((DOUBLE*)pvSrc);
+ break;
+ // currency
+ case VT_CY:
+ *((CY*)pvDst) = *((CY*)pvSrc);
+ break;
+ // date
+ case VT_DATE:
+ *((DATE*)pvDst) = *((DATE*)pvSrc);
+ break;
+ // boolean
+ case VT_BOOL:
+ *((VARIANT_BOOL*)pvDst) = *((VARIANT_BOOL*)pvSrc);
+ break;
+ // decimal
+ case VT_DECIMAL:
+ *((DECIMAL*)pvDst) = *((DECIMAL*)pvSrc);
+ break;
+ // TypeLib defined
+ case VT_USERDEFINED:
+ hr = m_pti->GetRefTypeInfo(vd->elemdescVar.tdesc.hreftype, &refInfo);
+ if (FAILED(hr)) return hr;
+ hr = GetRecordInfoFromTypeInfo2 (m_pti, &refrecInfo);
+ if (FAILED(hr)) return hr;
+ hr = refrecInfo->RecordCopy (pvSrc, pvDst);
+ if (FAILED(hr)) return hr;
+ break;
+ default:
+ break;
+ }
+ }
+ }
+ return S_OK;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * CComRecordInfoImpl::GetGuid --
+ * Retrieve GUID of struct. Can possibly be IID_NULL.
+ *
+ * Result:
+ * S_OK
+ *
+ * Side Effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+STDMETHODIMP CComRecordInfoImpl::GetGuid(GUID *pguid)
+{
+ *pguid = m_pta->guid;
+ return S_OK;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * CComRecordInfoImpl::GetName --
+ * Retrieve the name of the structure.
+ *
+ * Result:
+ * S_OK;
+ *
+ * Side Effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+STDMETHODIMP CComRecordInfoImpl::GetName(BSTR *pbstrName)
+{
+ *pbstrName = m_name.Copy();
+ return (pbstrName!=NULL?S_OK:E_FAIL);
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * CComRecordInfoImpl::GetSize --
+ * Retrieve the size, in bytes of the structure.
+ *
+ * Result:
+ * None.
+ *
+ * Side Effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+STDMETHODIMP CComRecordInfoImpl::GetSize(ULONG *pcbSize)
+{
+ ATLASSERT (m_pta != NULL);
+ *pcbSize = m_pta->cbSizeInstance;
+ return S_OK;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * CComRecordInfoImpl::GetTypeInfo --
+ * Retrieve ITypeInfo for this structure.
+ *
+ * Result:
+ * S_OK iff all ok.
+ *
+ * Side Effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+STDMETHODIMP CComRecordInfoImpl::GetTypeInfo(ITypeInfo **ppTypeInfo)
+{
+ ATLASSERT(m_pti != NULL);
+ return m_pti.CopyTo(ppTypeInfo);
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * CComRecordInfoImpl::GetField --
+ * Retrieve the value of a given field within a structure of this type
+ * The value of the field is returned as a copy of the original.
+ * Result:
+ *
+ * Side Effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+STDMETHODIMP CComRecordInfoImpl::GetField(PVOID pvData, LPCOLESTR szFieldName, VARIANT *pvarField)
+{
+ VARIANT refVar;
+ PVOID pvFieldData;
+ HRESULT hr;
+
+ VariantInit (&refVar);
+ VariantClear(pvarField);
+
+ hr = GetFieldNoCopy (pvData, szFieldName, &refVar, &pvFieldData);
+ if (FAILED(hr))
+ return hr;
+ hr = VariantCopyInd(pvarField, &refVar);
+ return hr;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * CComRecordInfoImpl::GetFieldNoCopy --
+ * Retrieve a direct reference to the field's value using a VARDESC to identify the
+ * field. The caller must not free the returned variant.
+ *
+ * Result:
+ * S_OK iff ok.
+ *
+ * Side Effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+STDMETHODIMP CComRecordInfoImpl::GetFieldNoCopy(PVOID pvData, VARDESC *pvd, VARIANT *pvarField, PVOID *ppvDataCArray) {
+ HRESULT hr;
+ hr = VariantClear (pvarField);
+ if (FAILED(hr)) return hr;
+
+ // retrieve a pointer to the field data
+ PVOID pfield;
+ pfield = ( ((BYTE*)pvData) + pvd->oInst);
+ *ppvDataCArray = pfield;
+
+ // now crack the field type ...
+
+ // first some assertions ...
+ // not by-reference (COM Automation / Variant Declaration rules)
+ ATLASSERT ( (pvd->elemdescVar.tdesc.vt & VT_BYREF) == 0);
+
+ if (pvd->elemdescVar.tdesc.vt == VT_USERDEFINED) {
+ // resolve the referenced type
+ CComPtr<ITypeInfo> pRefInfo;
+ CComPtr<IRecordInfo> pRefRecInfo;
+ hr = m_pti->GetRefTypeInfo (pvd->elemdescVar.tdesc.hreftype, &pRefInfo);
+ if (FAILED(hr))
+ return hr;
+ hr = GetRecordInfoFromTypeInfo2 (pRefInfo, &pRefRecInfo);
+ if (FAILED(hr))
+ return hr;
+
+ // set the field reference and its record info
+ pvarField->pvRecord = pfield;
+ hr = pRefRecInfo.CopyTo(&(pvarField->pRecInfo));
+ if (FAILED(hr))
+ return hr;
+ pvarField->vt = VT_RECORD;
+ } else {
+ // in all other cases, we just set the pointer to the field member
+ pvarField->byref = pfield;
+ // the vartype of the resulting parameter will be a reference to the type of the field
+ pvarField->vt = (pvd->elemdescVar.tdesc.vt | VT_BYREF);
+ }
+ return S_OK;
+
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * CComRecordInfoImpl::GetFieldNoCopy --
+ * Retrieve the value of a field as a reference, given the name of the field.
+ *
+ * Result:
+ * S_OK iff ok.
+ *
+ * Side Effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+STDMETHODIMP CComRecordInfoImpl::GetFieldNoCopy(PVOID pvData, LPCOLESTR szFieldName, VARIANT *pvarField, PVOID *ppvDataCArray)
+{
+ HRESULT hr;
+ CVarDesc vd;
+
+ hr = vd.Set(m_pti, szFieldName);
+ if (FAILED(hr)) return hr;
+
+ hr = VariantClear (pvarField);
+ if (FAILED(hr)) return hr;
+ return GetFieldNoCopy (pvData, vd, pvarField, ppvDataCArray);
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * CComRecordInfoImpl::PutField --
+ * Places a copy of the variant to the field, applying any type coercion
+ * as required. Rules for INVOKE_PROPERTYPUT are handled at a deeper
+ * level of call.
+ *
+ * Result:
+ * S_OK iff all ok.
+ *
+ * Side Effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+STDMETHODIMP CComRecordInfoImpl::PutField(ULONG wFlags, PVOID pvData, LPCOLESTR szFieldName, VARIANT *pvarField)
+{
+ CVarDesc vd;
+ HRESULT hr;
+ hr = vd.Set(m_pti, szFieldName);
+ if (FAILED(hr)) return hr;
+
+ VARIANT varCopy;
+ VariantInit (&varCopy);
+ hr = VariantCopy (&varCopy, pvarField);
+ if (FAILED(hr)) return hr;
+ return PutFieldNoCopy (wFlags, pvData, vd, &varCopy);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ * CComRecordInfoImpl::PutFieldNoCopy --
+ * Given the VARDESC for a field, this function places the value in
+ * pvarField to the field, without allocating any new resources.
+ * I'm not too sure about the INVOKE_PROPERTYPUT implementation
+ * which I've tried to follow from the MSDN documentation. As
+ * far as I can make out, the field must be of type VT_DISPATCH
+ * (or do I have to explicitly check for derivation from IDispatch?)
+ * The value is either of type VT_DISPATCH (in which case it's default
+ * property is used as the actual value), or any other valid variant
+ * sub-type. The actual value will be set to the default property of
+ * the field.
+ *
+ * Result:
+ * Standard COM result - S_OK iff all OK.
+ *
+ * Side Effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+STDMETHODIMP CComRecordInfoImpl::PutFieldNoCopy(ULONG wFlags, PVOID pvData, VARDESC *pvd, VARIANT *pvarField)
+{
+ PVOID field = (BYTE*)pvData + pvd->oInst;
+ HRESULT hr;
+
+ // perform the conversion ...
+
+ if (wFlags == INVOKE_PROPERTYPUT) {
+
+ // if the field isn't a dispatch object or is null then we fail
+ if (pvd->elemdescVar.tdesc.vt != VT_DISPATCH)
+ return E_FAIL;
+
+ IDispatch * pdisp = *((IDispatch**)field);
+ if (pdisp == NULL)
+ return E_FAIL;
+
+ CComVariant varResult;
+ DISPPARAMS dp;
+ DISPID dispidNamed = DISPID_PROPERTYPUT;
+ dp.cArgs = 1;
+ dp.cNamedArgs = 1;
+ dp.rgdispidNamedArgs = &dispidNamed;
+ dp.rgvarg = pvarField;
+ hr = pdisp->Invoke (DISPID_VALUE, IID_NULL, 0, DISPID_PROPERTYPUT, &dp, &varResult, NULL, NULL);
+ return hr;
+ } else {
+ // do a straight conversion
+ hr = VariantChangeType (pvarField, pvarField, NULL, pvd->elemdescVar.tdesc.vt);
+ if (FAILED(hr))
+ return hr;
+
+ // now perform a shallow copy
+ if (pvd->elemdescVar.tdesc.vt & VT_ARRAY != 0) {
+ *((SAFEARRAY**)field) = pvarField->parray;
+ } else {
+ switch (pvd->elemdescVar.tdesc.vt) {
+ // interfaces ...
+ case VT_UNKNOWN:
+ case VT_DISPATCH:
+ *((IUnknown**)field) = pvarField->punkVal;
+ break;
+ // string
+ case VT_BSTR:
+ *((BSTR*)field) = pvarField->bstrVal;
+ break;
+ // 8 bit copy
+ case VT_I1:
+ case VT_UI1:
+ *((BYTE*)field) = pvarField->bVal;
+ break;
+ // 16 bit copy
+ case VT_I2:
+ case VT_UI2:
+ *((SHORT*)field) = pvarField->iVal;
+ break;
+ // 32 bit copy
+ case VT_I4:
+ case VT_UI4:
+ case VT_R4:
+ case VT_ERROR:
+ *((ULONG*)field) = pvarField->ulVal;
+ break;
+ // doubles (64 bit)
+ case VT_R8:
+ *((DOUBLE*)field) = pvarField->dblVal;
+ break;
+ // currency
+ case VT_CY:
+ *((CY*)field) = pvarField->cyVal;
+ break;
+ // date
+ case VT_DATE:
+ *((DATE*)field) = pvarField->date;
+ break;
+ // boolean
+ case VT_BOOL:
+ *((VARIANT_BOOL*)field) = pvarField->boolVal;
+ break;
+ // decimal
+ case VT_DECIMAL:
+ *((DECIMAL*)field) = pvarField->decVal;
+ break;
+ // TypeLib defined
+ case VT_USERDEFINED:
+ *((PVOID*)field) = pvarField->pvRecord;
+ break;
+ default:
+ break;
+ }
+ }
+ return S_OK;
+ }
+
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * CComRecordInfoImpl::PutFieldNoCopy --
+ * As the VARDESC variation above, but using the field name instead.
+ *
+ * Result:
+ * S_O iff all ok.
+ *
+ * Side Effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+STDMETHODIMP CComRecordInfoImpl::PutFieldNoCopy(ULONG wFlags, PVOID pvData, LPCOLESTR szFieldName, VARIANT *pvarField)
+{
+ CVarDesc vd;
+ HRESULT hr;
+ hr = vd.Set(m_pti, szFieldName);
+ if (FAILED(hr)) return hr;
+ return PutFieldNoCopy (wFlags, pvData, vd, pvarField);
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * CComRecordInfoImpl::GetFieldNames --
+ * Retrieves an array of fields names.
+ *
+ * Result:
+ * S_OK iff all ok.
+ *
+ * Side Effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+STDMETHODIMP CComRecordInfoImpl::GetFieldNames(ULONG *pcNames, BSTR *rgBstrNames)
+{
+ ULONG index = 0;
+ if (pcNames == NULL)
+ return E_INVALIDARG;
+ if (rgBstrNames == NULL) {
+ *pcNames = m_pta->cVars;
+ return S_OK;
+ }
+
+ if (*pcNames > m_pta->cVars)
+ *pcNames = m_pta->cVars;
+
+ try {
+ for (index = 0; index < *pcNames; index++) {
+ CVarDesc vd;
+ HRESULT hr;
+ hr = vd.Set (m_pti, index);
+ if (FAILED(hr))
+ throw (hr);
+
+ UINT dummy = 1;
+ hr = m_pti->GetNames (vd->memid, rgBstrNames+index, 1, &dummy);
+ if (FAILED(hr))
+ throw(hr);
+ }
+ } catch (HRESULT hr) {
+ while (index > 0)
+ SysFreeString (rgBstrNames[--index]);
+ return hr;
+ }
+ return S_OK;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * CComRecordInfoImpl::IsMatchingType --
+ * Checks for equivalence of this record type and the one referenced by
+ * the only parameter. Because we can't guarantee the use of GUIDs
+ * I've settled for matching on the type and library name.
+ *
+ * Result:
+ * TRUE iff the record structures match.
+ *
+ * Side Effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+BOOL STDMETHODCALLTYPE CComRecordInfoImpl::IsMatchingType(IRecordInfo *pRecordInfo)
+{
+ BOOL result = FALSE;
+ CComBSTR bstrOtherName;
+ HRESULT hr;
+
+ hr = pRecordInfo->GetName(&bstrOtherName);
+ if (FAILED(hr)) return FALSE;
+
+ if (wcscmp(bstrOtherName, m_name) == 0) {
+ CComPtr<ITypeInfo> pOtherInfo;
+ CComPtr<ITypeLib> pOurLib, pOtherLib;
+ UINT dummy;
+ TLIBATTR * pOurAttr = NULL, *pOtherAttr = NULL;
+
+ hr = pRecordInfo->GetTypeInfo(&pOtherInfo);
+ if (FAILED (hr)) return FALSE;
+
+ hr = pOtherInfo->GetContainingTypeLib(&pOtherLib, &dummy);
+ if (FAILED(hr)) return FALSE;
+
+ hr = m_pti->GetContainingTypeLib(&pOurLib, &dummy);
+ if (FAILED(hr)) return FALSE;
+
+ hr = pOurLib->GetLibAttr (&pOurAttr);
+ hr = pOtherLib->GetLibAttr (&pOtherAttr);
+ if (pOurAttr != NULL && pOtherAttr != NULL)
+ result = (pOurAttr->guid == pOtherAttr->guid);
+ if (pOurAttr != NULL)
+ pOtherLib->ReleaseTLibAttr (pOurAttr);
+ if (pOtherAttr != NULL)
+ pOtherLib->ReleaseTLibAttr (pOtherAttr);
+ }
+ return result;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * STDMETHODCALLTYPE CComRecordInfoImpl::RecordCreate --
+ * Allocates (using the task memory allocator) a new record, and
+ * initialises it.
+ *
+ * Result:
+ * Pointer to the record structure iff successfull; else NULL.
+ *
+ * Side Effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+PVOID STDMETHODCALLTYPE CComRecordInfoImpl::RecordCreate( void)
+{
+ PVOID prec = CoTaskMemAlloc(m_pta->cbSizeInstance);
+ if (FAILED(RecordInit(prec))) {
+ CoTaskMemFree(prec);
+ prec = NULL;
+ }
+ return prec;
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * CComRecordInfoImpl::RecordCreateCopy --
+ * Creates a copy of the passed record structure.
+ *
+ * Result:
+ * S_OK iff successfull.
+ *
+ * Side Effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+STDMETHODIMP CComRecordInfoImpl::RecordCreateCopy(PVOID pvSource, PVOID *ppvDest)
+{
+ *ppvDest = RecordCreate();
+ if (*ppvDest == NULL)
+ return E_FAIL;
+ return RecordCopy (pvSource, *ppvDest);
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * CComRecordInfoImpl::RecordDestroy --
+ * Clears the given record and releases the memory associated with it.
+ *
+ * Result:
+ * S_OK iff all OK.
+ *
+ * Side Effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+STDMETHODIMP CComRecordInfoImpl::RecordDestroy(PVOID pvRecord)
+{
+ HRESULT hr;
+ if (pvRecord) {
+ hr = RecordClear(pvRecord);
+ CoTaskMemFree(pvRecord);
+ }
+ return hr;
+}
+
diff --git a/src/ComRecordInfoImpl.h b/src/ComRecordInfoImpl.h
new file mode 100644
index 0000000..78a3798
--- /dev/null
+++ b/src/ComRecordInfoImpl.h
@@ -0,0 +1,61 @@
+
+
+/*
+ *-------------------------------------------------------------------------
+ * ComRecordInfoImpl.h
+ * Declares a IRecordInfo, that unlike the one shipped by MS, isn't
+ * reliant on the presence of a GUID for any structure.
+ *
+ * Copyright (C) 2000 Farzad Pezeshkpour
+ * Email: fuzz@sys.uea.ac.uk
+ * Date: 6th April 2000
+ *
+ * How-To: 1) Add both this file and ComRecordInfoImpl.cpp to your project
+ * 2) Include this file where-ever you wish to access a structure
+ * using IRecordInfo.
+ * 3) Call GetRecordInfoFromTypeInfo2 instead of
+ * GetRecordInfoFromTypeInfo to retrieve an IRecordInfo.
+ * Licence:
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library 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
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ *
+ *-------------------------------------------------------------------------
+ */
+
+
+
+
+#if !defined(AFX_COMRECORDINFOIMPL_H__B3BDEDA0_FB84_11D3_9D8A_DFFCB467E034__INCLUDED_)
+#define AFX_COMRECORDINFOIMPL_H__B3BDEDA0_FB84_11D3_9D8A_DFFCB467E034__INCLUDED_
+
+#if _MSC_VER > 1000
+#pragma once
+#endif // _MSC_VER > 1000
+
+/*
+ *-------------------------------------------------------------------------
+ * GetRecordInfoFromTypeInfo2 --
+ * This is a replacement for GetRecordInfoFromTypeInfo. It returns an
+ * instance of the new IRecordInfo.
+ *
+ * Result:
+ * Standard COM result. S_OK iff all ok.
+ *
+ * Side Effects:
+ * Memory allocated for the new object implementing IRecordInfo.
+ *-------------------------------------------------------------------------
+ */
+HRESULT GetRecordInfoFromTypeInfo2 (ITypeInfo *pti, IRecordInfo **ppri);
+
+#endif // !defined(AFX_COMRECORDINFOIMPL_H__B3BDEDA0_FB84_11D3_9D8A_DFFCB467E034__INCLUDED_)
diff --git a/src/EventBinding.cpp b/src/EventBinding.cpp
index d8a12bd..af64f1a 100644
--- a/src/EventBinding.cpp
+++ b/src/EventBinding.cpp
@@ -537,7 +537,7 @@ int BindingProps::Eval (OptclObj *pObj, DISPPARAMS *pDispParams, LPVARIANT pVarR
for (count = 0; count < pDispParams->cArgs; count++)
{
TObjPtr param;
- if (!var2obj(m_pInterp, pDispParams->rgvarg[pDispParams->cArgs - count - 1], param, ppObjs+count))
+ if (!var2obj(m_pInterp, pDispParams->rgvarg[pDispParams->cArgs - count - 1], NULL, param, ppObjs+count))
break;
cmd.lappend(param, m_pInterp);
}
@@ -567,7 +567,7 @@ int BindingProps::Eval (OptclObj *pObj, DISPPARAMS *pDispParams, LPVARIANT pVarR
if (result == TCL_ERROR)
{
- // do we have a exception storage
+ // do we have an exception storage
if (pExcepInfo != NULL)
{
// fill it in
diff --git a/src/FixedSplitter.tcl b/src/FixedSplitter.tcl
new file mode 100644
index 0000000..6bed3ae
--- /dev/null
+++ b/src/FixedSplitter.tcl
@@ -0,0 +1,24 @@
+
+namespace eval FixedSplitter {
+ variable properties
+ proc _getState {w} {
+ uplevel {
+ variable properties
+ }
+ }
+ proc create {w args} {
+ _getState $w
+
+ frame $w -width 200 -height 200 -relief sunken -bd 1
+
+ set properties($w-orient) horizontal
+ set properties($w-fixed) A
+ set properties($w-windowA) {}
+ set properties($w-windowB) {}
+ set properties($w-barwidth) 8
+ set properties($w-fixedsize) 100
+
+ return $w
+ }
+
+}
\ No newline at end of file
diff --git a/src/ImageListBox.tcl b/src/ImageListBox.tcl
new file mode 100644
index 0000000..3f3921f
--- /dev/null
+++ b/src/ImageListBox.tcl
@@ -0,0 +1,335 @@
+proc ImageListBox {args} {
+ return [eval ImageListBox::create $args]
+}
+
+namespace eval ImageListBox {
+ variable properties
+ array set properties {}
+
+ proc _getState {w} {
+ uplevel {variable properties}
+ }
+
+ proc create {w args} {
+ _getState $w
+ text $w -bd 0 -relief flat -width 30 -height 15 -state disabled -cursor arrow -wrap none
+ set properties($w-item) {}
+ set properties($w-nextId) 0
+ set properties($w-active) 0
+ set properties($w-anchor) 0
+ set properties($w-selectmode) browse
+ set properties($w-uiselection) 0
+
+ $w tag configure ILB_Selection -background SystemHighlight -foreground SystemHighlightText
+ set font [$w cget -font]
+ $w tag configure ILB_Active -foreground red
+
+ setBindings $w
+ rename ::$w [namespace current]::$w
+ proc ::$w {cmd args} "return \[eval [namespace current]::_dispatch $w \$cmd \$args\]"
+
+ eval $w configure $args
+ return $w
+ }
+
+ proc setBindings {w} {
+ foreach binding [bind Text] {
+ bind $w $binding "break;"
+ }
+
+ foreach binding [bind Listbox] {
+ bind $w $binding "[bind Listbox $binding];break;"
+ }
+
+ # special bindings
+ bind $w <ButtonPress-1> "[namespace current]::OnBeginUISelection $w; [bind Listbox <ButtonPress-1>]; break;"
+ bind $w <ButtonRelease-1> "[namespace current]::OnEndUISelection $w; [bind Listbox <ButtonRelease-1>]; break;"
+ return
+ }
+
+ proc _dispatch {w cmd args} {
+ _getState $w
+ set cmds [info commands [namespace current]::$cmd*]
+ if {$cmds == {}} {
+ return [eval $w $cmd $args]
+ } else {
+ return [eval [lindex $cmds 0] $w $args]
+ }
+ }
+
+
+
+ proc insert {w index args} {
+ _getState $w
+
+ set bEnd [string match $index end]
+ if {!$bEnd} {
+ incr index
+ } else {
+ set index [expr int([$w index end])]
+ }
+
+ $w config -state normal
+ foreach item $args {
+ $w image create $index.0 -align center -name _ILB_IMAGE_$properties($w-nextId)
+ $w insert $index.1 $item\n
+ $w tag add _ILB_TAG_$properties($w-nextId) $index.0 $index.end
+
+ incr properties($w-nextId)
+ incr index
+ }
+ $w config -state disabled
+ }
+
+ proc setimage {w index image} {
+ _getState $w
+ set index [index $w $index]
+ if {$index >= [index $w end]} {
+ set index [expr [index $w end] - 1]
+ }
+ set pos [expr $index + 1].0
+ $w image configure $pos -image $image
+ }
+
+ proc getimage {w index} {
+ _getState $w
+ set index [index $w $index]
+ set pos [expr $index + 1].0
+ $w image cget $pos -image
+ }
+
+ proc delete {w first {last {}} } {
+ _getState $w
+
+ if {$last == {}} {
+ set last $first
+ }
+ set first [index $w $first]
+ set last [index $w $last]
+
+ incr first
+ incr last 2
+ $w config -state normal
+ $w delete $first.0 $last.0
+ $w config -state disabled
+ }
+
+ proc size {w} {
+ _getState $w
+ return [expr int([$w index end]) - 2]
+ }
+
+ proc get {w first {last {}} } {
+ _getState $w
+ if {$last == {}} {
+ set last $first
+ }
+ set first [index $w $first]
+ set last [index $w $last]
+ if { [catch {
+ incr first
+ incr last
+ } ]} {
+ return {}
+ }
+ set result {}
+ while {$first <= $last} {
+ lappend result [$w get $first.0 $first.end]
+ incr first
+ }
+ return $result
+ }
+
+ proc selection {w cmd args} {
+ _getState $w
+ switch -- $cmd {
+ clear {
+ eval _selectClear $w $args
+ }
+ includes {
+ eval _selectIncludes $w $args
+ }
+ set {
+ eval _selectSet $w $args
+ }
+ anchor {
+ eval _selectAnchor $w $args
+ }
+ default {error "unknown selection command: $cmd"}
+ }
+ }
+
+
+ proc _selectAnchor {w index} {
+ _getState $w
+ set properties($w-anchor) [index $w $index]
+ }
+
+ proc _selectClear {w first {last {}} } {
+
+ if {$last == {}} {
+ set last $first
+ }
+ set first [index $w $first]
+ set last [index $w $last]
+
+ incr first;
+ incr last
+
+ while {$first <= $last} {
+ $w tag remove ILB_Selection $first.0 [incr first].0
+ }
+ }
+
+ proc _selectSet {w args} {
+ _getState $w
+ $w tag remove ILB_Selection 1.0 end
+
+ foreach index $args {
+ set index [index $w $index]
+ if {$index < [size $w]} {
+ $w tag add ILB_Selection [incr index].0 [incr index].0
+ }
+ }
+
+ if {!$properties($w-uiselection)} {
+ event generate $w <<Select>>
+ }
+ }
+
+ proc _selectIncludes {w first {last {}}} {
+ if {$last == {}} {
+ set last $first
+ }
+ set first [index $w $first]
+ set last [index $w $last]
+ incr first;
+ incr last
+
+ while {$first <= $last} {
+ $w tag add ILB_Selection $first.0 [incr first].0
+ }
+
+ if {!$properties($w-uiselection)} {
+ event generate $w <<Select>>
+ }
+ }
+
+
+ proc curselection {w} {
+ _getState $w
+ set index 0.0
+ set result {}
+ while {[set range [$w tag nextrange ILB_Selection $index]] != {}} {
+ lappend result [expr int([lindex $range 0]) - 1]
+ set index [lindex $range 1]
+ }
+ return $result
+ }
+
+ proc nearest {w y} {
+ set index [$w index @0,$y]
+ return [expr int($index) - 1]
+ }
+
+
+ proc see {w index} {
+ set index [index $w $index]
+ if {![string match $index end]} {
+ set index [expr $index + 1].0
+ }
+ $w see $index
+ }
+
+ proc index {w index} {
+ _getState $w
+ if {$index == {}} {
+ error "index can't be an empty string"
+ }
+
+ switch -regexp -- $index {
+ {^(-)?[0-9]+$} {}
+ {^@(-)?[0-9]+,(-)?[0-9]+} { return [expr int([$w index $index]) - 1]}
+ active {return $properties($w-active)}
+ anchor {return $properties($w-anchor)}
+ end {return [size $w]}
+ default {error "unknown index value: $index"}
+ }
+ set size [size $w]
+ if {$index > $size} {
+ set index $size
+ } elseif {$index < 0} {
+ set index 0
+ }
+ return $index
+ }
+
+ proc activate {w index} {
+ _getState $w
+ set index [index $w $index]
+ set properties($w-active) $index
+ return
+ }
+
+ proc bbox {w index} {
+ _getState $w
+ set index [index $w $index]
+ return [$w bbox $index.0]
+ }
+
+ proc cget {w option} {
+ _getState $w
+ switch -- $option {
+ -selectmode {return $properties($w-selectmode)}
+ default {return [$w cget $option]}
+ }
+ }
+
+ proc configure {w args} {
+ _getState $w
+ if {[llength $args]%2 != 0 && [llength $args] != 1} {
+ error "configure requires pairs"
+ }
+ set def {}
+ foreach {option value} $args {
+ switch -- $option {
+ -selectmode {return [_configSelectMode $w $value]}
+ default {
+ if {[llength $args] == 1} {
+ lappend def $option
+ } else {
+ lappend def $option $value
+ }
+ }
+ }
+ }
+ if {$def != {}} {
+ eval [namespace current]::$w configure $def
+ }
+ }
+
+
+ proc _configSelectMode {w value} {
+ _getState $w
+ if {$value == {}} {
+ return $properties($w-selectmode)
+ } else {
+ if {[regexp {^single|browse|multiple|extended$} $value]} {
+ error "invalid select mode: $value"
+ }
+ set properties($w-selectmode) $value
+ }
+ }
+
+ proc OnBeginUISelection {w} {
+ _getState $w
+ set properties($w-uiselection) 1
+ }
+
+ proc OnEndUISelection {w} {
+ _getState $w
+ set properties($w-uiselection) 0
+ event generate $w <<Select>>
+ }
+}
+
diff --git a/src/ObjMap.cpp b/src/ObjMap.cpp
index 1e9fd53..236831e 100644
--- a/src/ObjMap.cpp
+++ b/src/ObjMap.cpp
@@ -68,6 +68,10 @@ ObjMap::~ObjMap()
*/
void ObjMap::DeleteAll ()
{
+#ifdef _DEBUG
+ ObjDump();
+#endif // _DEBUG
+
ObjNameMap::iterator i;
for (i = m_namemap.begin(); i != m_namemap.end(); i++) {
OptclObj *pobj = *i;
@@ -79,8 +83,32 @@ void ObjMap::DeleteAll ()
m_unkmap.deltbl();
}
+/*
+ *-------------------------------------------------------------------------
+ * ObjMap::ObjDump
+ * Dumps the current contents of the object map to the Debug Stream
+ *
+ * Result:
+ * None.
+ *
+ * Side Effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+void ObjMap::ObjDump ()
+{
+ TRACE("BEGIN: OpTcl Object Dump\n");
-
+ ObjNameMap::iterator i;
+ for (i = m_namemap.begin(); i != m_namemap.end(); i++) {
+ OptclObj *pobj = *i;
+ ASSERT (pobj != NULL);
+ TObjPtr interfacename;
+ pobj->InterfaceName(interfacename);
+ TRACE("\t%s %s %d\n", (char*)interfacename, pobj->m_name.c_str(), pobj->m_refcount);
+ }
+ TRACE("END: OpTcl Object Dump\n");
+}
/*
*-------------------------------------------------------------------------
@@ -119,13 +147,13 @@ OptclObj * ObjMap::Create (Tcl_Interp *pInterp, const char * id, const char * pa
if (m_unkmap.find(u, &ptmp) != NULL) {
ASSERT (ptmp != NULL);
delete pObj;
- ++ptmp->m_refcount;
+ Lock (ptmp);
return ptmp;
}
m_unkmap.set (u, pObj);
m_namemap.set (*pObj, pObj); // implicit const char * cast
- pObj->m_refcount = 1;
+ Lock(pObj);
CreateCommand (pObj);
return pObj;
}
@@ -146,7 +174,7 @@ OptclObj * ObjMap::Create (Tcl_Interp *pInterp, const char * id, const char * pa
* None.
*-------------------------------------------------------------------------
*/
-OptclObj * ObjMap::Add (Tcl_Interp *pInterp, LPUNKNOWN punk)
+OptclObj * ObjMap::Add (Tcl_Interp *pInterp, LPUNKNOWN punk, ITypeInfo *pti)
{
ASSERT (punk != NULL);
CComPtr<IUnknown> t_unk;
@@ -162,19 +190,17 @@ OptclObj * ObjMap::Add (Tcl_Interp *pInterp, LPUNKNOWN punk)
if (m_unkmap.find(u, &pObj) == NULL) {
pObj = new OptclObj();
- if (!pObj->Attach(pInterp, punk))
+ if (!pObj->Attach(pInterp, punk, pti))
{
delete pObj;
pObj = NULL;
}
m_namemap.set(*pObj, pObj);
m_unkmap.set(u, pObj);
- pObj->m_refcount = 1;
+
CreateCommand (pObj);
- } else {
- ++pObj->m_refcount;
}
-
+ Lock(pObj);
ASSERT (pObj != NULL);
return pObj;
}
@@ -260,7 +286,7 @@ void ObjMap::DeleteCommand (OptclObj *po)
return;
- CONST84 char * cmdname = Tcl_GetCommandName (po->m_pInterp, po->m_cmdtoken);
+ const char * cmdname = Tcl_GetCommandName (po->m_pInterp, po->m_cmdtoken);
if (cmdname == NULL)
return;
Tcl_CmdInfo cmdinf;
@@ -295,7 +321,8 @@ void ObjMap::DeleteCommand (OptclObj *po)
void ObjMap::Delete (OptclObj *pObj)
{
ASSERT (pObj != NULL);
-
+ TRACE("Deleting: ");
+ TRACE_OPTCLOBJ(pObj);
// first ensure that we delete the objects command
DeleteCommand(pObj);
m_namemap.delete_entry (*pObj);
@@ -350,6 +377,7 @@ void ObjMap::Lock (OptclObj *po)
{
ASSERT (po != NULL);
++po->m_refcount;
+ TRACE_OPTCLOBJ(po);
}
@@ -370,7 +398,9 @@ void ObjMap::Lock (OptclObj *po)
void ObjMap::Unlock(OptclObj *po)
{
ASSERT (po != NULL);
- if (--po->m_refcount == 0)
+ --(po->m_refcount);
+ TRACE_OPTCLOBJ(po);
+ if (po->m_refcount == 0)
Delete (po);
}
diff --git a/src/ObjMap.h b/src/ObjMap.h
index ce1a58c..8796bb9 100644
--- a/src/ObjMap.h
+++ b/src/ObjMap.h
@@ -46,7 +46,7 @@ public: // constructor / destructor
virtual ~ObjMap ();
OptclObj * Create (Tcl_Interp *pInterp, const char * id, const char * path, bool start);
- OptclObj * Add (Tcl_Interp *pInterp, LPUNKNOWN punk);
+ OptclObj * Add (Tcl_Interp *pInterp, LPUNKNOWN punk, ITypeInfo *pti = NULL);
OptclObj * Find (LPUNKNOWN punk);
OptclObj * Find (const char *name);
@@ -68,12 +68,12 @@ protected:
void Delete (OptclObj *);
void CreateCommand (OptclObj *);
void DeleteCommand (OptclObj *);
-
+ void ObjDump ();
};
// Global Variable Declaration!!!
-extern ObjMap g_objmap; // once object map per application
+extern ObjMap g_objmap; // one object map per application
#endif // !defined(AFX_OBJMAP_H__8A11BC00_616B_11D4_8004_0040055861F2__INCLUDED_)
diff --git a/src/OptclBindPtr.h b/src/OptclBindPtr.h
index da93d28..c64813b 100644
--- a/src/OptclBindPtr.h
+++ b/src/OptclBindPtr.h
@@ -76,17 +76,27 @@ public:
short OptclBindPtr::cParamsOpt()
{
+ int pin;
+ int oparams = 0;
ASSERT (m_bp.lpfuncdesc != NULL);
switch (m_dk) {
case DESCKIND_FUNCDESC:
- return m_bp.lpfuncdesc->cParamsOpt;
+ // this method doesn't work very well
+ // return m_bp.lpfuncdesc->cParamsOpt;
+ // so ...
+ for (pin = 0; pin < m_bp.lpfuncdesc->cParams; pin++) {
+ if (m_bp.lpfuncdesc->lprgelemdescParam[pin].paramdesc.wParamFlags & PARAMFLAG_FOPT)
+ oparams++;
+ }
+ break;
case DESCKIND_IMPLICITAPPOBJ:
case DESCKIND_VARDESC:
- return 1;
+ oparams = 1;
+ break;
default:
ASSERT (FALSE);
- return 0;
}
+ return oparams;
}
ELEMDESC * OptclBindPtr::param(short param)
diff --git a/src/OptclObj.cpp b/src/OptclObj.cpp
index b2c74f6..84a6631 100644
--- a/src/OptclObj.cpp
+++ b/src/OptclObj.cpp
@@ -40,7 +40,7 @@
//////////////////////////////////////////////////////////////////////
OptclObj::OptclObj ()
-: m_refcount(0), m_cmdtoken(NULL), m_pta(NULL),
+: m_refcount(0), m_cmdtoken(NULL),
m_destroypending(false), m_container(this)
{
}
@@ -67,7 +67,7 @@ bool OptclObj::Create (Tcl_Interp *pInterp, const char *strid,
if (!start)
hr = GetActiveObject(clsid, NULL, &m_punk);
if (start || FAILED(hr))
- hr = CoCreateInstance (clsid, NULL, CLSCTX_SERVER, IID_IUnknown, (void**)&m_punk);
+ hr = m_punk.CoCreateInstance (clsid, NULL, CLSCTX_SERVER);
CHECKHR_TCL(hr, pInterp, false);
}
@@ -100,17 +100,23 @@ bool OptclObj::Create (Tcl_Interp *pInterp, const char *strid,
* None.
*-------------------------------------------------------------------------
*/
-bool OptclObj::Attach (Tcl_Interp *pInterp, LPUNKNOWN punk)
+bool OptclObj::Attach (Tcl_Interp *pInterp, LPUNKNOWN punk, ITypeInfo *pti)
{
ASSERT (m_punk == NULL);
ASSERT (punk != NULL);
m_pInterp = pInterp;
try {
+ CComPtr<ITypeLib> ptl;
+ if (pti) {
+ UINT index;
+ CHECKHR(pti->GetContainingTypeLib (&ptl, &index));
+ }
+
CreateName (punk);
InitialiseUnknown(punk);
InitialiseClassInfo(m_punk);
- InitialisePointers (m_punk);
+ InitialisePointers (m_punk, ptl, pti);
}
catch (HRESULT hr) {
m_punk = NULL;
@@ -300,9 +306,9 @@ HRESULT OptclObj::InitialisePointersFromCoClass()
*/
HRESULT OptclObj::GetTypeAttr()
{
- ASSERT (m_pta == NULL);
ASSERT (m_pti != NULL);
- return m_pti->GetTypeAttr(&m_pta);
+ m_pta = m_pti;
+ return (m_pta.m_pattr == NULL)?E_FAIL:S_OK;
}
@@ -318,10 +324,7 @@ HRESULT OptclObj::GetTypeAttr()
*/
void OptclObj::ReleaseTypeAttr()
{
- if (m_pti != NULL && m_pta != NULL) {
- m_pti->ReleaseTypeAttr(m_pta);
- m_pta = NULL;
- }
+ m_pta.ReleaseTypeAttr();
}
@@ -343,35 +346,51 @@ HRESULT OptclObj::SetInterfaceFromType (ITypeInfo *reftype)
HRESULT hr;
CComPtr<ITypeLib> reftypelib;
UINT libindex;
- TYPEATTR *pta;
+
+ OptclTypeAttr pta;
+ CComPtr<ITypeInfo> pRT = reftype;
- hr = reftype->GetContainingTypeLib(&reftypelib, &libindex);
- if (FAILED(hr))
- return hr;
+ if (reftype == NULL)
+ return E_POINTER;
- hr = reftype->GetTypeAttr (&pta);
+ hr = pRT->GetContainingTypeLib(&reftypelib, &libindex);
if (FAILED(hr))
return hr;
+ pta = pRT;
+
+ if (pta.m_pattr == NULL)
+ return E_FAIL;
+
+ if (pta->typekind == TKIND_COCLASS) {
+ CComPtr<ITypeInfo> definterface;
+ hr = TypeLib_GetDefaultInterface(pRT, false, &definterface);
+ if (FAILED(hr)) return hr;
+ pRT = definterface;
+ pta = pRT;
+ if (pta.m_pattr == NULL)
+ return E_FAIL;
+ }
+
+ /*
if (pta->typekind != TKIND_DISPATCH) {
reftype->ReleaseTypeAttr (pta);
return E_NOINTERFACE;
}
+ */
GUID guid = pta->guid;
- reftype->ReleaseTypeAttr (pta);
-
+ m_pcurrent.Release();
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_pti = pRT;
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();
}
@@ -396,12 +415,12 @@ void OptclObj::InitialisePointers (LPUNKNOWN punk, ITypeLib *plib, ITypeInfo *pi
{
HRESULT hr;
ASSERT (punk != NULL);
- CComQIPtr<IDispatch> pdisp;
ASSERT ((plib!=NULL && pinfo!=NULL) || (plib==NULL && pinfo==NULL));
+ ReleaseTypeAttr();
if (plib != NULL && pinfo != NULL) {
- m_pcurrent = punk;
+ //m_pcurrent = punk;
m_ptl = plib;
m_pti = pinfo;
m_ptc = NULL;
@@ -409,17 +428,13 @@ void OptclObj::InitialisePointers (LPUNKNOWN punk, ITypeLib *plib, ITypeInfo *pi
GetTypeAttr();
}
- // else, if we have the coclass information, try building on its default
- // interface
+ // else, if we don't have coclass information, or we can't initialise
+ // from it, try building on its default ...
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));
+ CHECKHR(punk->QueryInterface (IID_IDispatch, reinterpret_cast<void**>(&m_pcurrent)));
// get the type information and library.
- hr = m_pcurrent->GetTypeInfo (0, LOCALE_SYSTEM_DEFAULT, &m_pti);
+ hr = (reinterpret_cast<IDispatch*>(m_pcurrent.p))->GetTypeInfo (0, LOCALE_SYSTEM_DEFAULT, &m_pti);
CHECKHR(hr);
UINT index;
hr = m_pti->GetContainingTypeLib(&m_ptl, &index);
@@ -427,10 +442,7 @@ void OptclObj::InitialisePointers (LPUNKNOWN punk, ITypeLib *plib, ITypeInfo *pi
m_ptc = NULL;
m_pti->GetTypeComp (&m_ptc);
GetTypeAttr();
- }
-
-
- catch (HRESULT) {
+ } catch (HRESULT) {
// there isn't a interface that we can use
ReleaseTypeAttr();
m_pcurrent.Release();
@@ -438,8 +450,9 @@ void OptclObj::InitialisePointers (LPUNKNOWN punk, ITypeLib *plib, ITypeInfo *pi
m_ptl = NULL;
m_ptc = NULL;
return;
- }
+ }
}
+
// inform the typelibrary browser system of the library
g_libs.EnsureCached (m_ptl);
}
@@ -549,26 +562,11 @@ void OptclObj::SetInterfaceName (TObjPtr &pObj)
TypeLib *ptl;
CComPtr<ITypeInfo> pti;
CComPtr<IUnknown> punk;
- TYPEATTR ta, *pta = NULL;
- HRESULT hr;
+ // throws an hresult
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);
+ CHECKHR(SetInterfaceFromType(pti));
}
@@ -593,12 +591,12 @@ void OptclObj::SetInterfaceName (TObjPtr &pObj)
bool OptclObj::InvokeCmd (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST objv[])
{
ASSERT (pInterp != NULL);
- CComPtr<IDispatch> pdisp;
+ CComPtr<IUnknown> punk;
CComPtr<ITypeComp> ptc;
CComPtr<ITypeInfo> pti;
TObjPtr name;
- int invkind = DISPATCH_METHOD;
+ int invkind = DISPATCH_PROPERTYGET | DISPATCH_METHOD;
char * msg =
"\n\tobj : ?-with subprop? prop ?value? ?prop value? ..."
@@ -625,13 +623,13 @@ bool OptclObj::InvokeCmd (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST objv[])
}
name.attach(objv[1]);
- if (!ResolvePropertyObject (pInterp, name, &pdisp, &pti, &ptc))
+ if (!ResolvePropertyObject (pInterp, name, &punk, &pti, &ptc))
return false;
objc -= 2;
objv += 2;
}
else {
- pdisp = m_pcurrent;
+ punk = m_pcurrent;
ptc = m_ptc;
pti = m_pti;
}
@@ -645,20 +643,20 @@ bool OptclObj::InvokeCmd (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST objv[])
objv++;
if (objc == 1)
- return GetProp (pInterp, objv[0], pdisp, pti, ptc);
+ return GetProp (pInterp, objv[0], punk, 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);
+ return SetProp (pInterp, objc/2, objv, punk, pti, ptc);
}
}
if (ptc == NULL)
- return InvokeNoTypeInf (pInterp, invkind, objc, objv, pdisp);
+ return InvokeNoTypeInf (pInterp, invkind, objc, objv, reinterpret_cast<IDispatch*>(punk.p));
else
- return InvokeWithTypeInf (pInterp, invkind, objc, objv, pdisp, pti, ptc);
+ return InvokeWithTypeInf (pInterp, invkind, objc, objv, punk, pti, ptc);
}
@@ -680,19 +678,8 @@ 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;
+ } else
+ return true;
}
@@ -704,6 +691,7 @@ bool OptclObj::CheckInterface (Tcl_Interp *pInterp)
*
* Result:
* true iff successful - else error string in interpreter.
+ *
* Side effects:
* None.
*-------------------------------------------------------------------------
@@ -741,8 +729,6 @@ bool OptclObj::BuildParamsWithBindPtr (Tcl_Interp *pInterp, int objc, Tcl_Obj *C
// 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]);
@@ -800,9 +786,8 @@ bool OptclObj::RetrieveOutParams (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST
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);
+ bok = var2obj (pInterp, dp[objc - count - 1], NULL, presult) &&
+ (Tcl_ObjSetVar2 (pInterp, objv[count], NULL, presult, TCL_LEAVE_ERR_MSG) != NULL);
}
}
@@ -816,7 +801,8 @@ bool OptclObj::RetrieveOutParams (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST
bool OptclObj::InvokeWithTypeInfVariant (Tcl_Interp *pInterp, long invokekind,
int objc, Tcl_Obj *CONST objv[],
- IDispatch *pDisp, ITypeInfo *pti, ITypeComp *pCmp, VARIANT &varResult)
+ IUnknown *pUnk, ITypeInfo *pti, ITypeComp *pCmp,
+ VARIANT &varResult, ITypeInfo **ppResultInfo)
{
USES_CONVERSION;
DispParams dp;
@@ -834,19 +820,21 @@ bool OptclObj::InvokeWithTypeInfVariant (Tcl_Interp *pInterp, long invokekind,
static DISPID propput = DISPID_PROPERTYPUT;
OptclBindPtr obp;
OptclTypeAttr ota;
+ unsigned short wFlags = invokekind;
ASSERT (objc >= 1);
- ASSERT (pDisp != NULL);
+ ASSERT (pUnk != NULL);
ASSERT (pti != NULL);
ASSERT (varResult.vt == VT_EMPTY);
ota = pti;
- ASSERT (ota->typekind == TKIND_DISPATCH || (ota->wTypeFlags & TYPEFLAG_FDUAL));
+ //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);
+ if (invokekind == DISPATCH_PROPERTYPUT)
+ wFlags |= DISPATCH_PROPERTYPUTREF;
+ hr = pCmp->Bind (olename, 0, wFlags, &obp.m_pti, &obp.m_dk, &obp.m_bp);
CHECKHR(hr);
if (obp.m_dk == DESCKIND_NONE) {
@@ -866,10 +854,30 @@ bool OptclObj::InvokeWithTypeInfVariant (Tcl_Interp *pInterp, long invokekind,
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[0].vt == VT_UNKNOWN || dp[0].vt == VT_DISPATCH || (dp[0].vt & VT_ARRAY) || (dp[0].vt & VT_BYREF)))
+ {
+ // Try first PUTREF then plain PUT as authors often forget to provide a putref version when they should.
+ invokekind = DISPATCH_PROPERTYPUTREF;
+ hr = E_FAIL;
+ while (FAILED(hr) && invokekind != DISPATCH_PROPERTYGET)
+ {
+ if (m_pta->typekind == TKIND_DISPATCH || (m_pta->wTypeFlags & TYPEFLAG_FDUAL))
+ hr = reinterpret_cast<IDispatch*>(pUnk)->Invoke(dispid, IID_NULL, LOCALE_SYSTEM_DEFAULT, invokekind, &dp, &varResult, &ei, &ea);
+ else
+ hr = DispInvoke (pUnk, pti, dispid, invokekind, &dp, &varResult, &ei, &ea);
+ invokekind >>= 1;
+ }
+ invokekind = DISPATCH_PROPERTYPUT;
+ }
+ else
+ {
+ if (m_pta->typekind == TKIND_DISPATCH || (m_pta->wTypeFlags & TYPEFLAG_FDUAL))
+ hr = reinterpret_cast<IDispatch*>(pUnk)->Invoke(dispid, IID_NULL, LOCALE_SYSTEM_DEFAULT, invokekind, &dp, &varResult, &ei, &ea);
+ else
+ hr = DispInvoke (pUnk, pti, dispid, invokekind, &dp, &varResult, &ei, &ea);
+ }
+
if (invokekind == DISPATCH_PROPERTYPUT) {
dp.rgdispidNamedArgs = NULL;
@@ -891,6 +899,29 @@ bool OptclObj::InvokeWithTypeInfVariant (Tcl_Interp *pInterp, long invokekind,
if (!RetrieveOutParams (pInterp, objc, objv, obp, dp))
return false;
+ if (ppResultInfo != NULL) {
+ // caller is requesting the typeinfo for the result
+ *ppResultInfo = NULL; // make sure that we definitely return a valid pointer
+ TYPEDESC * ptdesc = NULL;
+ switch (obp.m_dk) {
+ case DESCKIND_FUNCDESC:
+ ASSERT (obp.m_bp.lpfuncdesc != NULL);
+ ptdesc = & obp.m_bp.lpfuncdesc->elemdescFunc.tdesc;
+ break;
+ case DESCKIND_VARDESC:
+ ASSERT (obp.m_bp.lpvardesc != NULL);
+ ptdesc = & obp.m_bp.lpvardesc->elemdescVar.tdesc;
+ break;
+ }
+ // resolve any pointer types ...
+ while (ptdesc != NULL && ptdesc->vt == VT_PTR)
+ ptdesc = ptdesc->lptdesc;
+
+ // if we have a user defined type, return it!
+ if (ptdesc != NULL && ptdesc->vt == VT_USERDEFINED)
+ pti->GetRefTypeInfo (ptdesc->hreftype, ppResultInfo);
+
+ }
bOk = true;
}
}
@@ -920,17 +951,17 @@ bool OptclObj::InvokeWithTypeInfVariant (Tcl_Interp *pInterp, long invokekind,
*/
bool OptclObj::InvokeWithTypeInf (Tcl_Interp *pInterp, long invokekind,
int objc, Tcl_Obj *CONST objv[],
- IDispatch *pDisp, ITypeInfo *pti, ITypeComp *pCmp)
+ IUnknown *pUnk, ITypeInfo *pti, ITypeComp *pCmp)
{
VARIANT varResult;
VariantInit(&varResult);
TObjPtr presult;
-
+ CComPtr<ITypeInfo> pResultInfo;
bool bok;
- bok = InvokeWithTypeInfVariant (pInterp, invokekind, objc, objv, pDisp, pti, pCmp, varResult);
+ bok = InvokeWithTypeInfVariant (pInterp, invokekind, objc, objv, pUnk, pti, pCmp, varResult, &pResultInfo);
// set the result of the operation to the return value of the function
- if (bok && (bok = var2obj(pInterp, varResult, presult)))
+ if (bok && (bok = var2obj(pInterp, varResult, pResultInfo, presult)))
Tcl_SetObjResult (pInterp, presult);
VariantClear(&varResult);
return bok;
@@ -964,7 +995,7 @@ bool OptclObj::InvokeNoTypeInf( Tcl_Interp *pInterp, long invokekind,
bool bok;
if (bok = InvokeNoTypeInfVariant (pInterp, invokekind, objc, objv, pDisp, var)) {
- if (bok = var2obj(pInterp, var, presult))
+ if (bok = var2obj(pInterp, var, NULL, presult))
Tcl_SetObjResult (pInterp, presult);
VariantClear(&var);
}
@@ -1050,9 +1081,9 @@ bool OptclObj::InvokeNoTypeInfVariant ( Tcl_Interp *pInterp, long invokekind,
*-------------------------------------------------------------------------
*/
bool OptclObj::GetProp (Tcl_Interp *pInterp, Tcl_Obj *name,
- IDispatch *pdisp, ITypeInfo *pti, ITypeComp *ptc)
+ IUnknown *punk, ITypeInfo *pti, ITypeComp *ptc)
{
- ASSERT (pInterp != NULL && name != NULL && pdisp != NULL);
+ ASSERT (pInterp != NULL && name != NULL && punk != NULL);
TObjPtr params;
bool bok;
@@ -1070,10 +1101,10 @@ bool OptclObj::GetProp (Tcl_Interp *pInterp, Tcl_Obj *name,
if (pti != NULL) {
ASSERT (ptc != NULL);
- bok = InvokeWithTypeInf(pInterp, DISPATCH_PROPERTYGET, length, pplist, pdisp, pti, ptc);
+ bok = InvokeWithTypeInf(pInterp, DISPATCH_PROPERTYGET, length, pplist, punk, pti, ptc);
}
else {
- bok = InvokeNoTypeInf (pInterp, DISPATCH_PROPERTYGET, length, pplist, pdisp);
+ bok = InvokeNoTypeInf (pInterp, DISPATCH_PROPERTYGET, length, pplist, reinterpret_cast<IDispatch*>(punk));
}
free(pplist);
@@ -1097,9 +1128,9 @@ bool OptclObj::GetProp (Tcl_Interp *pInterp, Tcl_Obj *name,
*-------------------------------------------------------------------------
*/
bool OptclObj::GetIndexedVariant (Tcl_Interp *pInterp, Tcl_Obj *name,
- IDispatch *pdisp, ITypeInfo *pti, ITypeComp *ptc, VARIANT &varResult)
+ IUnknown *punk, ITypeInfo *pti, ITypeComp *ptc, VARIANT &varResult, ITypeInfo **ppResultInfo)
{
- ASSERT (pInterp != NULL && name != NULL && pdisp != NULL);
+ ASSERT (pInterp != NULL && name != NULL && punk != NULL);
ASSERT (varResult.vt == VT_EMPTY);
TObjPtr params;
@@ -1120,22 +1151,34 @@ bool OptclObj::GetIndexedVariant (Tcl_Interp *pInterp, Tcl_Obj *name,
if (pti != NULL) {
ASSERT (ptc != NULL);
- bok = InvokeWithTypeInfVariant (pInterp, invkind, length, pplist, pdisp, pti, ptc, varResult);
+ bok = InvokeWithTypeInfVariant (pInterp, invkind, length, pplist, punk, pti, ptc, varResult, ppResultInfo);
}
else {
- bok = InvokeNoTypeInfVariant (pInterp, invkind, length, pplist, pdisp, varResult);
+ bok = InvokeNoTypeInfVariant (pInterp, invkind, length, pplist, reinterpret_cast<IDispatch*>(punk), varResult);
}
free(pplist);
}
return bok;
}
+
+
+
+/*
+ *-------------------------------------------------------------------------
+ * OptclObj::SetProp --
+ * Called to get the value of a property or the return type of method, with
+ * Result:
+ * Side effects:
+ *-------------------------------------------------------------------------
+ */
+
bool OptclObj::SetProp (Tcl_Interp *pInterp,
int paircount, Tcl_Obj * CONST namevalues[],
- IDispatch *pdisp, ITypeInfo *pti, ITypeComp *ptc)
+ IUnknown *punk, ITypeInfo *pti, ITypeComp *ptc)
{
bool bok = true;
- ASSERT (pInterp != NULL && paircount > 0 && namevalues != NULL && pdisp != NULL);
+ ASSERT (pInterp != NULL && paircount > 0 && namevalues != NULL && punk != NULL);
for (int i = 0; bok && i < paircount; i++)
{
TObjPtr params;
@@ -1155,10 +1198,10 @@ bool OptclObj::SetProp (Tcl_Interp *pInterp,
if (pti != NULL) {
ASSERT (ptc != NULL);
- bok = InvokeWithTypeInf(pInterp, DISPATCH_PROPERTYPUT, length, pplist, pdisp, pti, ptc);
+ bok = InvokeWithTypeInf(pInterp, DISPATCH_PROPERTYPUT, length, pplist, punk, pti, ptc);
}
else {
- bok = InvokeNoTypeInf (pInterp, DISPATCH_PROPERTYPUT, length, pplist, pdisp);
+ bok = InvokeNoTypeInf (pInterp, DISPATCH_PROPERTYPUT, length, pplist, reinterpret_cast<IDispatch*>(punk));
}
namevalues += 2;
free(pplist);
@@ -1240,17 +1283,17 @@ bool OptclObj::GetPropVariantDispatch (Tcl_Interp *pInterp, const char*name,
*
*-------------------------------------------------------------------------
*/
-bool OptclObj::ResolvePropertyObject (Tcl_Interp *pInterp, const char *sname,
- IDispatch **ppdisp, ITypeInfo **ppinfo, ITypeComp **ppcmp /* = NULL*/)
+bool OptclObj::ResolvePropertyObject (Tcl_Interp *pInterp, const char *sname,
+ IUnknown **ppunk, ITypeInfo **ppinfo,
+ ITypeComp **ppcmp /* = NULL*/)
{
USES_CONVERSION;
- ASSERT (pInterp != NULL && ppdisp != NULL && sname != NULL);
+ ASSERT (pInterp != NULL && ppunk != NULL && sname != NULL);
// copy the string onto the stack
char * szname;
- char * seps = ".";
+ char * seps = "."; // seperators
char * szprop = NULL;
- _variant_t varobj;
- VARIANT varResult;
+
HRESULT hr;
@@ -1258,30 +1301,34 @@ bool OptclObj::ResolvePropertyObject (Tcl_Interp *pInterp, const char *sname,
TObjPtr plist;
TObjPtr pokstring;
+ // copy the command string
szname = (char*)_alloca (strlen (sname) + 1);
strcpy (szname, sname);
+
+ // tokenize on the dot
+ // warning: this section will *note* quoted seperators correctly
+ // ... *must* fix!
szprop = strtok(szname, seps);
- CComQIPtr <IDispatch> current;
+ CComPtr <IUnknown> current;
CComPtr <ITypeInfo> pti;
CComPtr <ITypeComp> pcmp;
- UINT typecount = 0;
+ UINT typecount = 0; // the total number of types in the type library
- current = m_pcurrent;
- pti = m_pti;
- pcmp = m_ptc;
+ current = m_pcurrent;
+ pti = m_pti;
+ pcmp = m_ptc;
pcmd.create();
- VariantInit (&varResult);
-
try {
while (szprop != NULL)
{
+ CComVariant varResult;
TObjPtr prop(szprop);
+ CComPtr<ITypeInfo> pResultInfo;
- VariantClear(&varResult);
- if (!GetIndexedVariant (pInterp, prop, current, pti, pcmp, varResult))
+ if (!GetIndexedVariant (pInterp, prop, current, pti, pcmp, varResult, &pResultInfo))
break;
// check that it's an object
@@ -1291,37 +1338,47 @@ bool OptclObj::ResolvePropertyObject (Tcl_Interp *pInterp, const char *sname,
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);
+ if (pResultInfo) {
+ // we have type information for this
+ pti = pResultInfo;
+ current = varResult.punkVal;
+ } else {
+ current.Release();
+ if (FAILED(varResult.punkVal->QueryInterface(IID_IDispatch, reinterpret_cast<void**>(¤t)))) {
+ Tcl_SetResult (pInterp, "unknown interface for '", TCL_STATIC);
+ Tcl_AppendResult (pInterp, szprop, "'", NULL);
+ break;
+ }
+ typecount = 0;
+ pti = NULL;
+
+
+ IDispatch *pdisp = reinterpret_cast<IDispatch*>(current.p);
+ pdisp->GetTypeInfoCount (&typecount);
+ if (typecount > 0) {
+ hr = pdisp->GetTypeInfo (0, LOCALE_SYSTEM_DEFAULT, &pti);
+ if (FAILED(hr))
+ throw hr;
+
}
- pti->GetTypeComp(&pcmp);
}
}
+
+ pcmp.Release();
+ g_libs.EnsureCached (pti);
+ pti->GetTypeComp(&pcmp);
- // get the next property
+ // get the next property - warning, doesn't work with quoted seperators
szprop = strtok(NULL, seps);
}
*ppinfo = pti.Detach();
*ppcmp = pcmp.Detach();
- *ppdisp = current.Detach ();
+ *ppunk = current.Detach ();
+ if (*ppunk == NULL)
+ Tcl_SetResult (pInterp, "value resolved to a null object", TCL_STATIC);
}
catch (HRESULT hr)
@@ -1333,8 +1390,7 @@ bool OptclObj::ResolvePropertyObject (Tcl_Interp *pInterp, const char *sname,
{
Tcl_SetResult (pInterp, error, TCL_STATIC);
}
- VariantClear(&varResult);
- return (szprop == NULL);
+ return (szprop == NULL && *ppunk != NULL);
}
@@ -1843,5 +1899,3 @@ void OptclObj::ContainerWantsToDie ()
if (!m_destroypending)
g_objmap.Delete(this);
}
-
-
diff --git a/src/OptclObj.h b/src/OptclObj.h
index 5d296f0..e80f7cb 100644
--- a/src/OptclObj.h
+++ b/src/OptclObj.h
@@ -32,6 +32,7 @@
// forward declarations of used classes
#include "container.h"
#include <string>
+#include "optcltypeattr.h"
class ObjMap;
class EventBindings;
@@ -51,7 +52,7 @@ public:
virtual ~OptclObj ();
bool Create (Tcl_Interp *pInterp, const char *strid, const char *windowpath, bool start);
- bool Attach (Tcl_Interp *pInterp, LPUNKNOWN punk);
+ bool Attach (Tcl_Interp *pInterp, LPUNKNOWN punk, ITypeInfo *pti = NULL);
operator LPUNKNOWN();
operator const char * ();
@@ -59,11 +60,12 @@ public:
void CoClassName (TObjPtr &pObj);
void InterfaceName (TObjPtr &pObj);
void SetInterfaceName (TObjPtr &pObj);
+ HRESULT SetInterfaceFromType (ITypeInfo *pinfo);
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 ResolvePropertyObject (Tcl_Interp *pInterp, const char *sname,
+ IUnknown **ppunk, ITypeInfo **ppinfo, ITypeComp **ppcmp);
bool GetBinding (Tcl_Interp *pInterp, char *name);
bool SetBinding (Tcl_Interp *pInterp, char *name, Tcl_Obj *command);
@@ -79,7 +81,6 @@ protected: // methods
void InitialisePointers (LPUNKNOWN punk, ITypeLib *pLib = NULL, ITypeInfo *pinfo = NULL);
void CreateCommand();
HRESULT InitialisePointersFromCoClass ();
- HRESULT SetInterfaceFromType (ITypeInfo *pinfo);
HRESULT GetTypeAttr();
void ReleaseTypeAttr();
void ReleaseBindingTable();
@@ -98,18 +99,19 @@ protected: // methods
bool InvokeWithTypeInfVariant (Tcl_Interp *pInterp, long invokekind,
int objc, Tcl_Obj *CONST objv[],
- IDispatch *pDisp, ITypeInfo *pti, ITypeComp *pCmp, VARIANT &varResult);
+ IUnknown *pUnk, ITypeInfo *pti, ITypeComp *pCmp,
+ VARIANT &varResult, ITypeInfo **ppResultInfo = NULL);
bool InvokeWithTypeInf (Tcl_Interp *pInterp, long ik, int objc, Tcl_Obj *CONST objv[],
- IDispatch *pDisp, ITypeInfo *pti, ITypeComp *pcmp);
+ IUnknown *pUnk, 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);
+ IUnknown *punk, ITypeInfo *pti, ITypeComp *ptc);
- bool GetProp (Tcl_Interp *pInterp, Tcl_Obj *name, IDispatch *pDisp, ITypeInfo *pti, ITypeComp *ptc);
+ bool GetProp (Tcl_Interp *pInterp, Tcl_Obj *name, IUnknown *punk, ITypeInfo *pti, ITypeComp *ptc);
bool GetIndexedVariant (Tcl_Interp *pInterp, Tcl_Obj *name,
- IDispatch *pdisp, ITypeInfo *pti, ITypeComp *ptc, VARIANT &varResult);
+ IUnknown *punk, ITypeInfo *pti, ITypeComp *ptc, VARIANT &varResult, ITypeInfo **ppResultInfo);
bool GetPropVariantDispatch (Tcl_Interp *pInterp, const char*name,
IDispatch * pcurrent, VARIANT &varResult);
@@ -121,14 +123,15 @@ protected: // methods
void ContainerWantsToDie ();
protected: // properties
- CComQIPtr<IDispatch> m_pcurrent; // Current interface
+ CComPtr<IUnknown> 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
-
+public:
+ OptclTypeAttr m_pta; // the type attribute for the current typeinfo
+protected:
std::string m_name;
unsigned long m_refcount; // reference count of this optcl object
Tcl_Interp * m_pInterp; // interpreter that created this object
diff --git a/src/Splitter.tcl b/src/Splitter.tcl
new file mode 100644
index 0000000..1de9d4d
--- /dev/null
+++ b/src/Splitter.tcl
@@ -0,0 +1,574 @@
+#----------------------------------------------------------------------
+# Splitter.tcl
+# Beautiful splitter, just the way mr fuzz likes it :-)
+# Proportional or fixed (on one of either two panes). One window
+# per splitter. Horizontal or vertical splits.
+#
+# Date First Completed: 2000.05.02
+# Last Updated: 2000.05.02
+# Author: fuzz@sys.uea.ac.uk
+#----------------------------------------------------------------------
+
+
+# Splitter --
+# Global level function to create a Splitter - delegates to the
+# Splitter::create namespace command. Requires the window
+# name followed by a collection of options
+proc Splitter {w args} {
+ return [eval Splitter::create $w $args]
+}
+
+# Namespace Splitter
+# Encapsulates the Splitter functionality
+namespace eval Splitter {
+
+ namespace import -force ::optcl_utils::*
+
+ # all splitter properties are held here
+ # indexing uses the window name followed by the property in the form $window-$property
+ variable properties
+
+ # _GetState --
+ # Retrieves state information regarding window w
+ # Actually all it does for now is bring the 'properties' variable into scope
+ proc _GetState {w} {
+ uplevel {
+ variable properties
+ set bar $w._splitbar
+ }
+ }
+
+
+ # create --
+ # Give a window name and a list of options, attempts to create a splitter widget
+ proc create {w args} {
+ _GetState $w
+ frame $w -width 200 -height 200 -relief flat -bd 0
+ set properties($w-position) 0.5
+ set properties($w-orientation) horizontal
+ set properties($w-windowA) {}
+ set properties($w-windowB) {}
+ set properties($w-barwidth) 8
+ set properties($w-type) prop
+ set properties($w-min) 0
+ set properties($w-max) -1
+
+ frame $bar -bd 1 -relief raised -width $properties($w-barwidth) -height $properties($w-barwidth) -cursor sb_v_double_arrow
+ bind $bar <ButtonPress-1> [namespace code "_StartDrag $w"]
+ bind $bar <ButtonRelease-1> [namespace code "_FinishDrag $w"]
+ try {
+ eval configure $w $args
+ } catch {er} {
+ destroy $w
+ throw $er
+ }
+ _UpdatePosition $w
+ rename ::$w [namespace current]::$w
+ proc ::$w {command args} "eval [namespace current]::_Dispatch $w \$command \$args"
+ eval ::$w configure $args
+ return $w
+ }
+
+ # _Dispatch --
+ # First port of call for the widget command. Attempts to find a suitable command
+ # (performing command completion), before dispatching the call.
+ proc _Dispatch {w command args} {
+ set cmd [info commands $command*]
+ if {$cmd == {}} {
+ throw "no such command: $command"
+ }
+ return [eval [lindex $cmd 0] $w $args]
+ }
+
+
+
+ # cget --
+ # retrieves the settings for this splitter or its underlying frame
+ proc cget {w option} {
+ _GetState $w
+ switch -- $option {
+ -orient {return $properties($w-orientation)}
+ -position {return $properties($w-position)}
+ -windowA {return $properties($w-windowA)}
+ -windowB {return $properties($w-windowB)}
+ -barwidth {return $properties($w-barwidth)}
+ -type {return $properties($w-type)}
+ -min {return $properties($w-min)}
+ -max {return $properties($w-max)}
+ default {return [$w cget $option]}
+ }
+ }
+
+
+ # configure --
+ # Performs basic widget (re)configuration. Defaults to the frame configuration command
+ # if option not found. Doesn't support option value query.
+ proc configure {w args} {
+ _GetState $w
+ if { [expr [llength $args] % 2] != 0 } {
+ throw "options must be in pairs"
+ }
+
+ set unhandled {}
+ set update 0
+
+ foreach {option value} $args {
+ switch -- $option {
+ -orient {
+ _SetOrientation $w $value
+ set update 1
+ }
+ -position {
+ set properties($w-position) $value;
+ set update 1
+ }
+ -windowA {
+ _SetWindow $w windowA $value
+ set update 1
+ }
+
+ -windowB {
+ _SetWindow $w windowB $value
+ set update 1
+ }
+ -barwidth {
+ set properties($w-barwidth) $value
+ set update 1
+ }
+ -type {
+ _SetType $w $value
+ set update 1
+ }
+ -min {
+ set properties($w-min) $value
+ if {$value > $properties($w-position)} {
+ set properties($w-position) $value
+ }
+ set update 1
+ }
+ -max {
+ set properties($w-max) $value
+ if {$value < $properties($w-position) && $value >= 0} {
+ set properties($w-position) $value
+ }
+ }
+ default {lappend unhandled $option $value}
+ }
+
+ if {$unhandled != {}} {
+ eval $w config $unhandled
+ set update 1
+ }
+
+ if {$update} {
+ _UpdatePosition $w
+ }
+ }
+ }
+
+ # _UpdatePosition --
+ # This is the main proc for setting up the visual representation of the splitter
+ proc _UpdatePosition {w} {
+ _GetState $w
+ _UpdateBar $w
+ switch $properties($w-orientation) {
+ horizontal {
+ _UpdatePositionHorizontal $w
+ }
+ vertical {
+ _UpdatePositionVertical $w
+ }
+ }
+ }
+
+
+ # _UpdatePositionHorizontal --
+ # Called to set window A and B when split is horizontal
+ proc _UpdatePositionHorizontal {w} {
+ _GetState $w
+ set height [winfo height $w]
+ set pos $properties($w-position)
+
+ if {$properties($w-type) != "prop"} {
+ if {$pos < 0} {
+ set pos 0
+ } elseif {$pos > $height} {
+ set pos $height
+ }
+ }
+ set hbw [expr $properties($w-barwidth) / 2]
+ switch $properties($w-type) {
+ prop {
+ if {$properties($w-windowA) != {} && [winfo exists $properties($w-windowA)]} {
+ place $properties($w-windowA) -in $w -x 0 -y 0 -relx 0 -rely 0 -relheight $pos -relwidth 1.0 -height [expr -$hbw] -width 0
+ }
+ if {$properties($w-windowB) != {} && [winfo exists $properties($w-windowB)]} {
+ place $properties($w-windowB) -in $w -y $hbw -x 0 -rely $pos -relx 0 -relwidth 1.0 -relheight [expr 1.0 - $pos] -height [expr -$hbw] -width 0
+ }
+ }
+ fixA {
+ if {$properties($w-windowA) != {} && [winfo exists $properties($w-windowA)]} {
+ place $properties($w-windowA) -in $w -y 0 -x 0 -rely 0 -relx 0 -relwidth 1.0 -relheight 0 -height [expr $pos - $hbw] -width 0
+ }
+ if {$properties($w-windowB) != {} && [winfo exists $properties($w-windowB)]} {
+ place $properties($w-windowB) -in $w -y [expr $properties($w-position) + $hbw] -x 0 -rely 0 -relx 0 -relwidth 1.0 -relheight 0 -height [expr $height - $pos - $hbw] -width 0
+ }
+ }
+ fixB {
+ if {$properties($w-windowA) != {} && [winfo exists $properties($w-windowA)]} {
+ place $properties($w-windowA) -in $w -y 0 -x 0 -rely 0 -relx 0 -relwidth 1.0 -relheight 0 -height [expr $height - $pos - $hbw] -width 0
+ }
+ if {$properties($w-windowB) != {} && [winfo exists $properties($w-windowB)]} {
+ place $properties($w-windowB) -in $w -y [expr $height - $pos + $hbw] -x 0 -rely 0 -relx 0 -relwidth 1.0 -relheight 0 -height [expr $pos - $hbw] -width 0
+ }
+ }
+ }
+ }
+
+
+
+ # _UpdatePositionVertical --
+ # Called to place window A and B when split is vertical
+ proc _UpdatePositionVertical {w} {
+ _GetState $w
+ set width [winfo width $w]
+ set pos $properties($w-position)
+ if {$properties($w-type) != "prop"} {
+ if {$pos < 0} {
+ set pos 0
+ } elseif {$pos > $width} {
+ set pos $width
+ }
+ }
+ set hbw [expr $properties($w-barwidth) / 2]
+ switch $properties($w-type) {
+ prop {
+ if {$properties($w-windowA) != {} && [winfo exists $properties($w-windowA)]} {
+ place $properties($w-windowA) -in $w -x 0 -y 0 -relx 0 -rely 0 -relheight 1.0 -relwidth $pos -width [expr -$hbw] -height 0
+ }
+ if {$properties($w-windowB) != {} && [winfo exists $properties($w-windowB)]} {
+ place $properties($w-windowB) -in $w -x $hbw -y 0 -relx $pos -rely 0 -relheight 1.0 -relwidth [expr 1.0 - $pos] -width [expr -$hbw] -height 0
+ }
+ }
+ fixA {
+ if {$properties($w-windowA) != {} && [winfo exists $properties($w-windowA)]} {
+ place $properties($w-windowA) -in $w -x 0 -y 0 -relx 0 -rely 0 -relheight 1.0 -relwidth 0 -width [expr $pos - $hbw] -height 0
+ }
+ if {$properties($w-windowB) != {} && [winfo exists $properties($w-windowB)]} {
+ place $properties($w-windowB) -in $w -x [expr $pos + $hbw] -y 0 -relx 0 -rely 0 -relheight 1.0 -relwidth 0 -width [expr $width - $pos - $hbw] -height 0
+ }
+ }
+ fixB {
+ if {$properties($w-windowA) != {} && [winfo exists $properties($w-windowA)]} {
+ place $properties($w-windowA) -in $w -x 0 -y 0 -relx 0 -rely 0 -relheight 1.0 -relwidth 0 -width [expr $width - $pos - $hbw] -height 0
+ }
+ if {$properties($w-windowB) != {} && [winfo exists $properties($w-windowB)]} {
+ place $properties($w-windowB) -in $w -x [expr $width - $pos + $hbw] -y 0 -relx 0 -rely 0 -relheight 1.0 -relwidth 0 -width [expr $pos - $hbw] -height 0
+ }
+ }
+ }
+ }
+
+
+ # _UpdateBar --
+ # Main proc for the visual setting of the split bar.
+ proc _UpdateBar {w} {
+ _GetState $w
+
+ switch $properties($w-orientation) {
+ horizontal {
+ _UpdateBarHorizontal $w
+ }
+ vertical {
+ _UpdateBarVertical $w
+ }
+ }
+ }
+
+ # _UpdateBarHorizontal --
+ # Called to set the bar when the split is horizontal
+ proc _UpdateBarHorizontal {w} {
+ _GetState $w
+ set bd [$w cget -bd]
+
+ if {$bd >= 1} {
+ $bar config -bd $bd
+ } else {
+ set bd 1
+ }
+
+ set height [winfo height $w]
+ set pos $properties($w-position)
+ if {$properties($w-type) != "prop"} {
+ if {$pos < 0} {
+ set pos 0
+ } elseif {$pos > $height} {
+ set pos $height
+ }
+ }
+
+ switch $properties($w-type) {
+ prop {
+ place $bar -y 0 -rely $pos -x [expr -2*$bd] -relx 0 -height $properties($w-barwidth) -relheight 0 -width [expr 4 * $bd] -relwidth 1.0 -anchor w
+ }
+ fixA {
+ place $bar -y $pos -rely 0 -x [expr -2*$bd] -relx 0 -height $properties($w-barwidth) -relheight 0 -width [expr 4 * $bd] -relwidth 1.0 -anchor w
+ }
+ fixB {
+ place $bar -y [expr $height - $pos] -rely 0 -x [expr -2*$bd] -relx 0 -height $properties($w-barwidth) -relheight 0 -width [expr 4 * $bd] -relwidth 1.0 -anchor w
+ }
+ }
+ }
+
+ # _UpdateBarVertical --
+ # Called to set the bar when split is vertical.
+ proc _UpdateBarVertical {w} {
+ _GetState $w
+ set bd [$w cget -bd]
+
+ if {$bd >= 1} {
+ $bar config -bd $bd
+ } else {
+ set bd 1
+ }
+
+ set width [winfo width $w]
+ set pos $properties($w-position)
+ if {$properties($w-type) != "prop"} {
+ if {$pos < 0} {
+ set pos 0
+ } elseif {$pos > $width} {
+ set pos $width
+ }
+ }
+
+ switch $properties($w-type) {
+ prop {
+ place $bar -x 0 -relx $pos -y [expr -2*$bd] -rely 0 -width $properties($w-barwidth) -relwidth 0 -height [expr 4 * $bd] -relheight 1.0 -anchor n
+ }
+ fixA {
+
+ place $bar -x $pos -relx 0 -y [expr -2*$bd] -rely 0 -width $properties($w-barwidth) -relwidth 0 -height [expr 4 * $bd] -relheight 1.0 -anchor n
+ }
+ fixB {
+ place $bar -x [expr $width - $pos] -relx 0 -y [expr -2*$bd] -rely 0 -width $properties($w-barwidth) -relwidth 0 -height [expr 4 * $bd] -relheight 1.0 -anchor n
+ }
+ }
+ }
+
+
+ # destroy --
+ # Proc to destroy this object
+ proc destroy {w} {
+ _GetState $w
+ destroy $w
+ }
+
+ # _SetOrientation --
+ # Called to set the orientation (vertical or horizontal) on this splitter.
+ proc _SetOrientation {w orientation} {
+ _GetState $w
+ if {![regexp ^(vertical|horizontal)$ $orientation]} {
+ throw "bad orientation - should be either horizontal or vertical"
+ }
+ set properties($w-orientation) $orientation
+
+ if {[string match $orientation "vertical"]} {
+ $bar config -cursor sb_h_double_arrow
+ } else {
+ $bar config -cursor sb_v_double_arrow
+ }
+ }
+
+ # _SetWindow --
+ # Called to set the window for pane A or B.
+ # w is the splitter window. winX is either windowA or windowB
+ # child is the child-window to be placed.
+ proc _SetWindow {w winX child} {
+ _GetState $w
+ if {$properties($w-$winX) != {} && [winfo exists $properties($w-$winX)]} {
+ place forget $properties($w-$winX)
+ }
+ if {$child != {}} {
+ lower $child $bar
+ }
+ set properties($w-$winX) $child
+ }
+
+ # _StartDrag --
+ # Called when the user clicks on the bar.
+ proc _StartDrag {w} {
+ _GetState $w
+ # create a proxy
+ set proxy [frame $w._proxysplitbar -bd [$bar cget -bd] -relief raised]
+ eval place $proxy [place info $bar]
+ lower $proxy $bar
+ focus $bar
+ bind $bar <Motion> [namespace code "_Move $w %X %Y"]
+ bind $bar <KeyPress-Escape> [namespace code "set properties($w-position) $properties($w-position); _FinishDrag $w"]
+ }
+
+ # _FinishDrag --
+ # Called when the user releases the mouse button from the bar.
+ proc _FinishDrag {w} {
+ _GetState $w
+ bind $bar <Motion> {}
+ bind $bar <KeyPress-Escape> {}
+ _UpdatePosition $w
+ ::destroy $w._proxysplitbar
+ }
+
+ # _Move --
+ # Called when
+ proc _Move {w x y} {
+ _GetState $w
+
+ if {$properties($w-type) == "prop"} {
+ set x [expr double($x - [winfo rootx $w] + 2) / double([winfo width $w])]
+ set y [expr double($y - [winfo rooty $w] + 2) / double([winfo height $w])]
+
+ if {$x < 0.0} {
+ set x 0.0
+ } elseif {$x > 1.0} {
+ set x 1.0
+ }
+
+ if {$y < 0.0} {
+ set y 0.0
+ } elseif {$y > 1.0} {
+ set y 1.0
+ }
+ } elseif {$properties($w-type) == "fixA"} {
+ set x [expr $x - [winfo rootx $w]]
+ set y [expr $y - [winfo rooty $w]]
+ } else {
+ set x [expr [winfo width $w] - ($x - [winfo rootx $w])]
+ set y [expr [winfo height $w] - ($y - [winfo rooty $w])]
+ }
+ if {$x < $properties($w-min)} {
+ set x $properties($w-min)
+ } elseif {$x > $properties($w-max) && $properties($w-max) >= 0} {
+ set x $properties($w-max)
+ }
+ if {$y < $properties($w-min)} {
+ set y $properties($w-min)
+ } elseif {$y > $properties($w-max) && $properties($w-max) >= 0} {
+ set y $properties($w-max)
+ }
+
+ switch $properties($w-orientation) {
+ horizontal {set properties($w-position) $y}
+ vertical {set properties($w-position) $x}
+ }
+
+ _UpdateBar $w
+ }
+
+ proc _SetType {w value} {
+ _GetState $w
+ if {![regexp {^(fixA)|(fixB)|(prop)$} $value]} {
+ throw "bad position type '$value': should be fixA, fixB or prop"
+ }
+
+
+ if {![string match $properties($w-type) $value]} {
+
+ if {[string match $properties($w-orientation) "vertical"]} {
+ set d [winfo width $w]
+ } else {
+ set d [winfo height $w]
+ }
+
+
+ if {$properties($w-type) == "prop"} {
+ # going from prop to fix*
+ set v [expr int(double($d) * $properties($w-position))]
+ set min [expr int(double($d) * $properties($w-min))]
+ set max [expr int(double($d) * $properties($w-max))]
+ if {$value == "fixB"} {
+ set v [expr $d - $v]
+ set min [expr $d - $min]
+ set max [expr $d - $max]
+ }
+ set properties($w-position) $v
+ set properties($w-min) $min
+ if {$properties($w-max) >= 0} {
+ set properties($w-max) $max
+ }
+ } elseif { ($value == "fixA" && $properties($w-type) == "fixB") ||
+ ($value == "fixB" && $properties($w-type) == "fixA") } {
+ # going from fixA to fixB or vice versa
+ set properties($w-position) [expr $d - $properties($w-position)]
+ set properties($w-min) [expr $d - $properties($w-min)]
+ if {$properties($w-max) >= 0} {
+ set properties($w-max) [expr $d - $properties($w-max)]
+ }
+ } else {
+ # going from fix* to prop
+ if {$properties($w-type) == "fixB"} {
+ set properties($w-position) [expr $d - $properties($w-position)]
+ set properties($w-min) [expr $d - $properties($w-min)]
+ if {$properties($w-max) >= 0} {
+ set properties($w-max) [expr $d - $properties($w-max)]
+ }
+ }
+ set properties($w-position) [expr double($properties($w-position)) / double($d)]
+ set properties($w-min) [expr double($properties($w-min)) / double($d)]
+ if {$properties($w-max) >= 0} {
+ set properties($w-max) [expr double($properties($w-max)) / double($d)]
+ }
+ }
+ set properties($w-type) $value
+ }
+
+
+ if {$value == "prop"} {
+ # we're not interested in window resize events any more
+ bind $w <Configure> {}
+ } else {
+ # bind to Configure event to watch window size changes
+ bind $w <Configure> [namespace code {_OnConfigure %W}]
+ }
+ }
+
+ proc _OnConfigure {w} {
+ _UpdatePosition $w
+ }
+
+}
+set type prop
+
+proc MakeHorizontal {w b} {
+ $w config -orient horizontal
+ $b config -command [namespace code "MakeVertical $w $b"]
+}
+
+proc MakeVertical {w b} {
+ $w config -orient vertical
+ $b config -command [namespace code "MakeHorizontal $w $b"]
+}
+
+proc ChangeType {w} {
+ variable type
+ $w config -type $type
+}
+
+if {0} {
+frame .f -bd 2 -relief groove
+pack .f -side bottom -fill x
+button .f.orient -text H/V -width 5 -command [namespace code "MakeVertical .s .f.orient"]
+checkbutton .f.prop -text prop -variable type -onvalue prop -indicatoron 0 -width 5 -command [namespace code "ChangeType .s"]
+checkbutton .f.fixA -text fixA -variable type -onvalue fixA -indicatoron 0 -width 5 -command [namespace code "ChangeType .s"]
+checkbutton .f.fixB -text fixB -variable type -onvalue fixB -indicatoron 0 -width 5 -command [namespace code "ChangeType .s"]
+pack .f.orient .f.prop .f.fixA .f.fixB -side left
+
+Splitter .s -orient horizontal -type fixB -min 40
+pack .s -fill both -expand 1
+Splitter .s.l1 -orient vertical -type fixA -position 100
+label .s.l2 -text Two -bg green
+.s config -windowA .s.l1 -windowB .s.l2
+label .s.l1.l1 -text One.One -bg red
+label .s.l1.l2 -text One.Two -bg blue -fg white
+.s.l1 config -windowA .s.l1.l1 -windowB .s.l1.l2
+console show
+}
\ No newline at end of file
diff --git a/src/TLView.tcl b/src/TLView.tcl
new file mode 100644
index 0000000..4f0c673
--- /dev/null
+++ b/src/TLView.tcl
@@ -0,0 +1,1380 @@
+#--------------------------------------------------------------------
+# File: TLView.tcl
+# Implements the GUI for Type Library management
+# Author: Farzad Pezeshkpour fuzz@sys.uea.ac.uk
+# Date: May 25th 2000
+#--------------------------------------------------------------------
+
+image create bitmap ::tlview::downarrow_img -data {
+ #define down_arrow_width 12
+ #define down_arrow_height 12
+ static char down_arrow_bits[] = {
+ 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,
+ 0xfc,0xf1,0xf8,0xf0,0x70,0xf0,0x20,0xf0,
+ 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00;
+ }
+}
+image create bitmap ::tlview::leftarrow_img -data {
+ #define left_width 12
+ #define left_height 12
+ static unsigned char down_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x80, 0x00, 0xc0, 0x00, 0xe0, 0x00, 0xf0, 0x00,
+ 0xe0, 0x00, 0xc0, 0x00, 0x80, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 };
+}
+
+image create bitmap ::tlview::rightarrow_img -data {
+ #define right_width 12
+ #define right_height 12
+ static unsigned char right_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
+ 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 };
+}
+
+image create bitmap ::tlview::find_img -data {
+ #define find_width 17
+ #define find_height 17
+ static char find_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x70, 0x1c, 0x00, 0x50, 0x1c, 0x00,
+ 0x50, 0x1c, 0x00, 0x70, 0x1c, 0x00, 0xf8, 0x3e, 0x00, 0xe8, 0x3a, 0x00,
+ 0xfc, 0x7f, 0x00, 0x7e, 0xfb, 0x00, 0x7e, 0xfb, 0x00, 0xfe, 0xfb, 0x00,
+ 0xfe, 0xfe, 0x00, 0x3a, 0xe8, 0x00, 0x3a, 0xe8, 0x00, 0x3e, 0xf8, 0x00,
+ 0x3e, 0xf8, 0x00, 0x00, 0x00, 0x00;
+ }
+}
+
+image create bitmap ::tlview::show_img -data {
+ #define show_width 17
+ #define show_height 17
+ static char show_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x10, 0x08, 0x00, 0x20, 0x04, 0x00, 0x40, 0x02, 0x00,
+ 0x80, 0x01, 0x00, 0x10, 0x08, 0x00, 0x20, 0x04, 0x00, 0x40, 0x02, 0x00,
+ 0x80, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00
+ };
+}
+image create bitmap ::tlview::hide_img -data {
+ #define hide_width 17
+ #define hide_height 17
+ static char hide_bits[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x80, 0x01, 0x00, 0x40, 0x02, 0x00, 0x20, 0x04, 0x00, 0x10, 0x08, 0x00,
+ 0x80, 0x01, 0x00, 0x40, 0x02, 0x00, 0x20, 0x04, 0x00, 0x10, 0x08, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00
+ };
+}
+
+image create photo ::tlview::class_img -file [file join $env(OPTCL_LIBRARY) images class.gif]
+image create photo ::tlview::interface_img -file [file join $env(OPTCL_LIBRARY) images interface.gif]
+image create photo ::tlview::dispatch_img -file [file join $env(OPTCL_LIBRARY) images dispatch.gif]
+image create photo ::tlview::module_img -file [file join $env(OPTCL_LIBRARY) images module.gif]
+image create photo ::tlview::struct_img -file [file join $env(OPTCL_LIBRARY) images struct.gif]
+image create photo ::tlview::union_img -file [file join $env(OPTCL_LIBRARY) images union.gif]
+image create photo ::tlview::enum_img -file [file join $env(OPTCL_LIBRARY) images enum.gif]
+image create photo ::tlview::typedef_img -file [file join $env(OPTCL_LIBRARY) images typedef.gif]
+image create photo ::tlview::property_img -file [file join $env(OPTCL_LIBRARY) images property.gif]
+image create photo ::tlview::method_img -file [file join $env(OPTCL_LIBRARY) images method.gif]
+image create photo ::tlview::copy_img -file [file join $env(OPTCL_LIBRARY) images copy.gif]
+image create photo ::tlview::select_img -file [file join $env(OPTCL_LIBRARY) images select.gif]
+image create photo ::tlview::noselect_img -file [file join $env(OPTCL_LIBRARY) images noselect.gif]
+image create photo ::tlview::libselect_img -file [file join $env(OPTCL_LIBRARY) images libselect.gif]
+
+
+namespace eval tlview {
+ namespace import -force ::optcl_utils::*
+
+ catch {font delete tlviewertext}
+ catch {font delete tlviewerhigh}
+ catch {font delete tlviewerbold}
+ catch {font delete tlvieweritalic}
+
+ font create tlviewertext -family Arial -size 9
+ font create tlviewerhigh -family Arial -size 9 -weight bold
+ font create tlviewerbold -family Arial -size 9 -weight bold
+ font create tlvieweritalic -family Arial -size 9 -slant italic
+
+ variable colors
+
+ set colors(bgcolor) SystemWindow
+ set colors(textcolor) SystemWindowText
+ set colors(highlightcolor) blue
+ set colors(selectcolor) red
+ set colors(labelcolor) brown
+
+ variable navigation_history
+ variable search_history
+ variable properties
+ variable libs
+
+ array set viewedtypes {}
+ array set navigation_history {}
+ array set search_history {}
+ array set properties {}
+ array set libs {}
+
+
+ proc TlviewScrolledListBox {w args} {
+ return [eval TlviewScrolledListBox::create $w $args]
+ }
+
+
+
+
+ namespace eval TlviewScrolledListBox {
+ proc create {w args} {
+ frame $w
+ label $w.label -text {}
+ scrollbar $w.h -orient horizontal -command [namespace code "$w.listbox xview"]
+ scrollbar $w.v -orient vertical -command [namespace code "$w.listbox yview"]
+ ImageListBox $w.listbox -yscrollcommand "$w.v set" -xscrollcommand "$w.h set"
+ grid $w.label -col 0 -row 0 -sticky nw
+ grid $w.listbox -col 0 -row 1 -sticky nsew
+ grid $w.v -col 1 -row 1 -sticky ns
+ grid $w.h -col 0 -row 2 -sticky ew
+ grid columnconfigure $w 0 -weight 1
+ grid rowconfigure $w 1 -weight 1
+ return $w
+ }
+ }
+
+
+ namespace eval TlviewPopup {
+ variable popupstate
+
+ proc Create {w} {
+ toplevel $w
+ wm withdraw $w
+ wm overrideredirect $w 1
+ return $w
+ }
+
+ proc Show {w x y} {
+
+ set parent [winfo parent $w]
+ wm geometry $w [join [list +$x $y] +]
+ wm deiconify $w
+ wm transient $w [winfo toplevel $w]
+
+ #raise $w $parent
+ #focus -force $w
+ bind $w <ButtonPress-1> [namespace code "Click $w %W"]
+ bind $w <KeyPress-Escape> "destroy $w"
+ bind $w <FocusOut> "destroy $w"
+ grab $w
+ return $w
+ }
+
+ proc Click {pw w} {
+ if {[string compare $pw $w] == 0} {
+ destroy $pw
+ }
+ }
+ }
+
+
+
+
+ namespace eval ScrolledList {
+ proc Create {w {callback {}}} {
+ frame $w -borderwidth 0 -highlightthickness 1 -highlightbackground black
+ listbox $w.lb -yscrollcommand "$w.s set" -borderwidth 0 -relief flat -background SystemWindow -fg SystemWindowText -highlightthickness 0 -height 5
+ bind $w.lb <ButtonRelease-1> [namespace code "OnSelect $w.lb $callback"]
+ scrollbar $w.s -orient vertical -command "$w.lb yview"
+ pack $w.s -side right -fill y
+ pack $w.lb -side left -fill both -expand 1
+ return $w
+ }
+
+ proc OnSelect {w args} {
+ set cs [$w curselection]
+ if {$cs != {}} {
+ if {$args != {}} {
+ eval $args [$w get $cs]
+ }
+ after 50 "destroy [winfo toplevel $w]"
+ }
+ }
+ }
+
+
+
+
+ namespace eval TlViewDropList {
+ proc Create {w contents callback} {
+ ::tlview::TlviewPopup::Create $w
+ set sl [::tlview::ScrolledList::Create $w.sl $callback]
+ eval $sl.lb insert end $contents
+ pack $sl -fill both -expand 1
+ }
+
+ proc Show {w x y} {
+ ::tlview::TlviewPopup::Show $w $x $y
+ }
+ }
+
+ namespace eval TlviewCombo {
+ proc Ondropdown {w contentsfn} {
+ set x [winfo rootx $w]
+ set y [expr [winfo rooty $w] + [winfo height $w]]
+ set contents [eval $contentsfn]
+ ::tlview::TlViewDropList::Create $w.dropdown $contents [namespace code "Callback $w"]
+
+ set height [winfo reqheight $w.dropdown.sl.lb]
+ set width [winfo width $w]
+ wm geometry $w.dropdown [join "$width $height" x]
+ if {[expr $y + $height + 20] >= [winfo screenheight $w.dropdown]} {
+ set y [expr [winfo rooty $w] - $height]
+ }
+ ::tlview::TlViewDropList::Show $w.dropdown $x $y
+ }
+
+ proc Create {w contents args} {
+ frame $w -borderwidth 2 -relief sunken -height 10
+ eval entry $w.e -borderwidth 0 -relief flat -font {{arial 8}} $args
+ label $w.b -image ::tlview::downarrow_img -font {arial 8} -borderwidth 1 -relief raised
+ pack $w.b -side right -fill y
+ pack $w.e -side left -fill both -expand 1
+
+ bind $w.b <ButtonPress-1> [namespace code [list Ondropdown $w $contents]]
+ bind $w.e <KeyPress-Down> [namespace code [list Ondropdown $w $contents]]
+ return $w
+ }
+
+
+ proc Callback {w value} {
+ set state [$w.e cget -state]
+ $w.e config -state normal
+ $w.e delete 0 end
+ $w.e insert end $value
+ $w.e config -state $state
+ }
+ }
+
+
+
+
+
+
+
+ proc search_history_add {w item} {
+ variable search_history
+ set pairs [array get search_history $w]
+ if {$pairs == {}} {
+ set search_history($w) $item
+ return
+ }
+
+ set searches [lindex $pairs 1]
+ set found [lsearch $searches $item]
+ if {$found >= 0} {
+ set searches [concat $item [lreplace $searches $found $found]]
+ } else {
+ set searches [concat $item $searches]
+ }
+ set search_history($w) $searches
+ }
+
+ proc search_history_getlist {w} {
+ variable search_history
+ set pairs [array get search_history $w]
+ if {$pairs == {}} {
+ return ""
+ } else {
+ return [lindex $pairs 1]
+ }
+ }
+
+ proc history_init {w} {
+ variable navigation_history
+
+ set navigation_history($w) {}
+ set navigation_history($w-index) -1
+ set navigation_history($w-changing) 0
+ }
+
+ proc history_erase {w} {
+ variable navigation_history
+ array unset navigation_history $w
+ array unset navigation_history $w-*
+ }
+
+ proc history_add {w lib {type {}} {elem {}}} {
+ variable navigation_history
+
+ if {[history_locked? $w]} return
+
+ set index $navigation_history($w-index)
+ set history [lrange $navigation_history($w) 0 $index]
+
+
+ # check that this isn't already the current item
+ set lastitem [lindex $history end]
+ if { [string match [lindex $lastitem 0] $lib] &&
+ [string match [lindex $lastitem 1] $type] &&
+ [string match [lindex $lastitem 2] $elem]} {
+
+ # we'll just quietly return
+ return
+ }
+
+ lappend history [list $lib $type $elem]
+ set navigation_history($w) $history
+ incr navigation_history($w-index)
+ viewlib_updatenav $w
+ }
+
+ proc history_addwindowstate {w} {
+ variable properties
+ history_add $w $properties($w-viewedlibrary) $properties($w-type) $properties($w-element)
+ }
+
+ proc history_back {w} {
+ variable navigation_history
+ if {![history_back? $w]} return
+
+ incr navigation_history($w-index) -1
+ history_current $w
+ }
+
+ proc history_forward {w} {
+ variable navigation_history
+ if {![history_forward? $w]} return
+ incr navigation_history($w-index)
+ history_current $w
+ }
+
+ proc history_current {w} {
+ variable navigation_history
+ history_lock $w
+ set item [lindex $navigation_history($w) $navigation_history($w-index)]
+ tlview::viewlib_select $w [lindex $item 0] [lindex $item 1] [lindex $item 2]
+ viewlib_updatenav $w
+ history_unlock $w
+ }
+
+ proc history_last {w} {
+ variable navigation_history
+ set navigation_history($w-index) [expr [llength navigation_history($w) - 1]
+ history_current $w
+ }
+
+ proc history_back? {w} {
+ variable navigation_history
+ return [expr $navigation_history($w-index) > 0]
+ }
+
+ proc history_forward? {w} {
+ variable navigation_history
+ return [expr $navigation_history($w-index) < ([llength $navigation_history($w)] - 1)]
+ }
+
+ proc history_lock {w} {
+ variable navigation_history
+ incr navigation_history($w-changing)
+ }
+
+ proc history_unlock {w} {
+ variable navigation_history
+ if {[incr navigation_history($w-changing) -1] < 0} {
+ set navigation_history($w-changing) 0
+ }
+ }
+
+ proc history_locked? {w} {
+ variable navigation_history
+ return [expr $navigation_history($w-changing) > 0]
+ }
+
+ proc history_clean {} {
+ variable navigation_history
+ set loadedlibs [typelib::loadedlibs]
+
+ foreach item [array names navigation_history] {
+ if {[regexp -- - $item]} continue
+
+ if {![winfo exists $item]} {
+ history_erase $item
+ continue
+ }
+
+ set newhistory {}
+ foreach history_item $navigation_history($item) {
+ set lib [lindex $history_item 0]
+ if {[lsearch -exact $loadedlibs $lib] >= 0} {
+ lappend newhistory $history_item
+ }
+ }
+ set navigation_history($item) $newhistory
+ if {$navigation_history($item-index) >= [llength $newhistory]} {
+ set navigation_history($item-index) [expr [llength $newhistory] - 1]
+ }
+ set history_item [lindex $newhistory $navigation_history($item-index)]
+ history_lock $item
+ viewlib_select $item [lindex $history_item 0] [lindex $history_item 1] [lindex $history_item 2] false
+ history_unlock $item
+ }
+ }
+
+ #------------------------------------------------------------------------------
+ proc scrltxt {w {sb {x y}}} {
+ variable colors
+
+ frame $w -bd 2 -relief sunken;
+
+ text $w.t -bg $colors(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;
+ return $w
+ }
+
+
+
+
+
+ proc libs {w} {
+ toplevel $w -class TLLoadedTypeLibs -height 250 -width 450
+ wm transient $w [winfo parent $w]
+ wm title $w "Referenced Type Libraries"
+
+ grab set $w
+
+ set closecmd "destroy $w"
+ set browsecmd "[namespace current]::libs_browse $w"
+ set savecmd {puts [typelib::persistLoaded]}
+ button $w.close -text Close -padx 5 -underline 0 -width 10 -command $closecmd
+ place $w.close -anchor ne -relx 1.0 -x -10 -y 10
+
+ button $w.browse -text "Browse ..." -padx 5 -underline 0 -width 10 -command $browsecmd
+ place $w.browse -anchor ne -relx 1.0 -x -10 -y 50
+
+ button $w.save -text "Save" -padx 5 -underline 0 -width 10 -command $savecmd
+ place $w.save -anchor ne -relx 1.0 -x -10 -y 90
+
+
+ set liblist [::tlview::TlviewScrolledListBox $w.liblist]
+ $liblist config -bd 2 -relief sunken
+
+ destroy $liblist.label
+
+ label $w.label1 -text "Available Libraries:"
+ place $w.label1 -anchor nw -x 10 -y 10
+
+
+ set lb $liblist.listbox
+ $lb config -spacing1 3 -takefocus 1
+ place $w.liblist -anchor nw -x 10 -y 30 -relheight 1.0 -height -100 -relwidth 1.0 -width -120
+
+ frame $w.details -bd 2 -relief groove
+ place $w.details -anchor sw -x 10 -rely 1.0 -y -10 -height 50 -relwidth 1.0 -width -20
+ label $w.details_label -text {Lib Details}
+ place $w.details_label -anchor nw -x 15 -rely 1.0 -y [expr -60 - [winfo reqheight $w.details_label] / 2]
+
+ label $w.details.path -text "Path: " -justify left -font {Arial 8 {}}
+ place $w.details.path -anchor nw -x 5 -y 10
+
+ bind $lb <Double-ButtonPress-1> [namespace code "libs_ondblselect $w %x %y; break;"]
+ bind $lb <<Select>> [namespace code "libs_onselect $w"]
+
+ bind $lb <B1-Motion> {break;}
+ bind $lb <KeyPress> [namespace code "libs_onkeypress $w %K; continue"]
+
+ bind $lb <KeyPress-space> [namespace code "libs_onenterkey $w"]
+
+
+ bind $lb <Alt-c> "$closecmd; break"
+ bind $lb <Alt-b> $browsecmd
+ bind $lb <Alt-s> $savecmd
+
+ bind $lb <Escape> $closecmd
+ bind $lb <KeyPress-Return> $closecmd
+ bind $w <Destroy> [namespace code "libs_close %W $w"]
+
+ focus $lb
+ $lb activate 0
+ $lb selection set 0
+
+ wm geometry $w 600x300
+ wm minsize $w 600 300
+ optcl_utils::center_window $w
+ libs_update $w
+
+ return $w
+ }
+
+ proc libs_close {W w} {
+ if {[string match $w $W]} {
+ viewlib_clean
+ }
+ }
+
+ proc libs_update {w} {
+ variable libs
+ set libs($w) {}
+
+ set loaded {}
+ set notloaded {}
+ set loadednames {}
+ set notloadednames {}
+ $w.liblist.listbox delete 0 end
+
+ foreach lib [array names ::typelib::typelibraries] {
+ mset {guid maj min} $lib
+ mset {name path} $typelib::typelibraries($lib)
+ if {[typelib::isloaded $guid $maj $min] != {}} {
+ lappend loaded [list $name $guid $maj $min $path]
+ } else {
+ lappend notloaded [list $name $guid $maj $min $path]
+ }
+ }
+
+ foreach lib [lsort -dictionary -index 0 $loaded ] {
+ $w.liblist.listbox insert end [lindex $lib 0]
+ $w.liblist.listbox setimage end ::tlview::select_img
+ lappend libs($w) $lib
+ }
+
+ foreach lib [lsort -dictionary -index 0 $notloaded ] {
+ $w.liblist.listbox insert end [lindex $lib 0]
+ $w.liblist.listbox setimage end ::tlview::noselect_img
+ lappend libs($w) $lib
+ }
+ $w.liblist.listbox selection set 0
+ libs_onselect $w
+ }
+
+ proc libs_onkeypress {w key} {
+ set lb $w.liblist.listbox
+ set key [string tolower $key]
+ if {![regexp {^[a-z]$} $key]} return
+
+ set currentindex [$lb index active]
+
+ set liblist [$lb get 0 end]
+ set searchlist [concat [lrange $liblist [expr $currentindex + 1] end] [lrange $liblist 0 $currentindex]]
+
+ set nextindex [lsearch -regexp $searchlist ^($key|[string toupper $key]).*$]
+
+ if {$nextindex>=0} {
+ if {$nextindex < [expr [llength $liblist] - $currentindex - 1]} {
+ set nextindex [expr $nextindex + $currentindex + 1]
+ } else {
+ set nextindex [expr $nextindex - ([llength $liblist] - $currentindex) + 1]
+ }
+ $lb selection clear 0 end
+ $lb activate $nextindex
+ $lb selection set $nextindex
+ $lb see active
+ }
+ }
+
+ proc libs_onenterkey {w} {
+ set lb $w.liblist.listbox
+ set index [lindex [$lb curselection] 0]
+ libs_loader $w $index
+ }
+
+ proc libs_loader {w index} {
+ variable libs
+ set lib [lindex $libs($w) $index]
+ mset {name guid maj min path} $lib
+
+ set lb $w.liblist.listbox
+ set progname [typelib::isloaded $guid $maj $min]
+ if {$progname != {}} {
+ typelib::unload $progname
+ $lb setimage $index ::tlview::noselect_img
+ } else {
+ if {[catch {typelib::load $path} e]} {
+ tk_messageBox -title "Type Library Error" -message $e -icon error -parent $w -type ok
+ } else {
+ $lb setimage $index ::tlview::select_img
+ }
+ }
+ $lb activate $index
+ $lb selection clear 0 end
+ $lb selection set $index
+ }
+
+ proc libs_ondblselect {w x y} {
+ set lb $w.liblist.listbox
+ set index [$lb index @$x,$y]
+ if {$index == {}} return
+ libs_loader $w $index
+ }
+
+ proc libs_onselect {w} {
+ variable libs
+ set lb $w.liblist.listbox
+ set index [$lb curselection]
+
+ set lib [lindex $libs($w) $index]
+ mset {name guid maj min path} $lib
+ $w.details_label config -text $name
+ $w.details.path config -text "Path: $path"
+ }
+
+
+
+ proc libs_browse {w} {
+ variable libs
+
+ set types {
+ {{Type Libraries} {.tlb .olb .dll}}
+ {{Executable Files} {.exe .dll}}
+ {{ActiveX Controls} {.ocx}}
+ {{All Files} {*}}
+ }
+ set fname [tk_getOpenFile -filetypes $types -parent $w -title "Add Type Library Reference"]
+ if {$fname != {}} {
+ try {
+ set progname [typelib::load $fname]
+ mset {guid maj min path fullname} [typelib::loadedlib_details $progname]
+ libs_update $w
+ set index [lsearch -exact $libs($w) [list $fullname $guid $maj $min $path]]
+ puts $index
+ if {$index >= 0} {
+ after 50 "$w.liblist.listbox selection set $index; $w.liblist.listbox see $index"
+ }
+ } catch {er} {
+ tk_messageBox -title "Error in loading library" -message $er -type ok -icon error
+ }
+ }
+ }
+
+
+ #------------------------------------------------------------------------------
+
+
+ proc viewlib_clean {} {
+ variable properties
+
+ history_clean
+
+ set loadedlibs [typelib::loadedlibs]
+
+ foreach item [array names properties] {
+
+ if {[regexp -- - $item]} continue
+ if {![winfo exists $item]} {
+ array unset properties $item
+ array unset properties $item-*
+ continue
+ }
+
+ if {[lsearch -exact $loadedlibs $properites($item-viewedlibrary)] < 0} {
+ # library is not loaded ... so revert to the current index of the history
+ history_current $item
+ }
+ }
+
+ }
+
+ proc viewlib_onenter {txt tag} {
+ $txt config -cursor hand2
+ $txt tag configure $tag -underline 1
+ }
+
+ proc viewlib_onleave {txt tag} {
+ $txt config -cursor arrow
+ $txt tag configure $tag -underline 0
+ }
+
+
+ proc viewlib_updatenav {w} {
+ set topbar $w.topbar
+ if {[history_back? $w]} {
+ $topbar.back config -state normal
+ } else {
+ $topbar.back config -state disabled
+ }
+
+ if {[history_forward? $w]} {
+ $topbar.forward config -state normal
+ } else {
+ $topbar.forward config -state disabled
+ }
+ }
+
+
+
+ proc viewlib_select {w lib {type {}} {element {}} {raise true}} {
+ variable properties
+
+ history_lock $w
+ if {![string match $properties($w-viewedlibrary) $lib]} {
+ # try to find a window that is already viewing this library
+ foreach tlviewer [array names properties *-viewedlibrary] {
+ if {[string match $properties($tlviewer) $lib]} {
+ set w [lindex [split $tlviewer -] 0]; break
+ }
+ }
+ }
+
+ set types_lb $w.sp1.sp2.types.listbox
+ set elements_lb $w.sp1.sp2.elements.listbox
+
+
+ # raise the window and instruct it to view the library
+ if {$raise} {
+ raise $w
+ }
+
+ viewlib_showlibrary $w $lib
+
+
+ if {$type != {}} {
+ # now find the type
+ set index [lsearch -exact [$types_lb get 0 end] $type]
+ if {$index >= 0} {
+ $types_lb selection set $index
+ $types_lb see $index
+ }
+ }
+
+ if {$type != {} && $element != {}} {
+ set index [lsearch -regexp [$elements_lb get 0 end] "^($element)( .+)?"]
+ if {$index >= 0} {
+ $elements_lb selection set $index
+ $elements_lb see $index
+ }
+ }
+ history_unlock $w
+ history_addwindowstate $w
+ }
+
+ # browse to a specific library
+ proc viewlib_showlibrary {w lib} {
+ variable colors
+ variable properties
+
+ set types_lb $w.sp1.sp2.types.listbox
+ set elements_lb $w.sp1.sp2.elements.listbox
+ set description $w.sp1.description.desc.t
+
+
+ $elements_lb delete 0 end
+ #$description config -state normal
+ $description delete 1.0 end
+ #$description config -state disabled
+
+ # if the viewed library is being changed, redirect through the
+ # $w-library property change event handler
+ if {![string match $properties($w-viewedlibrary) $lib] && $lib != {}} {
+ set properties($w-viewedlibrary) $lib
+ return
+ } elseif {[string match $properties($w-library) $lib] || $lib == {}} {
+ if {$properties($w-type) != {}} {
+ set properties($w-type) {}
+ $types_lb selection clear 0 end
+ }
+ return
+ }
+
+ set properties($w-library) $lib
+ set properties($w-type) {}
+ set properties($w-element) {}
+
+ history_addwindowstate $w
+
+ $types_lb delete 0 end
+ foreach tdesc [lsort [typelib::types $lib]] {
+ set typetype [lindex $tdesc 0]
+ set full [lindex $tdesc 1]
+ set type [lindex [split $full .] 1]
+ $types_lb insert end $type
+
+ switch -- $typetype {
+ class {$types_lb setimage end ::tlview::class_img}
+ dispatch {$types_lb setimage end ::tlview::dispatch_img}
+ interface {$types_lb setimage end ::tlview::interface_img}
+ module {$types_lb setimage end ::tlview::module_img}
+ struct {$types_lb setimage end ::tlview::struct_img}
+ union {$types_lb setimage end ::tlview::union_img}
+ enum {$types_lb setimage end ::tlview::enum_img}
+ typedef {$types_lb setimage end ::tlview::typedef_img}
+
+ }
+
+ }
+ bind $types_lb <<Select>> [namespace code "viewlib_showelements_byindex $w $lib \[$types_lb curselection\]"]
+ wm title $w "Type Library: $lib"
+ }
+
+
+
+ proc viewlib_writetype {txt fulltype} {
+ variable colors
+ set split [split $fulltype .]
+ set lib [lindex $split 0]
+ set type [lindex $split 1]
+ set element [lindex $split 2]
+
+ if {[llength [split $fulltype .]] > 1} {
+ $txt tag configure tag$fulltype -foreground $colors(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 [winfo toplevel $txt] $lib $type $element"]
+ if {$element == {}} {
+ $txt insert end "$fulltype" tag$fulltype
+ } else {
+ $txt insert end "$lib.$type $element" tag$fulltype
+ }
+ } else {
+ $txt insert end "$fulltype"
+ }
+ }
+
+
+ ###
+ # displays the elements for a type of some library
+ # a gives a brief description of the type
+ # This function is by the type index
+ #
+ proc viewlib_showelements_byindex {w lib typeindex} {
+ set lb $w.sp1.sp2.elements.listbox
+
+ if {[string trim $typeindex] == {}} {
+ viewlib_showlibrary $w $lib
+ } else {
+ set type [$w.sp1.sp2.types.listbox get $typeindex]
+ return [viewlib_showelements $w $lib $type]
+ }
+ }
+
+
+ proc viewlib_getProgIDs {classid} {
+ set key "HKEY_CLASSES_ROOT\\CLSID\\$classid\\ProgID"
+ set result {}
+ if {[catch {registry get $key {}} e]} {return {}}
+ lappend result $e
+ set key "HKEY_CLASSES_ROOT\\CLSID\\$classid\\VersionIndependentProgID"
+ if {[catch {registry get $key {}} e]} {return $result}
+ lappend result $e
+ return $result
+ }
+
+ ###
+ # displays the elements for a type of some library
+ # a gives a brief description of the type
+ #
+ proc viewlib_showelements {w lib type} {
+ variable colors
+ variable properties
+
+ set elements_lb $w.sp1.sp2.elements.listbox
+
+
+ set desc $w.sp1.description.desc.t
+ #$desc config -state normal
+ $desc delete 1.0 end
+
+ set properties($w-element) {}
+ set elements [typelib::typeinfo $lib.$type]
+ set typedesc [lindex $elements 0]
+ $desc insert end "$typedesc $type "
+ $desc tag add DescriptionLabel 1.[string length $typedesc] 1.end
+ $desc insert end "\n"
+ set line 2
+ if {[lindex $elements 4] != {}} {
+ $desc insert end \"[lindex $elements 4]\"\n
+ $desc tag add MemberDocumentation $line.0 $line.end
+ incr line
+ }
+
+ if {[lindex $elements 0] == "class"} {
+ set classid [lindex $elements 5]
+ $desc insert end "ClassID: [lindex $elements 5]\n"
+ $desc tag add MemberDocumentation $line.0 $line.end
+ incr line
+ set pids [viewlib_getProgIDs $classid]
+ if {$pids != {}} {
+ $desc insert end "ProgID: [lindex $pids 0]\n"
+ $desc tag add MemberDocumentation $line.0 $line.end
+ incr line
+ $desc insert end "VersionIndependentID: [lindex $pids 1]\n"
+ $desc tag add MemberDocumentation $line.0 $line.end
+ incr line
+ }
+ }
+
+ if {[string match "typedef" [lindex $elements 0]]} {
+ # --- we are working with a typedef
+ set t [lindex $elements 3]
+ viewlib_writetype $desc $t
+ }
+ if {![string match $properties($w-type) $type] && $type != {}} {
+ $elements_lb delete 0 end
+
+
+ set properties($w-type) $type
+ history_addwindowstate $w
+
+ if {![string match "typedef" [lindex $elements 0]]} {
+ foreach method [lsort [lindex $elements 1]] {
+ $elements_lb insert end $method
+ $elements_lb setimage end ::tlview::method_img
+ }
+
+ foreach prop [lsort [lindex $elements 2]] {
+ $elements_lb insert end $prop
+ $elements_lb setimage end ::tlview::property_img
+ }
+ foreach impl [lsort -index 1 [lindex $elements 3]] {
+ set t [lindex $impl 1]
+ set flags [lindex $impl 0]
+ set item $t
+ if {[lsearch -exact $flags default] != -1} {
+ lappend item "*"
+ }
+
+ if {[lsearch -exac $flags source] != -1} {
+ lappend item (event source)
+ }
+
+ $elements_lb insert end $item
+ $elements_lb setimage end ::tlview::typedef_img
+ }
+ }
+ bind $elements_lb <<Select>> [namespace code "viewlib_showelement_description_byindex $w $lib $type \[$elements_lb curselection\]"]
+ }
+ #$desc config -state disabled
+ }
+
+
+
+ proc viewlib_showelement_description_byindex {w lib type elemindex} {
+
+
+ set elements_lb $w.sp1.sp2.elements.listbox
+ if {$elemindex == {}} {
+ viewlib_showelements $w $lib $type
+ return
+ } else {
+ set element [$elements_lb get $elemindex]
+ # because we tend to mark up default and source interfaces
+ # with appended symbols and names, we'll strip these off
+ set element [lindex [lindex $element 0] 0]
+
+ # but in fact, any implemented type needs not an element
+ # description, but a jump to that types description
+ if {[regexp {^.+\..+$} $element]} {
+ set split [split $element .]
+ set newlib [lindex $split 0]
+ set newtype [lindex $split 1]
+ viewlib_select $w $newlib $newtype
+ } else {
+ viewlib_showelement_description $w $lib $type $element
+ }
+ }
+ }
+
+ ###
+ # retrieves the description for an element
+ proc viewlib_showelement_description {w lib type elem} {
+ variable colors
+ variable properties
+
+ set txt $w.sp1.description.desc.t
+ #$txt config -state normal
+
+ $txt tag bind element <1> [namespace code "viewlib_select $lib.$type $elem"]
+
+ # if we're not viewing this element already
+ if {$elem != {} && ![string match $properties($w-element) $elem]} {
+ $txt delete 1.0 end
+ set properties($w-element) $elem
+ history_addwindowstate $w
+
+ set elementdesc [typelib::typeinfo $lib.$type $elem]
+ set elementkind [lindex $elementdesc 0]
+
+ switch $elementkind {
+ property {
+ $txt insert end "property "
+
+ set propertydesc [lindex $elementdesc 1]
+ # insert the flags
+ set flags [lindex $propertydesc 0]
+ if {[lsearch -exact $flags read] < 0} {
+ set flags {(write only)}
+ } elseif {[lsearch -exact $flags write] < 0} {
+ set flags {(read only)}
+ } elseif {$flags != {}} {
+ set flags {(read+write)}
+ }
+ $txt insert end "$flags\n" FlagDescription
+
+ # the property type
+ viewlib_writetype $txt [lindex $propertydesc 1]
+ $txt insert end " "
+
+ # the property name
+ $txt insert end "[lindex $propertydesc 2]" DescriptionLabel
+
+ # now do the params
+ set params [lrange $propertydesc 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]"
+ }
+ # the documentation for the property
+ set documentation [lindex $elementdesc 2]
+ if {$documentation != {}} {
+ $txt insert end "\n\n\"$documentation\"" MemberDocumentation
+ }
+ }
+
+ method {
+ set methodesc [lindex $elementdesc 1]
+ $txt insert end "method\n"
+
+ # the return type
+ viewlib_writetype $txt [lindex $methodesc 0]
+ $txt insert end " "
+ $txt insert end "[lindex $methodesc 1]" DescriptionLabel
+ set params [lrange $methodesc 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]"
+ }
+ set documentation [lindex $elementdesc 2]
+ if {$documentation != {}} {
+ $txt insert end "\n\n\"$documentation\"" MemberDocumentation
+ }
+ }
+ }
+ }
+ #$txt config -state disabled
+
+ }
+
+
+ proc viewlib_copy {w} {
+ variable properties
+
+ set str $properties($w-viewedlibrary)
+ if {$properties($w-type) != {}} {
+ set str "$str.$properties($w-type)"
+ if {$properties($w-element)!={}} {
+ set str "$str $properties($w-element)"
+ }
+ }
+ clipboard clear
+ clipboard append -format STRING -- $str
+ }
+
+ ####
+ # Creates a viewer for library
+ proc viewlib {{w {}} {lib {}}} {
+ variable colors
+ variable properties
+
+ if {$w == {}} {
+
+ # iterate over the current windows to find one that is viewing this library
+ foreach viewedlib [array names properties *-viewedlibrary] {
+ if {[string match $properties($viewedlib) $lib]} {
+ set w [lindex [split $viewedlib -] 0]
+ break;
+ }
+ }
+ }
+
+ if {$w == {}} {
+ # make a unique name
+ set count 0
+
+ set w ._tlview_$count
+ while {[winfo exists $w]} {
+ set w ._tlview_[incr count]
+ }
+ }
+
+
+ if [winfo exists $w] {
+ raise $w
+ return $w
+ }
+
+ toplevel $w -class TypeLibraryViewer -width 400 -height 300
+ wm title $w "Type Library:"
+
+ # top bar - search stuff
+ set topbar [frame $w.topbar]
+ pack $topbar -side top -fill x -pady 2
+ pack [label $topbar.liblabel -text Library -underline 0 -width 6] -side left -anchor nw
+
+ ::tlview::TlviewCombo::Create $topbar.libs {::typelib::loadedlibs} -textvariable [namespace current]::properties($w-viewedlibrary)
+
+ $topbar.libs.e config -state disabled
+ pack $topbar.libs -side left -padx 3
+ pack [button $topbar.back -image ::tlview::leftarrow_img -bd 1 -height 16 -width 16 -command [namespace code "history_back $w"]] -side left
+ pack [button $topbar.forward -image ::tlview::rightarrow_img -bd 1 -height 16 -width 16 -command [namespace code "history_forward $w"]] -side left
+ pack [button $topbar.copy -image ::tlview::copy_img -bd 1 -height 16 -width 16 -command [namespace code "viewlib_copy $w"]] -padx 3 -side left
+ pack [button $topbar.libselect -image ::tlview::libselect_img -bd 1 -height 16 -width 16 -command [namespace code "libs $w.selectlibs"]] -padx 0 -side left
+
+ TlviewTooltip::Set $topbar.libs "Loaded Libraries"
+ TlviewTooltip::Set $topbar.back "Previous in History"
+ TlviewTooltip::Set $topbar.forward "Next in History"
+ TlviewTooltip::Set $topbar.copy "Copy"
+ TlviewTooltip::Set $topbar.libselect "Referenced Type Libraries"
+
+ searchbox $w.searchbox
+ pack $w.searchbox -side top -fill x -pady 2
+
+ # splitters
+ set sp1 [Splitter $w.sp1 -orient horizontal -type fixB -position 160 -barwidth 5 -width 460 -height 380]
+ set sp2 [Splitter $w.sp1.sp2 -orient vertical -type fixA -position 200 -barwidth 5]
+ pack $sp1 -fill both -expand 1 -side bottom
+ $sp1 config -windowA $sp2
+
+ # description frame
+ set desc [frame $sp1.description]
+ $sp1 config -windowB $desc
+ pack [label $desc.label -text Description] -side top -anchor nw
+ pack [scrltxt $desc.desc] -side top -anchor nw -fill both -expand 1
+ $desc.desc.t tag configure DescriptionLabel -foreground $colors(labelcolor) -font tlviewerbold
+ $desc.desc.t tag configure FlagDescription -font tlvieweritalic
+ $desc.desc.t tag configure MemberDocumentation -font tlvieweritalic -foreground $colors(labelcolor)
+ $desc.desc.t config -exportselection 1 -cursor xterm -insertontime 0 -selectforeground SystemHighlightText
+ bind $desc.desc.t <Alt-F4> {continue}
+ bind $desc.desc.t <KeyPress> "break;"
+
+ # types frame
+ set types [::tlview::TlviewScrolledListBox $sp2.types]
+ $types.listbox config -font {Arial 10 {}}
+ $sp2 config -windowA $types
+ $types.label config -text Types
+
+ set elements [::tlview::TlviewScrolledListBox $sp2.elements]
+ $elements.listbox config -font {Arial 10 {}}
+ $sp2 config -windowB $elements
+ $elements.label config -text "Elements"
+
+ if {$lib == {}} {
+ set lib [lindex [typelib::loadedlibs] 0]
+ }
+
+ trace vdelete [namespace current]::properties($w-viewedlibrary) w [namespace code viewlib_libchanged]
+ set properties($w-viewedlibrary) {}
+ set properties($w-library) {}
+ set properties($w-type) {}
+ set properties($w-element) {}
+ trace variable [namespace current]::properties($w-viewedlibrary) w [namespace code viewlib_libchanged]
+
+ bind $w <Destroy> [namespace code "viewlib_ondestroy %W"]
+ history_init $w
+ viewlib_showlibrary $w $lib
+
+ return $w
+ }
+
+ proc viewlib_ondestroy {w} {
+ variable properties
+
+ if {[winfo toplevel $w] == $w} {
+ history_erase $w
+ array unset properties $w
+ array unset properties $w-*
+ }
+ }
+
+ proc viewlib_libchanged {n1 n2 command} {
+ variable properties
+ set lib $properties($n2)
+ set w [lindex [split $n2 -] 0]
+ viewlib_showlibrary $w $lib
+ }
+
+ proc viewtype {fullname {elem {}} {history 1}} {
+ set split [split $fullname .]
+ set lib [lindex $split 0]
+ set type [lindex $split 1]
+
+ viewlib_select $lib $type $elem $history
+ }
+
+ ### -- Search box code
+
+
+ proc searchbox {w} {
+ variable properties
+
+ destroy $w
+
+ frame $w
+ set splitter [winfo parent $w]
+
+ frame $w.top
+ pack [label $w.top.searchlabel -text Search -underline 0 -width 6] -side left -anchor nw
+ ::tlview::TlviewCombo::Create $w.top.searchterm [namespace code "search_history_getlist $w"]
+ bind $w.top.searchterm.e <Return> [namespace code "searchbox_search $w"]
+
+ button $w.top.search -image ::tlview::find_img -borderwidth 1 -command [namespace code "searchbox_search $w"]
+ button $w.top.showhide -image ::tlview::show_img -borderwidth 1 -command [namespace code "searchbox_showhide $w"]
+ pack $w.top.showhide $w.top.search -side right -padx 2
+ pack $w.top.searchterm -side left -fill x -expand 1 -padx 3
+
+ TlviewTooltip::Set $w.top.showhide "Show/Hide Search Results"
+ TlviewTooltip::Set $w.top.searchterm "Search String"
+ TlviewTooltip::Set $w.top.search "Search for String"
+
+ scrltxt $w.searchresults
+ $w.searchresults.t config -height 10 -tabs 5c -state disabled
+
+ grid $w.top -sticky nsew
+ grid rowconfigure $w 1 -weight 1
+ grid columnconfigure $w 0 -weight 1
+ update
+ set properties($w-collapsed) [expr [winfo reqheight $w] + 2]
+ set properties($w-expanded) 200
+ set properties($w-min) 90
+
+ #$splitter config -windowB $w -type fixB -position $properties($w-collapsed) -min $properties($w-collapsed) -max $properties($w-collapsed)
+ return $w
+ }
+
+ proc searchbox_show {w} {
+ variable properties
+ if {[lsearch [grid slaves $w] $w.searchresults] >= 0} return
+
+ set toplevel [winfo toplevel $w]
+ set windowheight [winfo height $toplevel]
+ set windowheight [expr $windowheight + [winfo reqheight $w.searchresults] + 5]
+
+ grid $w.searchresults -row 1 -column 0 -sticky nsew -pady 5
+ wm geometry $toplevel [winfo width $toplevel]x$windowheight
+ $w.top.showhide config -image ::tlview::hide_img -relief sunken
+ }
+
+ proc searchbox_search {w} {
+ variable properties
+ set query [$w.top.searchterm.e get]
+ set lib $properties([winfo toplevel $w]-viewedlibrary)
+
+ search_history_add $w $query
+ search $w $query
+ $w.top.searchterm.e selection clear
+ $w.top.searchterm.e selection range 0 end
+ }
+
+ proc searchbox_hide {w} {
+ variable properties
+
+ if {[lsearch [grid slaves $w] $w.searchresults] < 0} return
+
+ set textheight [winfo reqheight $w.searchresults]
+ set toplevel [winfo toplevel $w]
+ set windowheight [expr [winfo height $toplevel] - $textheight - 5]
+ grid forget $w.searchresults
+
+ wm geometry $toplevel [winfo width $toplevel]x$windowheight
+ $w.top.showhide config -image ::tlview::show_img -relief raised
+ }
+
+ proc searchbox_showhide {w} {
+ if {[lsearch [grid slaves $w] $w.searchresults] < 0} {
+ searchbox_show $w
+ } else {
+ searchbox_hide $w
+ }
+ }
+
+ proc search {w query} {
+ variable properties
+
+ # ensure that the search window exists
+
+ set w [winfo toplevel $w]
+ set lib $properties($w-viewedlibrary)
+ set searchbox $w.searchbox
+ set sr $searchbox.searchresults.t
+
+ # set up the text box
+ $sr config -state normal
+ $sr delete 1.0 end
+
+ searchbox_show $searchbox
+
+ set query [join [list * $query *] {}]
+
+ foreach desc [typelib::types $lib] {
+ set fulltype [lindex $desc 1]
+ set reflib [lindex [split $fulltype .] 0]
+ set reftype [lindex [split $fulltype .] 1]
+
+ # perform search on the type name
+ if {[string match -nocase $query $reftype]} {
+ viewlib_writetype $sr $fulltype
+ $sr insert end "\n"
+ }
+
+ # now iterate through its members
+ set typeinfo [typelib::typeinfo $fulltype]
+ foreach item [lindex $typeinfo 1] {
+ if {[string match -nocase $query $item]} {
+ viewlib_writetype $sr $fulltype.$item
+ $sr insert end "\n"
+ }
+ }
+
+ foreach item [lindex $typeinfo 2] {
+ if {[string match -nocase $query $item]} {
+ viewlib_writetype $sr $fulltype.$item
+ $sr insert end "\n"
+ }
+ }
+ }
+ $sr config -state disabled
+ }
+
+ proc viewtype {fulltype {element {}}} {
+ variable properties
+ set w {}
+ set split [split $fulltype .]
+ set lib [lindex $split 0]
+ set type [lindex $split 1]
+
+
+ set w [viewlib {} $lib]
+ update
+ viewlib_select $w $lib $type $element
+ }
+
+
+ proc class {obj} {
+ viewtype [optcl::class $obj]
+ }
+
+ proc interface {obj} {
+ viewtype [optcl::interface $obj]
+ }
+}
diff --git a/src/Tooltip.tcl b/src/Tooltip.tcl
new file mode 100644
index 0000000..8f1ebbc
--- /dev/null
+++ b/src/Tooltip.tcl
@@ -0,0 +1,68 @@
+
+# public interface
+namespace eval TlviewTooltip {
+ proc Set {w text} {
+ variable properties
+ set properties($w-text) $text
+ bind $w <Enter> [namespace code "Pending $w %X %Y"]
+ bind $w <Leave> [namespace code "Hide"]
+ Hide
+ }
+
+ proc Unset {w} {
+ bind $w <Enter> {}
+ bind $w <Leave> {}
+ Hide
+ }
+}
+
+
+# private stuff
+namespace eval TlviewTooltip {
+ variable properties
+ set properties(window) .__tlview__tooltip
+ set properties(showbh) 1
+ set properties(pending) {}
+
+
+ destroy $properties(window)
+ toplevel $properties(window) -bg SystemInfoText
+ label $properties(window).l -text "Tooltip" -bg SystemInfoBackground -fg SystemInfoText
+ pack $properties(window).l -padx 1 -pady 1
+
+
+ wm overrideredirect $properties(window) 1
+ wm withdraw $properties(window)
+
+
+ proc Pending {w x y} {
+ variable properties
+ Cancel
+ set properties(pending) [after 1000 [namespace code "Show $w $x $y"]]
+ }
+
+ proc Cancel {} {
+ variable properties
+ if {$properties(pending) != {}} {
+ after cancel $properties(pending)
+ set properties(pending) {}
+ }
+ }
+
+ proc Show {w x y} {
+ variable properties
+
+ $properties(window).l configure -text $properties($w-text)
+ wm deiconify $properties(window)
+ incr x 8
+ incr y 8
+ wm transient $properties(window) $w
+ wm geometry $properties(window) +$x+$y
+ }
+
+ proc Hide {} {
+ variable properties
+ Cancel
+ wm withdraw $properties(window)
+ }
+}
diff --git a/src/Utilities.tcl b/src/Utilities.tcl
new file mode 100644
index 0000000..7fdcb39
--- /dev/null
+++ b/src/Utilities.tcl
@@ -0,0 +1,43 @@
+
+namespace eval optcl_utils {
+namespace export *
+# nice and simple error catching
+proc try {body catch errvarname catchblock} {
+ upvar $errvarname errvar
+
+ if {![string match $catch catch]} {
+ error "invalid syntax - should be: try {body} catch {catchblock}"
+ }
+ if { [catch [list uplevel $body] errvar] } {
+ uplevel $catchblock
+ } else {
+ return $errvar
+ }
+}
+
+proc throw {errmsg} {
+ uplevel [list error $errmsg]
+}
+
+
+proc center_window {w} {
+ set width [winfo reqwidth $w]
+ set height [winfo reqheight $w]
+ set swidth [winfo screenwidth $w]
+ set sheight [winfo screenheight $w]
+
+ set x [expr ($swidth - $width) /2 ]
+ set y [expr ($sheight - $height) /2 ]
+ wm geometry $w +$x+$y
+}
+
+# set multiple variables with the contents of the list
+proc mset {vars values} {
+ foreach var $vars value $values {
+ if {$var == {}} {error "not enough variables for mset operation"}
+ upvar $var myvar
+ set myvar $value
+ }
+}
+
+}
\ No newline at end of file
diff --git a/src/optcl.cpp b/src/optcl.cpp
index d2fa2e1..941b689 100644
--- a/src/optcl.cpp
+++ b/src/optcl.cpp
@@ -38,7 +38,7 @@
HINSTANCE ghDll = NULL;
CComModule _Module;
CComPtr<IMalloc> g_pmalloc;
-
+bool g_bTkInit = false;
//----------------------------------------------------------------
// Function declarations
@@ -394,7 +394,7 @@ TCL_CMDEF(OptclInvokeLibFunction)
CHECKHR_TCL(hr, pInterp, TCL_ERROR);
if (FAILED(hr))
return TCL_ERROR;
- if (bOk = var2obj(pInterp, varResult, presult))
+ if (bOk = var2obj(pInterp, varResult, NULL, presult))
Tcl_SetObjResult (pInterp, presult);
VariantClear(&varResult);
}
@@ -623,6 +623,7 @@ int Optcl_Init (Tcl_Interp *pInterp)
// initialise the Tk stubs - failure
if (Tk_InitStubs (pInterp, "8.0", 0) == NULL)
return TCL_ERROR;
+ g_bTkInit = true;
}
#else
#error Wrong Tcl version for Stubs
@@ -630,11 +631,14 @@ int Optcl_Init (Tcl_Interp *pInterp)
#endif // USE_TCL_STUBS
HRESULT hr;
+ Tcl_PkgProvide(pInterp, "optcl", "3.0");
+
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);
@@ -652,6 +656,7 @@ int Optcl_Init (Tcl_Interp *pInterp)
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);
diff --git a/src/optcl.dsp b/src/optcl.dsp
index c4407bd..bc1dfd3 100644
--- a/src/optcl.dsp
+++ b/src/optcl.dsp
@@ -4,7 +4,7 @@
# TARGTYPE "Win32 (x86) Dynamic-Link Library" 0x0102
-CFG=optcl - Win32 Debug_NoStubs
+CFG=optcl - Win32 Debug
!MESSAGE This is not a valid makefile. To build this project using NMAKE,
!MESSAGE use the Export Makefile command and run
!MESSAGE
@@ -13,14 +13,13 @@ CFG=optcl - Win32 Debug_NoStubs
!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 NMAKE /f "optcl.mak" CFG="optcl - Win32 Debug"
!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 "optcl - Win32 Release Static" (based on "Win32 (x86) Dynamic-Link Library")
!MESSAGE
# Begin Project
@@ -41,11 +40,11 @@ RSC=rc.exe
# PROP Use_MFC 0
# PROP Use_Debug_Libraries 0
# PROP Output_Dir "Release"
-# PROP Intermediate_Dir "Release"
+# PROP Intermediate_Dir "Release\Objects"
# 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 CPP /nologo /MD /W3 /GX /Zi /O1 /Ob2 /I "c:\opt\tcl\include" /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "OPTCL_EXPORTS" /D "USE_TCL_STUBS" /D "USE_TK_STUBS" /D TCL_THREADS=1 /D USE_THREAD_ALLOC=1 /D _REENTRANT=1 /D _THREAD_SAFE=1 /FR /YX /FD /c
# ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32
# ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32
# ADD BASE RSC /l 0x809 /d "NDEBUG"
@@ -55,23 +54,24 @@ BSC32=bscmake.exe
# 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"
+# ADD LINK32 tclstub84.lib tkstub84.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib /nologo /dll /debug /machine:I386 /out:"Release/optcl30.dll" /libpath:"c:\opt\tcl\lib"
+# SUBTRACT LINK32 /incremental:yes
!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 Output_Dir "Debug"
+# PROP BASE Intermediate_Dir "Debug"
# PROP BASE Target_Dir ""
# PROP Use_MFC 0
# PROP Use_Debug_Libraries 1
# PROP Output_Dir "Debug"
-# PROP Intermediate_Dir "Debug"
+# PROP Intermediate_Dir "Debug\Objects"
# 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 CPP /nologo /MDd /W3 /Gm /GX /Zi /Od /I "c:\opt\tcl\include" /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "OPTCL_EXPORTS" /D "USE_TCL_STUBS" /D "USE_TK_STUBS" /D "ATL_DEBUG_INTERFACES" /FR /YX"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"
@@ -81,24 +81,22 @@ BSC32=bscmake.exe
# 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"
+# ADD LINK32 tclstub84.lib tkstub84.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib /nologo /dll /debug /machine:I386 /out:"Debug/optcl30g.dll" /pdbtype:sept /libpath:"c:\opt\tcl\lib"
-!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs"
+!ELSEIF "$(CFG)" == "optcl - Win32 Release Static"
# 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 Output_Dir "Release"
+# PROP BASE Intermediate_Dir "Release\Static"
# 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 Output_Dir "Release"
+# PROP Intermediate_Dir "Release\Static"
# 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 CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_MBCS" /D "_LIB" /YX /FD /c
+# ADD CPP /nologo /MD /W3 /GX /Zi /O1 /Ob2 /I "c:\opt\tcl\include" /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_LIB" /D "OPTCL_EXPORTS" /D TCL_THREADS=1 /D USE_THREAD_ALLOC=1 /D _REENTRANT=1 /D _THREAD_SAFE=1 /FR /YX /FD /c
# ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32
# ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32
# ADD BASE RSC /l 0x809 /d "NDEBUG"
@@ -107,35 +105,8 @@ 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"
+# ADD BASE LINK32 /nologo /machine:IX86
+# ADD LINK32 /nologo /machine:IX86 /out:"Release\optcl30s.lib" /lib
!ENDIF
@@ -143,27 +114,30 @@ LINK32=link.exe
# Name "optcl - Win32 Release"
# Name "optcl - Win32 Debug"
-# Name "optcl - Win32 Release_NoStubs"
-# Name "optcl - Win32 Debug_NoStubs"
-# Begin Group "Source"
+# Name "optcl - Win32 Release Static"
+# Begin Group "Source Files"
+
+# PROP Default_Filter "cpp;c;cxx;rc;def;r;odl;idl;hpj;bat"
+# Begin Source File
-# PROP Default_Filter "cpp"
+SOURCE=.\ComRecordInfoImpl.cpp
+# End Source File
# Begin Source File
SOURCE=.\Container.cpp
!IF "$(CFG)" == "optcl - Win32 Release"
-# ADD CPP /Yu"StdAfx.h"
+# ADD CPP /YX"stdafx.h"
!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
-!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs"
+# ADD CPP /YX
-# ADD BASE CPP /Yu"StdAfx.h"
-# ADD CPP /Yu"StdAfx.h"
+!ELSEIF "$(CFG)" == "optcl - Win32 Release Static"
-!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs"
+# ADD BASE CPP /YX"stdafx.h"
+# ADD CPP /YX"stdafx.h"
!ENDIF
@@ -174,21 +148,16 @@ SOURCE=.\DispParams.cpp
!IF "$(CFG)" == "optcl - Win32 Release"
-# ADD CPP /Yu"stdafx.h"
+# ADD CPP /YX"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"
+# ADD CPP /YX
-!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs"
+!ELSEIF "$(CFG)" == "optcl - Win32 Release Static"
-# ADD BASE CPP /Yu"StdAfx.h"
-# ADD CPP /Yu"StdAfx.h"
+# ADD BASE CPP /YX"stdafx.h"
+# ADD CPP /YX"stdafx.h"
!ENDIF
@@ -199,16 +168,16 @@ SOURCE=.\EventBinding.cpp
!IF "$(CFG)" == "optcl - Win32 Release"
-# ADD CPP /Yu"stdafx.h"
+# ADD CPP /YX"stdafx.h"
!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
-!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs"
+# ADD CPP /YX
-# ADD BASE CPP /Yu"stdafx.h"
-# ADD CPP /Yu"stdafx.h"
+!ELSEIF "$(CFG)" == "optcl - Win32 Release Static"
-!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs"
+# ADD BASE CPP /YX"stdafx.h"
+# ADD CPP /YX"stdafx.h"
!ENDIF
@@ -216,7 +185,22 @@ SOURCE=.\EventBinding.cpp
# Begin Source File
SOURCE=.\initonce.cpp
-# SUBTRACT CPP /YX /Yc /Yu
+
+!IF "$(CFG)" == "optcl - Win32 Release"
+
+# ADD CPP /YX"stdafx.h"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
+
+# SUBTRACT CPP /YX
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Release Static"
+
+# ADD BASE CPP /YX"stdafx.h"
+# ADD CPP /YX"stdafx.h"
+
+!ENDIF
+
# End Source File
# Begin Source File
@@ -224,21 +208,16 @@ SOURCE=.\ObjMap.cpp
!IF "$(CFG)" == "optcl - Win32 Release"
-# ADD CPP /Yu"stdafx.h"
+# ADD CPP /YX"stdafx.h"
!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
-# ADD CPP /Yu"StdAfx.h"
-
-!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs"
+# ADD CPP /YX
-# ADD BASE CPP /Yu"stdafx.h"
-# ADD CPP /Yu"stdafx.h"
+!ELSEIF "$(CFG)" == "optcl - Win32 Release Static"
-!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs"
-
-# ADD BASE CPP /Yu"StdAfx.h"
-# ADD CPP /Yu"StdAfx.h"
+# ADD BASE CPP /YX"stdafx.h"
+# ADD CPP /YX"stdafx.h"
!ENDIF
@@ -249,21 +228,16 @@ SOURCE=.\optcl.cpp
!IF "$(CFG)" == "optcl - Win32 Release"
-# ADD CPP /Yu"stdafx.h"
+# ADD CPP /YX"stdafx.h"
!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
-# ADD CPP /Yu"StdAfx.h"
-
-!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs"
+# ADD CPP /YX
-# ADD BASE CPP /Yu"stdafx.h"
-# ADD CPP /Yu"stdafx.h"
+!ELSEIF "$(CFG)" == "optcl - Win32 Release Static"
-!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs"
-
-# ADD BASE CPP /Yu"StdAfx.h"
-# ADD CPP /Yu"StdAfx.h"
+# ADD BASE CPP /YX"stdafx.h"
+# ADD CPP /YX"stdafx.h"
!ENDIF
@@ -271,6 +245,22 @@ SOURCE=.\optcl.cpp
# Begin Source File
SOURCE=.\OptclBindPtr.cpp
+
+!IF "$(CFG)" == "optcl - Win32 Release"
+
+# ADD CPP /YX"stdafx.h"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
+
+# ADD CPP /YX
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Release Static"
+
+# ADD BASE CPP /YX"stdafx.h"
+# ADD CPP /YX"stdafx.h"
+
+!ENDIF
+
# End Source File
# Begin Source File
@@ -278,48 +268,97 @@ SOURCE=.\OptclObj.cpp
!IF "$(CFG)" == "optcl - Win32 Release"
-# ADD CPP /Yu"stdafx.h"
+# ADD CPP /YX"stdafx.h"
!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
-# ADD CPP /Yu"StdAfx.h"
+# ADD CPP /YX
-!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs"
+!ELSEIF "$(CFG)" == "optcl - Win32 Release Static"
-# ADD BASE CPP /Yu"stdafx.h"
-# ADD CPP /Yu"stdafx.h"
+# ADD BASE CPP /YX"stdafx.h"
+# ADD CPP /YX"stdafx.h"
-!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs"
+!ENDIF
-# ADD BASE CPP /Yu"StdAfx.h"
-# ADD CPP /Yu"StdAfx.h"
+# End Source File
+# Begin Source File
+
+SOURCE=.\OptclTypeAttr.cpp
+
+!IF "$(CFG)" == "optcl - Win32 Release"
+
+# ADD CPP /YX"stdafx.h"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
+
+# ADD CPP /YX
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Release Static"
+
+# ADD BASE CPP /YX"stdafx.h"
+# ADD CPP /YX"stdafx.h"
!ENDIF
# End Source File
# Begin Source File
-SOURCE=.\OptclTypeAttr.cpp
+SOURCE=.\resource.rc
# End Source File
# Begin Source File
SOURCE=.\StdAfx.cpp
-# ADD CPP /Yc"StdAfx.h"
+# ADD CPP /Yc"stdafx.h"
# End Source File
# Begin Source File
SOURCE=.\typelib.cpp
-# ADD CPP /Yu"StdAfx.h"
+
+!IF "$(CFG)" == "optcl - Win32 Release"
+
+# ADD CPP /YX"stdafx.h"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
+
+# ADD CPP /YX
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Release Static"
+
+# ADD BASE CPP /YX"stdafx.h"
+# ADD CPP /YX"stdafx.h"
+
+!ENDIF
+
# End Source File
# Begin Source File
SOURCE=.\utility.cpp
-# ADD CPP /Yu"StdAfx.h"
+
+!IF "$(CFG)" == "optcl - Win32 Release"
+
+# ADD CPP /YX"stdafx.h"
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
+
+# ADD CPP /YX
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Release Static"
+
+# ADD BASE CPP /YX"stdafx.h"
+# ADD CPP /YX"stdafx.h"
+
+!ENDIF
+
# End Source File
# End Group
-# Begin Group "Header"
+# Begin Group "Header Files"
+
+# PROP Default_Filter "h;hpp;hxx;hm;inl"
+# Begin Source File
-# PROP Default_Filter "h"
+SOURCE=.\ComRecordInfoImpl.h
+# End Source File
# Begin Source File
SOURCE=.\Container.h
@@ -373,42 +412,272 @@ SOURCE=.\typelib.h
SOURCE=.\utility.h
# End Source File
# End Group
-# Begin Group "Resource"
+# Begin Group "Resource Files"
-# PROP Default_Filter ""
+# PROP Default_Filter "ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe"
# Begin Source File
-SOURCE=.\resource.rc
+SOURCE=.\ImageListBox.tcl
+
+!IF "$(CFG)" == "optcl - Win32 Release"
+
+# Begin Custom Build
+InputPath=.\ImageListBox.tcl
+
+"c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+ copy $(InputPath) c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)
+
+# End Custom Build
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
+
+# Begin Custom Build
+InputPath=.\ImageListBox.tcl
+
+"c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+ copy $(InputPath) c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)
+
+# End Custom Build
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Release Static"
+
+# Begin Custom Build
+InputPath=.\ImageListBox.tcl
+
+"c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+ copy $(InputPath) c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)
+
+# End Custom Build
+
+!ENDIF
+
+# End Source File
+# Begin Source File
+
+SOURCE=.\optcl.tcl
+
+!IF "$(CFG)" == "optcl - Win32 Release"
+
+# Begin Custom Build
+InputPath=.\optcl.tcl
+
+"c:\progra~1\tcl\lib\optcl\$(InputPath)" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+ copy $(InputPath) c:\progra~1\tcl\lib\optcl\$(InputPath)
+
+# End Custom Build
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
+
+# Begin Custom Build
+InputPath=.\optcl.tcl
+
+"c:\progra~1\tcl\lib\optcl\$(InputPath)" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+ copy $(InputPath) c:\progra~1\tcl\lib\optcl\$(InputPath)
+
+# End Custom Build
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Release Static"
+
+# Begin Custom Build
+InputPath=.\optcl.tcl
+
+"c:\progra~1\tcl\lib\optcl\$(InputPath)" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+ copy $(InputPath) c:\progra~1\tcl\lib\optcl\$(InputPath)
+
+# End Custom Build
+
+!ENDIF
+
+# End Source File
+# Begin Source File
+
+SOURCE=.\Splitter.tcl
+
+!IF "$(CFG)" == "optcl - Win32 Release"
+
+# Begin Custom Build
+InputPath=.\Splitter.tcl
+
+"c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+ copy $(InputPath) c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)
+
+# End Custom Build
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
+
+# Begin Custom Build
+InputPath=.\Splitter.tcl
+
+"c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+ copy $(InputPath) c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)
+
+# End Custom Build
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Release Static"
+
+# Begin Custom Build
+InputPath=.\Splitter.tcl
+
+"c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+ copy $(InputPath) c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)
+
+# End Custom Build
+
+!ENDIF
+
+# End Source File
+# Begin Source File
+
+SOURCE=.\TLView.tcl
+
+!IF "$(CFG)" == "optcl - Win32 Release"
+
+# Begin Custom Build
+InputPath=.\TLView.tcl
+
+"c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+ copy $(InputPath) c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)
+
+# End Custom Build
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
+
+# Begin Custom Build
+InputPath=.\TLView.tcl
+
+"c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+ copy $(InputPath) c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)
+
+# End Custom Build
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Release Static"
+
+# Begin Custom Build
+InputPath=.\TLView.tcl
+
+"c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+ copy $(InputPath) c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)
+
+# End Custom Build
+
+!ENDIF
+
+# End Source File
+# Begin Source File
+
+SOURCE=.\Tooltip.tcl
+
+!IF "$(CFG)" == "optcl - Win32 Release"
+
+# Begin Custom Build
+InputPath=.\Tooltip.tcl
+
+"c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+ copy $(InputPath) c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)
+
+# End Custom Build
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
+
+# Begin Custom Build
+InputPath=.\Tooltip.tcl
+
+"c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+ copy $(InputPath) c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)
+
+# End Custom Build
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Release Static"
+
+# Begin Custom Build
+InputPath=.\Tooltip.tcl
+
+"c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+ copy $(InputPath) c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)
+
+# End Custom Build
+
+!ENDIF
+
# End Source File
# Begin Source File
SOURCE=.\typelib.tcl
+
+!IF "$(CFG)" == "optcl - Win32 Release"
+
+# Begin Custom Build
+InputPath=.\typelib.tcl
+
+"c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+ copy $(InputPath) c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)
+
+# End Custom Build
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
+
+# Begin Custom Build
+InputPath=.\typelib.tcl
+
+"c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+ copy $(InputPath) c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)
+
+# End Custom Build
+
+!ELSEIF "$(CFG)" == "optcl - Win32 Release Static"
+
+# Begin Custom Build
+InputPath=.\typelib.tcl
+
+"c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+ copy $(InputPath) c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)
+
+# End Custom Build
+
+!ENDIF
+
# End Source File
-# End Group
# Begin Source File
-SOURCE=.\test.tcl
+SOURCE=.\Utilities.tcl
!IF "$(CFG)" == "optcl - Win32 Release"
-# PROP Exclude_From_Build 1
+# Begin Custom Build
+InputPath=.\Utilities.tcl
+
+"c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+ copy $(InputPath) c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)
+
+# End Custom Build
!ELSEIF "$(CFG)" == "optcl - Win32 Debug"
-# PROP Exclude_From_Build 1
+# Begin Custom Build
+InputPath=.\Utilities.tcl
+
+"c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+ copy $(InputPath) c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)
-!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs"
+# End Custom Build
-# PROP BASE Exclude_From_Build 1
-# PROP Exclude_From_Build 1
+!ELSEIF "$(CFG)" == "optcl - Win32 Release Static"
-!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs"
+# Begin Custom Build
+InputPath=.\Utilities.tcl
-# PROP BASE Exclude_From_Build 1
-# PROP Exclude_From_Build 1
+"c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
+ copy $(InputPath) c:\progra~1\tcl\lib\optcl\scripts\$(InputPath)
+
+# End Custom Build
!ENDIF
+# End Source File
+# End Group
+# Begin Source File
+
+SOURCE=.\test.tcl
# End Source File
# End Target
# End Project
diff --git a/src/optcl.dsw b/src/optcl.dsw
new file mode 100644
index 0000000..1b00bbc
--- /dev/null
+++ b/src/optcl.dsw
@@ -0,0 +1,29 @@
+Microsoft Developer Studio Workspace File, Format Version 6.00
+# WARNING: DO NOT EDIT OR DELETE THIS WORKSPACE FILE!
+
+###############################################################################
+
+Project: "optcl"=.\optcl.dsp - Package Owner=<4>
+
+Package=<5>
+{{{
+}}}
+
+Package=<4>
+{{{
+}}}
+
+###############################################################################
+
+Global:
+
+Package=<5>
+{{{
+}}}
+
+Package=<3>
+{{{
+}}}
+
+###############################################################################
+
diff --git a/src/optcl.h b/src/optcl.h
index 7e21c66..e50e25e 100644
--- a/src/optcl.h
+++ b/src/optcl.h
@@ -41,5 +41,5 @@ int TypeLib_Init (Tcl_Interp *pInterp);
extern CComPtr<IMalloc> g_pmalloc;
-
+extern bool g_bTkInit;
#endif// _OPTCL_H_B229D2A0_616A_11d4_8004_0040055861F2
\ No newline at end of file
diff --git a/src/optcl.tcl b/src/optcl.tcl
new file mode 100644
index 0000000..c92fd71
--- /dev/null
+++ b/src/optcl.tcl
@@ -0,0 +1,10 @@
+package provide optcl 3.0
+set env(OPTCL_LIBRARY) [file dirname [info script]]
+source [file join $env(OPTCL_LIBRARY) scripts Utilities.tcl]
+source [file join $env(OPTCL_LIBRARY) scripts Splitter.tcl]
+source [file join $env(OPTCL_LIBRARY) scripts TypeLib.tcl]
+source [file join $env(OPTCL_LIBRARY) scripts ImageListBox.tcl]
+source [file join $env(OPTCL_LIBRARY) scripts Tooltip.tcl]
+if {[info commands tk] != {}} {source [file join $env(OPTCL_LIBRARY) scripts TLView.tcl]}
+load [file join $env(OPTCL_LIBRARY) bin optcl.dll]
+typelib::updateLibs
\ No newline at end of file
diff --git a/src/resource.aps b/src/resource.aps
deleted file mode 100644
index 28c86bb..0000000
Binary files a/src/resource.aps and /dev/null differ
diff --git a/src/resource.h b/src/resource.h
index d253af9..74f1227 100644
--- a/src/resource.h
+++ b/src/resource.h
@@ -9,7 +9,7 @@
//
#ifdef APSTUDIO_INVOKED
#ifndef APSTUDIO_READONLY_SYMBOLS
-#define _APS_NEXT_RESOURCE_VALUE 103
+#define _APS_NEXT_RESOURCE_VALUE 104
#define _APS_NEXT_COMMAND_VALUE 40001
#define _APS_NEXT_CONTROL_VALUE 1000
#define _APS_NEXT_SYMED_VALUE 101
diff --git a/src/resource.rc b/src/resource.rc
index 52e366d..54e4d81 100644
--- a/src/resource.rc
+++ b/src/resource.rc
@@ -21,13 +21,6 @@ LANGUAGE LANG_ENGLISH, SUBLANG_ENGLISH_UK
#pragma code_page(1252)
#endif //_WIN32
-/////////////////////////////////////////////////////////////////////////////
-//
-// TCL_SCRIPT
-//
-
-IDR_TYPELIB TCL_SCRIPT DISCARDABLE "typelib.tcl"
-
#ifdef APSTUDIO_INVOKED
/////////////////////////////////////////////////////////////////////////////
//
@@ -80,15 +73,15 @@ 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 "FileVersion", "3,0,1,0\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"
+ VALUE "ProductVersion", "3,0,1,0\0"
+ VALUE "SpecialBuild", "threaded\0"
END
END
BLOCK "VarFileInfo"
diff --git a/src/test.tcl b/src/test.tcl
index 86b8d60..278d3b3 100644
--- a/src/test.tcl
+++ b/src/test.tcl
@@ -1,100 +1,8 @@
console show
-load optcl
+package require 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
-}
+set xl [optcl::new Excel.Application]
+$xl : visible 1
+$xl -with workbooks add
+$xl -with workbooks.item(1).worksheets.item(1).range(a1,d4) : value 16
+set r [$xl -with workbooks.item(1).worksheets.item(1) range a1 d4]
diff --git a/src/typelib.cpp b/src/typelib.cpp
index 4e2ec52..916ea4b 100644
--- a/src/typelib.cpp
+++ b/src/typelib.cpp
@@ -32,7 +32,8 @@
#include "typelib.h"
#include "objmap.h"
#include "optclbindptr.h"
-
+#include "optcltypeattr.h"
+#include <strstream>
//----------------------------------------------------------------
// \/\/\/\/\/\ Declarations /\/\/\/\/\/\/
@@ -63,7 +64,9 @@ TCL_CMDEF(TypeLib_UnloadLib);
TCL_CMDEF(TypeLib_IsLibLoaded);
TCL_CMDEF(TypeLib_TypesInLib);
TCL_CMDEF(TypeLib_TypeInfo);
-
+TCL_CMDEF(TypeLib_GetRegLibPath);
+TCL_CMDEF(TypeLib_GetLoadedLibPath);
+TCL_CMDEF(TypeLib_GetDetails);
//// TEST CODE ////
TCL_CMDEF(TypeLib_ResolveConstantTest);
@@ -102,65 +105,35 @@ void TypeLibsTbl::DeleteAll ()
deltbl();
}
-
-ITypeLib * TypeLibsTbl::LoadLib (Tcl_Interp *pInterp, const char *fullname)
+/*
+ *-------------------------------------------------------------------------
+ * TypeLibsTbl::LoadLib --
+ * Load a Type Library by it's pathname.
+ *
+ * Result:
+ * Pointer to the TypeLib object iff successful.
+ * Side Effects:
+ * Library is added to the cache
+ *-------------------------------------------------------------------------
+ */
+TypeLib * TypeLibsTbl::LoadLib (Tcl_Interp *pInterp, const char *pathname)
{
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);
+ CComPtr<ITypeComp> pComp;
+ TObjPtr progname, fullname;
+ Tcl_HashEntry *pEntry = NULL;
+ HRESULT hr;
+
+ hr = LoadTypeLibEx(A2OLE(pathname), REGKIND_NONE, &pLib);
CHECKHR(hr);
+ ASSERT(pLib != NULL);
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);
+ return Cache (pInterp, pLib, pathname);
}
catch (char *error) {
@@ -170,7 +143,7 @@ ITypeLib * TypeLibsTbl::LoadLib (Tcl_Interp *pInterp, const char *fullname)
Tcl_SetResult (pInterp, (char*)HRESULT2Str(hr), TCL_DYNAMIC);
}
- return pLib;
+ return NULL;
}
@@ -188,32 +161,107 @@ ITypeLib * TypeLibsTbl::LoadLib (Tcl_Interp *pInterp, const char *fullname)
* None.
*-------------------------------------------------------------------------
*/
-TypeLib* TypeLibsTbl::Cache (const char *szname, const char *szfullname, ITypeLib *ptl, ITypeComp *ptc)
+TypeLib* TypeLibsTbl::Cache (Tcl_Interp *pInterp, ITypeLib *ptl, const char * path /* = NULL */)
{
- ASSERT(szname != NULL && szfullname != NULL);
- ASSERT (ptl != NULL && ptc != NULL);
+ TLIBATTR * ptlattr = NULL;
+ CComPtr<ITypeComp> ptc;
TypeLib *pLib = NULL;
Tcl_HashEntry *pEntry = NULL;
- pLib = new TypeLib (ptl, ptc);
- pEntry = set(szname, pLib);
- ASSERT (pEntry != NULL);
- m_loadedlibs.set (szfullname, pEntry);
+ if (FAILED(ptl->GetLibAttr(&ptlattr))) {
+ if (pInterp)
+ Tcl_SetResult (pInterp, "couldn't retrieve type library attributes", TCL_STATIC);
+ return NULL;
+ }
+
+ ASSERT(ptlattr != NULL);
+
+ TypeLibUniqueID uid (ptlattr->guid, ptlattr->wMajorVerNum, ptlattr->wMinorVerNum);
+
+
+ ptl->ReleaseTLibAttr(ptlattr);
+
+ // search for this guid
+ if (m_loadedlibs.find(&uid, &pEntry) != NULL) {
+ ASSERT (pEntry != NULL);
+ pLib = (TypeLib *)Tcl_GetHashValue (pEntry);
+ return pLib;
+ }
+
+ // now generate the names, and do a search on the programmatic name
+ TObjPtr progname, fullname;
+ GenerateNames(progname, fullname, ptl);
+
+ if (g_libs.find((char*)progname, &pLib) != NULL) {
+ if (pInterp)
+ Tcl_SetResult (pInterp, "library already loaded with the same programmatic name", TCL_STATIC);
+ return NULL;
+ }
+
+ if (FAILED(ptl->GetTypeComp(&ptc))) {
+ if (pInterp)
+ Tcl_SetResult (pInterp, "failed to retrieve the ITypeComp interface", TCL_STATIC);
+ return NULL;
+ }
+
+ pLib = new TypeLib ();
+ if (FAILED(pLib->Init(ptl, ptc, progname, fullname, path))) {
+ delete pLib;
+ pLib = NULL;
+ } else {
+ pEntry = set(progname, pLib);
+ ASSERT (pEntry != NULL);
+ m_loadedlibs.set (&uid, pEntry);
+ }
+
return pLib;
}
-bool TypeLibsTbl::IsLibLoaded (const char *fullname)
+TypeLib * TypeLibsTbl::TypeLibFromUID (const GUID &guid, WORD maj, WORD min)
{
- ASSERT (fullname != NULL);
- return (m_loadedlibs.find (fullname) != NULL);
+ TypeLibUniqueID uid(guid, maj, min);
+ TypeLib *plib = NULL;
+ Tcl_HashEntry *pEntry = NULL;
+ m_loadedlibs.find(&uid, &pEntry);
+ if (pEntry)
+ plib = (TypeLib*)Tcl_GetHashValue (pEntry);
+ return plib;
}
+
+char * TypeLibsTbl::GetFullName (char * szProgName)
+{
+ ASSERT (szProgName != NULL);
+ TypeLib * pLib = NULL;
+ char * result = NULL;
+ if (find(szProgName, &pLib) != end()) {
+ ASSERT (pLib != NULL);
+ result = pLib->m_fullname;
+ }
+ return result;
+}
+
+
+
+GUID * TypeLibsTbl::GetGUID (char * szProgName)
+{
+ ASSERT (szProgName != NULL);
+ TypeLib * pLib = NULL;
+ GUID * result = NULL;
+ if (find(szProgName, &pLib) != end()) {
+ ASSERT (pLib != NULL && pLib->m_libattr != NULL);
+ result = &(pLib->m_libattr->guid);
+ }
+ return result;
+}
+
+
/*
*-------------------------------------------------------------------------
* TypeLibsTbl::UnloadLib --
- * Given the fullname of a library, the routine unloads it, if it is
+ * Given the programmatic name of a library, the routine unloads it, if it is
* loaded.
*
* Result:
@@ -223,22 +271,73 @@ bool TypeLibsTbl::IsLibLoaded (const char *fullname)
* None.
*-------------------------------------------------------------------------
*/
-void TypeLibsTbl::UnloadLib (Tcl_Interp *pInterp, const char *fullname)
+void TypeLibsTbl::UnloadLib (Tcl_Interp *pInterp, const char *szprogname)
{
Tcl_HashEntry *pEntry = NULL;
TypeLib *ptl = NULL;
+ pEntry = g_libs.find(szprogname, &ptl);
- if (!m_loadedlibs.find (fullname, &pEntry))
+ if (pEntry == NULL)
return;
- ASSERT (pEntry != NULL);
- ptl = (TypeLib*)Tcl_GetHashValue (pEntry);
- ASSERT (ptl != NULL);
+ ASSERT (ptl != NULL && ptl->m_ptl != NULL);
+
+ TObjPtr progname, fullname;
+ HRESULT hr = GenerateNames(progname, fullname, ptl->m_ptl);
+
+ if (FAILED(hr)) {
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ return;
+ }
+ ASSERT (fullname != (Tcl_Obj*)(NULL));
+ TypeLibUniqueID uid (ptl->m_libattr->guid, ptl->m_libattr->wMajorVerNum, ptl->m_libattr->wMinorVerNum);
+ m_loadedlibs.delete_entry(&(uid));
delete ptl;
- m_loadedlibs.delete_entry(fullname);
Tcl_DeleteHashEntry (pEntry);
}
+/*
+ *-------------------------------------------------------------------------
+ * TypeLibsTbl::GenerateNames --
+ * Given a type library, generates the programmatic and full name for the
+ * library.
+ *
+ * Result:
+ * S_OK iff successful.
+ *
+ * Side Effects:
+ * The objects, progname and username allocate memory to store the
+ * names.
+ *-------------------------------------------------------------------------
+ */
+HRESULT TypeLibsTbl::GenerateNames (TObjPtr &progname, TObjPtr &username, ITypeLib *pLib)
+{
+ USES_CONVERSION;
+ ASSERT (pLib != NULL);
+ CComBSTR bprogname, busername;
+ HRESULT hr;
+ hr = pLib->GetDocumentation(-1, &bprogname, &busername, NULL, NULL);
+ if (FAILED(hr)) return hr;
+
+ TLIBATTR * pattr = NULL;
+ hr = pLib->GetLibAttr (&pattr);
+ if (FAILED(hr)) return hr;
+
+ ASSERT (pattr != NULL);
+ TDString str;
+ if (busername != NULL)
+ str << OLE2A(busername);
+ else
+ str << OLE2A(bprogname);
+ str << " (Ver " << pattr->wMajorVerNum << "." << pattr->wMinorVerNum << ")";
+ pLib->ReleaseTLibAttr(pattr);
+
+ username.create();
+ username = str;
+ progname.create();
+ progname = OLE2A(bprogname);
+ return hr;
+}
@@ -256,42 +355,7 @@ void TypeLibsTbl::UnloadLib (Tcl_Interp *pInterp, const char *fullname)
*/
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;
+ return Cache(NULL, ptl);
}
@@ -314,7 +378,7 @@ TypeLib *TypeLibsTbl::EnsureCached (ITypeInfo *pInfo)
UINT tmp;
HRESULT hr;
hr = pInfo->GetContainingTypeLib(&pLib, &tmp);
- CHECKHR(hr);
+ if (FAILED(hr)) return NULL;
return EnsureCached (pLib);
}
@@ -329,13 +393,17 @@ 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::loadedlibs", 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);
+ Tcl_CreateObjCommand (pInterp, "typelib::reglib_path", TypeLib_GetRegLibPath, NULL, NULL);
+ Tcl_CreateObjCommand (pInterp, "typelib::loadedlib_path", TypeLib_GetLoadedLibPath, NULL, NULL);
+ Tcl_CreateObjCommand (pInterp, "typelib::loadedlib_details", TypeLib_GetDetails, NULL, NULL);
+
//// TESTS ////
Tcl_CreateObjCommand (pInterp, "typelib::resolveconst", TypeLib_ResolveConstantTest, NULL, NULL);
@@ -599,6 +667,8 @@ void TypeLib_GetName (ITypeLib *pLib, ITypeInfo *pInfo, TObjPtr &pname)
bLibcreate = true;
}
// get the library programmatic name
+
+
hr = pLib->GetDocumentation (-1, &progname, NULL, NULL, NULL);
CHECKHR(hr);
@@ -1203,10 +1273,30 @@ int TypeLib_DescribeTypeInfo (Tcl_Interp *pInterp, ITypeInfo *pti)
default:
presult = "???"; break;
}
+
presult.lappend(methods).lappend(properties).lappend(inherited);
- cmdresult = TCL_OK;
+
+
+ if (SUCCEEDED(pti->GetDocumentation (MEMBERID_NIL, NULL, &bdoc, NULL, NULL)) && bdoc != NULL)
+ {
+ presult.lappend (OLE2A(bdoc));
+ SysFreeString (bdoc);
+ }
+ else
+ presult.lappend ("");
+
+ LPOLESTR lpsz;
+ CHECKHR(StringFromCLSID (pta->guid, &lpsz));
+ ASSERT (lpsz != NULL);
+ if (lpsz != NULL) {
+ presult.lappend(OLE2A (lpsz));
+ CoTaskMemFree (lpsz); lpsz = NULL;
+ }
}
+ Tcl_SetObjResult (pInterp, presult);
+ cmdresult = TCL_OK;
+
ReleaseTypeAttr (pti, pta);
}
catch (HRESULT hr) {
@@ -1218,18 +1308,6 @@ int TypeLib_DescribeTypeInfo (Tcl_Interp *pInterp, ITypeInfo *pti)
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;
}
@@ -1522,7 +1600,7 @@ TCL_CMDEF(TypeLib_LoadedLibs)
*-------------------------------------------------------------------------
* TypeLib_LoadLib --
* Ensures that a given library is loaded. A library is described in terms
- * of its full human-readable name.
+ * of its filename.
*
* Result:
* TCL_OK iff successful.
@@ -1534,14 +1612,16 @@ TCL_CMDEF(TypeLib_LoadedLibs)
TCL_CMDEF(TypeLib_LoadLib)
{
if (objc != 2) {
- Tcl_WrongNumArgs (pInterp, 1, objv, "full_libname");
+ Tcl_WrongNumArgs (pInterp, 1, objv, "library_path");
return TCL_ERROR;
}
TObjPtr libname;
libname.attach(objv[1], false);
- if (g_libs.LoadLib (pInterp, libname) != NULL)
+ TypeLib * pLib = g_libs.LoadLib (pInterp, libname);
+ if (pLib) {
+ Tcl_SetResult (pInterp, pLib->m_progname, TCL_VOLATILE);
return TCL_OK;
- else
+ } else
return TCL_ERROR;
}
@@ -1585,16 +1665,34 @@ TCL_CMDEF(TypeLib_UnloadLib)
*/
TCL_CMDEF(TypeLib_IsLibLoaded)
{
- if (objc != 2) {
- Tcl_WrongNumArgs (pInterp, 1, objv, "fullname_library");
+ USES_CONVERSION;
+ if (objc != 4) {
+ Tcl_WrongNumArgs (pInterp, 1, objv, "lib_guid majorver minorver");
return TCL_ERROR;
}
- TObjPtr name;
- TObjPtr value;
- value.create(false);
- name.attach(objv[1]);
- value = g_libs.IsLibLoaded(name);
- Tcl_SetObjResult (pInterp, value);
+ GUID guid;
+ long maj, min;
+
+ char * szguid = Tcl_GetStringFromObj (objv[1], NULL);
+ ASSERT (szguid != NULL);
+ if (FAILED(CLSIDFromString(A2OLE(szguid), &guid))) {
+ Tcl_SetResult (pInterp, "string isn't a guid", TCL_STATIC);
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetLongFromObj(pInterp, objv[2], &maj) == TCL_ERROR)
+ return TCL_ERROR;
+
+ if (Tcl_GetLongFromObj(pInterp, objv[3], &min) == TCL_ERROR)
+ return TCL_ERROR;
+
+ TypeLib * pLib = NULL;
+
+ pLib = g_libs.TypeLibFromUID(guid, maj, min);
+ Tcl_ResetResult (pInterp);
+ if (pLib)
+ Tcl_SetObjResult(pInterp, pLib->m_progname);
+
return TCL_OK;
}
@@ -1687,7 +1785,62 @@ TCL_CMDEF (TypeLib_TypesInLib)
+HRESULT TypeLib_GetDefaultInterface (ITypeInfo *pti, bool bEventSource, ITypeInfo ** ppdefti) {
+ ASSERT (pti != NULL && ppdefti != NULL);
+ OptclTypeAttr attr;
+ attr = pti;
+ ASSERT (attr.m_pattr != NULL);
+ if (attr->typekind != TKIND_COCLASS)
+ return E_FAIL;
+ HRESULT hr;
+ WORD selected = -1;
+
+ for (WORD index = 0; index < attr->cImplTypes; index++) {
+
+ INT implflags;
+ hr = pti->GetImplTypeFlags(index, &implflags);
+ if (FAILED(hr)) return hr;
+
+ if ( ((implflags & IMPLTYPEFLAG_FDEFAULT) == IMPLTYPEFLAG_FDEFAULT) &&
+ ((bEventSource && (implflags & IMPLTYPEFLAG_FSOURCE) == IMPLTYPEFLAG_FSOURCE) ||
+ (!bEventSource && (implflags & IMPLTYPEFLAG_FSOURCE) != (IMPLTYPEFLAG_FSOURCE)))
+ ) {
+ break;
+ }
+ }
+ if (index == attr->cImplTypes)
+ return E_FAIL;
+
+ CComPtr<ITypeInfo> pimpl;
+ HREFTYPE hreftype;
+
+ // retrieve the referenced typeinfo
+ hr = pti->GetRefTypeOfImplType(index, &hreftype);
+ if (FAILED(hr)) return hr;
+
+ hr = pti->GetRefTypeInfo(hreftype, &pimpl);
+ if (FAILED(hr)) return hr;
+ OptclTypeAttr pimplattr;
+ pimplattr = pimpl;
+
+ // resolve typedefs
+ while (pimplattr->typekind == TKIND_ALIAS) {
+ CComPtr<ITypeInfo> pref;
+ hr = pimpl->GetRefTypeInfo(pimplattr->tdescAlias.hreftype, &pref);
+ if (FAILED(hr)) return hr;
+ pimpl = pref;
+ pimplattr = pimpl;
+ }
+
+ // if this isn't an interface forget it
+ if ((pimplattr->typekind != TKIND_DISPATCH) &&
+ (pimplattr->typekind != TKIND_INTERFACE))
+ return E_FAIL;
+
+ // okay - return the typeinfo to the caller
+ return pimpl.CopyTo(ppdefti);
+}
@@ -1747,6 +1900,102 @@ TCL_CMDEF(TypeLib_TypeInfo)
}
+
+
+
+
+
+TCL_CMDEF(TypeLib_GetRegLibPath)
+{
+ USES_CONVERSION;
+ if (objc != 4) {
+ Tcl_WrongNumArgs (pInterp, 1, objv, "lib_id majver minver");
+ return TCL_ERROR;
+ }
+
+ char * szGuid = Tcl_GetStringFromObj (objv[1], NULL);
+ long maj, min;
+
+ if (Tcl_GetLongFromObj(pInterp, objv[2], &maj) == TCL_ERROR)
+ return TCL_ERROR;
+
+ if (Tcl_GetLongFromObj(pInterp, objv[3], &min) == TCL_ERROR)
+ return TCL_ERROR;
+
+ GUID guid;
+ if (FAILED(CLSIDFromString(A2OLE(szGuid), &guid))) {
+ Tcl_SetResult (pInterp, "failed to convert to a guid: ", TCL_STATIC);
+ Tcl_AppendResult (pInterp, szGuid, NULL);
+ return TCL_ERROR;
+ }
+
+ CComBSTR path;
+ HRESULT hr = QueryPathOfRegTypeLib(guid, maj, min, LOCALE_SYSTEM_DEFAULT, &path);
+ if (FAILED(hr)) {
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ return TCL_ERROR;
+ }
+ Tcl_SetResult (pInterp, W2A(path), TCL_VOLATILE);
+ return TCL_OK;
+}
+
+TCL_CMDEF(TypeLib_GetLoadedLibPath)
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs (pInterp, 1, objv, "progname");
+ return TCL_ERROR;
+ }
+ char * szProgName = Tcl_GetStringFromObj(objv[1], NULL);
+ ASSERT (szProgName);
+
+ TypeLib * plib = NULL;
+ g_libs.find(szProgName, &plib);
+ if (plib==NULL) {
+ Tcl_SetResult (pInterp, "couldn't find loaded library: ", TCL_STATIC);
+ Tcl_AppendResult (pInterp, szProgName, NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult (pInterp, plib->m_path);
+ return TCL_OK;
+}
+
+
+TCL_CMDEF(TypeLib_GetDetails)
+{
+ USES_CONVERSION;
+ if (objc != 2) {
+ Tcl_WrongNumArgs (pInterp, 1, objv, "progname");
+ return TCL_ERROR;
+ }
+ char * szProgName = Tcl_GetStringFromObj (objv[1], NULL);
+ ASSERT(szProgName);
+ TypeLib * plib = NULL;
+ g_libs.find(szProgName, &plib);
+ if (plib == NULL) {
+ Tcl_SetResult (pInterp, "couldn't find loaded library: ", TCL_STATIC);
+ Tcl_AppendResult (pInterp, szProgName, NULL);
+ return TCL_ERROR;
+ }
+ TObjPtr obj;
+ obj.create();
+ LPOLESTR pstr;
+ HRESULT hr;
+ hr = StringFromCLSID(plib->m_libattr->guid, &pstr);
+ if (FAILED(hr)) {
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ return TCL_ERROR;
+ }
+ obj.lappend(OLE2A(pstr));
+ CoTaskMemFree(pstr);
+ obj.lappend(plib->m_libattr->wMajorVerNum);
+ obj.lappend(plib->m_libattr->wMinorVerNum);
+ obj.lappend(plib->m_path);
+ obj.lappend(plib->m_fullname);
+ Tcl_SetObjResult (pInterp, obj);
+ return TCL_OK;
+}
+
+
/*
*-------------------------------------------------------------------------
* TypeLib_ResolveName --
@@ -1761,6 +2010,7 @@ TCL_CMDEF(TypeLib_TypeInfo)
*
*-------------------------------------------------------------------------
*/
+
void TypeLib_ResolveName (const char * lib, const char * type,
TypeLib **pptl, ITypeInfo **ppinfo)
{
@@ -1884,7 +2134,7 @@ bool TypeLib_ResolveConstant (Tcl_Interp *pInterp, ITypeInfo *pti,
ASSERT (bp.lpvardesc->lpvarValue != NULL);
if (bp.lpvardesc->lpvarValue == NULL)
throw ("constant didn't have a associated value!");
- var2obj (pInterp, *(bp.lpvardesc->lpvarValue), pObj);
+ var2obj (pInterp, *(bp.lpvardesc->lpvarValue), NULL, pObj);
pti->ReleaseVarDesc (bp.lpvardesc);
return true;
}
@@ -2006,3 +2256,4 @@ TCL_CMDEF(TypeLib_ResolveConstantTest)
return TCL_ERROR;
}
+
diff --git a/src/typelib.h b/src/typelib.h
index 907709a..8e1610b 100644
--- a/src/typelib.h
+++ b/src/typelib.h
@@ -34,14 +34,55 @@
struct TypeLib {
CComPtr<ITypeLib> m_ptl;
CComPtr<ITypeComp> m_ptc;
+ TLIBATTR * m_libattr;
+
+ TObjPtr m_progname, m_fullname, m_path;
+
+
+ TypeLib () {
+ m_progname.create();
+ m_fullname.create();
+ m_path.create();
+ m_libattr = NULL;
+ }
+
+ ~TypeLib () {
+ if (m_libattr != NULL) {
+ ASSERT (m_ptl != NULL);
+ m_ptl->ReleaseTLibAttr(m_libattr);
+ }
+ }
+
+ HRESULT Init (ITypeLib *ptl, ITypeComp *ptc, const char * progname,
+ const char * fullname, const char * path) {
+ ASSERT (progname != NULL && fullname != NULL);
- TypeLib (ITypeLib *ptl, ITypeComp *ptc) {
m_ptl = ptl;
m_ptc = ptc;
+
+ m_progname = progname;
+ m_fullname = fullname;
+ if (path)
+ m_path = path;
+ else
+ m_path = "???";
+ return ptl->GetLibAttr(&m_libattr);
}
};
+struct TypeLibUniqueID {
+ TypeLibUniqueID (const GUID & guid, WORD maj, WORD min) {
+ m_guid = guid;
+ m_majorver = maj;
+ m_minorver = min;
+ }
+
+ GUID m_guid;
+ WORD m_majorver;
+ WORD m_minorver;
+};
+
// 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
@@ -51,19 +92,28 @@ 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* LoadLib (Tcl_Interp *pInterp, const char * fullpath);
+ void UnloadLib (Tcl_Interp *pInterp, const char * progname);
+ TypeLib* TypeLibFromUID (const GUID & guid, WORD maj, WORD min);
+
TypeLib* EnsureCached (ITypeLib *pLib);
TypeLib* EnsureCached (ITypeInfo *pInfo);
+
+ char* GetFullName (char * szProgName);
+ GUID* GetGUID (char * szProgName);
+
protected: // methods
- TypeLib* Cache (const char *szname, const char *szfullname, ITypeLib *ptl, ITypeComp *ptc);
+ TypeLib* Cache (Tcl_Interp * pInterp, ITypeLib *ptl, const char * path = NULL);
+ HRESULT GenerateNames (TObjPtr &progname, TObjPtr &username, ITypeLib *pLib);
protected: // properties
- THash <char, Tcl_HashEntry*> m_loadedlibs; // by name
+ THash <TypeLibUniqueID, Tcl_HashEntry*> m_loadedlibs; // by unique and full descriptor
};
+
// globals
extern TypeLibsTbl g_libs;
@@ -76,6 +126,6 @@ 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);
-
+HRESULT TypeLib_GetDefaultInterface (ITypeInfo *pti, bool bEventSource, ITypeInfo ** ppdefti);
#endif // _TYPELIB_H_62518A80_624A_11d4_8004_0040055861F2
\ No newline at end of file
diff --git a/src/typelib.tcl b/src/typelib.tcl
index ac19136..7d8b00c 100644
--- a/src/typelib.tcl
+++ b/src/typelib.tcl
@@ -1,26 +1,78 @@
package require registry
-package provide optcl 3.0
namespace eval typelib {
- variable syslibs
- variable syslibguids
- array set syslibs {}
- array set syslibguids {}
+ variable typelibraries
+ array set typelibraries {}
+
+
+ namespace export *
+ namespace import -force ::optcl_utils::*
# -----------------------------------------------------------------------------
- # updatelibs -- called to enumerate and store the system libraries
- proc updatelibs {} {
- variable syslibs;
- catch {unset syslibs}
- array set syslibs {}
+ # latest_typelib_version --
+ # For a given registered type library guid, it retrieves the most recent version
+ # number of the library, and returns a string giving a version qualified string
+ # description for the library. Returns {} iff failed.
+ #
+ proc latest_typelib_version {typelib_guid} {
+ set typelibpath HKEY_CLASSES_ROOT\\TypeLib\\$typelib_guid
+ if {[registry keys HKEY_CLASSES_ROOT\\TypeLib $typelib_guid] == {}} {
+ puts "couldn't find typelib $typelib"
+ return {}
+ }
+ set v [lindex [lsort -decreasing -real [registry keys $typelibpath]] 0]
+
+ if {$v == {}} {
+ puts "bad typelib version number: $v for $typelib_guid"
+ set result {}
+ } else {
+ set result [makelibname $typelib $v]
+ }
+ return $result
+ }
+
+ # makelibname --
+ # standard function for creating a library's human readable name from the
+ # registered guid.
+ #
+ proc makelibname {typelib_guid ver} {
+ set maj 0
+ set min 0
+ scan $ver "%d.%d" maj min
+ return "[registry get HKEY_CLASSES_ROOT\\TypeLib\\$typelib_guid\\$ver {}] (Ver $maj.$min)"
+ }
+
+ proc path_from_libname {libname} {
+ variable typelibraries
+ set r [array get typelibraries $libname]
+ if {$r == {}} {
+ error "library does not exist: $libname"
+ }
+ set libsettings [lindex $r 1]
+ return [eval path_from_libid $libsettings]
+ }
+ # updateLibs -- called to enumerate and store the system libraries
+ proc updateLibs {} {
+ variable typelibraries;
+
+ # enumerate the current type libraries to make sure that they're still there
+ foreach library [array names typelibraries] {
+ try {
+ mset {name path} $typelibraries($library)
+ if {![file exists $path]} {throw {}}
+ } catch {er} {
+ unset typelibraries($library)
+ }
+ }
+ # now iterate over the registered type libraries in the system
set root {HKEY_CLASSES_ROOT\TypeLib}
foreach id [registry keys $root] {
- catch {
+ try {
foreach v [registry keys $root\\$id] {
scan $v "%d.%d" maj min;
if [catch {
@@ -32,60 +84,93 @@ namespace eval typelib {
continue;
}
- set name "[registry get $root\\$id\\$v {}] (Ver $maj.$min)"
- set syslibs($name) [list $id $maj $min]
+ set name [makelibname $id $maj.$min]
+ set path [typelib::reglib_path $id $maj $min]
+ addLibrary $name $id $maj $min $path
}
+ } catch {e} {
+ puts $e
}
}
}
- # -----------------------------------------------------------------------------
- # categories -- returns the component categories
- proc categories {} {
+ proc addLibrary {name typelib_id maj min path} {
+ variable typelibraries
+ set typelibraries([list [string toupper $typelib_id] $maj $min]) [list $name $path]
+ }
- set alldata {}
- set k "HKEY_CLASSES_ROOT\\Component Categories"
- set cats [registry keys $k]
+ proc persistLoaded {} {
+ set cmd "typelib::loadLibsFromDetails"
+ lappend cmd [getLoadedLibsDetails]
+ return $cmd
+ }
- foreach cat $cats {
- set values [registry values $k\\$cat]
- set data {}
- foreach value $values {
- lappend data [registry get $k\\$cat $value]
- }
- lappend alldata $data
+ # getLoadedLibsDetails --
+ # Retrieves a list of descriptors for the current loaded libraries
+ proc getLoadedLibsDetails {} {
+ set result {}
+ foreach progname [typelib::loadedlibs] {
+ lappend result [typelib::loadedlib_details $progname]
}
+ return $result
+ }
- return $alldata
+ proc loadLibsFromDetails {details} {
+ foreach libdetail $details {
+ loadLibFromDetail $libdetail
+ }
}
+ proc loadLibFromDetail {libdetail} {
+ variable typelibraries
+ mset {guid maj min path fullname} $libdetail
+ # if the library is already registered, get the path from the registry
+ mset { _ regpath} [lindex [array get typelibraries [list $guid $maj $min]] 1]
+ if {$regpath != {}} {
+ set path $regpath
+ }
+
+ typelib::load $path
+ addLibrary $fullname $guid $maj $min $path
+ }
+
+ proc load {path} {
+ set progname [typelib::_load $path]
+ mset {guid maj min path fullname} [typelib::loadedlib_details $progname]
+ addLibrary $fullname $guid $maj $min $path
+ return $progname
+ }
# -----------------------------------------------------------------------------
- # libdetail -- returns a the id, maj and min version number
- # in a list if it exists, else throws an error
+
+ # libdetail --
+ # returns the id, maj and min version numbers and
+ # the path as a list if they exists, else throws an error.
+ #
proc libdetail {name} {
- variable syslibs
+ variable typelibraries
- if {[array names syslibs $name] == {}} {
+ if {[array names typelibraries $name] == {}} {
error "could not find the library '$name'"
}
- return [lindex [array get syslibs $name] 1]
+ return [lindex [array get typelibraries $name] 1]
}
#------------------------------------------------------------------------------
- # alllibs -- returns all the registered libraries by name
+ # alllibs -- returns all the registered libraries by {guid maj min} identification
proc alllibs {} {
- variable syslibs
- return [array names syslibs]
+ variable typelibraries
+ return [array names typelibraries]
}
+ # returns the fully qualified default interface for a com class
proc defaultinterface {classtype} {
set desc [typelib::typeinfo $classtype]
if {[llength $desc] != 3} {
@@ -101,522 +186,174 @@ namespace eval typelib {
}
#------------------------------------------------------------------------------
- updatelibs
-
}
+namespace eval COM {
+ namespace import -force ::typelib::*
-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;
+ # categories
+ # retrieve a list of all category names
+ proc categories {} {
+ set alldata {}
+ set k "HKEY_CLASSES_ROOT\\Component Categories"
+ set cats [registry keys $k]
- 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;
+ foreach cat $cats {
+ set values [registry values $k\\$cat]
+ set data {}
+ foreach value $values {
+ lappend data [registry get $k\\$cat $value]
}
-
- 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
+ lappend alldata $data
}
+ return $alldata
+ }
- 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
+ # collate all the category names under the category clsid (parameter 1) into an
+ # array passed by name
+ proc collate_category_names {category arrname} {
+ upvar $arrname categories
- foreach tl [lsort [array names ::typelib::syslibs]] {
- cl_list_addlib $w $tl
+ set ck "HKEY_CLASSES_ROOT\\Component Categories\\$category"
+ catch {
+ foreach value [registry values $ck] {
+ catch {set categories([registry get $ck $value]) ""}
}
- }
-
-
-
- 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
+ } err
+ return $err
+ }
- set bbox [$c bbox entry]
- set sr [list 0 0 [lindex $bbox 2] [expr $bottom + 20]]
- $c config -scrollregion $sr
- }
+ # collates all categories for a given clsid in an array that is passed by name
+ proc clsid_categories_to_array {clsid arrname} {
+ upvar $arrname categories
+ set k "HKEY_CLASSES_ROOT\\CLSID\\$clsid"
+
+ # catch if there aren't any implemented categories
- proc cl_list_updatetag {w tag} {
- variable textcolor
- variable highlightcolor
+ foreach subkey [registry keys "HKEY_CLASSES_ROOT\\CLSID\\$clsid"] {
+ switch $subkey {
+ {Implemented Categories} {
+ foreach category [registry keys "$k\\$subkey"] {
+ collate_category_names $category categories
+ }
+ }
- set c $w.c
- set tl [$c itemcget $tag -text]
+ Programmable {
+ array set categories {{Automation Objects} {}}
+ }
- if {![typelib::isloaded $tl]} {
- $c itemconfig $tag -fill $textcolor -font tlviewertext
- } else {
- $c itemconfig $tag -fill $highlightcolor -font tlviewerhigh
- }
- }
+ Control {
+ array set categories {Controls {}}
+ }
+ DocObject {
+ array set categories {{Document Objects} {}}
+ }
- 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
+ Insertable {
+ array set categories {{Embeddable Objects} {}}
+ }
}
- } 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
- }
+ # retrieves, as a list, the categories for the given clsid
+ proc clsid_categories {clsid} {
+ array set categories {}
+ clsid_categories_to_array $clsid categories
+ return [array names categories]
+ }
- 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) {}
- }
+ # retrieves all clsids that match the category name given by the first parameter
+ proc clsids {{cat {}}} {
+ array set categories {}
+ set clsidk "HKEY_CLASSES_ROOT\\CLSID"
+ if {$cat == {}} {
+ return [registry keys $clsidk]
}
+ # else ...
-
- 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;
- }
+ set classes {}
-
- 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"
+ foreach clsid [registry keys $clsidk] {
+ catch [unset categories]
+ array set categories {}
+ clsid_categories_to_array $clsid categories
+ if {[array names categories $cat]!={}} {
+ lappend classes $clsid
}
}
+ return $classes
+ }
- ###
- # 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
- }
+ # provides a description for the clsid
+ proc describe_clsid {clsid} {
+ set clsidk "HKEY_CLASSES_ROOT\\CLSID\\$clsid"
+ return [registry get $clsidk {}]
+ }
- 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 a list of clsid descriptor for all clsids that have the category specified by
+ # parameter one. If parameter is {} then all clsids are returned.
+ proc describe_all_clsids {{cat {}}} {
+ set l {}
+ foreach clsid [categories::all_clsids $cat] {
+ lappend l [categories::describe_clsid $clsid]
}
+ return [lsort -dictionary $l]
+ }
+ # retrieve the programmatics identifier for a clsid.
+ # If any exist, the result of this procedure is the programmatic identifier for the
+ # the clsid, followed by an optional version independent identifier
+ proc progid_from_clsid {clsid} {
+ set clsidk "HKEY_CLASSES_ROOT\\CLSID\\$clsid"
+ set progid {}
+ set verindid {}
+ catch {set progid [registry get "$clsidk\\ProgID" {}]}
+ catch {lappend progid [registry get "$clsidk\\VersionIndependentProgID" {}]}
+ return $progid
+ }
- ###
- # 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
+ proc typelib_from_clsid {clsid} {
+ set clsidk "HKEY_CLASSES_ROOT\\CLSID\\$clsid"
+ # associated typelib?
+
+ if {[registry keys $clsidk TypeLib] == {}} {
+ return {}
}
+ set typelib [registry get $clsidk\\TypeLib {}]
-
- ####
- # 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
+ # does it exist?
+ if {[registry keys HKEY_CLASSES_ROOT\\TypeLib $typelib] == {}} {
+ puts "couldn't find typelib $typelib from clsid $clsid"
+ return {}
}
-
- proc viewtype {fullname} {
- viewlib_select $fullname
+ # do we have a version number??
+ if {[registry keys $clsidk Version] != {}} {
+ set ver [registry get $clsidk\\Version {}]
+ set result [makelibname $typelib $ver]
+ } elseif {[registry keys $clsidk VERSION] != {}} {
+ set ver [registry get $clsidk\\VERSION {}]
+ set result [makelibname $typelib $ver]
+ } else {
+ # get the latest version of the type library
+ set result [latest_typelib_version $typelib]
}
+ return $result
}
-}
\ No newline at end of file
+}
diff --git a/src/utility.cpp b/src/utility.cpp
index ea4bba6..5c41a1f 100644
--- a/src/utility.cpp
+++ b/src/utility.cpp
@@ -31,6 +31,10 @@
#include "typelib.h"
#include "optclobj.h"
#include "optcltypeattr.h"
+#include "optclbindptr.h"
+#include "comrecordinfoimpl.h"
+#include <stack>
+
#ifdef _DEBUG
/*
@@ -63,6 +67,35 @@ void OptclTrace(LPCTSTR lpszFormat, ...)
#endif //_DEBUG
+
+template <class T>
+class TCoMem {
+public:
+ TCoMem () : p(NULL) {}
+ ~TCoMem () {
+ Free();
+ }
+
+ void Free () {
+ if (p) {
+ CoTaskMemFree(p);
+ p = NULL;
+ }
+ }
+
+ T* Alloc (ULONG size) {
+ Free();
+ p = (T*)(CoTaskMemAlloc (size));
+ return p;
+ }
+
+ operator T* () {
+ return p;
+ }
+protected:
+ T * p;
+};
+
/*
*-------------------------------------------------------------------------
* HRESULT2Str --
@@ -317,7 +350,7 @@ void OptclVariantClear (VARIANT *pvar)
-bool var2obj_byref (Tcl_Interp *pInterp, VARIANT &var, TObjPtr &presult, OptclObj **ppObj)
+bool var2obj_byref (Tcl_Interp *pInterp, VARIANT &var, ITypeInfo *pti, TObjPtr &presult, OptclObj **ppObj)
{
ASSERT (var.ppunkVal != NULL);
@@ -327,7 +360,7 @@ bool var2obj_byref (Tcl_Interp *pInterp, VARIANT &var, TObjPtr &presult, OptclOb
BSTR bstr = NULL;
HRESULT hr = S_OK;
OptclObj * pObj = NULL;
-
+ ULONG size = 0;
presult.create();
if (var.ppunkVal == NULL) {
@@ -340,7 +373,7 @@ bool var2obj_byref (Tcl_Interp *pInterp, VARIANT &var, TObjPtr &presult, OptclOb
case VT_DISPATCH:
case VT_UNKNOWN:
if (*var.ppunkVal != NULL) {
- pObj = g_objmap.Add (pInterp, *var.ppunkVal);
+ pObj = g_objmap.Add (pInterp, *var.ppunkVal, pti);
presult = (const char*)(*pObj); // cast to char*
if (ppObj != NULL)
*ppObj = pObj;
@@ -385,9 +418,12 @@ bool var2obj_byref (Tcl_Interp *pInterp, VARIANT &var, TObjPtr &presult, OptclOb
Tcl_SetResult (pInterp, "pointer to null", TCL_STATIC);
bOk = false;
} else {
- bOk = var2obj (pInterp, *var.pvarVal, presult, ppObj);
+ bOk = var2obj (pInterp, *var.pvarVal, NULL, presult, ppObj);
}
break;
+ case VT_RECORD:
+ return record2obj(pInterp, var, presult);
+ break;
default:
presult = "?unhandledtype?";
}
@@ -404,6 +440,125 @@ bool var2obj_byref (Tcl_Interp *pInterp, VARIANT &var, TObjPtr &presult, OptclOb
}
+/*
+ *-------------------------------------------------------------------------
+ * record2obj
+ * Converts a VT_RECORD variant to a Tcl object
+ * Result:
+ * true iff successful
+ * Side Effects:
+ * Can create new optcl objects, which without reference counting might
+ * become a nightmare! :-(
+ *-------------------------------------------------------------------------
+ */
+bool record2obj (Tcl_Interp *pInterp, VARIANT &var, TObjPtr &result)
+{
+ USES_CONVERSION;
+ ASSERT (var.vt == VT_RECORD && var.pRecInfo != NULL);
+
+ ULONG fields = 0, index;
+ TCoMem<BSTR> fieldnames;
+ bool bok = true;
+
+
+ IRecordInfo *prinfo = var.pRecInfo;
+ CComPtr<ITypeInfo> pinf;
+
+ try {
+ CHECKHR(prinfo->GetTypeInfo(&pinf));
+ CHECKHR(prinfo->GetFieldNames (&fields, NULL));
+ if (fieldnames.Alloc (fields) == NULL)
+ throw "failed to allocate memory.";
+ CHECKHR(prinfo->GetFieldNames (&fields, fieldnames));
+
+ for (index = 0; bok && index < fields; index++) {
+ CComVariant varValue;
+ TObjPtr value;
+ CHECKHR(prinfo->GetField(var.pvRecord, fieldnames[index], &varValue));
+ result.lappend(OLE2A(fieldnames[index]));
+ bok = var2obj (pInterp, varValue, pinf, value, NULL);
+ if (bok)
+ result.lappend(value);
+ }
+
+ } catch (HRESULT hr) {
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ bok = false;
+ } catch (_com_error ce) {
+ Tcl_SetResult (pInterp, T2A((TCHAR*)ce.ErrorMessage()), TCL_VOLATILE);
+ bok = false;
+ } catch (char *err) {
+ Tcl_SetResult (pInterp, err, TCL_VOLATILE);
+ bok = false;
+ } catch (...) {
+ Tcl_SetResult (pInterp, "An unexpected error type occurred", TCL_STATIC);
+ bok = false;
+ }
+
+ if (fieldnames != NULL) {
+ for (index = 0; index < fields; index++)
+ SysFreeString(fieldnames[index]);
+ }
+ return bok;
+}
+
+
+
+
+bool vararray2obj (Tcl_Interp * pInterp, VARIANT &var, ITypeInfo * pti, TObjPtr &presult)
+{
+ bool bOk = false;
+ LONG lbound, ubound;
+ VARTYPE vt = var.vt & (~VT_ARRAY); // type of elements array
+
+ presult.create();
+
+ if (var.parray == NULL) {
+ Tcl_SetResult (pInterp, "invalid pointer to COM safe array", TCL_STATIC);
+ return false;
+ }
+
+
+ ULONG dims = SafeArrayGetDim (var.parray), // total number of dimensions
+ dindex; // dimension iterator
+ auto_array<LONG> lbounds(dims), ubounds(dims);
+
+ // get the lower and upper bounds of each dimension
+ for (dindex = 0; dindex < dims; dindex++) {
+ CHECKHR_TCL(SafeArrayGetLBound(var.parray, dindex, lbounds+dindex), pInterp, false);
+ CHECKHR_TCL(SafeArrayGetUBound(var.parray, dindex, ubounds+dindex), pInterp, false);
+ }
+
+
+
+ CHECKHR_TCL(SafeArrayGetLBound(var.parray, 0, &lbound), pInterp, false);
+ CHECKHR_TCL(SafeArrayGetUBound(var.parray, 0, &ubound), pInterp, false);
+
+ for (LONG index = lbound; index <= ubound; index++) {
+ CComVariant varElement;
+ varElement.vt = vt;
+
+ // WARNING: The following code is *not* solid, as it doesn't handle record structures at all!!
+ // in order to do this, I'll have to take into account the type info associate with this
+ // array ... not now I guess.
+ if (vt == VT_VARIANT) {
+ CHECKHR_TCL(SafeArrayGetElement(var.parray, &index, &varElement), pInterp, false);
+ } else {
+ CHECKHR_TCL(SafeArrayGetElement(var.parray, &index, &(varElement.punkVal)), pInterp, false);
+ }
+ TObjPtr element;
+ // now that we've got the variant, convert it to a tcl object
+ if (!var2obj (pInterp, varElement, pti, element))
+ return false;
+ // append it to the result
+ presult += element;
+ }
+
+ return bOk;
+}
+
+
+
/*
*-------------------------------------------------------------------------
* var2obj --
@@ -414,7 +569,7 @@ bool var2obj_byref (Tcl_Interp *pInterp, VARIANT &var, TObjPtr &presult, OptclOb
* None.
*-------------------------------------------------------------------------
*/
-bool var2obj (Tcl_Interp *pInterp, VARIANT &var, TObjPtr &presult, OptclObj **ppObj /* = NULL*/)
+bool var2obj (Tcl_Interp *pInterp, VARIANT &var, ITypeInfo *pti, TObjPtr &presult, OptclObj **ppObj /* = NULL*/)
{
USES_CONVERSION;
@@ -430,17 +585,16 @@ bool var2obj (Tcl_Interp *pInterp, VARIANT &var, TObjPtr &presult, OptclObj **pp
if ((var.vt & VT_ARRAY) || (var.vt & VT_VECTOR)) {
- Tcl_SetResult (pInterp, "can't handle arrays or vectors for now", TCL_STATIC);
- return false;
+ return vararray2obj (pInterp, var, pti, presult);
}
if (var.vt == VT_VARIANT) {
ASSERT (var.pvarVal != NULL);
- return var2obj (pInterp, *(var.pvarVal), presult, ppObj);
+ return var2obj (pInterp, *(var.pvarVal), pti, presult, ppObj);
}
if (var.vt & VT_BYREF)
- return var2obj_byref (pInterp, var, presult, ppObj);
+ return var2obj_byref (pInterp, var, pti, presult, ppObj);
presult.create();
@@ -454,6 +608,10 @@ bool var2obj (Tcl_Interp *pInterp, VARIANT &var, TObjPtr &presult, OptclObj **pp
presult = (const char*)(*pObj); // cast to char*
if (ppObj != NULL)
*ppObj = pObj;
+ if (pti != NULL) {
+ g_libs.EnsureCached (pti);
+ pObj->SetInterfaceFromType(pti);
+ }
}
else
presult = 0;
@@ -473,6 +631,9 @@ bool var2obj (Tcl_Interp *pInterp, VARIANT &var, TObjPtr &presult, OptclObj **pp
case VT_R8:
presult = (double)(var.dblVal);
break;
+ case VT_RECORD:
+ return record2obj (pInterp, var, presult);
+ break;
default: // standard string conversion required
comvar = var;
name = comvar;
@@ -507,6 +668,7 @@ bool var2obj (Tcl_Interp *pInterp, VARIANT &var, TObjPtr &presult, OptclObj **pp
*
* Result:
* true iff successful, else interpreter holds error string.
+ *
* Side effects:
* None.
*-------------------------------------------------------------------------
@@ -519,7 +681,6 @@ bool obj2var_ti (Tcl_Interp *pInterp, TObjPtr &obj, VARIANT &var,
ASSERT (pInterp != NULL);
OptclTypeAttr ota;
- CComPtr<ITypeInfo> pcurrent;
CComPtr<IUnknown> ptmpunk;
HRESULT hr;
TObjPtr ptmp;
@@ -527,115 +688,110 @@ bool obj2var_ti (Tcl_Interp *pInterp, TObjPtr &obj, VARIANT &var,
OptclObj * pOptclObj = NULL;
long lValue;
+ // if we have no value, set the variant to an empty
+ if (obj.isnull ()) {
+ VariantClear(&var);
+ return true;
+ }
+
// 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 {
+ else if (pdesc->vt == VT_USERDEFINED) {
// type information provided and it refers to a user defined type
// resolve the initial type
+ CComPtr<ITypeInfo> refinfo;
+ CHECKHR(pInfo->GetRefTypeInfo (pdesc->hreftype, &refinfo));
- hr = pInfo->GetRefTypeInfo (pdesc->hreftype, &ota.m_pti);
- CHECKHR(hr);
- g_libs.EnsureCached (ota.m_pti);
- hr = ota.GetTypeAttr();
- CHECKHR(hr);
+ if (!TypeInfoResolveAliasing (pInterp, refinfo, &ota.m_pti))
+ return false;
+ CHECKHR(ota.GetTypeAttr());
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));
+ if (ota.m_pattr->typekind == TKIND_ALIAS &&
+ ota->tdescAlias.vt != VT_USERDEFINED)
+ return obj2var_ti (pInterp, obj, var, ota.m_pti, &(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))
+ 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;
+ V_VT(&var) = VT_UNKNOWN;
+ V_UNKNOWN(&var) = NULL;
+
+ // let's first check for the 'special' cases.
+
+ // images:
+ // check to see if we have tk installed and we're requested a picture
+ if (g_bTkInit && IsEqualGUID (ota.m_pattr->guid, __uuidof(IPicture))) {
+ // create picture variant
+ bOk = obj2picture(pInterp, obj, var);
+ } else if (((char*)obj)[0] != 0) {
+ pOptclObj = g_objmap.Find (obj);
+ if (pOptclObj != NULL) {
+ ptmpunk = (IUnknown*)(*pOptclObj);
+ ASSERT (ptmpunk != NULL);
+ hr = ptmpunk->QueryInterface (intfguid, (void**)&(var.punkVal));
+ CHECKHR(hr);
+ bOk = true;
+ } else {
+ ObjectNotFound (pInterp, obj);
+ }
+ } else
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;
+ V_VT(&var) = VT_UNKNOWN;
+ V_UNKNOWN(&var) = NULL;
+
+ if (obj.isnotnull() && ((char*)obj)[0] != 0) {
+ pOptclObj = g_objmap.Find (obj);
+ if (pOptclObj != NULL) {
+ var.punkVal = (IUnknown*)(*pOptclObj);
+ var.punkVal->AddRef();
+
+ bOk = true;
+ } else
+ ObjectNotFound (pInterp, obj);
} else
- ObjectNotFound (pInterp, obj);
+ bOk = true;
break;
- case TKIND_ALIAS:
ASSERT (FALSE); // should be hanlded above.
break;
// can't handle these types
case TKIND_MODULE:
+ break;
+ case TKIND_ALIAS:
case TKIND_RECORD:
+ return obj2record(pInterp, obj, var, ota.m_pti);
+ break;
case TKIND_UNION:
obj2var (obj, var);
bOk = true;
@@ -646,13 +802,196 @@ bool obj2var_ti (Tcl_Interp *pInterp, TObjPtr &obj, VARIANT &var,
}
}
+ else if (pdesc->vt == VT_PTR) {
+ ASSERT (pdesc->lptdesc != NULL);
+ if (pdesc->lptdesc->vt == VT_USERDEFINED)
+ return obj2var_ti (pInterp, obj, var, pInfo, pdesc->lptdesc);
+
+ ASSERT (pdesc->lptdesc->vt != VT_USERDEFINED);
+ return obj2var_vt_byref (pInterp, obj, var, pdesc->lptdesc->vt);
+ }
+
+ // a simple type
+ else {
+ ASSERT (pdesc->vt != VT_ARRAY && pdesc->vt != VT_PTR && pdesc->vt != VT_USERDEFINED);
+ return obj2var_vt (pInterp, obj, var, pdesc->vt);
+ }
+
+ // arrays - should be easy to do - not enough time right now...
+
+
return bOk;
}
+/*
+ *-------------------------------------------------------------------------
+ * TypeInfoResolveAliasing
+ * Resolves a type info to its base referenced type.
+ *
+ * Result:
+ * true iff successful.
+ *
+ * Side Effects:
+ * The pointer referenced by pti is updated to point to the base type.
+ *-------------------------------------------------------------------------
+ */
+bool TypeInfoResolveAliasing (Tcl_Interp *pInterp, ITypeInfo * pti, ITypeInfo ** presolved) {
+ ASSERT (pInterp != NULL && pti != NULL && presolved != NULL);
+
+ bool result = false;
+ CComPtr<ITypeInfo> currentinfo = pti, temp;
+ OptclTypeAttr pta;
+ try {
+ pta = currentinfo;
+ while (pta->typekind == TKIND_ALIAS && pta->tdescAlias.vt == VT_USERDEFINED) {
+ CHECKHR(currentinfo->GetRefTypeInfo (pta->tdescAlias.hreftype, &temp));
+ currentinfo = temp;
+ temp.Release();
+ pta = currentinfo;
+ g_libs.EnsureCached (currentinfo);
+ }
+
+ CHECKHR(currentinfo.CopyTo(presolved));
+ result = true;
+ } catch (char *er) {
+ Tcl_SetResult (pInterp, er, TCL_VOLATILE);
+ } catch (HRESULT hr) {
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ } catch (...) {
+ Tcl_SetResult (pInterp, "unknown error in obj2record", TCL_STATIC);
+ }
+ return result;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ * obj2record
+ *
+ * Result:
+ *
+ * Side Effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+bool obj2record (Tcl_Interp *pInterp, TObjPtr &obj, PVOID precord, ITypeInfo *pinf)
+{
+ USES_CONVERSION;
+ HRESULT hr;
+ try{
+ CComPtr<IRecordInfo> prinf;
+ CHECKHR(GetRecordInfoFromTypeInfo2(pinf, &prinf));
+
+ CComPtr<ITypeComp> pcmp;
+ CHECKHR(pinf->GetTypeComp (&pcmp));
+
+ int length = obj.llength ();
+ if ((length % 2) != 0)
+ throw ("record definition must have name value pairs");
+
+ // iterate over the list of name value pairs
+ for (int i = 0; (i+1) < length; i += 2) {
+ OptclBindPtr obp;
+
+ char * name = obj.lindex (i);
+ LPOLESTR lpoleName = A2OLE(name);
+ TObjPtr ptr = obj.lindex (i+1);
+ CComVariant vValue;
+
+ // retrieve the vardesc for this item:
+ hr = pcmp->Bind (lpoleName, 0, INVOKE_PROPERTYPUT | INVOKE_PROPERTYPUTREF | INVOKE_PROPERTYGET, &obp.m_pti, &obp.m_dk, &obp.m_bp);
+ if (obp.m_dk == DESCKIND_NONE) {
+ Tcl_SetResult (pInterp, "record doesn't have member called: ", TCL_STATIC);
+ Tcl_AppendResult (pInterp, name, NULL);
+ return false;
+ }
+ CHECKHR(hr);
+
+ ASSERT (obp.m_dk == DESCKIND_VARDESC);
+
+ if (obp.m_bp.lpvardesc->elemdescVar.tdesc.vt == VT_USERDEFINED) {
+ CComPtr<ITypeInfo> inforef, inforesolved;
+ CHECKHR(pinf->GetRefTypeInfo (obp.m_bp.lpvardesc->elemdescVar.tdesc.hreftype, &inforef));
+ if (!TypeInfoResolveAliasing (pInterp, inforef, &inforesolved))
+ return false;
+ OptclTypeAttr pta;
+ pta = inforesolved;
+ if (pta->typekind == TKIND_RECORD) {
+ VARIANT var;
+ CComPtr<ITypeInfo> peti;
+ VariantInit(&var);
+ PVOID pfield = NULL;
+ HRESULT hr = prinf->GetFieldNoCopy (precord, lpoleName, &var, &pfield);
+ ASSERT (var.vt & VT_RECORD);
+ CHECKHR(var.pRecInfo->GetTypeInfo (&peti));
+ if (!obj2record (pInterp, ptr, var.pvRecord, peti))
+ return false;
+ } else {
+ if (!obj2var_ti(pInterp, ptr, vValue, obp.m_pti, &(obp.m_bp.lpvardesc->elemdescVar.tdesc)))
+ return false;
+ CHECKHR(prinf->PutField (INVOKE_PROPERTYPUT, precord, lpoleName, &vValue));
+ }
+ } else {
+ if (!obj2var_ti(pInterp, ptr, vValue, obp.m_pti, &(obp.m_bp.lpvardesc->elemdescVar.tdesc)))
+ return false;
+ CHECKHR(prinf->PutField (INVOKE_PROPERTYPUT, precord, lpoleName, &vValue));
+ }
+ }
+ return true;
+ } catch (char *er) {
+ Tcl_SetResult (pInterp, er, TCL_VOLATILE);
+ } catch (HRESULT hr) {
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ } catch (...) {
+ Tcl_SetResult (pInterp, "unknown error in obj2record", TCL_STATIC);
+ }
+ return false;
+}
+/*
+ *-------------------------------------------------------------------------
+ * obj2record
+ * Converts a Tcl object to a record structure declared by a provided
+ * type info.
+ * Result:
+ * true iff successful.
+ * Side Effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+bool obj2record (Tcl_Interp *pInterp, TObjPtr& obj, VARIANT&var, ITypeInfo *pinf) {
+ ASSERT(pInterp != NULL && pinf != NULL);
+ USES_CONVERSION;
+ CComBSTR name;
+ try {
+ CComPtr<ITypeInfo> precinfo;
+ OptclTypeAttr pta;
+ pta = pinf;
+ //ASSERT (pta->typekind == TKIND_RECORD);
+
+ CComPtr<IRecordInfo> prinf;
+ CHECKHR(GetRecordInfoFromTypeInfo2(pinf, &prinf));
+
+ CComPtr<ITypeComp> pcmp;
+ CHECKHR(pinf->GetTypeComp (&pcmp));
+
+ VariantClear(&var);
+ var.pvRecord = prinf->RecordCreate ();
+ var.vt = VT_RECORD;
+ CHECKHR(prinf.CopyTo (&(var.pRecInfo)));
+ prinf->RecordInit (var.pvRecord);
+ return obj2record (pInterp, obj, var.pvRecord, pinf);
+ } catch (char *er) {
+ Tcl_SetResult (pInterp, er, TCL_VOLATILE);
+ } catch (HRESULT hr) {
+ Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC);
+ } catch (...) {
+ Tcl_SetResult (pInterp, "unknown error in obj2record", TCL_STATIC);
+ }
+ return false;
+}
/*
@@ -853,15 +1192,22 @@ bool obj2var_vt (Tcl_Interp *pInterp, TObjPtr &obj, VARIANT &var, VARTYPE vt)
IUnknown * ptmpunk = NULL;
bool bOk = true;
HRESULT hr;
+ OptclObj *pObj = g_objmap.Find (obj);
+ if (pObj != NULL) {
+ if (pObj->m_pta->typekind == TKIND_DISPATCH || (pObj->m_pta->wTypeFlags & TYPEFLAG_FDUAL))
+ vt = VT_DISPATCH;
+ else
+ vt = VT_UNKNOWN;
+ }
switch (vt)
{
case VT_DISPATCH:
case VT_UNKNOWN:
V_VT(&var) = vt;
- if (obj.isnull())
- var.punkVal = NULL;
- else {
+ V_UNKNOWN(&var) = NULL;
+
+ if (obj.isnotnull() && ( ((char*)obj)[0] != 0) ) {
// attempt to cast from an optcl object
pOptclObj = g_objmap.Find (obj);
@@ -995,7 +1341,7 @@ bool SplitBrackets (Tcl_Interp *pInterp, Tcl_Obj *pObj,
if (Tcl_EvalObj (pInterp, pcmd) == TCL_ERROR)
return false;
- CONST84 char * okstr = Tcl_GetStringResult (pInterp);
+ const 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);
@@ -1015,6 +1361,25 @@ bool SplitBrackets (Tcl_Interp *pInterp, Tcl_Obj *pObj,
return true;
}
+
+
+/*
+ *-------------------------------------------------------------------------
+ * obj2picture
+ * Convert the name of a tk image to an com object supporting IPicture
+ *
+ * Result:
+ * True iff successful. Else, error description in Tcl interpreter.
+ *
+ * Side Effects:
+ * None.
+ *-------------------------------------------------------------------------
+ */
+bool obj2picture(Tcl_Interp *pInterp, TObjPtr &obj, VARIANT &var) {
+ return false; // NOT IMPLEMENTED YET
+}
+
+
/// Tests
TCL_CMDEF (Obj2VarTest)
{
diff --git a/src/utility.h b/src/utility.h
index 510c692..6ad1903 100644
--- a/src/utility.h
+++ b/src/utility.h
@@ -43,11 +43,21 @@
void OptclTrace(LPCTSTR lpszFormat, ...);
#else
# define TRACE
-#endif
+#endif // _DEBUG
+
+// TRACE_OPTCLOBJ
+// Gives a trace output for an optcl object, in terms of its name, current interface, and reference count
+#ifdef _DEBUG
+# define TRACE_OPTCLOBJ(obj) {TObjPtr interfacename; obj->InterfaceName(interfacename); OptclTrace("%s %s --> %d\n", (char*)interfacename, obj->m_name.c_str(), obj->m_refcount);}
+#else
+# define TRACE_OPTCLOBJ
+#endif // _DEBUG
+
+
#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 CHECKHR_TCL(hr, i, v) {HRESULT _hr = (hr); if (FAILED(_hr)) {Tcl_SetResult (i, HRESULT2Str(_hr), TCL_DYNAMIC); return v;}}
#define SETDISPPARAMS(dp, numArgs, pvArgs, numNamed, pNamed) \
{\
@@ -62,6 +72,33 @@ void OptclTrace(LPCTSTR lpszFormat, ...);
#define _countof(x) (sizeof(x)/sizeof(x[0]))
+template <class T>
+class auto_array {
+public:
+ typedef T* TPTR;
+ auto_array () : m_ptr(NULL) {}
+ auto_array(unsigned long items) : m_ptr(NULL) {
+ Allocate(items);
+ }
+ ~auto_array() { ReleaseArray();}
+ void ReleaseArray () {
+ if (m_ptr != NULL) {
+ delete [] m_ptr;
+ m_ptr = NULL;
+ }
+ }
+ TPTR Allocate(unsigned long items) {
+ ReleaseArray();
+ m_ptr = new T[items];
+ return m_ptr;
+ }
+ operator TPTR () {
+ return m_ptr;
+ }
+protected:
+ TPTR m_ptr;
+};
+
template <class T> void delete_ptr (T* &ptr)
{
if (ptr != NULL) {
@@ -83,11 +120,15 @@ template <class T> T* delete_array (T *&ptr) {
class OptclObj;
-bool var2obj (Tcl_Interp *pInterp, VARIANT &var, TObjPtr &presult, OptclObj **ppObj = NULL);
+bool var2obj (Tcl_Interp *pInterp, VARIANT &var, ITypeInfo *pti, 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);
+bool record2obj (Tcl_Interp *pInterp, VARIANT &var, TObjPtr &result);
+bool obj2record (Tcl_Interp *pInterp, TObjPtr &obj, VARIANT &var, ITypeInfo *pinf);
+bool obj2picture(Tcl_Interp *pInterp, TObjPtr &obj, VARIANT &var);
+
void OptclVariantClear (VARIANT *pvar);
@@ -103,8 +144,8 @@ 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);
+bool SplitBrackets (Tcl_Interp *pInterp, Tcl_Obj *pObj, TObjPtr & result);
+bool TypeInfoResolveAliasing (Tcl_Interp *pInterp, ITypeInfo * pti, ITypeInfo ** presolved);
/// TESTS
TCL_CMDEF (Obj2VarTest);
diff --git a/temp code/reg.tcl b/temp code/reg.tcl
new file mode 100644
index 0000000..09ade01
--- /dev/null
+++ b/temp code/reg.tcl
@@ -0,0 +1,139 @@
+package require registry
+
+
+namespace eval COM {
+
+ # categories
+ # retrieve a list of all category names
+ 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
+ }
+
+
+ # collate all the category names under the category clsid (parameter 1) into an
+ # array passed by name
+ proc collate_category_names {category arrname} {
+ upvar $arrname categories
+
+ set ck "HKEY_CLASSES_ROOT\\Component Categories\\$category"
+ catch {
+ foreach value [registry values $ck] {
+ catch {set categories([registry get $ck $value]) ""}
+ }
+ } err
+ return $err
+ }
+
+
+ # collates all categories for a given clsid in an array that is passed by name
+ proc clsid_categories_to_array {clsid arrname} {
+ upvar $arrname categories
+ set k "HKEY_CLASSES_ROOT\\CLSID\\$clsid"
+
+ # catch if there aren't any implemented categories
+
+ foreach subkey [registry keys "HKEY_CLASSES_ROOT\\CLSID\\$clsid"] {
+ switch $subkey {
+ {Implemented Categories} {
+ foreach category [registry keys "$k\\$subkey"] {
+ collate_category_names $category categories
+ }
+ }
+
+ Programmable {
+ array set categories {{Automation Objects} {}}
+ }
+
+ Control {
+ array set categories {Controls {}}
+ }
+
+ DocObject {
+ array set categories {{Document Objects} {}}
+ }
+
+ Insertable {
+ array set categories {{Embeddable Objects} {}}
+ }
+ }
+ }
+
+ }
+
+ # retrieves, as a list, the categories for the given clsid
+ proc clsid_categories {clsid} {
+ array set categories {}
+ clsid_categories_to_array $clsid categories
+ return [array names categories]
+ }
+
+
+ # retrieves all clsids that match the category name given by the first parameter
+ proc clsids {{cat {}}} {
+ array set categories {}
+ set clsidk "HKEY_CLASSES_ROOT\\CLSID"
+ if {$cat == {}} {
+ return [registry keys $clsidk]
+ }
+
+ # else ...
+
+ set classes {}
+
+ foreach clsid [registry keys $clsidk] {
+ catch [unset categories]
+ array set categories {}
+ clsid_categories_to_array $clsid categories
+ if {[array names categories $cat]!={}} {
+ lappend classes $clsid
+ }
+ }
+ return $classes
+ }
+
+
+
+ # provides a description for the clsid
+ proc describe_clsid {clsid} {
+ set clsidk "HKEY_CLASSES_ROOT\\CLSID\\$clsid"
+ return [registry get $clsidk {}]
+ }
+
+
+
+ # retrieves a list of clsid descriptor for all clsids that have the category specified by
+ # parameter one. If parameter is {} then all clsids are returned.
+ proc descrive_all_clsids {{cat {}}} {
+ set l {}
+ foreach clsid [categories::all_clsids $cat] {
+ lappend l [categories::describe_clsid $clsid]
+ }
+ return [lsort -dictionary $l]
+ }
+
+ # retrieve the programmatics identifier for a clsid.
+ # If any exist, the result of this procedure is the programmatic identifier for the
+ # the clsid, followed by an optional version independent identifier
+ proc progid_from_clsid {clsid} {
+ set clsidk "HKEY_CLASSES_ROOT\\CLSID\\$clsid"
+ set progid {}
+ set verindid {}
+ catch {set progid [registry get "$clsidk\\ProgID" {}]}
+ catch {lappend progid [registry get "$clsidk\\VersionIndependentProgID" {}]}
+ return $progid
+ }
+}
+
diff --git a/tests/calendar.tcl b/tests/calendar.tcl
index 2ee371b..6543fa4 100644
--- a/tests/calendar.tcl
+++ b/tests/calendar.tcl
@@ -39,11 +39,11 @@ pack .cal
# bind to the calendar AfterUpdate event
# routing it to the tcl procedure onupdate
#
-optcl::bind $cal AfterUpdate onupdate
+#optcl::bind $cal AfterUpdate onupdate
# get the current value
-set currentdate [$cal : value]
+#set currentdate [$cal : value]
# make a button to view the type information of
diff --git a/tests/pdf.tcl b/tests/pdf.tcl
index 9304dca..bf11079 100644
--- a/tests/pdf.tcl
+++ b/tests/pdf.tcl
@@ -4,7 +4,7 @@ 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}]
+set pdf [optcl::new -window .pdf {C:\Program Files\Adobe\Acrobat 4.0\Help\ENU\acrobat.pdf}]
.pdf config -width 500 -height 300
pack .pdf -fill both -expand 1