optcl-3010 import master
authorPat Thoyts <patthoyts@users.sourceforge.net>
Fri, 13 Jun 2008 16:30:39 +0000 (17:30 +0100)
committerPat Thoyts <patthoyts@users.sourceforge.net>
Fri, 13 Jun 2008 16:30:39 +0000 (17:30 +0100)
61 files changed:
GNU_Public_Licence.html [deleted file]
Images/class.gif [new file with mode: 0644]
Images/copy.gif [new file with mode: 0644]
Images/dispatch.gif [new file with mode: 0644]
Images/down.xbm [new file with mode: 0644]
Images/enum.gif [new file with mode: 0644]
Images/find.gif [new file with mode: 0644]
Images/find.xbm [new file with mode: 0644]
Images/hide.xbm [new file with mode: 0644]
Images/interface.gif [new file with mode: 0644]
Images/libselect.gif [new file with mode: 0644]
Images/libselect.xbm [new file with mode: 0644]
Images/method.gif [new file with mode: 0644]
Images/module.gif [new file with mode: 0644]
Images/noselect.gif [new file with mode: 0644]
Images/property.gif [new file with mode: 0644]
Images/right.xbm [new file with mode: 0644]
Images/select.gif [new file with mode: 0644]
Images/show.xbm [new file with mode: 0644]
Images/struct.gif [new file with mode: 0644]
Images/typedef.gif [new file with mode: 0644]
Images/union.gif [new file with mode: 0644]
ReadMe.txt
docs/optcl.html
docs/optcltypelibaccess.html
docs/optcltypes.html
install/optcl80.dll [deleted file]
install/optcl_Install.tcl [deleted file]
install/optclstubs.dll [deleted file]
license.txt [new file with mode: 0644]
src/ComRecordInfoImpl.cpp [new file with mode: 0644]
src/ComRecordInfoImpl.h [new file with mode: 0644]
src/EventBinding.cpp
src/FixedSplitter.tcl [new file with mode: 0644]
src/ImageListBox.tcl [new file with mode: 0644]
src/ObjMap.cpp
src/ObjMap.h
src/OptclBindPtr.h
src/OptclObj.cpp
src/OptclObj.h
src/Splitter.tcl [new file with mode: 0644]
src/TLView.tcl [new file with mode: 0644]
src/Tooltip.tcl [new file with mode: 0644]
src/Utilities.tcl [new file with mode: 0644]
src/optcl.cpp
src/optcl.dsp
src/optcl.dsw [new file with mode: 0644]
src/optcl.h
src/optcl.tcl [new file with mode: 0644]
src/resource.aps [deleted file]
src/resource.h
src/resource.rc
src/test.tcl
src/typelib.cpp
src/typelib.h
src/typelib.tcl
src/utility.cpp
src/utility.h
temp code/reg.tcl [new file with mode: 0644]
tests/calendar.tcl
tests/pdf.tcl

diff --git a/GNU_Public_Licence.html b/GNU_Public_Licence.html
deleted file mode 100644 (file)
index ee2d7f1..0000000
+++ /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 &amp; GNU inquiries &amp; 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 (file)
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 (file)
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 (file)
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 (file)
index 0000000..c867fce
--- /dev/null
@@ -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 (file)
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 (file)
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 (file)
index 0000000..03267a1
--- /dev/null
@@ -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 (file)
index 0000000..11e2008
--- /dev/null
@@ -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 (file)
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 (file)
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 (file)
index 0000000..4602777
--- /dev/null
@@ -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 (file)
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 (file)
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 (file)
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 (file)
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 (file)
index 0000000..9a8a5f0
--- /dev/null
@@ -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 (file)
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 (file)
index 0000000..e9d8548
--- /dev/null
@@ -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 (file)
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 (file)
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 (file)
index 0000000..06e042f
Binary files /dev/null and b/Images/union.gif differ
index 310352f255b5fa5669a0e5eefc853cfdbd525e3a..b2ead576286070ffaf04d351ade936196270f791 100644 (file)
@@ -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
 ---------
 
 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
 -------------
 
 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
 fuzz@sys.uea.ac.uk
-
-
index 206a2d559ae944c35353bb24e7d6e8990be79b5b..a1b76dc9f5c8ef6c038105e583acdb8b3f679935 100644 (file)
@@ -3,7 +3,7 @@
 <head>
 <meta http-equiv="Content-Type"
 content="text/html; charset=iso-8859-1">
 <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>
 
 <title>OpTcl Documentation</title>
 </head>
 
@@ -18,12 +18,8 @@ Pezeshkpour</a></p>
 
 <p align="center">August 1999</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>
 
 
 <h1>The Distribution</h1>
 
@@ -33,9 +29,11 @@ the distribution:</p>
 <table border="0" cellpadding="4" cellspacing="4">
     <tr>
         <td><strong>install</strong></td>
 <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>
     </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
     <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>
 
     </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>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>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>
 </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>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>
 </ul>
 
 <h1>Credits</h1>
index f83e0b84f434b6e37712858089a8ace5de870430..7527b88f609d396370d9a52e1e1ab668f6e92ce9 100644 (file)
@@ -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>
         <em>libname</em></dd>
     <dd><a href="#typelib::typeinfo"><strong>typelib::typeinfo</strong></a>
         <em>libname.type </em>?<em>element</em>?</dd>
-    <dt>&nbsp;</dt>
 </dl>
 
 <h3>Description</h3>
 </dl>
 
 <h3>Description</h3>
index 55bcdb64ed33bb75f5a83dc4467fada28ca1d1ee..54dd225a66ce81ecc84d9f33bdd9fb02fed5e7dc 100644 (file)
@@ -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>
 
 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
 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,
 
 <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 (file)
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 (file)
index 0b04ace..0000000
+++ /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 (file)
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 (file)
index 0000000..363ea12
--- /dev/null
@@ -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 (file)
index 0000000..d393911
--- /dev/null
@@ -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 (file)
index 0000000..78a3798
--- /dev/null
@@ -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_)
index d8a12bdc1deb2d2664fab3bf8426bbdff524ca69..af64f1a37573860ca8f6e85283d64a04c4217cd9 100644 (file)
@@ -537,7 +537,7 @@ int BindingProps::Eval (OptclObj *pObj, DISPPARAMS *pDispParams, LPVARIANT pVarR
                for (count = 0; count < pDispParams->cArgs; count++)
                {
                        TObjPtr param;
                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);
                }
                                break;
                        cmd.lappend(param, m_pInterp);
                }
@@ -567,7 +567,7 @@ int BindingProps::Eval (OptclObj *pObj, DISPPARAMS *pDispParams, LPVARIANT pVarR
 
        if (result == TCL_ERROR)
        {
 
        if (result == TCL_ERROR)
        {
-               // do we have a exception storage
+               // do we have an exception storage
                if (pExcepInfo != NULL)
                {
                        // fill it in
                if (pExcepInfo != NULL)
                {
                        // fill it in
diff --git a/src/FixedSplitter.tcl b/src/FixedSplitter.tcl
new file mode 100644 (file)
index 0000000..6bed3ae
--- /dev/null
@@ -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 (file)
index 0000000..3f3921f
--- /dev/null
@@ -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>>
+       }
+}
+
index 1e9fd53ac38e17a2debbc16c91d54c411cc2ebf5..236831e60e7ccbc26b97ae1cff061ec3ad041a21 100644 (file)
@@ -68,6 +68,10 @@ ObjMap::~ObjMap()
  */
 void ObjMap::DeleteAll ()
 {
  */
 void ObjMap::DeleteAll ()
 {
+#ifdef _DEBUG
+       ObjDump();
+#endif // _DEBUG
+
        ObjNameMap::iterator i;
        for (i = m_namemap.begin(); i != m_namemap.end(); i++) {
                OptclObj *pobj = *i;
        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();
 }
 
        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;
        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
                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;
 }
        CreateCommand (pObj);
        return pObj;
 }
@@ -146,7 +174,7 @@ OptclObj * ObjMap::Create (Tcl_Interp *pInterp, const char * id, const char * pa
  *     None.
  *-------------------------------------------------------------------------
  */
  *     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;
 {
        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 (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);
                {
                        delete pObj;
                        pObj = NULL;
                }
                m_namemap.set(*pObj, pObj);
                m_unkmap.set(u, pObj);
-               pObj->m_refcount = 1;
+               
                CreateCommand (pObj);
                CreateCommand (pObj);
-       } else {
-               ++pObj->m_refcount;
        }
        }
-
+       Lock(pObj);
        ASSERT (pObj != NULL);
        return pObj;
 }
        ASSERT (pObj != NULL);
        return pObj;
 }
@@ -260,7 +286,7 @@ void ObjMap::DeleteCommand (OptclObj *po)
                return;
        
        
                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;
        if (cmdname == NULL)
                return;
        Tcl_CmdInfo cmdinf;
@@ -295,7 +321,8 @@ void ObjMap::DeleteCommand (OptclObj *po)
 void ObjMap::Delete (OptclObj *pObj)
 {
        ASSERT (pObj != NULL);
 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);
        // 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;
 {
        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);
 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);
 }
 
                Delete (po);
 }
 
index ce1a58c56fea532e0238204cf6b3f6eaebf4f46b..8796bb9ebb04661eceb96300722141eaac9ce2f1 100644 (file)
@@ -46,7 +46,7 @@ public: // constructor / destructor
        virtual ~ObjMap ();
 
        OptclObj *      Create (Tcl_Interp *pInterp, const char * id, const char * path, bool start);
        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);
 
        OptclObj *      Find (LPUNKNOWN punk);
        OptclObj *      Find (const char *name);
 
@@ -68,12 +68,12 @@ protected:
        void            Delete (OptclObj *);
        void            CreateCommand (OptclObj *);
        void            DeleteCommand (OptclObj *);
        void            Delete (OptclObj *);
        void            CreateCommand (OptclObj *);
        void            DeleteCommand (OptclObj *);
-
+       void            ObjDump ();
 };
 
 
 // Global Variable Declaration!!!
 
 };
 
 
 // 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_)
 
 #endif // !defined(AFX_OBJMAP_H__8A11BC00_616B_11D4_8004_0040055861F2__INCLUDED_)
index da93d280e76333c1f4d182abe2a0797fe11a2f93..c64813bfa9f932e12712b51cada04fe2067d8f36 100644 (file)
@@ -76,17 +76,27 @@ public:
 
        short           OptclBindPtr::cParamsOpt()
        {
 
        short           OptclBindPtr::cParamsOpt()
        {
+               int pin;
+               int oparams = 0;
                ASSERT (m_bp.lpfuncdesc != NULL);
                switch (m_dk) {
                case DESCKIND_FUNCDESC:
                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:
                case DESCKIND_IMPLICITAPPOBJ:
                case DESCKIND_VARDESC:
-                       return 1;
+                       oparams = 1;
+                       break;
                default:
                        ASSERT (FALSE);
                default:
                        ASSERT (FALSE);
-                       return 0;
                }
                }
+               return oparams;
        }
 
        ELEMDESC *      OptclBindPtr::param(short param)
        }
 
        ELEMDESC *      OptclBindPtr::param(short param)
index b2c74f6044e6a2ca989259fcdf5aef9325891651..84a66316b65d64a757b27ab06a8bcca57d20b712 100644 (file)
@@ -40,7 +40,7 @@
 //////////////////////////////////////////////////////////////////////
 
 OptclObj::OptclObj ()
 //////////////////////////////////////////////////////////////////////
 
 OptclObj::OptclObj ()
-: m_refcount(0), m_cmdtoken(NULL), m_pta(NULL),
+: m_refcount(0), m_cmdtoken(NULL),
 m_destroypending(false), m_container(this)
 {
 }
 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)) 
                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);
                
        }
                CHECKHR_TCL(hr, pInterp, false);
                
        }
@@ -100,17 +100,23 @@ bool OptclObj::Create (Tcl_Interp *pInterp, const char *strid,
  *     None.
  *-------------------------------------------------------------------------
  */
  *     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 {
 {
        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);
                CreateName (punk);
                InitialiseUnknown(punk);
                InitialiseClassInfo(m_punk);
-               InitialisePointers (m_punk);
+               InitialisePointers (m_punk, ptl, pti);
        }
        catch (HRESULT hr) {
                m_punk = NULL;
        }
        catch (HRESULT hr) {
                m_punk = NULL;
@@ -300,9 +306,9 @@ HRESULT OptclObj::InitialisePointersFromCoClass()
  */
 HRESULT OptclObj::GetTypeAttr()
 {
  */
 HRESULT OptclObj::GetTypeAttr()
 {
-       ASSERT (m_pta == NULL);
        ASSERT (m_pti != 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()
 {
  */
 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;
        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;
 
        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;
        }
        if (pta->typekind != TKIND_DISPATCH) {
                reftype->ReleaseTypeAttr (pta);
                return E_NOINTERFACE;
        }
+       */
 
        GUID guid = pta->guid;
 
        GUID guid = pta->guid;
-       reftype->ReleaseTypeAttr (pta);
-       
+       m_pcurrent.Release();
        hr = m_punk->QueryInterface(guid, (void**)(&m_pcurrent));
        if (FAILED(hr))
                return hr;
 
        hr = m_punk->QueryInterface(guid, (void**)(&m_pcurrent));
        if (FAILED(hr))
                return hr;
 
-       
        // nice! now we cache the result of all our hard work
        // 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);
        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();
 }
        // 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);
 {
        HRESULT hr;
        ASSERT (punk != NULL);
-       CComQIPtr<IDispatch> pdisp;
 
        ASSERT ((plib!=NULL && pinfo!=NULL) || (plib==NULL && pinfo==NULL));
 
        ASSERT ((plib!=NULL && pinfo!=NULL) || (plib==NULL && pinfo==NULL));
+       ReleaseTypeAttr();
 
        if (plib != NULL && pinfo != NULL) {
 
        if (plib != NULL && pinfo != NULL) {
-               m_pcurrent = punk;
+               //m_pcurrent = punk;
                m_ptl = plib;
                m_pti = pinfo;
                m_ptc = NULL;
                m_ptl = plib;
                m_pti = pinfo;
                m_ptc = NULL;
@@ -409,17 +428,13 @@ void OptclObj::InitialisePointers (LPUNKNOWN punk, ITypeLib *plib, ITypeInfo *pi
                GetTypeAttr();
        } 
 
                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())) {
        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 {
                try {
-                       if (m_pcurrent == NULL)
-                               throw (HRESULT(0));
+                       CHECKHR(punk->QueryInterface (IID_IDispatch, reinterpret_cast<void**>(&m_pcurrent)));
                        // get the type information and library.
                        // 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);
                        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();
                        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();
                        // 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;
                        m_ptl = NULL;
                        m_ptc = NULL;
                        return;
-               }
+               }               
        }
        }
+
        // inform the typelibrary browser system of the library
        g_libs.EnsureCached (m_ptl);
 }
        // 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;
        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.
        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);
 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;
        
        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? ..."
 
        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]);
                }
 
                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 {
                        return false;
                objc -= 2;
                objv += 2;
        }
        else {
-               pdisp = m_pcurrent;
+               punk = m_pcurrent;
                ptc = m_ptc;
                pti = m_pti;
        }
                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) 
                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;
                        }
                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)
                }
        }
 
        if (ptc == NULL)
-               return InvokeNoTypeInf (pInterp, invkind, objc, objv, pdisp);
+               return InvokeNoTypeInf (pInterp, invkind, objc, objv, reinterpret_cast<IDispatch*>(punk.p));
        else
        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;
        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.
  *
  * Result:
  *     true iff successful - else error string in interpreter.
+ *
  * Side effects:
  *     None.
  *-------------------------------------------------------------------------
  * 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));
                                // 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]);
                                }
                                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
                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[], 
 
 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;
 {
        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;
        static  DISPID          propput = DISPID_PROPERTYPUT;
        OptclBindPtr    obp;
        OptclTypeAttr   ota;
+    unsigned short wFlags = invokekind;
 
        ASSERT (objc >= 1);
 
        ASSERT (objc >= 1);
-       ASSERT (pDisp != NULL);
+       ASSERT (pUnk != NULL);
        ASSERT (pti != NULL);
        ASSERT (varResult.vt == VT_EMPTY);
        ota = pti;
 
        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));
 
        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) {
                CHECKHR(hr);
 
                if (obp.m_dk == DESCKIND_NONE) {
@@ -866,10 +854,30 @@ bool OptclObj::InvokeWithTypeInfVariant (Tcl_Interp *pInterp, long invokekind,
                                dp.rgdispidNamedArgs = &propput;
                        }
 
                                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;
 
                        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 (!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;
                }
        }
                        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[], 
  */
 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;
 {
        VARIANT varResult;
        VariantInit(&varResult);
        TObjPtr presult;
-
+       CComPtr<ITypeInfo> pResultInfo;
        bool bok;
        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
 
        // 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;
                        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)) {
        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);
        }
                        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, 
  *-------------------------------------------------------------------------
  */
 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;
 
        TObjPtr params;
        bool bok;
 
@@ -1070,10 +1101,10 @@ bool OptclObj::GetProp (Tcl_Interp *pInterp, Tcl_Obj *name,
 
                if (pti != NULL) {
                        ASSERT (ptc != NULL);
 
                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 {
                }
                else {
-                       bok = InvokeNoTypeInf (pInterp, DISPATCH_PROPERTYGET, length, pplist, pdisp);
+                       bok = InvokeNoTypeInf (pInterp, DISPATCH_PROPERTYGET, length, pplist, reinterpret_cast<IDispatch*>(punk));
                }
 
                free(pplist);
                }
 
                free(pplist);
@@ -1097,9 +1128,9 @@ bool OptclObj::GetProp (Tcl_Interp *pInterp, Tcl_Obj *name,
  *-------------------------------------------------------------------------
  */
 bool OptclObj::GetIndexedVariant (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;
        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);
 
                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 {
                }
                else {
-                       bok = InvokeNoTypeInfVariant (pInterp, invkind, length, pplist, pdisp, varResult);
+                       bok = InvokeNoTypeInfVariant (pInterp, invkind, length, pplist, reinterpret_cast<IDispatch*>(punk), varResult);
                }
                free(pplist);
        }
        return bok;
 }
 
                }
                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[], 
 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;
 {
        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;
        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);
 
                        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 {
                        }
                        else {
-                               bok = InvokeNoTypeInf (pInterp, DISPATCH_PROPERTYPUT, length, pplist, pdisp);
+                               bok = InvokeNoTypeInf (pInterp, DISPATCH_PROPERTYPUT, length, pplist, reinterpret_cast<IDispatch*>(punk));
                        }
                        namevalues += 2;
                        free(pplist);
                        }
                        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;
 {
        USES_CONVERSION;
-       ASSERT (pInterp != NULL && ppdisp != NULL && sname != NULL);
+       ASSERT (pInterp != NULL && ppunk != NULL && sname != NULL);
        // copy the string onto the stack
        char *          szname;
        // copy the string onto the stack
        char *          szname;
-       char *          seps = ".";
+       char *          seps = ".";     // seperators
        char *          szprop = NULL;
        char *          szprop = NULL;
-       _variant_t      varobj;
-       VARIANT         varResult;
+
 
        HRESULT         hr;
        
 
        HRESULT         hr;
        
@@ -1258,30 +1301,34 @@ bool    OptclObj::ResolvePropertyObject (Tcl_Interp *pInterp, const char *sname,
        TObjPtr plist;
        TObjPtr pokstring;
 
        TObjPtr plist;
        TObjPtr pokstring;
 
+       // copy the command string
        szname = (char*)_alloca (strlen (sname) + 1);
        strcpy (szname, sname);
        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);
        szprop = strtok(szname, seps);
-       CComQIPtr <IDispatch> current;
+       CComPtr <IUnknown> current;
        CComPtr <ITypeInfo> pti;
        CComPtr <ITypeComp> pcmp;
 
        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();
 
 
        pcmd.create();
 
-       VariantInit (&varResult);
-
        try {
                while (szprop != NULL)
                {
        try {
                while (szprop != NULL)
                {
+                       CComVariant     varResult;
                        TObjPtr prop(szprop);
                        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
                                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;
                        }
                                Tcl_AppendResult (pInterp, szprop, "' is not an object", NULL);
                                break;
                        }
-
                        else
                        {
                        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**>(&current)))) {
+                                               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();
                        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)
        }
 
        catch (HRESULT hr)
@@ -1333,8 +1390,7 @@ bool      OptclObj::ResolvePropertyObject (Tcl_Interp *pInterp, const char *sname,
        {
                Tcl_SetResult (pInterp, error, TCL_STATIC);
        }
        {
                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);
 }
        if (!m_destroypending)
                g_objmap.Delete(this);
 }
-
-
index 5d296f05f682e65f167419a063699d33f68e966d..e80f7cb319241348975cef11d88fed4b59cf7b56 100644 (file)
@@ -32,6 +32,7 @@
 // forward declarations of used classes
 #include "container.h"
 #include <string>
 // forward declarations of used classes
 #include "container.h"
 #include <string>
+#include "optcltypeattr.h"
 
 class ObjMap;
 class EventBindings;
 
 class ObjMap;
 class EventBindings;
@@ -51,7 +52,7 @@ public:
        virtual ~OptclObj ();
 
        bool    Create (Tcl_Interp *pInterp, const char *strid, const char *windowpath, bool start);
        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 * ();
 
        operator LPUNKNOWN();
        operator const char * ();
@@ -59,11 +60,12 @@ public:
        void    CoClassName (TObjPtr &pObj);
        void    InterfaceName (TObjPtr &pObj);
        void    SetInterfaceName (TObjPtr &pObj);
        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    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);
 
        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 ();
        void    InitialisePointers (LPUNKNOWN punk, ITypeLib *pLib = NULL, ITypeInfo *pinfo = NULL);
        void    CreateCommand();
        HRESULT InitialisePointersFromCoClass ();
-       HRESULT SetInterfaceFromType (ITypeInfo *pinfo);
        HRESULT GetTypeAttr();
        void    ReleaseTypeAttr();
        void    ReleaseBindingTable();
        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[], 
 
        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[], 
        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[], 
 
        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, 
        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);
 
        bool    GetPropVariantDispatch (Tcl_Interp *pInterp, const char*name, 
                                                                        IDispatch * pcurrent, VARIANT &varResult);
@@ -121,14 +123,15 @@ protected:        // methods
 
        void    ContainerWantsToDie ();
 protected:     // properties
 
        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
        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
        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 (file)
index 0000000..1de9d4d
--- /dev/null
@@ -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 (file)
index 0000000..4f0c673
--- /dev/null
@@ -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 (file)
index 0000000..8f1ebbc
--- /dev/null
@@ -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 (file)
index 0000000..7fdcb39
--- /dev/null
@@ -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
index d2fa2e161c3aa9afd376f0e358bf5878030f0de0..941b68926697f96db2094ef562908c0e45d45b86 100644 (file)
@@ -38,7 +38,7 @@
 HINSTANCE                      ghDll = NULL;
 CComModule                     _Module;
 CComPtr<IMalloc>       g_pmalloc;
 HINSTANCE                      ghDll = NULL;
 CComModule                     _Module;
 CComPtr<IMalloc>       g_pmalloc;
-
+bool                           g_bTkInit = false;
 //----------------------------------------------------------------
 
 // Function declarations
 //----------------------------------------------------------------
 
 // Function declarations
@@ -394,7 +394,7 @@ TCL_CMDEF(OptclInvokeLibFunction)
                                        CHECKHR_TCL(hr, pInterp, TCL_ERROR);
                                if (FAILED(hr))
                                        return TCL_ERROR;
                                        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);
                        }
                                        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;
                // 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
        }
 #else
 #error Wrong Tcl version for Stubs
@@ -630,11 +631,14 @@ int Optcl_Init (Tcl_Interp *pInterp)
 #endif // USE_TCL_STUBS
 
        HRESULT hr;
 #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);
        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);
        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;
        ASSERT (szscript != NULL);
        if (Tcl_GlobalEval (pInterp, szscript) == TCL_ERROR)
                return TCL_ERROR;
+       */
 
        Tcl_CreateObjCommand (pInterp, "optcl::new", OptclNewCmd, NULL, NULL);
        Tcl_CreateObjCommand (pInterp, "optcl::lock", OptclLockCmd, NULL, NULL);
 
        Tcl_CreateObjCommand (pInterp, "optcl::new", OptclNewCmd, NULL, NULL);
        Tcl_CreateObjCommand (pInterp, "optcl::lock", OptclLockCmd, NULL, NULL);
index c4407bd2e987931ca249dadf9f258814a73c545a..bc1dfd3f81dafa21214f6a78d5c0fdb47bf7b92d 100644 (file)
@@ -4,7 +4,7 @@
 
 # TARGTYPE "Win32 (x86) Dynamic-Link Library" 0x0102
 
 
 # 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 
 !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 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 
 !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
 !MESSAGE 
 
 # Begin Project
@@ -41,11 +40,11 @@ RSC=rc.exe
 # PROP Use_MFC 0
 # PROP Use_Debug_Libraries 0
 # PROP Output_Dir "Release"
 # 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
 # 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"
 # 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 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
 
 !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 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
 # 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"
 # 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 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 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 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 ""
 # 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"
 # 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 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 
 
 
 !ENDIF 
 
@@ -143,27 +114,30 @@ LINK32=link.exe
 
 # Name "optcl - Win32 Release"
 # Name "optcl - Win32 Debug"
 
 # 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"
 
 # 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 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 
 
 
 !ENDIF 
 
@@ -174,21 +148,16 @@ SOURCE=.\DispParams.cpp
 
 !IF  "$(CFG)" == "optcl - Win32 Release"
 
 
 !IF  "$(CFG)" == "optcl - Win32 Release"
 
-# ADD CPP /Yu"stdafx.h"
+# ADD CPP /YX"stdafx.h"
 
 !ELSEIF  "$(CFG)" == "optcl - Win32 Debug"
 
 
 !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 
 
 
 !ENDIF 
 
@@ -199,16 +168,16 @@ SOURCE=.\EventBinding.cpp
 
 !IF  "$(CFG)" == "optcl - Win32 Release"
 
 
 !IF  "$(CFG)" == "optcl - Win32 Release"
 
-# ADD CPP /Yu"stdafx.h"
+# ADD CPP /YX"stdafx.h"
 
 !ELSEIF  "$(CFG)" == "optcl - Win32 Debug"
 
 
 !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 
 
 
 !ENDIF 
 
@@ -216,7 +185,22 @@ SOURCE=.\EventBinding.cpp
 # Begin Source File
 
 SOURCE=.\initonce.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
 
 # End Source File
 # Begin Source File
 
@@ -224,21 +208,16 @@ SOURCE=.\ObjMap.cpp
 
 !IF  "$(CFG)" == "optcl - Win32 Release"
 
 
 !IF  "$(CFG)" == "optcl - Win32 Release"
 
-# ADD CPP /Yu"stdafx.h"
+# ADD CPP /YX"stdafx.h"
 
 !ELSEIF  "$(CFG)" == "optcl - Win32 Debug"
 
 
 !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 
 
 
 !ENDIF 
 
@@ -249,21 +228,16 @@ SOURCE=.\optcl.cpp
 
 !IF  "$(CFG)" == "optcl - Win32 Release"
 
 
 !IF  "$(CFG)" == "optcl - Win32 Release"
 
-# ADD CPP /Yu"stdafx.h"
+# ADD CPP /YX"stdafx.h"
 
 !ELSEIF  "$(CFG)" == "optcl - Win32 Debug"
 
 
 !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 
 
 
 !ENDIF 
 
@@ -271,6 +245,22 @@ SOURCE=.\optcl.cpp
 # Begin Source File
 
 SOURCE=.\OptclBindPtr.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
 
 # End Source File
 # Begin Source File
 
@@ -278,48 +268,97 @@ SOURCE=.\OptclObj.cpp
 
 !IF  "$(CFG)" == "optcl - Win32 Release"
 
 
 !IF  "$(CFG)" == "optcl - Win32 Release"
 
-# ADD CPP /Yu"stdafx.h"
+# ADD CPP /YX"stdafx.h"
 
 !ELSEIF  "$(CFG)" == "optcl - Win32 Debug"
 
 
 !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
 
 
 !ENDIF 
 
 # End Source File
 # Begin Source File
 
-SOURCE=.\OptclTypeAttr.cpp
+SOURCE=.\resource.rc
 # End Source File
 # Begin Source File
 
 SOURCE=.\StdAfx.cpp
 # 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
 # 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
 # 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
 # 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
 # Begin Source File
 
 SOURCE=.\Container.h
@@ -373,42 +412,272 @@ SOURCE=.\typelib.h
 SOURCE=.\utility.h
 # End Source File
 # End Group
 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
 
 # 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
 # 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 Source File
-# End Group
 # Begin Source File
 
 # Begin Source File
 
-SOURCE=.\test.tcl
+SOURCE=.\Utilities.tcl
 
 !IF  "$(CFG)" == "optcl - Win32 Release"
 
 
 !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"
 
 
 !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 
 
 
 !ENDIF 
 
+# End Source File
+# End Group
+# Begin Source File
+
+SOURCE=.\test.tcl
 # End Source File
 # End Target
 # End Project
 # End Source File
 # End Target
 # End Project
diff --git a/src/optcl.dsw b/src/optcl.dsw
new file mode 100644 (file)
index 0000000..1b00bbc
--- /dev/null
@@ -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>
+{{{
+}}}
+
+###############################################################################
+
index 7e21c6610f6d12e5b8e73a9dfc578a988c512ad2..e50e25e4be73e3e841b563bdad63d9e48f52ed1b 100644 (file)
@@ -41,5 +41,5 @@ int           TypeLib_Init (Tcl_Interp *pInterp);
 
 
 extern CComPtr<IMalloc> g_pmalloc;
 
 
 extern CComPtr<IMalloc> g_pmalloc;
-
+extern bool g_bTkInit;
 #endif// _OPTCL_H_B229D2A0_616A_11d4_8004_0040055861F2
\ No newline at end of file
 #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 (file)
index 0000000..c92fd71
--- /dev/null
@@ -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 (file)
index 28c86bb..0000000
Binary files a/src/resource.aps and /dev/null differ
index d253af9c46b5c6ce833334b1f051a2f0bbdb4328..74f1227718461356b1b382034896e2d85627b1ed 100644 (file)
@@ -9,7 +9,7 @@
 // 
 #ifdef APSTUDIO_INVOKED
 #ifndef APSTUDIO_READONLY_SYMBOLS
 // 
 #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
 #define _APS_NEXT_COMMAND_VALUE         40001
 #define _APS_NEXT_CONTROL_VALUE         1000
 #define _APS_NEXT_SYMED_VALUE           101
index 52e366da16fc5de79fd0690cd1cdaf1698193824..54e4d81fb07fa3763c7d22ec0b41dd4818b0aa3b 100644 (file)
@@ -21,13 +21,6 @@ LANGUAGE LANG_ENGLISH, SUBLANG_ENGLISH_UK
 #pragma code_page(1252)
 #endif //_WIN32
 
 #pragma code_page(1252)
 #endif //_WIN32
 
-/////////////////////////////////////////////////////////////////////////////
-//
-// TCL_SCRIPT
-//
-
-IDR_TYPELIB             TCL_SCRIPT DISCARDABLE  "typelib.tcl"
-
 #ifdef APSTUDIO_INVOKED
 /////////////////////////////////////////////////////////////////////////////
 //
 #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 "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 "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"
         END
     END
     BLOCK "VarFileInfo"
index 86b8d60a2f24542fa2886cd8779d900dc3cf29d7..278d3b3ed38638abb93eb5b57511731ebfd3b599 100644 (file)
@@ -1,100 +1,8 @@
 console show
 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]
index 4e2ec52fb88ab7bd9fe86c28ef30f7b295f627b2..916ea4b3e2c7687d084521df7c26debb4b0d95c9 100644 (file)
@@ -32,7 +32,8 @@
 #include "typelib.h"
 #include "objmap.h"
 #include "optclbindptr.h"
 #include "typelib.h"
 #include "objmap.h"
 #include "optclbindptr.h"
-
+#include "optcltypeattr.h"
+#include <strstream>
 
 //----------------------------------------------------------------
 //                             \/\/\/\/\/\ Declarations /\/\/\/\/\/\/
 
 //----------------------------------------------------------------
 //                             \/\/\/\/\/\ Declarations /\/\/\/\/\/\/
@@ -63,7 +64,9 @@ TCL_CMDEF(TypeLib_UnloadLib);
 TCL_CMDEF(TypeLib_IsLibLoaded);
 TCL_CMDEF(TypeLib_TypesInLib);
 TCL_CMDEF(TypeLib_TypeInfo);
 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);
 
 //// TEST CODE ////
 TCL_CMDEF(TypeLib_ResolveConstantTest);
@@ -102,65 +105,35 @@ void TypeLibsTbl::DeleteAll ()
        deltbl();
 }
 
        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;
 {
        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 {
        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);
                CHECKHR(hr);
+               ASSERT(pLib != NULL);
                if (pLib == NULL)
                        throw ("failed to bind to a type library");
 
                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) {
        } 
 
        catch (char *error) {
@@ -170,7 +143,7 @@ ITypeLib * TypeLibsTbl::LoadLib (Tcl_Interp *pInterp, const char *fullname)
                Tcl_SetResult (pInterp, (char*)HRESULT2Str(hr), TCL_DYNAMIC);
        }
 
                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.
  *-------------------------------------------------------------------------
  */
  *     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;
 
        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;
 }
 
 
        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 --
 /*
  *-------------------------------------------------------------------------
  * 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:
  *     loaded.
  *
  * Result:
@@ -223,22 +271,73 @@ bool TypeLibsTbl::IsLibLoaded (const char *fullname)
  *     None.
  *-------------------------------------------------------------------------
  */
  *     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;
 {
        Tcl_HashEntry *pEntry = NULL;
        TypeLib *ptl  = NULL;
+       pEntry = g_libs.find(szprogname, &ptl);
 
 
-       if (!m_loadedlibs.find (fullname, &pEntry)
+       if (pEntry == NULL
                return;
 
                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;
        delete ptl;
-       m_loadedlibs.delete_entry(fullname);
        Tcl_DeleteHashEntry (pEntry);
 }
 
        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)
 {
  */
 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);
        UINT tmp;
        HRESULT hr;
        hr = pInfo->GetContainingTypeLib(&pLib, &tmp);
-       CHECKHR(hr);
+       if (FAILED(hr)) return NULL;
        return EnsureCached (pLib);
 }
 
        return EnsureCached (pLib);
 }
 
@@ -329,13 +393,17 @@ int TypeLib_Init (Tcl_Interp *pInterp)
 {
        OleInitialize(NULL);
        Tcl_CreateExitHandler (TypeLib_Exit, NULL);
 {
        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::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);
        
        //// 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
                bLibcreate = true;
        }
        // get the library programmatic name
+
+       
        hr = pLib->GetDocumentation (-1, &progname, NULL, NULL, NULL);
        CHECKHR(hr);
 
        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;
                        }
                        default:
                                presult = "???"; break;
                        }
+
                        
                        presult.lappend(methods).lappend(properties).lappend(inherited);
                        
                        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) {
                ReleaseTypeAttr (pti, pta);
        }
        catch (HRESULT hr) {
@@ -1218,18 +1308,6 @@ int TypeLib_DescribeTypeInfo (Tcl_Interp *pInterp, ITypeInfo *pti)
                throw (error);
        }
 
                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;
 }
 
        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
  *-------------------------------------------------------------------------
  * 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.
  *
  * Result:
  *     TCL_OK iff successful.
@@ -1534,14 +1612,16 @@ TCL_CMDEF(TypeLib_LoadedLibs)
 TCL_CMDEF(TypeLib_LoadLib)
 {
        if (objc != 2) {
 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);
                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;
                return TCL_OK;
-       else
+       else
                return TCL_ERROR;
 }
 
                return TCL_ERROR;
 }
 
@@ -1585,16 +1665,34 @@ TCL_CMDEF(TypeLib_UnloadLib)
  */
 TCL_CMDEF(TypeLib_IsLibLoaded)
 {
  */
 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;
        }
                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;
 }
 
        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 --
 /*
  *-------------------------------------------------------------------------
  * TypeLib_ResolveName --
@@ -1761,6 +2010,7 @@ TCL_CMDEF(TypeLib_TypeInfo)
  *
  *-------------------------------------------------------------------------
  */
  *
  *-------------------------------------------------------------------------
  */
+
 void TypeLib_ResolveName (const char * lib, const char * type, 
                                                  TypeLib **pptl, ITypeInfo **ppinfo)
 {
 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!");
                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;
        }
                pti->ReleaseVarDesc (bp.lpvardesc);
                return true;
        }
@@ -2006,3 +2256,4 @@ TCL_CMDEF(TypeLib_ResolveConstantTest)
                return TCL_ERROR;
 }
 
                return TCL_ERROR;
 }
 
+
index 907709adea15c7367525af4ff4b9a1e7830ba246..8e1610ba61b3fd8c8c948abf6442371570bac0b9 100644 (file)
 struct TypeLib {
        CComPtr<ITypeLib>       m_ptl; 
        CComPtr<ITypeComp>      m_ptc;
 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_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
 
 // 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 ();
 public:
                                TypeLibsTbl ();
        virtual         ~TypeLibsTbl ();
+
        void            DeleteAll ();
        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);
        TypeLib*        EnsureCached (ITypeLib  *pLib);
        TypeLib*        EnsureCached (ITypeInfo *pInfo);
+
+       char*           GetFullName (char * szProgName);
+       GUID*           GetGUID (char * szProgName);
+
 protected: // methods
 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
 
 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;
 
 // 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);
                                                                 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
 
 #endif // _TYPELIB_H_62518A80_624A_11d4_8004_0040055861F2
\ No newline at end of file
index ac191366bdaf9287e834140b53984e4f949a797e..7d8b00c9e3954cf10d615c18445cce3f37da7eb0 100644 (file)
@@ -1,26 +1,78 @@
 package require registry
 package require registry
-package provide optcl 3.0
 
 namespace eval typelib {
 
 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] {
                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 {
                                foreach v [registry keys $root\\$id] {
                                        scan $v "%d.%d" maj min;
                                        if [catch {
@@ -32,60 +84,93 @@ namespace eval typelib {
                                                continue;
                                        }
 
                                                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} {
        proc libdetail {name} {
-               variable syslibs
+               variable typelibraries
 
 
-               if {[array names syslibs $name] == {}} {
+               if {[array names typelibraries $name] == {}} {
                        error "could not find the library '$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 {} {
        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} {
        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
+}
index ea4bba687254fc11226319e066f9390a53af8dea..5c41a1f34b3cfc5f57a6421c8535443d8eb2038f 100644 (file)
 #include "typelib.h"
 #include "optclobj.h"
 #include "optcltypeattr.h"
 #include "typelib.h"
 #include "optclobj.h"
 #include "optcltypeattr.h"
+#include "optclbindptr.h"
+#include "comrecordinfoimpl.h"
+#include <stack>
+
 
 #ifdef _DEBUG
 /*
 
 #ifdef _DEBUG
 /*
@@ -63,6 +67,35 @@ void OptclTrace(LPCTSTR lpszFormat, ...)
 #endif //_DEBUG
 
 
 #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 --
 /*
  *-------------------------------------------------------------------------
  * 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);
 
 {
        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;
        BSTR            bstr = NULL;
        HRESULT         hr = S_OK;
        OptclObj *      pObj = NULL;
-
+       ULONG           size = 0;
 
        presult.create();
        if (var.ppunkVal == NULL) {
 
        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) {
                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;
                                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 {
                                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;
                        }
                        break;
+               case VT_RECORD:
+                       return record2obj(pInterp, var, presult);
+                       break;
                default:
                        presult = "?unhandledtype?";
                }
                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 --
 /*
  *-------------------------------------------------------------------------
  * var2obj --
@@ -414,7 +569,7 @@ bool var2obj_byref (Tcl_Interp *pInterp, VARIANT &var, TObjPtr &presult, OptclOb
  *     None.
  *-------------------------------------------------------------------------
  */
  *     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;
 
 {
        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)) {
        
 
        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);
        }
 
        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)
        }
 
        if (var.vt & VT_BYREF)
-               return var2obj_byref (pInterp, var, presult, ppObj);
+               return var2obj_byref (pInterp, var, pti, presult, ppObj);
 
        presult.create();
 
 
        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;
                                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;
                        }
                        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_R8:
                        presult = (double)(var.dblVal);
                        break;
+               case VT_RECORD:
+                       return record2obj (pInterp, var, presult);
+                       break;
                default: // standard string conversion required
                        comvar = var;
                        name = comvar;
                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.
  *
  * Result:
  *     true iff successful, else interpreter holds error string.
+ *
  * Side effects:
  *     None.
  *-------------------------------------------------------------------------
  * Side effects:
  *     None.
  *-------------------------------------------------------------------------
@@ -519,7 +681,6 @@ bool obj2var_ti (Tcl_Interp *pInterp, TObjPtr &obj, VARIANT &var,
        ASSERT (pInterp != NULL);
 
        OptclTypeAttr           ota;
        ASSERT (pInterp != NULL);
 
        OptclTypeAttr           ota;
-       CComPtr<ITypeInfo>      pcurrent;
        CComPtr<IUnknown>       ptmpunk;
        HRESULT                         hr;
        TObjPtr                         ptmp;
        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;
 
        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;
        }
 
        // 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 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
                // 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);
                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
                // 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;      
 
 
 
                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);
                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
                                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;
                                bOk = true;
-                       } else 
-                               ObjectNotFound (pInterp, obj);
                        break;
 
                case TKIND_COCLASS:
                        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 
                        } else 
-                               ObjectNotFound (pInterp, obj);
+                               bOk = true;
                        break;
 
                        break;
 
-               case TKIND_ALIAS: 
                        ASSERT (FALSE); // should be hanlded above.
                        break;
 
                // can't handle these types
                case TKIND_MODULE:
                        ASSERT (FALSE); // should be hanlded above.
                        break;
 
                // can't handle these types
                case TKIND_MODULE:
+                       break;
+               case TKIND_ALIAS: 
                case TKIND_RECORD:
                case TKIND_RECORD:
+                       return obj2record(pInterp, obj, var, ota.m_pti);
+                       break;
                case TKIND_UNION:
                        obj2var (obj, var);
                        bOk = true;
                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;
 }
 
 
        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;
        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;
 
        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);
                        
                        // 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;
 
        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);
        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;
 }
 
        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)
 {
 /// Tests
 TCL_CMDEF (Obj2VarTest)
 {
index 510c69281e521f8664bd718daf806394ccb293c2..6ad1903063419f370630c34646513dc8be59feb2 100644 (file)
 void OptclTrace(LPCTSTR lpszFormat, ...);
 #else
 #      define TRACE
 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 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) \
     {\
 
 #define SETDISPPARAMS(dp, numArgs, pvArgs, numNamed, pNamed) \
     {\
@@ -62,6 +72,33 @@ void OptclTrace(LPCTSTR lpszFormat, ...);
 #define _countof(x) (sizeof(x)/sizeof(x[0]))
 
 
 #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) {
 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;
 
 
 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           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);
 
 
 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);
 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);
 
 /// TESTS
 TCL_CMDEF (Obj2VarTest);
diff --git a/temp code/reg.tcl b/temp code/reg.tcl
new file mode 100644 (file)
index 0000000..09ade01
--- /dev/null
@@ -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
+       }
+}
+
index 2ee371b3b968b82e27737c7e121963dd3ceb9e7c..6543fa46069411a9795a3e4a3fbea7b0ba8c78a2 100644 (file)
@@ -39,11 +39,11 @@ pack .cal
 # bind to the calendar AfterUpdate event
 # routing it to the tcl procedure onupdate
 #
 # 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
 
 
 # get the current value
-set currentdate [$cal : value]
+#set currentdate [$cal : value]
 
 
 # make a button to view the type information of 
 
 
 # make a button to view the type information of 
index 9304dca753fd8361905c2057d133d4862caa342f..bf11079f21926d121eaf960d9e55120cf0b91415 100644 (file)
@@ -4,7 +4,7 @@ package require optcl
 bind . <F2> {console show}
 
 wm title . {PDF Document in Tk}
 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
 
 .pdf config -width 500 -height 300
 pack .pdf -fill both -expand 1