From: Pat Thoyts Date: Fri, 13 Jun 2008 16:22:40 +0000 (+0100) Subject: optcl-3004 import X-Git-Url: http://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=e944f7eaa3aa55648cec04cd0e9623f4d8bd2cfd;p=optcl optcl-3004 import --- e944f7eaa3aa55648cec04cd0e9623f4d8bd2cfd diff --git a/GNU_Public_Licence.html b/GNU_Public_Licence.html new file mode 100644 index 0000000..ee2d7f1 --- /dev/null +++ b/GNU_Public_Licence.html @@ -0,0 +1,525 @@ + + + +GNU General Public License - GNU Project - Free Software Foundation (FSF) + + + +

GNU General Public License

+ + +

+ +

GNU GENERAL PUBLIC LICENSE +
+

+ +

+ + + +

GNU GENERAL PUBLIC LICENSE

+Version 2, June 1991 + +

+ +

+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.
+

+ + + +

Preamble

+ +

+ 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. + +

+ 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. + +

+ 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. + +

+ 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. + +

+ 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. + +

+ 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. + +

+ 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. + +

+ The precise terms and conditions for copying, distribution and +modification follow. + +

+ + +

TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION

+ + +

+ +0. + 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". +

+ +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. + +

+ +1. + 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. +

+ +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. +

+ +2. + 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: +

+ +

a) + You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + +
+
b) + 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. + +
+
c) + 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.) +

+ +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. +

+ +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. +

+ +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. + +

+ +3. + 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: + + + + +

a) + 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, + +
+
b) + 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, + +
+
c) + 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.) +

+ +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. +

+ +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. +

+ +4. + 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. + +

+ +5. + 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. + +

+ +6. + 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. + +

+ +7. + 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. +

+ +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. +

+ +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. +

+ +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + +

+ +8. + 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. + +

+ +9. + 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. +

+ +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. + +

+ + +10. + 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. + + + +

NO WARRANTY

+ +

+ +11. + 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. + +

+ +12. + 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. + +

+ + +

END OF TERMS AND CONDITIONS

+ + + +

How to Apply These Terms to Your New Programs

+ +

+ 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. + +

+ 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. + +

+ +

+one line to give the program's name and an idea of what it does.
+Copyright (C) yyyy  name of author
+
+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.
+

+ +

+Also add information on how to contact you by electronic and paper mail. + +

+If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + +

+ +

+Gnomovision version 69, Copyright (C) yyyy name of author
+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.
+

+ +

+The hypothetical commands `show w' and `show c' should show +the appropriate parts of the General Public License. Of course, the +commands you use may be called something other than `show w' and +`show c'; they could even be mouse-clicks or menu items--whatever +suits your program. + +

+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: + +

+ +

+Yoyodyne, Inc., hereby disclaims all copyright
+interest in the program `Gnomovision'
+(which makes passes at compilers) written 
+by James Hacker.
+
+signature of Ty Coon, 1 April 1989
+Ty Coon, President of Vice
+

+ +

+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. + +

+ +Return to GNU's home page. +

+FSF & GNU inquiries & questions to +gnu@gnu.org. +Other ways to contact the FSF. +

+Comments on these web pages to +webmasters@www.gnu.org, +send other questions to +gnu@gnu.org. +

+Copyright notice above.
+Free Software Foundation, Inc., +59 Temple Place - Suite 330, Boston, MA 02111, USA +

+Updated: + +16 Feb 1998 tower + +

+ + diff --git a/ReadMe.txt b/ReadMe.txt new file mode 100644 index 0000000..310352f --- /dev/null +++ b/ReadMe.txt @@ -0,0 +1,19 @@ +OpTcl v3.0 build 04 +------------------- + +Licencing +--------- +Use of this software indicates an agreement to the GNU Public Licence under which, +this software is provided. + +Documentation +------------- +Please open the default.html file in the 'docs' directory for installation instructions +and documentation. + + + +I welcome any comments, suggestions and bug reports: +fuzz@sys.uea.ac.uk + + diff --git a/docs/default.html b/docs/default.html new file mode 100644 index 0000000..e4fb47d --- /dev/null +++ b/docs/default.html @@ -0,0 +1,18 @@ + + + + +OpTcl Documentation + + + + + + + <body> + </body> + + + diff --git a/docs/index.html b/docs/index.html new file mode 100644 index 0000000..bc469d4 --- /dev/null +++ b/docs/index.html @@ -0,0 +1,24 @@ + + + + +Index + + + + +

Index

+ +

About

+ +

Types

+ +

Type +Library Access

+ +

Objects

+ +

+ + diff --git a/docs/loadedlibs.gif b/docs/loadedlibs.gif new file mode 100644 index 0000000..7cc3016 Binary files /dev/null and b/docs/loadedlibs.gif differ diff --git a/docs/optcl.art b/docs/optcl.art new file mode 100644 index 0000000..1a04f07 Binary files /dev/null and b/docs/optcl.art differ diff --git a/docs/optcl.gif b/docs/optcl.gif new file mode 100644 index 0000000..19b9645 Binary files /dev/null and b/docs/optcl.gif differ diff --git a/docs/optcl.html b/docs/optcl.html new file mode 100644 index 0000000..206a2d5 --- /dev/null +++ b/docs/optcl.html @@ -0,0 +1,100 @@ + + + + + +OpTcl Documentation + + + + +

+version 3.0 build 04

+ +

Farzad +Pezeshkpour

+ +

August 1999

+ +

This software is freely distributed under the GNU Public +Licence. I've include this in this distribution as an HTML file.

+ +

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!

+ +

The Distribution

+ +

The following is a description of the directory structure for +the distribution:

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

install	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.
docs	Documentation.
src	The source for OpTcl with Visual C++ v6.0 (sp3) + workspace.
tests	A couple of test scripts using MS Word, and the + Calendar Control.

+ +

To install, run the install script optcl_install.tcl. +This will autodetect your version and location of your Tcl and +select the appropriate installation settings. The installer +copies the suitable DLL <tcl_lib>/../optcl/optcl.dll, and pkg_mkIndex +is applied to that directory.

+ +

The package can now be used by loaded using the command:

+ +

	package require optcl

+ +

Things To Do

+ +

Distribute example files.
Implement array parameters.
Implement default parameter values.
Test out-flagged parameters (I haven't found a + server to do this, yet).
Implement in/out-flagged parameters for events.
Use Type Libraries on the type conversion of an event-handlers + result.
Test with DCOM. (does anyone have a setup that can do + this?)
Write an ActiveScripting engine interface.
In some cases perhaps, reconsider syntax.

+ +

Known Bugs/Limitations

+ +

Not thread-safe.
Can't set parameters by their name, à la Visual Basic.
Microsoft Forms ActiveX objects can't be fully in-place + activated.

+ +

Credits

+ +

This work uses ideas developed by Jacob Levy in his Taxi +specification. I am very grateful for his helpful comments and +encouragement.

+ +

+ + diff --git a/docs/optcl_large.gif b/docs/optcl_large.gif new file mode 100644 index 0000000..6c8621b Binary files /dev/null and b/docs/optcl_large.gif differ diff --git a/docs/optcl_medium.gif b/docs/optcl_medium.gif new file mode 100644 index 0000000..b0e98a8 Binary files /dev/null and b/docs/optcl_medium.gif differ diff --git a/docs/optcl_small.gif b/docs/optcl_small.gif new file mode 100644 index 0000000..6d6ba48 Binary files /dev/null and b/docs/optcl_small.gif differ diff --git a/docs/optclobjects.html b/docs/optclobjects.html new file mode 100644 index 0000000..9b0ba03 --- /dev/null +++ b/docs/optclobjects.html @@ -0,0 +1,178 @@ + + + + +Optcl Objects + + + + +

+ +

Objects

+ +

The manipulation of objects in OpTcl is performed +with commands defined in the optcl namespace. The +following is the synopsis of this namespace.

+ +

optcl::new ?-start? + ?-window windowname? CLSID_ProgID_DocumentURL_HTML

optcl::lock + objid

optcl::unlock + objid ?objid ...?

optcl::isobject + objid

optcl::interface + objid ?new_interface_name?

optcl::class + objid

optcl::bind objid + eventname tcl_procedure

objid ?-with subobj? + methodname ?arg ...?

objid ?-with subobj? + : propname ?new_value?

objid ?-with subobj? + : propname(index?, index + ...?) ?new_value?

+ + +

Description

+ +

optcl::new

+ +

The optcl::new command creates or attaches to +existing COM objects, returning a unique object identifier, if +successful. The -start flag is used to indicate that the call +should always create a new instance of the object. The -window +option creates with the COM object, a Tk widget that will attempt +to in-place activate the user interface of the object. Not all +COM objects provide a user interface, and not all objects with +user-interfaces will in-place activate.

+ +

The final parameter of the command is an identifier for the +COM class of the object. This can take four different forms: +CLSID, ProgID, document path or raw HTML. Currently, the latter +two only work with the -window option. A CLSID is a string +representation of a COM Globally Unique IDentifer (GUID for short). +CLSIDs uniquely identify the location of a COM class server +through the system registry. To successfully create an instance +of the COM class, the server must be correctly registered with +the system registery. An example of a CLSID is {8E27C92B-1264-101C-8A2F-040224009C02} +(the CLSID for the Calendar Control). In order to pass a CLSID +correctly to the optcl::new command, the CLSID +must be wrapped in an extra pair of braces. This will ensure that +the bracing surrounding the CLSID is not stripped by the Tcl +interpreter. For example, {{8E27C92B-1264-101C-8A2F-040224009C02}}. +A ProgID (programmatic identifier) is a human readable name that +performs the same job as a CLSID. For example, MSCAL.Calendar.7. +

+ +

Additionally, the command can take two further forms of +identifer. A URL to a document with a correctly registered +document server, or an inline HTML. Both these options are only +available currently with in-place activation only (-window option) +and require the installation of Internet Explorer 4.0 or above. +To use inline HTML, the source string must begin with the +characters "mshtml:".

+ +

Reference Management

+ +

At the time of writing, OpTcl cannot provide a robust +automatic handling of object lifetimes. So for now, the optcl::lock +and optcl::unlock commands provide explicit +means for respectively incrementing or decrementing the reference +count on an object. On creation, the reference count of an object +is one. If, the reference count of an object becomes zero, the +object is destroyed, together with its Tk container window, if +one exists. Furthermore, the destruction of a container window, +will immediately destroy its related object.

+ +

optcl::isobject

+ +

The optcl::isobject command returns true if +and only if its only parameter is an OpTcl object.

+ +

optcl::interface

+ +

The optcl::interface command performs the +role of querying the current interface name of an OpTcl object, +or setting it to a new interface type. COM objects are +polymorphic, in that they can (and often do) support multiple +interfaces. In OpTcl an interface name is a properly formed type, and hence can be +browsed with the Type Library +Access functionality of OpTcl. One can discover the supported +interfaces of an object by finding +and viewing details of its COM class. The initial +interface of an object, is its default interface.

+ +

optcl::class

+ +

The optcl::class command returns the class name of the object. +If no class name information is provided, the command returns +'???'.

+ +

optcl::bind

+ +

The optcl::bind command binds an event from +an object to a Tcl procedure name. The event can either be the +name of an event on the default interface, or the name of an +event on another event interface. The latter must take the form lib.eventinterface.event. +The Tcl procedure will be called with the first parameter being +the object identifier of the OpTcl object raising the event, +followed by the parameters of the event itself.

+ +

Object Command

+ +

The object identifer returned from optcl::new, +is also a Tcl command for the lifetime of the object. Using the +command, we can invoke the object's methods, and properties. As a +means to improving efficiency, both forms of member access can be +applied to a sub-object of the invoked +OpTcl object. Methods can be invoked on an object, by appending +to the object command (with a possible sub-object), the method +name and its parameters. +

+ +

Access to properties of an OpTcl object are differentiated +from method invocations by the placement of a : +prior the property name, with white space seperating it from the +name. For example to set the visible property of an +object to true, we would use the following syntax:

+ +

	$myobj : visible 1

+ +

And to retrieve it:

+ +

	$myobj : visible
+	==> 1

+ +

If the property is indexed, then its index can be specified +within matching braces as a comma-seperated list. For example:

+ +

	$myobj : grid(3,4) "foo"

+ +

Sub-Objects

+ +

COM objects often have deep hierarchies of objects, reachable +from the created object. In many cases it may be inefficient to +represent several of these objects within the hierarchy as OpTcl +objects, in order to access a single object. For this purpose, +the object command can take the -with option. This is a dot +seperated list of sub-objects that it has to traverse before +invoking the method or property. For example:

+ +

	$app -with documents(1) save
+	$xl -with workbooks(1).worksheets(sheet1).range(a1,b2) : value 15

+ +

+ + diff --git a/docs/optcltypelibaccess.html b/docs/optcltypelibaccess.html new file mode 100644 index 0000000..f83e0b8 --- /dev/null +++ b/docs/optcltypelibaccess.html @@ -0,0 +1,293 @@ + + + + +Type Library Access + + + + +

+ +

Type Library Access

+ +

OpTcl provides two means of accessing the type information +stored in a Type Library - graphical or command-line based, with +the graphical version being built on top of the command-line +commands.

+ +

Command Line Access of Type Libraries

+ +

The command line access to type libraries is +implemented with the typelib namespace. Here's its +synopsis:

+ +

typelib::alllibs; typelib::updatelibs; typelib::libdetail + fulllibname; typelib::load + fulllibname; typelib::unload + fulllibname; typelib::isloaded + fulllibname; typelib::loaded; typelib::types + libname; typelib::typeinfo + libname.type ?element?

+ +

Description

+ +

typelib::alllibs

+ +

The typelib::alllibs command returns a list +of registered libraries by their human readable names.

+ +

typelib::updatelibs

+ +

The typelib::updatelibs command update OpTcl's +internal list of registered libraries from the system registry.

+ +

typelib::libdetail

+ +

The typelib::libdetail command returns a list +of three elements - the unique identifier for the library, its +major version number, and its minor version number.

+ +

typelib::load

+ +

The typelib::load takes as its only parameter, +the human readable name of a registered Type Library. If +successful in loading the library, the command returns the +programmatic name for the library. Otherwise, the function +returns an error.

+ +

typelib::unload

+ +

The typelib::unload command takes as its only +parameter, the human readable library name of a registered Type +Library. If the library has been loaded, it is subsequently +unloaded.

+ +

typelib::isloaded

+ +

The typelib::isloaded command returns true if +and only if its only argument is the user readable name of a +library that is currently loaded.

+ +

typelib::loaded

+ +

The typelib::loaded command returns a list of +the currently loaded libraries, in terms of their programmatic +names.

+ +

typelib::types

+ +

The typelib::types command takes as its only +required parameter, a programmatic name for a loaded library. It +returns as its result a list of types defined in the library. +Each element of this list is composed of two elements: a type +category followed by the name of the +type. Types fall into one of the following categories.

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

Category	Description
enum	An enumeration type.
struct	A record/structure type.
union	A union type. Currently OpTcl can't + manipulate these.
typedef	An alias to another type.
module	Globally declared functions (currently, + OpTcl cannot call these).
interface	A collection of functions that implement + the objects methods, and its properties (get and set + functions). OpTcl cannot call these directly.
dispatch	The same as interface, except that OpTcl + can call these directly. Usually a dispatch interface + wraps an inherited interface type.
class	A collection of interfaces (or + dispatches), broken into two categories: incoming and + outgoing. Incoming interfaces are those that are used to + invoke methods or access properties of an object, whilst + outgoing interfaces generate events from an object. In + each category, a class type can specify a default + interface. Each OpTcl object is associated with a maximum + of one class type.

+ +

typelib::typeinfo

+ +

The typelib::typeinfo command returns +information for either a type (in the form lib.type) or, +if provided as the last parameter, an element of a type. These +two forms are described as follows.

+ +

Type Information

+ +

The first form returns a list with four items. The first item +is the type's category. The second is a list of methods supported +by the type; the third is a list of properties for the type. The +last item is a list of fully formed +names of inherited types.

+ +

Element Information

+ +

Information of an element is stored in a list of three +elements: the category of the element (either method or property), +its signature, and documentation string (null, if not provided by +the library).

+ +

The format for an element's signature is based upon the +elements category. method elements return a signature +that is a list, with the first item being the return type of the +method, the second being the name of the method, and the +remaining elements being its parameters.

+ +

For a property element, the signature is a list with +the first element being the access flags to the property (a +combination of read or write), followed by the +properties type and its name. The remaining list elements are the +parameters required to access an +indexed property.

+ +

Parameters

+ +

A parameter description in OpTcl is a list with three required +members and one optional.

+ +

The first list element is a collection of flags describing the +direction of information flow for the parameter. This can either +be in, out, or both together. A parameter +flagged as in indicates that information flows from the +caller to the callee (by value call). A parameter flagged with out +indicates that information flows from the callee to the caller. +In the case of both flags being present, the information flow is +bi-directional (call by reference). It is important to note the +significance of this when operating with COM objects from OpTcl. +A parameter that is out or inout requires the +name of a Tcl variable to hold the value of the parameter. In the +case of inout the variable must exist prior to the +method call. Currently, OpTcl doesn't make full use of type +information for event handling. All parameters of an event are +passed to Tcl by-value only, for the time being.

+ +

The second list element is the correctly +formed type-name of the parameter. The third list element is +the parameters name. The final optional list element is either a +question mark, '?', indicating that the parameter is optional, or +some other value, denoting a default value. OpTcl currently does +not fill-in missing parameters with their default values.

+ +

Graphical Method for Accessing Type Libraries

+ +

For this OpTcl defines the tlview namespace. Here is +a synopsis of the commands defined within it:

+ +

tlview::refview + windowpath

tlview::loadedlibs + windowpath

tlview::viewlib + libname

tlview::viewtype + libname.typename

+ + +

Description

+ +

tlview::refview

+ +

The tlview::refview command creates a +toplevel window that displays a list of system-registered +typelibraries. Here's a screen-shot:

+ +

In blue are the libraries currently loaded by OpTcl; the +others aren't loaded. The Refresh button updates the list. +Clicking on a library, either loads or unloads it, depending on +its currently status. At the bottom of the screen, a status bar +informs of result of the most recent operation.

+ +

tlview::loadedlibs

+ +

Once a library is loaded, it is referenced within OpTcl using +a programmatic identifier; in fact, this is true for any client +of COM's type-libraries - e.g. Visual Basic. The tlview::loadedlibs +command creates a toplevel window, hosting a list of currently +loaded libraries, in terms of their programmatic id. Heres's a +screen-shot:

+ +

tlview::viewlib

+ +

The list is automatically updated, every time the +window receives mouse focus. Here's where the fun begins. Each +element is mouse-sensitive - clicking on one creates a browser +window for that library. At any time, a type browser can be +opened using tlview::viewlib command. The system +ensures that there is only one browser per library. Here's a grab +of browser in action:

+ +

The left-hand pane contains a list of types +within the library. Clicking on any type displays its elements in +the right-hand pane. Elements in a typelibrary are organised in +terms of methods, properties and inherited types. The right-hand +pane sorts the elements into these basic groups. The lower pane +gives a description of the element last clicked. If the type +library provides any describing text for that element that is +also displayed. In the lower pane, if a non-primitive type is +used to describe either a property or an element of a method, +then that type will also be click-sensitive. For a more detailed +explanation please read the section on accessing elements of a +type.

+ +

tlview::viewtype

+ +

The tlview::viewtype command can +call-up a browser window to view the details of a specific type +in a Type Library.

+ +

+ + diff --git a/docs/optcltypes.html b/docs/optcltypes.html new file mode 100644 index 0000000..55bcdb6 --- /dev/null +++ b/docs/optcltypes.html @@ -0,0 +1,112 @@ + + + + +Types In Optcl + + + + +

+ +

Types

+ +

Type Libraries

+ +

In order to precisely describe the interface and (in some +cases!) the functionality of a COM object, COM defines a language +independant mechanism for describing types, called Type Libraries. +You can think of these as a machine readable superset of header +files. Using Type Libraries, the interfaces (more about these +later), methods, events and properties of an object can be +accurrately described.

+ +

Having this kind of information is very important as it can a) +allow for the accurate type conversion between Tcl objects and +COM types, and b) speed up an invocation on an object.

+ +

Optcl is now type library aware - at least in terms of reading them and being type +sensitive in its invocations. I hope a future version will be +able to write out Type Libraries.

+ +

In OpTcl, types are represented as a strings comprising of the +programmatic name for a type library and its contained typename, +joined using a dot. So for example, stdole.IFontDisp is +the IFontDisp type defined in the library called stdole. +

+ +

Primitive Types

+ +

The only exception to the formatting rule specified above are +primitive. These are always a single word with no '.' delimiter. +They are listed in the following table:

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

Type	Description	Type	Description
char	A single character	string	single byte string
uchar	An unsigned character	carray	C-style array - not currently supported
short	16 bit signed integer	decimal	96-bit number
ushort	16 bit unsigned integer	float	32 bit real number
long	32 bit signed integer	double	64 bit real number
ulong	32 bit unsigned integer	dispatch	Scriptable interface to an object
bool	boolean	interface	Non-scriptable interface to an object
date	Date type.	currency	Currency. Range: ±922337203685477.5807
any	A variant type.

+ +

+ + diff --git a/docs/refview.gif b/docs/refview.gif new file mode 100644 index 0000000..3522f14 Binary files /dev/null and b/docs/refview.gif differ diff --git a/docs/viewlib1.gif b/docs/viewlib1.gif new file mode 100644 index 0000000..1398ecd Binary files /dev/null and b/docs/viewlib1.gif differ diff --git a/docs/viewlib2.gif b/docs/viewlib2.gif new file mode 100644 index 0000000..dc7ddd4 Binary files /dev/null and b/docs/viewlib2.gif differ diff --git a/install/optcl80.dll b/install/optcl80.dll new file mode 100644 index 0000000..a45c51a Binary files /dev/null and b/install/optcl80.dll differ diff --git a/install/optcl_Install.tcl b/install/optcl_Install.tcl new file mode 100644 index 0000000..0b04ace --- /dev/null +++ b/install/optcl_Install.tcl @@ -0,0 +1,88 @@ + +# 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 . {console show} +bind . {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 new file mode 100644 index 0000000..516434b Binary files /dev/null and b/install/optclstubs.dll differ diff --git a/src/Container.cpp b/src/Container.cpp new file mode 100644 index 0000000..b9de8d5 --- /dev/null +++ b/src/Container.cpp @@ -0,0 +1,569 @@ +/* + *------------------------------------------------------------------------------ + * container.cpp + * Implementation of the CContainer class, providing functionality for + * a Tk activex container widget. + * 1999-01-26 created + * 1999-08-25 modified for use in Optcl + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ + + + +#include "stdafx.h" +#include "tbase.h" +#include "optcl.h" +#include "utility.h" +#include "Container.h" +#include "optclobj.h" + + + +const char * CContainer::m_propname = "container"; + +////////////////////////////////////////////////////////////////////// +// Construction/Destruction +////////////////////////////////////////////////////////////////////// +/* + *------------------------------------------------------------------------- + * CContainer::CContainer() -- + * Constructor + * Result: + * None + * Side effects: + * Members set to default values - initial height and width information + * stored here. + *------------------------------------------------------------------------- + */ +CContainer::CContainer(OptclObj *parent) : +m_tkWindow(NULL), +m_widgetCmd(NULL), +m_pInterp(NULL), +m_height(200), +m_width(200), +m_windowproc(NULL), +m_bDestroyPending(false), +m_optclobj(parent) +{ + ASSERT (parent != NULL); +} + +/* + *------------------------------------------------------------------------- + * CContainer::~CContainer() -- + * Destructor + * Result: + * None + * Side effects: + * Tk window is requested to be destroyed. + * COM resources release (except for the control container which is release + * when the Tk window is actually destroyed. + *------------------------------------------------------------------------- + */ + +CContainer::~CContainer() +{ + // close down the references to the object + m_bDestroyPending = true; + m_pUnk.Release(); + m_pObj.Release(); + m_pSite.Release(); + m_pInPlaceObj.Release(); + m_pOleWnd.Release(); + m_pUnkHost.Release(); + + if (m_widgetCmd != NULL) { + if (!Tcl_InterpDeleted(m_pInterp)) + Tcl_DeleteCommandFromToken (m_pInterp, m_widgetCmd); + m_widgetCmd = NULL; + } + + if (m_tkWindow != NULL) + { + // remove the subclass + SetWindowLong (m_hTkWnd, GWL_WNDPROC, (LONG)m_windowproc); + RemoveProp (m_hTkWnd, m_propname); + Tk_DestroyWindow (m_tkWindow); + m_tkWindow = NULL; + } + +} + +/* + *------------------------------------------------------------------------- + * CContainer::ContainerEventProc -- + * Called by Tk to process events + * Result: + * None + * Side effects: + * Lifetime and size of widget affected - focus model needs working on! + *------------------------------------------------------------------------- + */ +void CContainer::ContainerEventProc (ClientData cd, XEvent *pEvent) +{ + CContainer *pContainer = (CContainer *)cd; + SIZEL s, hm; + RECT r; + + switch (pEvent->type) + { + case Expose: + // Nothing required as the AxAtl window + // should receive its own exposure event + break; + case FocusIn: + if (pContainer->m_pSite) + pContainer->m_pSite->OnFocus(TRUE); + /* + hControl = ::GetWindow (pContainer->m_hTkWnd, GW_CHILD); + if (hControl) + ::SetFocus(hControl); + */ + + break; + case ConfigureNotify: + s.cx = Tk_Width(pContainer->m_tkWindow); + s.cy = Tk_Height(pContainer->m_tkWindow); + r.left = r.top = 0; + r.right = s.cx; + r.bottom = s.cy; + + + AtlPixelToHiMetric(&s, &hm); + if (pContainer->m_pObj) + pContainer->m_pObj->SetExtent(DVASPECT_CONTENT, &hm); + if (pContainer->m_pInPlaceObj) + pContainer->m_pInPlaceObj->SetObjectRects (&r, &r); + + break; + case DestroyNotify: + if (!pContainer->m_bDestroyPending) { + Tcl_EventuallyFree(cd, DeleteContainer); + pContainer->m_tkWindow = NULL; + } + break; + + + default: + break; + } + +} + +/* + *------------------------------------------------------------------------- + * CContainer::DeleteContainer -- + * Called by ContainerEventProc, when the Tk_Window is about to be + * destroyed by scripting. + * Result: + * None + * Side effects: + * Memory deallocated + *------------------------------------------------------------------------- + */ +void CContainer::DeleteContainer (char *pObject) +{ + CContainer *pContainer = (CContainer*)pObject; + pContainer->m_optclobj->ContainerWantsToDie(); +} + + + +/* + *------------------------------------------------------------------------- + * CContainer::Create -- + * Called by the related object in order to create the window. + * tkParent in a parent of the window to be created. The string + * pointed to by 'id' is the clsid/progid/documentpath of this object. + * + * Result: + * NULL iff failed to be created (pInterp will store descriptive result) + * + * Side effects: + * Depends on object being created. + *------------------------------------------------------------------------- + */ +IUnknown * CContainer::Create (Tcl_Interp *pInterp, Tk_Window tkParent, + const char * widgetpath, const char *id) +{ + m_pInterp = pInterp; + char *path; + if (TCL_ERROR == CreateTkWindow (tkParent, (char*)widgetpath)) + return NULL; + + path = Tk_PathName(m_tkWindow); + + Tcl_VarEval (pInterp, "winfo id ", path, (char*)NULL); + + int iParent; + Tcl_GetIntFromObj (pInterp, Tcl_GetObjResult (pInterp), &iParent); + m_hTkWnd = (HWND) iParent; + SetProp (m_hTkWnd, m_propname, (HANDLE)this); + + if (!CreateControl(pInterp, id)) + return NULL; + + InitFromObject (); + + + // subclass this window (once again, since ATL has already hooked it), in order + // to correctly handle mouse messages and destruction + m_windowproc = SetWindowLong (m_hTkWnd, GWL_WNDPROC, (LONG)WidgetSubclassProc); + + // Set up the height and width accordingly + Tk_GeometryRequest (m_tkWindow, m_width, m_height); + + + m_widgetCmd = Tcl_CreateObjCommand (m_pInterp, path, WidgetCmd, + (ClientData)this, NULL); + + Tcl_SetResult (m_pInterp, path, TCL_STATIC); + return m_pUnk; +} + + + + +/* + *------------------------------------------------------------------------- + * CContainer::WidgetCmd -- + * Static class method that is called by Tcl when invoking the widget + * command. + * Result: + * TCL_OK if command execute ok; else TCL_ERROR + * Side effects: + * Dependant on the subcommand + *------------------------------------------------------------------------- + */ +int CContainer::WidgetCmd ( ClientData cd, Tcl_Interp *pInterp, int objc, + Tcl_Obj *CONST objv[] ) +{ + if (objc < 2) { + Tcl_AppendResult (pInterp, "wrong # args: should be \"", + Tcl_GetStringFromObj (objv[0], NULL), " option ?arg arg ...?\"", (char*)NULL); + return TCL_ERROR; + } + char *szCommand = Tcl_GetStringFromObj(objv[1], NULL); + int nLength = strlen(szCommand); + CContainer *pWidget = (CContainer*)cd; + + if (strncmp (szCommand, "configure", nLength) == 0) { + switch (objc) { + case 2: + return pWidget->ConfigInfo (pInterp); + break; + case 3: + return pWidget->ConfigInfo (pInterp, Tcl_GetStringFromObj(objv[2], NULL)); + break; + default: + return pWidget->ConfigInfo (pInterp, objc - 2, objv + 2); + break; + } + } + + if (strncmp (szCommand, "cget", nLength) == 0) { + if (objc == 3) { + return pWidget->ConfigInfo (pInterp, Tcl_GetStringFromObj(objv[2], NULL)); + } else { + Tcl_AppendResult (pInterp, "wrong # args: should be \"", + Tcl_GetStringFromObj (objv[0], NULL), " cget arg\"", (char*)NULL); + return TCL_ERROR; + } + } + + Tcl_AppendResult (pInterp, "urecognised command: ", szCommand, (char*)NULL); + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * CContainer::ConfigInfo (Tcl_Interp *pInterp) -- + * Overloaded method that returns the value of all configuration options + * for the widget + * Result: + * TCL_OK + * Side effects: + * New Tcl result + *------------------------------------------------------------------------- + */ +int CContainer::ConfigInfo (Tcl_Interp *pInterp) +{ + Tcl_DString dstring; + Tcl_DStringInit(&dstring); + + Tcl_ResetResult(pInterp); + ConfigInfo (pInterp, "-width"); + Tcl_DStringAppendElement(&dstring, Tcl_GetStringResult (pInterp)); + + Tcl_ResetResult(pInterp); + ConfigInfo (pInterp, "-height"); + Tcl_DStringAppendElement(&dstring, Tcl_GetStringResult (pInterp)); + + Tcl_SetResult(pInterp, dstring.string, TCL_VOLATILE); + Tcl_DStringFree(&dstring); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * CContainer::ConfigInfo (Tcl_Interp *pInterp, char *pProperty) -- + * Overloaded method that provides the value of a given configuration + * option. + * Result: + * TCL_OK iff configuration option exists; else TCL_ERROR + * Side effects: + * New Tcl result. + *------------------------------------------------------------------------- + */ +int CContainer::ConfigInfo (Tcl_Interp *pInterp, char *pProperty) +{ + bool bFound = false; + if (strcmp(pProperty, "-width")==0) { + bFound = true; + Tcl_SetObjResult (pInterp, Tcl_NewIntObj (m_width)); + } + + else if (strcmp(pProperty, "-height")==0) { + bFound = true; + Tcl_SetObjResult (pInterp, Tcl_NewIntObj (m_height)); + } + + else if (strcmp(pProperty, "-takefocus")==0) { + bFound = true; + Tcl_SetObjResult (pInterp, Tcl_NewBooleanObj(1)); + } + + if (!bFound) { + Tcl_ResetResult (pInterp); + Tcl_AppendResult (pInterp, "unknown option \"", pProperty, (char*)NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * CContainer::ConfigInfo (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST pArgs[]) -- + * Overloaded method; used to set the value of a number of options + * Result: + * TCL_OK iff all specified options are set ok; else TCL_ERROR + * Side effects: + * Change in options may have an effect on the size and viewing of the + * widget + *------------------------------------------------------------------------- + */ +int CContainer::ConfigInfo (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST pArgs[]) +{ + if (objc % 2 == 0) + { + bool bChanged = false; + for (int i = 0; i < objc; i += 2) { + if (SetProperty (pInterp, pArgs[i], pArgs[i+1], bChanged) != TCL_OK) + return TCL_ERROR; + } + if (bChanged) + { + Tk_GeometryRequest(m_tkWindow, m_width, m_height); + } + return TCL_OK; + } + else // # of values != # of options + { + char *szLast = Tcl_GetStringFromObj(pArgs[objc-1], NULL); + Tcl_ResetResult(pInterp); + Tcl_AppendResult (pInterp, "unknown option \"", szLast, "\"", (char*)NULL); + return TCL_ERROR; + } +} + +/* + *------------------------------------------------------------------------- + * CContainer::SetProperty -- + * Sets a single option with a new value. + * Result: + * TCL_OK iff option set ok; else TCL_ERROR + * Side effects: + * Size and other viewing factors may change for widget + *------------------------------------------------------------------------- + */ +int CContainer::SetProperty (Tcl_Interp *pInterp, Tcl_Obj *pProperty, Tcl_Obj *pValue, bool &bChanged) +{ + char *szProperty = Tcl_GetStringFromObj (pProperty, NULL); + int value; + + if (strcmp(szProperty, "-width")==0) { + if (Tcl_GetIntFromObj (pInterp, pValue, &value) == TCL_ERROR) + return TCL_ERROR; + m_width = abs(value); + bChanged = true; + } + + else if (strcmp(szProperty, "-height")==0) { + if (Tcl_GetIntFromObj (pInterp, pValue, &value) == TCL_ERROR) + return TCL_ERROR; + m_height = abs(value); + bChanged = true; + } + + else { + Tcl_ResetResult (pInterp); + Tcl_AppendResult (pInterp, "unknown option \"", szProperty, (char*)NULL); + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * CContainer::WidgetSubclassProc -- + * This is used to subclass the main window to handle proper forwarding + * of mouse capture, release of the control container, and the release of + * OLE resources. + * Result: + * The return of the subclassed window procedure + * Side effects: + * Mouse capture affected - COM interfaces destroyed, OLE uninitialised by one + *------------------------------------------------------------------------- + */ +LRESULT CALLBACK CContainer::WidgetSubclassProc (HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam) +{ + CContainer *pContainer = (CContainer*) GetProp (hwnd, m_propname); + if (pContainer == NULL) return 0; + WORD fwEvent = LOWORD (wParam); + WORD idChild = HIWORD (wParam); + HWND hCurrentFocus = GetFocus(); + + switch (uMsg) { + case WM_MOUSEACTIVATE: + return MA_ACTIVATE; + break; + + case WM_NCCREATE: + pContainer->m_pHost.Release(); + break; + } + + return CallWindowProc ((WNDPROC)(pContainer->m_windowproc), hwnd, uMsg, wParam, lParam); +} + + +/* + *------------------------------------------------------------------------- + * CContainer::InitFromObject -- + * Initialises interface pointers to the underlying control, and site + * Result: + * None + * Side effects: + * COM memory allocation of vtables etc. + *------------------------------------------------------------------------- + */ +void CContainer::InitFromObject () +{ + AtlAxGetControl(m_hTkWnd, &m_pUnk); + m_pObj = m_pUnk; + m_pInPlaceObj = m_pUnk; + m_pOleWnd = m_pUnk; + m_pSite = m_pUnkHost; +} + + +/* + *------------------------------------------------------------------------- + * CContainer::CreateTkWindow -- + * Called by the Create member function to create the Tk window + * Result: + * returns TCL_OK iff window created + * Side effects: + * + *------------------------------------------------------------------------- + */ +int CContainer::CreateTkWindow(Tk_Window tkParent, char *path) +{ + // create the window, specifying that it is a child + m_tkWindow = Tk_CreateWindowFromPath(m_pInterp, tkParent, path, NULL); + if (m_tkWindow == NULL) + return TCL_ERROR; + + Tk_SetClass(m_tkWindow, "Container"); + m_tkDisplay = Tk_Display(m_tkWindow); + + Tk_CreateEventHandler (m_tkWindow, + StructureNotifyMask | + ExposureMask | + FocusChangeMask, + ContainerEventProc, (ClientData)this); + + Tk_MakeWindowExist(m_tkWindow); + return TCL_OK; +} + + + +/* + *------------------------------------------------------------------------- + * CContainer::CreateControl -- + * Using Atl, creates the control. Ensures that the children of the + * control can be navigated with the keyboard. + * + * Result: + * true iff succeeded. pInterp will hold a description of the error. + * + * Side effects: + * Depends on the object being created + *------------------------------------------------------------------------- + */ +bool CContainer::CreateControl (Tcl_Interp *pInterp, const char *id) +{ + USES_CONVERSION; + HRESULT hr = E_FAIL; + HWND hWndChild; + LPOLESTR oleid = A2OLE(id); + + hr = AtlAxCreateControl (oleid, m_hTkWnd, NULL, &m_pUnkHost); + if (FAILED(hr)) + goto error; + + m_pHost = m_pUnkHost; + + if (m_pHost == NULL) { + hr = E_NOINTERFACE; + goto error; + } + + + // check for control parent style if control has a window + hWndChild = ::GetWindow(m_hTkWnd, GW_CHILD); + if(hWndChild != NULL) + { + if(::GetWindowLong(hWndChild, GWL_EXSTYLE) & WS_EX_CONTROLPARENT) + { + DWORD dwExStyle = ::GetWindowLong(m_hTkWnd, GWL_EXSTYLE); + dwExStyle |= WS_EX_CONTROLPARENT; + ::SetWindowLong(m_hTkWnd, GWL_EXSTYLE, dwExStyle); + } + } + return true; +error: + Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_STATIC); + return false; +} + + + diff --git a/src/Container.h b/src/Container.h new file mode 100644 index 0000000..85fda55 --- /dev/null +++ b/src/Container.h @@ -0,0 +1,90 @@ +/* + *------------------------------------------------------------------------------ + * container.cpp + * Declaration of the CContainer class, providing functionality for + * a Tk activex container widget. + * 1999-01-26 created + * 1999-08-25 modified for use in Optcl + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ + +#if !defined(AFX_CONTAINER_H__C07038C0_9445_11D2_86E7_0000B482A708__INCLUDED_) +#define AFX_CONTAINER_H__C07038C0_9445_11D2_86E7_0000B482A708__INCLUDED_ + +#if _MSC_VER > 1000 +#pragma once +#endif // _MSC_VER > 1000 + + +class OptclObj; + + +class CContainer +{ +public: // constructors + CContainer(OptclObj *pObj); + virtual ~CContainer(); + +public: // non-static methods + IUnknown * Create (Tcl_Interp *pInterp, Tk_Window tkParent, const char * path, const char *id); + +public: // static methods + static void ContainerEventProc (ClientData cd, XEvent *pEvent); + static void DeleteContainer (char *pObject); + static LRESULT CALLBACK WidgetSubclassProc (HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam); +protected: // static methods + static int WidgetCmd (ClientData cd, Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST objv[]); + +protected: // non-static methods + int ConfigInfo (Tcl_Interp *pInterp); + int ConfigInfo (Tcl_Interp *pInterp, char *pProperty); + int ConfigInfo (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST pArgs[]); + int SetProperty (Tcl_Interp *pInterp, Tcl_Obj *pProperty, Tcl_Obj *pValue, bool &bChanged); + bool CreateControl (Tcl_Interp *pInterp, const char *id); + void InitFromObject (); + int CreateTkWindow(Tk_Window tkParent, char *path); + +protected: // members variables + Tk_Window m_tkWindow; + Tcl_Interp * m_pInterp; + Display * m_tkDisplay; + Tcl_Command m_widgetCmd; + HWND m_hTkWnd; + DWORD m_height; + DWORD m_width; + LONG m_windowproc; + bool m_bDestroyPending; + OptclObj * m_optclobj; + + // Com pointers + CComPtr m_pUnk; // pointer to the contained object + CComPtr m_pUnkHost; // pointer to the host IUnknown + + // QI ptrs that have the IDD-templatised versions + CComQIPtr m_pObj; + CComQIPtr m_pInPlaceObj; + CComQIPtr m_pOleWnd; + CComQIPtr m_pSite; + CComQIPtr m_pHost; // pointer to the host (client site) object +protected: // static member variables + + static const char * m_propname; +}; + +#endif // !defined(AFX_CONTAINER_H__C07038C0_9445_11D2_86E7_0000B482A708__INCLUDED_) diff --git a/src/DispParams.cpp b/src/DispParams.cpp new file mode 100644 index 0000000..8573c8c --- /dev/null +++ b/src/DispParams.cpp @@ -0,0 +1,191 @@ +/* + *------------------------------------------------------------------------------ + * dispparams.cpp + * Implementation of the DispParams class, a wrapper for the DISPPARAMS + * Automation type. + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ + +#include "stdafx.h" +#include "tbase.h" +#include "optcl.h" +#include "DispParams.h" +#include "utility.h" + + + + +////////////////////////////////////////////////////////////////////// +// Construction/Destruction +////////////////////////////////////////////////////////////////////// + +/* + *------------------------------------------------------------------------- + * DispParams::DispParams -- + * Constructor - nulls out everything. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +DispParams::DispParams() +{ + rgvarg = NULL; + rgdispidNamedArgs = NULL; + cArgs = 0; + cNamedArgs = 0; +} + +/* + *------------------------------------------------------------------------- + * DispParams::~DispParams -- + * Destructor - releases internal data. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +DispParams::~DispParams() +{ + Release(); +} + +/* + *------------------------------------------------------------------------- + * DispParams::Release -- + * Releases all allocated variants. Nulls out the DISPPARAMS structure. + * + * Result: + * None. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void DispParams::Release () +{ + // start releasing the variants + for (UINT i = 0; i < cArgs; i++) + { + ASSERT (rgvarg != NULL); + OptclVariantClear (rgvarg+i); + } + + delete_ptr (rgvarg); + delete_ptr (rgdispidNamedArgs); + cArgs = 0; + cNamedArgs = 0; +} + + + +/* + *------------------------------------------------------------------------- + * DispParams::Args -- + * Sets up the number of arguments, both name and unnamed. + * + * Result: + * None. + * + * Side effects: + * Allocates enough memory for the dispatch id's of the named arguments. + * + *------------------------------------------------------------------------- + */ +void DispParams::Args (UINT args, UINT named) +{ + UINT i; + + Release(); + if (args > 0) + { + rgvarg = new VARIANTARG[args]; + for (i = 0; i < args; i++) + VariantInit(rgvarg+i); + cArgs = args; + } + + if (named > 0) + { + rgdispidNamedArgs = new DISPID[named]; + for (i = 0; i < named; i++) + rgdispidNamedArgs[i] = DISPID_UNKNOWN; + cNamedArgs = named; + } +} + +/* + *------------------------------------------------------------------------- + * DispParams::SetDISPID -- + * Sets the dispatch id of a named arguments. The argument is accessed using + * the index 'named'. + * + * Result: + * None. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void DispParams::SetDISPID (UINT named, DISPID id) +{ + ASSERT (named < cNamedArgs); + rgdispidNamedArgs[named] = id; +} + + +/* + *------------------------------------------------------------------------- + * DispParams::operator[] -- + * operator to get direct access to an argument at a certain index. + * + * Result: + * A reference to the argument. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +VARIANTARG &DispParams::operator[] (UINT arg) +{ + ASSERT (arg < cArgs); + return rgvarg[arg]; +} + + + + +/* + *------------------------------------------------------------------------- + * DispParams::Set -- + * + * Result: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ +void DispParams::Set (UINT index, VARIANT * pv) +{ + ASSERT (pv != NULL); + ASSERT (index < cArgs); + + V_VARIANTREF(rgvarg + index) = pv; + V_VT(rgvarg + index) = VT_VARIANT|VT_BYREF; +} diff --git a/src/DispParams.h b/src/DispParams.h new file mode 100644 index 0000000..0827cbc --- /dev/null +++ b/src/DispParams.h @@ -0,0 +1,71 @@ +/* + *------------------------------------------------------------------------------ + * dispparams.h + * Declaration of the DispParams class, a wrapper for the DISPPARAMS + * Automation type. + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ + +#if !defined(AFX_DISPPARAMS_H__BF3EF6CA_73B0_11D4_8004_0040055861F2__INCLUDED_) +#define AFX_DISPPARAMS_H__BF3EF6CA_73B0_11D4_8004_0040055861F2__INCLUDED_ + +#if _MSC_VER > 1000 +#pragma once +#endif // _MSC_VER > 1000 + + + +class DispParams : public DISPPARAMS +{ +public: + DispParams(); + virtual ~DispParams(); + + void Release (); + void Args (UINT args, UINT named = 0); + void SetDISPID (UINT named, DISPID id); + VARIANTARG &operator[] (UINT arg); + + + /* + *------------------------------------------------------------------------- + * Set -- + * Template function that sets the value of a variant at index 'index' + * to a template-type value. This works because the type T should have + * an appropriate casting operator to fit those of VC6's _variant_t + * Result: + * None. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ + template void Set (UINT index, T value) + { + _variant_t t; + VARIANTARG *pref = &(operator[](index)); + t.Attach (*pref); + t = value; + *pref = t.Detach(); + } + + void Set (UINT index, VARIANT * pv); +}; + +#endif // !defined(AFX_DISPPARAMS_H__BF3EF6CA_73B0_11D4_8004_0040055861F2__INCLUDED_) + diff --git a/src/EventBinding.cpp b/src/EventBinding.cpp new file mode 100644 index 0000000..d8a12bd --- /dev/null +++ b/src/EventBinding.cpp @@ -0,0 +1,612 @@ +/* + *------------------------------------------------------------------------------ + * eventbinding.cpp + * Declares classes used for implementing OpTcl's event binding. + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ + +#include "stdafx.h" +#include "tbase.h" +#include "EventBinding.h" +#include "optcl.h" +#include "utility.h" +#include "objmap.h" +#include "typelib.h" +#include "optclbindptr.h" + +////////////////////////////////////////////////////////////////////// +// Construction/Destruction +////////////////////////////////////////////////////////////////////// + + +/* + *------------------------------------------------------------------------- + * EventNotFound -- + * Writes a standard error message to the interpreter, indicating + * that an event was not found. + * + * Result: + * None. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void EventNotFound (Tcl_Interp *pInterp, const char * event) +{ + Tcl_SetResult (pInterp, "event not found: ", TCL_STATIC); + Tcl_AppendResult (pInterp, (char*) event, NULL); +} + + +/* + *------------------------------------------------------------------------- + * EventBindings::EventBindings -- + * Constructor - caches the parameters, and attempts to bind to ITypeComp + * interface. If not found, throw an HRESULT. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +EventBindings::EventBindings(OptclObj *pObj, REFGUID guid, ITypeInfo *pInfo) +: m_ref(0), m_bindings(0), m_cookie(0) +{ + ASSERT (pInfo!= NULL); + ASSERT (pObj != NULL); + + HRESULT hr; + + m_pti = pInfo; + m_optclobj = pObj; + m_guid = guid; + + hr = m_pti->GetTypeComp(&m_ptc); + CHECKHR(hr); + ASSERT (m_ptc != NULL); +} + + +/* + *------------------------------------------------------------------------- + * EventBindings::~EventBindings -- + * Destructor - ensures that any event bindings within this object + * are deleted. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +EventBindings::~EventBindings() +{ + DeleteTbl(); +} + + + +/* + *------------------------------------------------------------------------- + * EventBindings::DeleteTbl -- + * Iterates through the command table, and deletes each object + * before finally deleting the hash table. + * + * Result: + * None. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void EventBindings::DeleteTbl() +{ + DispCmdTbl::iterator i; + TObjPtr p; + + for (i = m_cmdtbl.begin(); i != m_cmdtbl.end(); i++) + { + BindingProps *p = *i; + ASSERT (p != NULL); + delete p; + } + m_cmdtbl.deltbl(); + m_bindings = 0; +} + + + + +// IUnknown Entries +/* + *------------------------------------------------------------------------- + * EventBindings::QueryInterface -- + * Implements the IUnknown member. Successfull iff riid is for IUnknown, + * IDispatch, or the event interface that we're implementing. + * + * Result: + * Standard COM result. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +HRESULT STDMETHODCALLTYPE EventBindings::QueryInterface(REFIID riid, void ** ppvObject) +{ + HRESULT hr = S_OK; + if (riid == IID_IUnknown) + *ppvObject = (IUnknown*)this; + else if (riid == IID_IDispatch || riid == m_guid) + *ppvObject = (IDispatch*)this; + else + hr = E_NOINTERFACE; + if (SUCCEEDED(hr)) + AddRef(); + + return hr; +} + + + + + +/* + *------------------------------------------------------------------------- + * EventBindings::AddRef -- + * Implements the IUnknown member. + * Result: + * Standard AddRef result. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +ULONG STDMETHODCALLTYPE EventBindings::AddRef( void) +{ + return InterlockedIncrement (&m_ref); +} + + + + + +/* + *------------------------------------------------------------------------- + * EventBindings::Release -- + * Implements the IUnknown member. In fact, this never deletes this object + * That responsibility is always with the optcl object. I am not sure + * if this approach is a good one. So beware! :o + * + * Result: + * Standard Release result. + * Side effects: + * None, what so ever. + *------------------------------------------------------------------------- + */ +ULONG STDMETHODCALLTYPE EventBindings::Release( void) +{ + // a dummy function + if (InterlockedDecrement (&m_ref) <= 0) + m_ref = 0; + return m_ref; +} + + + + + +// IDispatch Entries +/* + *------------------------------------------------------------------------- + * EventBindings::GetTypeInfoCount -- + * Implements the IDispatch member. 1 if we did get a type info. The + * check isn't necessary at all, but I've put it there just as a reminder. + * Result: + * S_OK always. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +HRESULT STDMETHODCALLTYPE EventBindings::GetTypeInfoCount(UINT *pctinfo) +{ + ASSERT (m_pti != NULL); + *pctinfo = (m_pti!=NULL)?1:0; + return S_OK; +} + + + + + + +/* + *------------------------------------------------------------------------- + * EventBindings::GetTypeInfo -- + * Implements the IDispatch member. Standard stuff. + * Result: + * Standard GetTypeInfo result. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +HRESULT STDMETHODCALLTYPE +EventBindings::GetTypeInfo(UINT iTInfo, LCID lcid, ITypeInfo ** ppTInfo) +{ + ASSERT (lcid == LOCALE_SYSTEM_DEFAULT); + HRESULT hr = S_OK; + if (iTInfo != 0 || m_pti == NULL || ppTInfo == NULL) + hr = DISP_E_BADINDEX; + else { + (*ppTInfo) = m_pti; + (*ppTInfo)->AddRef(); + } + return hr; +} + + + + + +/* + *------------------------------------------------------------------------- + * EventBindings::GetIDsOfNames -- + * Standard IDispatch member. Passes on the responsiblity to the type + * library. + * Result: + * Standard com result. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +HRESULT STDMETHODCALLTYPE +EventBindings::GetIDsOfNames(REFIID riid, LPOLESTR *rgszNames, + UINT cNames, LCID lcid, DISPID *rgDispId) +{ + HRESULT hr = S_OK; + if (m_pti == NULL) + hr = DISP_E_UNKNOWNNAME; + if (lcid != LOCALE_SYSTEM_DEFAULT) + hr = DISP_E_UNKNOWNLCID; + else + hr = DispGetIDsOfNames (m_pti, rgszNames, cNames, rgDispId); + return hr; +} + + + + + +/* + *------------------------------------------------------------------------- + * EventBindings::Invoke -- + * Called by the event source when an event is raised. Attempts to + * find event in the event table. If not bound yet, simply returns, + * otherwise, asks the binding to be evaluated. + * Result: + * S_OK iff succeeded. If error and an exception info struct is available, + * then it is filled out. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +HRESULT STDMETHODCALLTYPE +EventBindings::Invoke(DISPID dispIdMember, REFIID riid, LCID lcid, + WORD wFlags, DISPPARAMS *pDispParams, LPVARIANT pVarResult, + LPEXCEPINFO pExcepInfo, UINT *puArgErr) +{ + if (pDispParams == NULL) + return E_FAIL; + + // look up the dispatch id in our table. + BindingProps *bp = NULL; + + + + if (m_cmdtbl.find((DISPID*)dispIdMember, &bp) != NULL) + { + ASSERT (bp != NULL); + int res = bp->Eval(m_optclobj, pDispParams, pVarResult, pExcepInfo); + if (res == TCL_ERROR) { + if (pExcepInfo == NULL) + return E_FAIL; + else + return DISP_E_EXCEPTION; + } + } + return S_OK; +} + + + +/* + *------------------------------------------------------------------------- + * EventBindings::Name2Dispid -- + * Binds a string name to a dispatch id in the implemented event interface. + * + * Result: + * true iff successful. pInterp will contain the error string if not. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +bool EventBindings::Name2Dispid (Tcl_Interp *pInterp, const char * name, DISPID &dispid) +{ + ASSERT (pInterp != NULL && name != NULL && m_ptc != NULL); + + USES_CONVERSION; + LPOLESTR olename; + HRESULT hr; + OptclBindPtr obp; + bool bOk = false; + + olename = A2OLE (name); + + try { + hr = m_ptc->Bind (olename, LHashValOfName(LOCALE_SYSTEM_DEFAULT, olename), + INVOKE_FUNC, &obp.m_pti, &obp.m_dk, &obp.m_bp); + CHECKHR(hr); + + if (obp.m_dk == DESCKIND_FUNCDESC) { + ASSERT (obp.m_bp.lpfuncdesc != NULL); + dispid = obp.m_bp.lpfuncdesc->memid; + bOk = true; + } else + EventNotFound(pInterp, name); + } + catch (HRESULT hr) { + Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC); + } + + return bOk; +} + +/* + *------------------------------------------------------------------------- + * EventBindings::TotalBindings -- + * Returns the total number of even bindings in this collection. + * Result: + * The count. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +ULONG EventBindings::TotalBindings () +{ + return m_bindings; +} + + +/* + *------------------------------------------------------------------------- + * EventBindings::SetBinding -- + * Attempts to bind an event, give by name, to a tcl command (a tcl object) + * + * Result: + * true iff successful. Else, error string in interpreter. + * Side effects: + * Changes the count of the number of bindings. + *------------------------------------------------------------------------- + */ +bool EventBindings::SetBinding (Tcl_Interp *pInterp, const char * name, Tcl_Obj *pCommand) +{ + ASSERT (pInterp != NULL && name != NULL && pCommand != NULL); + + DISPID dispid; + + if (!Name2Dispid (pInterp, name, dispid)) + return false; + + BindingProps *pbp = NULL; + if (!m_cmdtbl.find ((DISPID*)(dispid), &pbp)) { + pbp = new BindingProps (pInterp, pCommand); + m_cmdtbl.set ((DISPID*)(dispid), pbp); + m_bindings++; + } else { + ASSERT (pbp != NULL); + pbp->m_pInterp = pInterp; + pbp->m_pScript = pCommand; + } + return true; +} + + + +/* + *------------------------------------------------------------------------- + * EventBindings::GetBinding -- + * Returns within the interpreter the tcl command bound to an event. + * Result: + * true iff successful. Else, error string in interpreter. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +bool EventBindings::GetBinding (Tcl_Interp *pInterp, const char * name) +{ + ASSERT (pInterp != NULL && name != NULL); + DISPID dispid; + + if (!Name2Dispid (pInterp, name, dispid)) + return false; + + + BindingProps *pbp = NULL; + if (m_cmdtbl.find ((DISPID*)(dispid), &pbp)) { + ASSERT (pbp != NULL); + Tcl_SetObjResult (pInterp, pbp->m_pScript); + } + return true; +} + + +/* + *------------------------------------------------------------------------- + * EventBindings::DeleteBinding -- + * Removes an event binding. + * Result: + * false iff 'name' is not the name of an existing event. + * Side effects: + * Changes the count of the number of bindings. + *------------------------------------------------------------------------- + */ +bool EventBindings::DeleteBinding (Tcl_Interp *pInterp, const char * name) +{ + ASSERT (pInterp != NULL && name != NULL); + DISPID dispid; + + if (!Name2Dispid (pInterp, name, dispid)) + return false; + BindingProps *pbp = NULL; + if (m_cmdtbl.find ((DISPID*)(dispid), &pbp)) { + ASSERT (pbp != NULL); + delete pbp; + m_cmdtbl.delete_entry ((DISPID*)(dispid)); + m_bindings--; + } + return true; +} + + +/* + *------------------------------------------------------------------------- + * BindingProps::Eval -- + * The guts of the event handler. Pulls out the parameters (in reverse order) + * and invokes that on the registered tcl handler. Note that the command + * line will look like: + * handler objid ?arg ...? + * where objid is the optcl identifier of the activex object that created + * the event. + * + * Result: + * Standard Tcl Result. + * + * Side effects: + * Depends on the tcl handler. + *------------------------------------------------------------------------- + */ +int BindingProps::Eval (OptclObj *pObj, DISPPARAMS *pDispParams, LPVARIANT pVarResult, + LPEXCEPINFO pExcepInfo) +{ + ASSERT (m_pInterp != NULL && m_pScript.isnotnull()); + ASSERT (pDispParams != NULL); + ASSERT (pObj != NULL); + + OptclObj ** ppObjs = NULL; + + TObjPtr cmd; + UINT count; + int result = TCL_ERROR; + + cmd.copy(m_pScript); + cmd.lappend ((const char*)(*pObj)); // cast to a string + + ASSERT (pDispParams->cNamedArgs == 0); + + // potentially all the parameters could result in an object, so + // allocate an array and set it all to nulls. + if (pDispParams->cArgs > 0) { + ppObjs = (OptclObj**)calloc(pDispParams->cArgs, sizeof (OptclObj*)); + if (ppObjs == NULL) { + Tcl_SetResult (m_pInterp, "failed to allocate memory", TCL_STATIC); + Tcl_BackgroundError (m_pInterp); + return TCL_ERROR; + } + } + + // temporarily increase the reference count on the object + // this way, if the event handler unlocks the objects, a possible + // destruction doesn't occur until this event has been handled + g_objmap.Lock (pObj); + + try { + // convert the dispatch parameters into Tcl arguments + for (count = 0; count < pDispParams->cArgs; count++) + { + TObjPtr param; + if (!var2obj(m_pInterp, pDispParams->rgvarg[pDispParams->cArgs - count - 1], param, ppObjs+count)) + break; + cmd.lappend(param, m_pInterp); + } + } + + // the error will already be stored in the interpreter + catch (char *) { + } + + + // if we managed to convert all the parameters, invoke the function + if (count == pDispParams->cArgs) + result = Tcl_GlobalEvalObj (m_pInterp, cmd); + + + + // deallocate the objects + for (count = 0; count < pDispParams->cArgs; count++) + { + if (ppObjs[count] != NULL) + g_objmap.Unlock (ppObjs[count]); + } + + // release the object pointers + if (ppObjs != NULL) + free (ppObjs); + + if (result == TCL_ERROR) + { + // do we have a exception storage + if (pExcepInfo != NULL) + { + // fill it in + _bstr_t src(Tcl_GetStringResult(m_pInterp)); + _bstr_t name("OpTcl"); + pExcepInfo->wCode = 1001; + pExcepInfo->wReserved = 0; + pExcepInfo->bstrSource = name.copy(); + pExcepInfo->bstrDescription = src.copy(); + pExcepInfo->bstrHelpFile = NULL; + pExcepInfo->pvReserved = NULL; + pExcepInfo->pfnDeferredFillIn = NULL; + } + Tcl_BackgroundError (m_pInterp); + } + else + { + // get the Tcl result and store it in the result variant + // currently we are limited to the basic types, until + // I get the time to pull the typelib stuff to this point + if (pVarResult != NULL) + { + TObjPtr pres(Tcl_GetObjResult (m_pInterp), false); + VariantInit(pVarResult); + obj2var (pres, *pVarResult); + } + } + + // finally unlock the object + g_objmap.Unlock (pObj); + return result; +} + + + + + + + + + + diff --git a/src/EventBinding.h b/src/EventBinding.h new file mode 100644 index 0000000..ec8d400 --- /dev/null +++ b/src/EventBinding.h @@ -0,0 +1,107 @@ +/* + *------------------------------------------------------------------------------ + * eventbinding.h + * Declares classes used for implementing OpTcl's event binding. + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ + +#if !defined(AFX_EVENTBINDING_H__818C3160_57FC_11D3_86E8_0000B482A708__INCLUDED_) +#define AFX_EVENTBINDING_H__818C3160_57FC_11D3_86E8_0000B482A708__INCLUDED_ + +#if _MSC_VER > 1000 +#pragma once +#endif // _MSC_VER > 1000 + +struct BindingProps; +class OptclObj; + + +typedef THash DispCmdTbl; + + + +struct BindingProps +{ + TObjPtr m_pScript; + Tcl_Interp * m_pInterp; + + BindingProps (Tcl_Interp *pInterp, Tcl_Obj * pScript) + { + ASSERT (pInterp != NULL && pScript != NULL); + m_pInterp = pInterp; + m_pScript = pScript; + } + + int Eval (OptclObj *pObj, DISPPARAMS *pDispParams, LPVARIANT pVarResult, + LPEXCEPINFO pExcepInfo); +}; + + + +class EventBindings : public IDispatch +{ +public: + friend OptclObj; + + EventBindings(OptclObj *pObj, REFGUID guid, ITypeInfo *pInfo); + virtual ~EventBindings(); + + + bool SetBinding (Tcl_Interp *pInterp, const char * name, Tcl_Obj *pCommand); + bool GetBinding (Tcl_Interp *pInterp, const char * name); + bool DeleteBinding (Tcl_Interp *pInterp, const char * name); + + ULONG TotalBindings (); + + // IUnknown Entries + HRESULT STDMETHODCALLTYPE QueryInterface(REFIID riid, void ** ppvObject); + ULONG STDMETHODCALLTYPE AddRef( void); + ULONG STDMETHODCALLTYPE Release( void); + + // IDispatch Entries + HRESULT STDMETHODCALLTYPE GetTypeInfoCount(UINT *pctinfo); + + HRESULT STDMETHODCALLTYPE + GetTypeInfo(UINT iTInfo, LCID lcid, ITypeInfo ** ppTInfo); + + HRESULT STDMETHODCALLTYPE + GetIDsOfNames(REFIID riid, LPOLESTR *rgszNames, + UINT cNames, LCID lcid, DISPID *rgDispId); + + HRESULT STDMETHODCALLTYPE + Invoke(DISPID dispIdMember, REFIID riid, LCID lcid, + WORD wFlags, DISPPARAMS *pDispParams, LPVARIANT pVarResult, + LPEXCEPINFO pExcepInfo, UINT *puArgErr); + +protected: + void DeleteTbl(); + bool Name2Dispid (Tcl_Interp *pInterp, const char * name, DISPID &dispid); + +protected: + LONG m_ref; // COM reference count for this event binding + ULONG m_bindings; // total number of bindings in this event object + CComPtr m_pti; // the type information that we are going to be binding + CComPtr m_ptc; // fast access to members + DispCmdTbl m_cmdtbl; // mapping of dispatch ids to Tcl commands + OptclObj * m_optclobj; // the parent object of this binding + DWORD m_cookie; // cookie used for event advise + GUID m_guid; // the id for the event interface +}; + +#endif // !defined(AFX_EVENTBINDING_H__818C3160_57FC_11D3_86E8_0000B482A708__INCLUDED_) diff --git a/src/ObjMap.cpp b/src/ObjMap.cpp new file mode 100644 index 0000000..1e9fd53 --- /dev/null +++ b/src/ObjMap.cpp @@ -0,0 +1,505 @@ +/* + *------------------------------------------------------------------------------ + * objmap.cpp + * Implementation of the object table. + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ +#include "stdafx.h" +#include "tbase.h" +#include "optcl.h" +#include "utility.h" +#include "objmap.h" + + + + +// globals + +// the one and only object map for this extension +// this class uses a Tcl hash table - this usually wouldn't be +// safe, except that this hash table is initialised (courtsey of THash<>) +// only on first uses (lazy). So it should be okay. Not sure how +// this will behave in a multithreaded application + +ObjMap g_objmap; + + +////////////////////////////////////////////////////////////////////// +// Construction/Destruction +////////////////////////////////////////////////////////////////////// + + +ObjMap::ObjMap() : m_destructpending(false) +{ + +} + +ObjMap::~ObjMap() +{ + +} + + +/* + *------------------------------------------------------------------------- + * ObjMap::DeleteAll -- + * Deletes all objects in the system. + * Result: + * None. + * Side effects: + * Deletes all object commands from respective interpreters + *------------------------------------------------------------------------- + */ +void ObjMap::DeleteAll () +{ + ObjNameMap::iterator i; + for (i = m_namemap.begin(); i != m_namemap.end(); i++) { + OptclObj *pobj = *i; + ASSERT (pobj != NULL); + DeleteCommand (pobj); + delete pobj; + } + m_namemap.deltbl(); + m_unkmap.deltbl(); +} + + + + +/* + *------------------------------------------------------------------------- + * ObjMap::Create -- + * Creates an object for a particular interpreter. The type of the object + * is identified by a string representing either a CLSID or ProgId. It would + * be neat if it also could be the name of a file on the local system or + * at some URL. More on this later.... + * If the object already exists in the object table, then we return that + * object. In fact, this is a limitation of the system, as objects that have + * been registered in one interpreter cannot be accessed from another + * interpreter. + * + * Result: + * A non-null pointer to the underlying Optcl object representation, + * iff successful. + * + * Side effects: + * Creates also the Tcl command used to invoke this object. + * + *------------------------------------------------------------------------- + */ +OptclObj * ObjMap::Create (Tcl_Interp *pInterp, const char * id, const char * path, bool start) +{ + ASSERT (id != NULL); + OptclObj *pObj = NULL, + *ptmp = NULL; + + pObj = new OptclObj (); + if (!pObj->Create(pInterp, id, path, start)) { + delete pObj; + return NULL; + } + + IUnknown **u = (IUnknown**)(IUnknown*)(*pObj); + if (m_unkmap.find(u, &ptmp) != NULL) { + ASSERT (ptmp != NULL); + delete pObj; + ++ptmp->m_refcount; + return ptmp; + } + + m_unkmap.set (u, pObj); + m_namemap.set (*pObj, pObj); // implicit const char * cast + pObj->m_refcount = 1; + CreateCommand (pObj); + return pObj; +} + + +/* + *------------------------------------------------------------------------- + * ObjMap::Add -- + * Given an IUnknown pointer, this function ensures that the object table + * has a representation for it. If one cannot be found, then a new + * representation is created, and the object command is created in the + * specified interpreter. + * + * Result: + * Non-null pointer to the internal representation iff successful. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +OptclObj * ObjMap::Add (Tcl_Interp *pInterp, LPUNKNOWN punk) +{ + ASSERT (punk != NULL); + CComPtr t_unk; + HRESULT hr; + OptclObj *pObj = NULL; + + // get the objects pure IUnknown interface (punk can + // point to any interface + + hr = punk->QueryInterface (IID_IUnknown, (void**)(&t_unk)); + CHECKHR(hr); + IUnknown ** u = (IUnknown **)(IUnknown*)t_unk; + + if (m_unkmap.find(u, &pObj) == NULL) { + pObj = new OptclObj(); + if (!pObj->Attach(pInterp, punk)) + { + delete pObj; + pObj = NULL; + } + m_namemap.set(*pObj, pObj); + m_unkmap.set(u, pObj); + pObj->m_refcount = 1; + CreateCommand (pObj); + } else { + ++pObj->m_refcount; + } + + ASSERT (pObj != NULL); + return pObj; +} + + + +/* + *------------------------------------------------------------------------- + * ObjMap::Find -- + * Given and IUnknown pointer, this function attempts to bind to an + * existing representation within the object table. + * + * Result: + * A non-null pointer to the required Optcl object, iff successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ +OptclObj *ObjMap::Find (LPUNKNOWN punk) +{ + ASSERT (punk != NULL); + CComPtr t_unk; + HRESULT hr; + OptclObj *pObj = NULL; + + // get the objects pure IUnknown interface (punk can + // point to any interface + + hr = punk->QueryInterface (IID_IUnknown, (void**)(&t_unk)); + CHECKHR(hr); + IUnknown **u = (IUnknown**)(IUnknown*)(t_unk); + m_unkmap.find (u, &pObj); + return pObj; +} + + + +/* + *------------------------------------------------------------------------- + * ObjMap::Find -- + * Finds an existing optcl object keyed on its name. + * + * Result: + * A non-null pointer to the required Optcl object, iff successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ +OptclObj *ObjMap::Find (const char *name) +{ + ASSERT (name != NULL); + OptclObj *pObj = NULL; + m_namemap.find (name, &pObj); + return pObj; +} + + + + + +/* + *------------------------------------------------------------------------- + * ObjMap::DeleteCommand -- + * Ensures that the object command associated with a valid Optcl object + * is quietly removed. + * + * Result: + * None. + * + * Side effects: + * po->m_cmdtoken is set to NULL. + *------------------------------------------------------------------------- + */ +void ObjMap::DeleteCommand (OptclObj *po) +{ + ASSERT (po != NULL); + + if (po->m_cmdtoken == NULL) + return; + + + CONST84 char * cmdname = Tcl_GetCommandName (po->m_pInterp, po->m_cmdtoken); + if (cmdname == NULL) + return; + Tcl_CmdInfo cmdinf; + + if (Tcl_GetCommandInfo (po->m_pInterp, cmdname, &cmdinf) == 0) + return; + + // modify the command info of this command so that the callback is now disabled + cmdinf.deleteProc = NULL; + cmdinf.deleteData = NULL; + + Tcl_SetCommandInfo (po->m_pInterp, cmdname, &cmdinf); + Tcl_DeleteCommand (po->m_pInterp, cmdname); + po->m_cmdtoken = NULL; +} + + +/* + *------------------------------------------------------------------------- + * ObjMap::Delete -- + * Deletes an Optcl object, ensuring the removal of its object command, + * and its entries in the object table. + * + * Result: + * None. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ +void ObjMap::Delete (OptclObj *pObj) +{ + ASSERT (pObj != NULL); + + // first ensure that we delete the objects command + DeleteCommand(pObj); + m_namemap.delete_entry (*pObj); + m_unkmap.delete_entry ((IUnknown**)(IUnknown*)(*pObj)); + delete pObj; +} + + + +/* + *------------------------------------------------------------------------- + * ObjMap::Delete -- + * Deletes an optcl object keyed on its name. Ensures the removal of the + * object command, as well as its reference in the object table. + * + * Result: + * None. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ +void ObjMap::Delete (const char * name) +{ + ASSERT (name != NULL); + OptclObj *pObj = NULL; + + if (m_namemap.find (name, &pObj) == NULL) + return; + ASSERT (pObj != NULL); + ASSERT (strcmp(name, *pObj) == 0); + Delete (pObj); +} + + + +/* + *------------------------------------------------------------------------- + * ObjMap::Lock -- + * Increments the reference count on an optcl object. + * + * Result: + * None. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ +void ObjMap::Lock (OptclObj *po) +{ + ASSERT (po != NULL); + ++po->m_refcount; +} + + +/* + *------------------------------------------------------------------------- + * ObjMap::Unlock -- + * Decrements the reference count on an optcl object. If zero, the object + * is deleted. These functions could do with thread safety in the future. + * + * Result: + * None. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ +void ObjMap::Unlock(OptclObj *po) +{ + ASSERT (po != NULL); + if (--po->m_refcount == 0) + Delete (po); +} + + + + +/* + *------------------------------------------------------------------------- + * ObjMap::Lock -- + * Increments the reference count on an optcl object, keyed on its name + * + * Result: + * None. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ +bool ObjMap::Lock (const char *name) +{ + ASSERT (name != NULL); + OptclObj *pObj = NULL; + if (m_namemap.find (name, &pObj) == NULL) + return false; + Lock (pObj); + return true; +} + + + + + + +/* + *------------------------------------------------------------------------- + * ObjMap::Unlock -- + * Decrements the reference count of an optcl object, keyed on its name. + * If zero, the object is deleted. + * + * Result: + * None. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ +bool ObjMap::Unlock(const char *name) +{ + ASSERT (name != NULL); + OptclObj *pObj = NULL; + if (m_namemap.find (name, &pObj) == NULL) + return false; + Unlock(pObj); + return true; +} + + + +/* + *------------------------------------------------------------------------- + * ObjMap::CreateCommand -- + * Creates the command that is to be associated with an optcl object. + * The command is created within the interpreter referenced by the object. + * The command token is stored within the object. + * + * Result: + * None. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ +void ObjMap::CreateCommand(OptclObj * pObj) +{ + ASSERT (pObj != NULL); + pObj->m_cmdtoken = + Tcl_CreateObjCommand (pObj->m_pInterp, (char*)(const char*)(*pObj), + ObjMap::OnCmd, (ClientData)pObj, ObjMap::OnCmdDelete); +} + + +/* + *------------------------------------------------------------------------- + * ObjMap::OnCmd -- + * Function called from tcl whenever an optcl object command is invoked. + * The ClientData is the pointer to the object. + * + * Result: + * Std Tcl results. + * + * Side effects: + * Anything, depending on the invocation + * + *------------------------------------------------------------------------- + */ +TCL_CMDEF(ObjMap::OnCmd) +{ + OptclObj *po = (OptclObj*)cd; // cast the client data to the underlying + // object + ASSERT (po != NULL); + return (po->InvokeCmd (pInterp, objc-1, objv+1))?TCL_OK:TCL_ERROR; +} + + +/* + *------------------------------------------------------------------------- + * ObjMap::OnCmdDelete -- + * Called when (and only when) a script deletes an object command. The + * referenced optcl object is also destroyed. + * + * Result: + * None. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ +void ObjMap::OnCmdDelete (ClientData cd) +{ + OptclObj *po = (OptclObj*) cd; + ASSERT (po != NULL); + g_objmap.Delete(po); +} + + + + + diff --git a/src/ObjMap.h b/src/ObjMap.h new file mode 100644 index 0000000..ce1a58c --- /dev/null +++ b/src/ObjMap.h @@ -0,0 +1,79 @@ +/* + *------------------------------------------------------------------------------ + * objmap.h + * Definition of the object table. + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ + +#if !defined(AFX_OBJMAP_H__8A11BC00_616B_11D4_8004_0040055861F2__INCLUDED_) +#define AFX_OBJMAP_H__8A11BC00_616B_11D4_8004_0040055861F2__INCLUDED_ + +#if _MSC_VER > 1000 +#pragma once +#endif // _MSC_VER > 1000 + +#include "optcl.h" +#include "OptclObj.h" + +typedef THash ObjNameMap; +typedef THash ObjUnkMap; + +class ObjMap { + friend OptclObj; +protected: + ObjNameMap m_namemap; + ObjUnkMap m_unkmap; + bool m_destructpending; + +public: // constructor / destructor + ObjMap (); + virtual ~ObjMap (); + + OptclObj * Create (Tcl_Interp *pInterp, const char * id, const char * path, bool start); + OptclObj * Add (Tcl_Interp *pInterp, LPUNKNOWN punk); + OptclObj * Find (LPUNKNOWN punk); + OptclObj * Find (const char *name); + + void Delete (const char * name); + void DeleteAll (); + + bool Lock (const char *name); + bool Unlock(const char *name); + + void Lock (OptclObj *); + void Unlock(OptclObj *); + + +public: // statics + static TCL_CMDEF(OnCmd); + static void OnCmdDelete (ClientData cd); + +protected: + void Delete (OptclObj *); + void CreateCommand (OptclObj *); + void DeleteCommand (OptclObj *); + +}; + + +// Global Variable Declaration!!! + +extern ObjMap g_objmap; // once object map per application + +#endif // !defined(AFX_OBJMAP_H__8A11BC00_616B_11D4_8004_0040055861F2__INCLUDED_) diff --git a/src/OptclBindPtr.cpp b/src/OptclBindPtr.cpp new file mode 100644 index 0000000..c6557f6 --- /dev/null +++ b/src/OptclBindPtr.cpp @@ -0,0 +1,52 @@ +/* + *------------------------------------------------------------------------------ + * optclbindptr.cpp + * Implements the class used wrapping a BINDPTR, DESCKIND and ITypeInfo + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ + +#include "stdafx.h" +#include "typelib.h" +#include "OptclBindPtr.h" + +////////////////////////////////////////////////////////////////////// +// Construction/Destruction +////////////////////////////////////////////////////////////////////// + +OptclBindPtr::OptclBindPtr() +{ + m_bp.lpfuncdesc = NULL; + m_dk = DESCKIND_NONE; +} + +OptclBindPtr::~OptclBindPtr() +{ + ReleaseBindPtr(); +} + + +void OptclBindPtr::ReleaseBindPtr () +{ + ::ReleaseBindPtr(m_pti, m_dk, m_bp); + m_dk = DESCKIND_NONE; +} + + + + diff --git a/src/OptclBindPtr.h b/src/OptclBindPtr.h new file mode 100644 index 0000000..da93d28 --- /dev/null +++ b/src/OptclBindPtr.h @@ -0,0 +1,127 @@ +/* + *------------------------------------------------------------------------------ + * optclbindptr.h + * Defines the class used wrapping a BINDPTR, DESCKIND and ITypeInfo + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */#if !defined(AFX_OPTCLBINDPTR_H__2682D1C3_5EDC_11D3_86E8_0000B482A708__INCLUDED_) +#define AFX_OPTCLBINDPTR_H__2682D1C3_5EDC_11D3_86E8_0000B482A708__INCLUDED_ + +#if _MSC_VER > 1000 +#pragma once +#endif // _MSC_VER > 1000 + + +// wrapper class for a BINDPTR, DESCKIND, and ITypeInfo +class OptclBindPtr +{ +public: + BINDPTR m_bp; + DESCKIND m_dk; + CComPtr m_pti; + +public: + OptclBindPtr(); + virtual ~OptclBindPtr(); + void ReleaseBindPtr (); + + // inline functions + MEMBERID OptclBindPtr::memid () + { + ASSERT (m_bp.lpfuncdesc != NULL); + + switch (m_dk) { + case DESCKIND_FUNCDESC: + return m_bp.lpfuncdesc->memid; + + case DESCKIND_IMPLICITAPPOBJ: + case DESCKIND_VARDESC: + return m_bp.lpvardesc->memid; + default: + ASSERT (FALSE); + return DISPID_UNKNOWN; + } + } + + + short OptclBindPtr::cParams() + { + ASSERT (m_bp.lpfuncdesc != NULL); + switch (m_dk) { + case DESCKIND_FUNCDESC: + return m_bp.lpfuncdesc->cParams; + case DESCKIND_IMPLICITAPPOBJ: + case DESCKIND_VARDESC: + return 1; + default: + ASSERT (FALSE); + return 0; + } + } + + short OptclBindPtr::cParamsOpt() + { + ASSERT (m_bp.lpfuncdesc != NULL); + switch (m_dk) { + case DESCKIND_FUNCDESC: + return m_bp.lpfuncdesc->cParamsOpt; + case DESCKIND_IMPLICITAPPOBJ: + case DESCKIND_VARDESC: + return 1; + default: + ASSERT (FALSE); + return 0; + } + } + + ELEMDESC * OptclBindPtr::param(short param) + { + ASSERT (m_bp.lpfuncdesc != NULL); + ASSERT (param < cParams()); + + switch (m_dk) { + case DESCKIND_FUNCDESC: + return (m_bp.lpfuncdesc->lprgelemdescParam + param); + case DESCKIND_IMPLICITAPPOBJ: + case DESCKIND_VARDESC: + return (&m_bp.lpvardesc->elemdescVar); + default: + ASSERT (FALSE); + return 0; + } + + } + + ELEMDESC * OptclBindPtr::result() + { + ASSERT (m_bp.lpfuncdesc != NULL); + + switch (m_dk) { + case DESCKIND_FUNCDESC: + return (&m_bp.lpfuncdesc->elemdescFunc); + case DESCKIND_IMPLICITAPPOBJ: + case DESCKIND_VARDESC: + return (&m_bp.lpvardesc->elemdescVar); + default: + ASSERT (FALSE); + return 0; + } + } +}; + +#endif // !defined(AFX_OPTCLBINDPTR_H__2682D1C3_5EDC_11D3_86E8_0000B482A708__INCLUDED_) diff --git a/src/OptclObj.cpp b/src/OptclObj.cpp new file mode 100644 index 0000000..b2c74f6 --- /dev/null +++ b/src/OptclObj.cpp @@ -0,0 +1,1847 @@ +/* + *------------------------------------------------------------------------------ + * optclobj.cpp + * Implements the functionality for the internal representation of + * an optcl object. + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ + +#include "stdafx.h" +#include +#include "tbase.h" +#include "utility.h" +#include "optcl.h" +#include "OptclObj.h" +#include "typelib.h" +#include "ObjMap.h" +#include "dispparams.h" +#include "eventbinding.h" +#include "optclbindptr.h" +#include "optcltypeattr.h" + +////////////////////////////////////////////////////////////////////// +// Construction/Destruction +////////////////////////////////////////////////////////////////////// + +OptclObj::OptclObj () +: m_refcount(0), m_cmdtoken(NULL), m_pta(NULL), +m_destroypending(false), m_container(this) +{ +} + +bool OptclObj::Create (Tcl_Interp *pInterp, const char *strid, + const char * windowpath, bool start) +{ + m_pInterp = pInterp; + + USES_CONVERSION; + ASSERT (strid != NULL); + + if (windowpath == NULL) { + LPOLESTR lpolestrid = A2OLE(strid); + CLSID clsid; + HRESULT hr; + + // convert strid to CLSID + hr = CLSIDFromString (lpolestrid, &clsid); + if (FAILED (hr)) + hr = CLSIDFromProgID (lpolestrid, &clsid); + CHECKHR_TCL(hr, pInterp, false); + + if (!start) + hr = GetActiveObject(clsid, NULL, &m_punk); + if (start || FAILED(hr)) + hr = CoCreateInstance (clsid, NULL, CLSCTX_SERVER, IID_IUnknown, (void**)&m_punk); + CHECKHR_TCL(hr, pInterp, false); + + } + else { + m_punk = m_container.Create(pInterp, Tk_MainWindow(pInterp), windowpath, strid); + if (m_punk == NULL) + return false; + } + try { + CreateName (m_punk); + InitialiseClassInfo(m_punk); + InitialisePointers (m_punk); + } + catch (HRESULT hr) { + CHECKHR_TCL(hr, pInterp, false); + } + return true; +} + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::Attach -- + * Connects this object to an existing interface + * Result: + * true iff successful + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +bool OptclObj::Attach (Tcl_Interp *pInterp, LPUNKNOWN punk) +{ + ASSERT (m_punk == NULL); + ASSERT (punk != NULL); + + m_pInterp = pInterp; + try { + CreateName (punk); + InitialiseUnknown(punk); + InitialiseClassInfo(m_punk); + InitialisePointers (m_punk); + } + catch (HRESULT hr) { + m_punk = NULL; + CHECKHR_TCL(hr, pInterp, false); + } + return true; +} + + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::~OptclObj -- + * Destructor + * Result: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ +OptclObj::~OptclObj() +{ + m_destroypending = true; + ReleaseBindingTable(); + ReleaseTypeAttr(); +} + + + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::CreateName -- + * Creates the string representation for this object - a unique name is + * created from the object's IUnknown pointer. + * + * Result: + * None. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void OptclObj::CreateName (LPUNKNOWN punk) +{ + ASSERT (punk != NULL); + char str[10]; + sprintf (str, "%x", punk); + m_name = "optcl0x"; + m_name += str; +} + + + + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::InitialiseClassInfo -- + * Attempts to find the typeinfo for this object's coclass. + * + * Result: + * None. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void OptclObj::InitialiseClassInfo (LPUNKNOWN punk) +{ + CComQIPtr pcli; + + // try to pull out the coclass information + pcli = punk; // implicit query interface + if (pcli != NULL) + pcli->GetClassInfo (&m_pti_class); +} + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::InitialiseUnknown -- + * Initialises the OptclObj's 'true' IUnknown pointer. + * + * Result: + * None. + * + * Side effects: + * Throws HRESULT on error. + *------------------------------------------------------------------------- + */ +void OptclObj::InitialiseUnknown (LPUNKNOWN punk) +{ + ASSERT (punk != NULL); + HRESULT hr; + + hr = punk->QueryInterface (IID_IUnknown, (void**)(&m_punk)); + CHECKHR(hr); +} + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::InitialisePointersFromCoClass -- + * Called when we have the coclass information for this object. The + * function identifies the default interface and binds to it. + * + * Result: + * None. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +HRESULT OptclObj::InitialisePointersFromCoClass() +{ + ASSERT (m_pti_class != NULL); + TYPEATTR *pta = NULL; + HRESULT hr; + + // retrieve the type attribute + hr = m_pti_class->GetTypeAttr (&pta); + CHECKHR(hr); + + // store the number of implemented interfaces + WORD impcount = pta->cImplTypes; + m_pti_class->ReleaseTypeAttr (pta); pta = NULL; + + // iterate through the type looking for the default interface + for (WORD i = 0; i < impcount; i++) + { + INT flags; + hr = m_pti_class->GetImplTypeFlags (i, &flags); + if (FAILED (hr)) + return hr; + if (flags == IMPLTYPEFLAG_FDEFAULT) + break; + } + + // if not found return an error + if (i == impcount) + return E_FAIL; + + // we found the interface - now to get its iid... + // first retrieve the type info; + + CComPtr reftype; + CComPtr reftypelib; + + HREFTYPE href; + + hr = m_pti_class->GetRefTypeOfImplType (i, &href); + if (FAILED(hr)) + return hr; + + hr = m_pti_class->GetRefTypeInfo (href, &reftype); + if (FAILED(hr)) + return hr; + + // now set the interface from typeinfo + return SetInterfaceFromType (reftype); +} + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::GetTypeAttr -- + * Retrieves the type attribute for the type of this object's current + * interface. + * Result: + * Standard HRESULT. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +HRESULT OptclObj::GetTypeAttr() +{ + ASSERT (m_pta == NULL); + ASSERT (m_pti != NULL); + return m_pti->GetTypeAttr(&m_pta); +} + + +/* + *------------------------------------------------------------------------- + * OptclObj::ReleaseTypeAttr -- + * Releases the current type attribute, and sets it to NULL. + * Result: + * None. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void OptclObj::ReleaseTypeAttr() +{ + if (m_pti != NULL && m_pta != NULL) { + m_pti->ReleaseTypeAttr(m_pta); + m_pta = NULL; + } +} + + +/* + *------------------------------------------------------------------------- + * OptclObj::SetInterfaceFromType -- + * Queries for the interface described in the typeinfo. The interface, + * if found, becomes the current interface. + * + * Result: + * HRESULT giving success code. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +HRESULT OptclObj::SetInterfaceFromType (ITypeInfo *reftype) +{ + HRESULT hr; + CComPtr reftypelib; + UINT libindex; + TYPEATTR *pta; + + hr = reftype->GetContainingTypeLib(&reftypelib, &libindex); + if (FAILED(hr)) + return hr; + + hr = reftype->GetTypeAttr (&pta); + if (FAILED(hr)) + return hr; + + if (pta->typekind != TKIND_DISPATCH) { + reftype->ReleaseTypeAttr (pta); + return E_NOINTERFACE; + } + + GUID guid = pta->guid; + reftype->ReleaseTypeAttr (pta); + + hr = m_punk->QueryInterface(guid, (void**)(&m_pcurrent)); + if (FAILED(hr)) + return hr; + + + // nice! now we cache the result of all our hard work + ReleaseTypeAttr (); + m_pti = reftype; + m_ptl = reftypelib; + m_ptc = NULL; + m_pti->GetTypeComp (&m_ptc); + // now that we got the interface ok, retrieve the type attributes again + return GetTypeAttr(); +} + + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::InitialisePointers -- + * Called to initialise this objects interface pointers + * + * Result: + * None. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void OptclObj::InitialisePointers (LPUNKNOWN punk, ITypeLib *plib, ITypeInfo *pinfo) +{ + HRESULT hr; + ASSERT (punk != NULL); + CComQIPtr pdisp; + + ASSERT ((plib!=NULL && pinfo!=NULL) || (plib==NULL && pinfo==NULL)); + + if (plib != NULL && pinfo != NULL) { + m_pcurrent = punk; + m_ptl = plib; + m_pti = pinfo; + m_ptc = NULL; + m_pti->GetTypeComp (&m_ptc); + GetTypeAttr(); + } + + // else, if we have the coclass information, try building on its default + // interface + else if (m_pti_class == NULL || FAILED(InitialisePointersFromCoClass())) { + // failed to build using coclass information + // Query Interface cast to a dispatch interface + m_pcurrent = punk; + try { + if (m_pcurrent == NULL) + throw (HRESULT(0)); + // get the type information and library. + hr = m_pcurrent->GetTypeInfo (0, LOCALE_SYSTEM_DEFAULT, &m_pti); + CHECKHR(hr); + UINT index; + hr = m_pti->GetContainingTypeLib(&m_ptl, &index); + CHECKHR(hr); + m_ptc = NULL; + m_pti->GetTypeComp (&m_ptc); + GetTypeAttr(); + } + + + catch (HRESULT) { + // there isn't a interface that we can use + ReleaseTypeAttr(); + m_pcurrent.Release(); + m_pti = NULL; + m_ptl = NULL; + m_ptc = NULL; + return; + } + } + // inform the typelibrary browser system of the library + g_libs.EnsureCached (m_ptl); +} + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::operator LPUNKNOWN -- + * Gives the 'true' IUnknown pointer for this object. + * + * Result: + * None. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +OptclObj::operator LPUNKNOWN() +{ + return m_punk; +} + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::operator const char * -- + * Gives the string representation for this object. + * + * Result: + * None. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +OptclObj::operator const char * () +{ + return m_name.c_str(); +} + + + +/* + *------------------------------------------------------------------------- + * void OptclObj::CoClassName -- + * Returns the class name in the tcl object smart ptr or ??? if unknown. + * + * Result: + * None. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void OptclObj::CoClassName (TObjPtr &pObj) +{ + pObj.create(); + if (m_pti_class == NULL) + pObj = "???"; + else + TypeLib_GetName (NULL, m_pti_class, pObj); +} + + +/* + *------------------------------------------------------------------------- + * OptclObj::InterfaceName -- + * Returns the name of this objects current interface. + * + * Result: + * None. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void OptclObj::InterfaceName (TObjPtr &pObj) +{ + pObj.create(); + if (m_pti == NULL) + pObj = "???"; + else + TypeLib_GetName (NULL, m_pti, pObj); +} + + + +/* + *------------------------------------------------------------------------- + * OptclObj::SetInterfaceName -- + * Sets the current interface to that named by pObj. + * + * Result: + * None. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void OptclObj::SetInterfaceName (TObjPtr &pObj) +{ + ASSERT (pObj.isnotnull()); + TypeLib *ptl; + CComPtr pti; + CComPtr punk; + TYPEATTR ta, *pta = NULL; + HRESULT hr; + + TypeLib_ResolveName (pObj, &ptl, &pti); + // we need to insert some alias type resolution here. + + hr = pti->GetTypeAttr (&pta); + CHECKHR(hr); + ta = *pta; + pti->ReleaseTypeAttr (pta); + + + if (ta.typekind != TKIND_INTERFACE && + ta.typekind != TKIND_DISPATCH) + throw ("type does not resolve to an interface"); + + + hr = m_punk->QueryInterface (ta.guid, (void**)(&punk)); + CHECKHR(hr); + InitialisePointers (punk, ptl->m_ptl, pti); +} + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::InvokeCmd -- + * Called by the object map as a result of invoking the object command + * on this object. Format of the command is as follows + * + * obj : ?-with subprop? prop ?value? ?prop value? ... + * obj method ?arg? ... + * + * Result: + * true iff successful. Error string in interpreter. + * + * Side effects: + * Depends on the parameters. + *------------------------------------------------------------------------- + */ +bool OptclObj::InvokeCmd (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST objv[]) +{ + ASSERT (pInterp != NULL); + CComPtr pdisp; + CComPtr ptc; + CComPtr pti; + TObjPtr name; + + int invkind = DISPATCH_METHOD; + + char * msg = + "\n\tobj : ?-with subprop? prop ?value? ?prop value? ..." + "\n\tobj method ?arg? ..."; + + if (objc == 0) { + Tcl_WrongNumArgs (pInterp, 0, NULL, msg); + return TCL_ERROR; + } + + if (CheckInterface (pInterp) == false) + return TCL_ERROR; + + + + // parse for a -with flag + name.attach(objv[0]); + if (strncmp (name, "-with", strlen(name)) == 0) + { + // check that we have enough parameters + if (objc < 3) { + Tcl_WrongNumArgs (pInterp, 0, NULL, msg); + return false; + } + + name.attach(objv[1]); + if (!ResolvePropertyObject (pInterp, name, &pdisp, &pti, &ptc)) + return false; + objc -= 2; + objv += 2; + } + else { + pdisp = m_pcurrent; + ptc = m_ptc; + pti = m_pti; + } + + // check the first argument for a ':' + char * str = Tcl_GetStringFromObj (objv[0], NULL); + ASSERT (str != NULL); + + if (*str == ':') { + objc--; + objv++; + + if (objc == 1) + return GetProp (pInterp, objv[0], pdisp, pti, ptc); + else { + if (objc % 2 != 0) { + Tcl_SetResult (pInterp, "property set requires pairs of parameters", TCL_STATIC); + return false; + } + return SetProp (pInterp, objc/2, objv, pdisp, pti, ptc); + } + } + + if (ptc == NULL) + return InvokeNoTypeInf (pInterp, invkind, objc, objv, pdisp); + else + return InvokeWithTypeInf (pInterp, invkind, objc, objv, pdisp, pti, ptc); +} + + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::CheckInterface -- + * Checks for current interface being valid. + * Result: + * Currently, returns true iff an interface exists. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +bool OptclObj::CheckInterface (Tcl_Interp *pInterp) +{ + if (m_pcurrent == NULL) { + Tcl_SetResult (pInterp, "no interface available", TCL_STATIC); + return false; + } + + /* -- not needed now that we are only working with dispatch interfaces + + if (m_pta != NULL) { + if (m_pta->typekind == TKIND_INTERFACE && ((m_pta->wTypeFlags&TYPEFLAG_FDUAL)==0)) + { + Tcl_SetResult (pInterp, "interface is a pure vtable - optcl can't call these ... yet!", TCL_STATIC); + return false; + } + } + */ + return true; +} + + +/* + *------------------------------------------------------------------------- + * OptclObj::BuildParamsWithBindPtr -- + * Builds the dispatch parameters using the values found in a bindptr + * object. + * + * Result: + * true iff successful - else error string in interpreter. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +bool OptclObj::BuildParamsWithBindPtr (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST objv[], + OptclBindPtr & bp, DispParams & dp) +{ + ASSERT (pInterp != NULL && objv != NULL); + bool con_ok = true; + TObjPtr obj; + + + // check for the last parameter being the return value and take + // this into account when checking parameter counts + int params = bp.cParams (); + if (params > 0 && bp.param(params - 1)->paramdesc.wParamFlags & PARAMFLAG_FRETVAL) + --params; + + if (objc <= params && + objc >= (params - bp.cParamsOpt())) + { + // set up the dispatch arguments - must be in reverse order + dp.Args (objc); + for (int count = objc-1; count >= 0 && con_ok; count--) + { + con_ok = false; + ELEMDESC *pdesc = bp.param(count); + ASSERT (pdesc != NULL); + // cases for parameters : [in] - value + // [inout] - reference (variable must exist) + // [out] - reference (variable doesn have to exist) + + // is it an in* type + if ((pdesc->paramdesc.wParamFlags & PARAMFLAG_FIN) || (pdesc->paramdesc.wParamFlags == PARAMFLAG_NONE)) { + // is it [inout]? + if (pdesc->paramdesc.wParamFlags & PARAMFLAG_FOUT) { + obj.attach(Tcl_ObjGetVar2 (pInterp, objv[count], NULL, TCL_LEAVE_ERR_MSG)); + if (obj.isnull()) + return false; + } + else // just [in] + obj.attach(objv[count]); + + con_ok = obj2var_ti(pInterp, obj, dp[objc - count - 1], bp.m_pti, &(pdesc->tdesc)); + } + + else if (pdesc->paramdesc.wParamFlags & PARAMFLAG_FOUT) + { // a pure out flag - we'll set up the type of the parameter correctly, but fill it with a null + con_ok = obj2var_ti(pInterp, TObjPtr(NULL), dp[objc - count - 1], bp.m_pti, &(pdesc->tdesc)); + } + + else { + // unknown parameter type + ASSERT(false); + } + } + } + else + { + Tcl_SetResult (pInterp, "wrong # args", TCL_STATIC); + con_ok = false; + } + + return con_ok; +} + + + +/* + *------------------------------------------------------------------------- + * OptclObj::RetrieveOutParams -- + * Scans the parameter types in a bind pointer and pulls out those that + * are either out or in/out, and sets the appropriate Tcl variable to + * their value. + * + * Result: + * true iff successful. Else, error string in interpreter. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +bool OptclObj::RetrieveOutParams (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST objv[], + OptclBindPtr & bp, DispParams & dp) + +{ + TObjPtr presult; + bool bok = true; + // now loop through the parameters again, pulling out the [*out] values + for (int count = objc - 1; bok && count >= 0; count--) + { + ELEMDESC *pdesc = bp.param(count); + ASSERT (pdesc != NULL); + // is it an out parameter? + if (pdesc->paramdesc.wParamFlags & PARAMFLAG_FOUT) + { + // convert the value back to a tcl object + bok = (!var2obj (pInterp, dp[objc - count - 1], presult) || + Tcl_ObjSetVar2 (pInterp, objv[count], NULL, + presult, TCL_LEAVE_ERR_MSG) == NULL); + + } + } + return bok; +} + + + + + + +bool OptclObj::InvokeWithTypeInfVariant (Tcl_Interp *pInterp, long invokekind, + int objc, Tcl_Obj *CONST objv[], + IDispatch *pDisp, ITypeInfo *pti, ITypeComp *pCmp, VARIANT &varResult) +{ + USES_CONVERSION; + DispParams dp; + LPOLESTR olename; + + + DISPID dispid; + HRESULT hr; + EXCEPINFO ei; + UINT ea = 0; + + bool bOk = false; + TObjPtr obj; + TObjPtr presult; + static DISPID propput = DISPID_PROPERTYPUT; + OptclBindPtr obp; + OptclTypeAttr ota; + + ASSERT (objc >= 1); + ASSERT (pDisp != NULL); + ASSERT (pti != NULL); + ASSERT (varResult.vt == VT_EMPTY); + ota = pti; + + ASSERT (ota->typekind == TKIND_DISPATCH || (ota->wTypeFlags & TYPEFLAG_FDUAL)); + + try { + olename = A2OLE(Tcl_GetStringFromObj (objv[0], NULL)); + hr = pCmp->Bind (olename, LHashValOfName(LOCALE_SYSTEM_DEFAULT, olename), + invokekind, &obp.m_pti, &obp.m_dk, &obp.m_bp); + CHECKHR(hr); + + if (obp.m_dk == DESCKIND_NONE) { + Tcl_SetResult (pInterp, "member not found: ", TCL_STATIC); + Tcl_AppendResult (pInterp, (char*)obj, NULL); + } else { + dispid = obp.memid(); + // check the number of parameters + + objc--; // count of parameters provided + objv++; // the parameters + if (!BuildParamsWithBindPtr (pInterp, objc, objv, obp, dp)) + return false; + + if (invokekind == DISPATCH_PROPERTYPUT) { + dp.cNamedArgs = 1; + dp.rgdispidNamedArgs = &propput; + } + + // can't invoke through the typelibrary for local objects + //hr = pti->Invoke(pDisp, dispid, invokekind, &dp, &varResult, &ei, &ea); + hr = pDisp->Invoke(dispid, IID_NULL, LOCALE_SYSTEM_DEFAULT, invokekind, + &dp, &varResult, &ei, &ea); + + if (invokekind == DISPATCH_PROPERTYPUT) { + dp.rgdispidNamedArgs = NULL; + } + + // error check + if (hr == DISP_E_EXCEPTION) + Tcl_SetResult (pInterp, ExceptInfo2Str (&ei), TCL_DYNAMIC); + + else if (hr == DISP_E_TYPEMISMATCH) { + TDString td("type mismatch in parameter #"); + td << (long)(ea); + Tcl_SetResult (pInterp, td, TCL_VOLATILE); + } + else + CHECKHR_TCL(hr, pInterp, false); + if (FAILED(hr)) + return false; + + if (!RetrieveOutParams (pInterp, objc, objv, obp, dp)) + return false; + bOk = true; + } + } + catch (HRESULT hr) + { + Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC); + } + return bOk; +} + + + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::InvokeWithTypeInf -- + * Performs a method invocation, given a dispatch interface and a + * ITypeComp interface for typing. + * + * Result: + * true iff successful. Error string in interpreter. + * Side effects: + * Depends on the method being invoked. + *------------------------------------------------------------------------- + */ +bool OptclObj::InvokeWithTypeInf (Tcl_Interp *pInterp, long invokekind, + int objc, Tcl_Obj *CONST objv[], + IDispatch *pDisp, ITypeInfo *pti, ITypeComp *pCmp) +{ + VARIANT varResult; + VariantInit(&varResult); + TObjPtr presult; + + bool bok; + bok = InvokeWithTypeInfVariant (pInterp, invokekind, objc, objv, pDisp, pti, pCmp, varResult); + + // set the result of the operation to the return value of the function + if (bok && (bok = var2obj(pInterp, varResult, presult))) + Tcl_SetObjResult (pInterp, presult); + VariantClear(&varResult); + return bok; +} + + + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::InvokeNoTypeInf -- + * Performs a member invocation without any type information on an + * IDispatch interface. + * + * Result: + * true iff successful. Else, error string in interpreter. + * Side effects: + * Depends on the methods being invoked. + *------------------------------------------------------------------------- + */ + +bool OptclObj::InvokeNoTypeInf( Tcl_Interp *pInterp, long invokekind, + int objc, Tcl_Obj *CONST objv[], + IDispatch *pDisp) +{ + VARIANT var; + VariantInit (&var); + TObjPtr presult; + bool bok; + + if (bok = InvokeNoTypeInfVariant (pInterp, invokekind, objc, objv, pDisp, var)) { + if (bok = var2obj(pInterp, var, presult)) + Tcl_SetObjResult (pInterp, presult); + VariantClear(&var); + } + + return bok; +} + + + +/* + *------------------------------------------------------------------------- + * OptclObj::InvokeNoTypeInfVariant -- + * The same as InvokeNoTypeInf, but instead of placing the result in + * the interpreter, returns within a variant. + * Result: + * true iff successful. Else, error string in interpreter + * Side effects: + * Depends on member being invoked + *------------------------------------------------------------------------- + */ +bool OptclObj::InvokeNoTypeInfVariant ( Tcl_Interp *pInterp, long invokekind, + int objc, Tcl_Obj *CONST objv[], + IDispatch *pDisp, VARIANT &varResult) +{ + ASSERT (varResult.vt == VT_EMPTY); + + DispParams dp; + DISPID dispid; + HRESULT hr; + TObjPtr obj; + EXCEPINFO ei; + UINT ea = 0; + bool bOk = false; + + ASSERT (objc >= 1); + ASSERT (pDisp != NULL); + + obj.attach(objv[0]); + dispid = Name2ID(pDisp, obj); + if (dispid == DISPID_UNKNOWN) { + Tcl_SetResult (pInterp, "member not found: ", TCL_STATIC); + Tcl_AppendResult (pInterp, obj, NULL); + } else { + objc--; // count of parameters + // set up the dispatch arguments - must be in reverse order + dp.Args (objc); + for (int i = objc-1; i >= 0; i--) + { + obj.attach(objv[i+1]); + obj2var(obj, dp[i]); + } + + hr = pDisp->Invoke(dispid, IID_NULL, LOCALE_SYSTEM_DEFAULT, invokekind, + &dp, &varResult, &ei, &ea); + if (hr == DISP_E_EXCEPTION) + Tcl_SetResult (pInterp, ExceptInfo2Str (&ei), TCL_DYNAMIC); + else if (hr == DISP_E_TYPEMISMATCH) { + TDString td("type mismatch in parameter #"); + td << (long)(ea); + Tcl_SetResult (pInterp, td, TCL_VOLATILE); + } + else if (FAILED(hr)) + Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC); + else { + } + } + + return bOk; +} + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::GetProp -- + * Called to get the value of a property (a property can be indexed) + * If type information is provided, then it will be used in the invocation + * Result: + * true iff ok. Else, error string in interpreter + * Side effects: + * Depends on the property and its value. + *------------------------------------------------------------------------- + */ +bool OptclObj::GetProp (Tcl_Interp *pInterp, Tcl_Obj *name, + IDispatch *pdisp, ITypeInfo *pti, ITypeComp *ptc) +{ + ASSERT (pInterp != NULL && name != NULL && pdisp != NULL); + TObjPtr params; + bool bok; + + if (bok = SplitBrackets (pInterp, name, params)) { + int length = params.llength(); + ASSERT (length >= 1); + Tcl_Obj ** pplist = (Tcl_Obj **)malloc(sizeof(Tcl_Obj*) * length); + if (pplist == NULL) { + Tcl_SetResult (pInterp, "out of memory", TCL_STATIC); + return false; + } + + for (int p = 0; p < length; p++) + pplist[p] = params.lindex(p); + + if (pti != NULL) { + ASSERT (ptc != NULL); + bok = InvokeWithTypeInf(pInterp, DISPATCH_PROPERTYGET, length, pplist, pdisp, pti, ptc); + } + else { + bok = InvokeNoTypeInf (pInterp, DISPATCH_PROPERTYGET, length, pplist, pdisp); + } + + free(pplist); + } + return bok; +} + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::GetIndexedVariant -- + * Called to get the value of a property or the return type of method, with + * bracket indexing. + * If type information is provided, then it will be used in the invocation + * Result: + * true iff ok. Else, error string in interpreter + * Side effects: + * Depends on the property and its value. + *------------------------------------------------------------------------- + */ +bool OptclObj::GetIndexedVariant (Tcl_Interp *pInterp, Tcl_Obj *name, + IDispatch *pdisp, ITypeInfo *pti, ITypeComp *ptc, VARIANT &varResult) +{ + ASSERT (pInterp != NULL && name != NULL && pdisp != NULL); + ASSERT (varResult.vt == VT_EMPTY); + + TObjPtr params; + TObjPtr presult; + bool bok; + static const int invkind = DISPATCH_PROPERTYGET|DISPATCH_METHOD; + if (bok = SplitBrackets (pInterp, name, params)) { + int length = params.llength(); + ASSERT (length >= 1); + Tcl_Obj ** pplist = (Tcl_Obj **)malloc(sizeof(Tcl_Obj*) * length); + if (pplist == NULL) { + Tcl_SetResult (pInterp, "out of memory", TCL_STATIC); + return false; + } + + for (int p = 0; p < length; p++) + pplist[p] = params.lindex(p); + + if (pti != NULL) { + ASSERT (ptc != NULL); + bok = InvokeWithTypeInfVariant (pInterp, invkind, length, pplist, pdisp, pti, ptc, varResult); + } + else { + bok = InvokeNoTypeInfVariant (pInterp, invkind, length, pplist, pdisp, varResult); + } + free(pplist); + } + return bok; +} + +bool OptclObj::SetProp (Tcl_Interp *pInterp, + int paircount, Tcl_Obj * CONST namevalues[], + IDispatch *pdisp, ITypeInfo *pti, ITypeComp *ptc) +{ + bool bok = true; + ASSERT (pInterp != NULL && paircount > 0 && namevalues != NULL && pdisp != NULL); + for (int i = 0; bok && i < paircount; i++) + { + TObjPtr params; + if (bok = SplitBrackets (pInterp, namevalues[0], params)) { + params.lappend(namevalues[1]); + int length = params.llength(); + ASSERT (length >= 1); + Tcl_Obj ** pplist = (Tcl_Obj **)malloc(sizeof(Tcl_Obj*) * length); + if (pplist == NULL) { + Tcl_SetResult (pInterp, "out of memory", TCL_STATIC); + return false; + } + + + for (int p = 0; p < length; p++) + pplist[p] = params.lindex(p); + + if (pti != NULL) { + ASSERT (ptc != NULL); + bok = InvokeWithTypeInf(pInterp, DISPATCH_PROPERTYPUT, length, pplist, pdisp, pti, ptc); + } + else { + bok = InvokeNoTypeInf (pInterp, DISPATCH_PROPERTYPUT, length, pplist, pdisp); + } + namevalues += 2; + free(pplist); + } + } + if (bok) + Tcl_ResetResult (pInterp); + return true; +} + + + + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::GetPropVariantDispatch -- + * Retrieves the value of property as a variant, relative to a dispatch + * interface. + * + * Result: + * true iff successful. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +bool OptclObj::GetPropVariantDispatch (Tcl_Interp *pInterp, const char*name, + IDispatch* pcurrent, VARIANT &varResult) + +{ + USES_CONVERSION; + + ASSERT (pcurrent != NULL && pInterp != NULL); + + DISPID dispid; + HRESULT hr; + DISPPARAMS dispparamsNoArgs; SETNOPARAMS (dispparamsNoArgs); + EXCEPINFO ei; + bool bOk = false; + + dispid = Name2ID (pcurrent, name); + if (dispid == DISPID_UNKNOWN) { + Tcl_SetResult (pInterp, "property not found: ", TCL_STATIC); + Tcl_AppendResult (pInterp, name, NULL); + return false; + } + + hr = pcurrent->Invoke (dispid, IID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_PROPERTYGET, + &dispparamsNoArgs, &varResult, &ei, NULL); + if (hr == DISP_E_EXCEPTION) + Tcl_SetResult (pInterp, ExceptInfo2Str (&ei), TCL_DYNAMIC); + else if (FAILED(hr)) + Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC); + else + bOk = true; + + return bOk; +} + + + + + + + + + + +/* + *------------------------------------------------------------------------- + * ResolvePropertyObject -- + * Resolves a property list of objects in the dot format + * e.g. application.documents(1).pages(2) + * Result: + * true iff successful to bind the ppunk parameter to a valid + * Side effects: + * + *------------------------------------------------------------------------- + */ +bool OptclObj::ResolvePropertyObject (Tcl_Interp *pInterp, const char *sname, + IDispatch **ppdisp, ITypeInfo **ppinfo, ITypeComp **ppcmp /* = NULL*/) +{ + USES_CONVERSION; + ASSERT (pInterp != NULL && ppdisp != NULL && sname != NULL); + // copy the string onto the stack + char * szname; + char * seps = "."; + char * szprop = NULL; + _variant_t varobj; + VARIANT varResult; + + HRESULT hr; + + TObjPtr pcmd; + TObjPtr plist; + TObjPtr pokstring; + + szname = (char*)_alloca (strlen (sname) + 1); + strcpy (szname, sname); + szprop = strtok(szname, seps); + CComQIPtr current; + CComPtr pti; + CComPtr pcmp; + + UINT typecount = 0; + + current = m_pcurrent; + pti = m_pti; + pcmp = m_ptc; + + pcmd.create(); + + VariantInit (&varResult); + + try { + while (szprop != NULL) + { + TObjPtr prop(szprop); + + VariantClear(&varResult); + if (!GetIndexedVariant (pInterp, prop, current, pti, pcmp, varResult)) + break; + + // check that it's an object + if (varResult.vt != VT_DISPATCH && varResult.vt != VT_UNKNOWN) + { + Tcl_SetResult (pInterp, "'", TCL_STATIC); + Tcl_AppendResult (pInterp, szprop, "' is not an object", NULL); + break; + } + + else + { + current = varResult.punkVal; + if (current == NULL) + { + Tcl_SetResult (pInterp, "'", TCL_STATIC); + Tcl_AppendResult (pInterp, szprop, "' is not a dispatchable object", NULL); + break; + } + typecount = 0; + pti = NULL; + pcmp = NULL; + + current->GetTypeInfoCount (&typecount); + if (typecount > 0) { + hr = current->GetTypeInfo (0, LOCALE_SYSTEM_DEFAULT, &pti); + if (SUCCEEDED(hr)) { + g_libs.EnsureCached (pti); + } + pti->GetTypeComp(&pcmp); + } + } + + // get the next property + szprop = strtok(NULL, seps); + } + + *ppinfo = pti.Detach(); + *ppcmp = pcmp.Detach(); + *ppdisp = current.Detach (); + } + + catch (HRESULT hr) + { + Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC); + } + + catch (char * error) + { + Tcl_SetResult (pInterp, error, TCL_STATIC); + } + VariantClear(&varResult); + return (szprop == NULL); +} + + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::GetBinding -- + * Retrieves the current binding, if any for a properly formed event. + * Event is in the form of either + * 'event_name' on default interface + * 'lib.type.event_name' + * + * Result: + * true iff successful. Error in interpreter. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +bool OptclObj::GetBinding (Tcl_Interp *pInterp, char *pname) +{ + ASSERT (pInterp != NULL && pname != NULL); + + EventBindings * pbinding = NULL; + GUID guid; + CComPtr + pti; + int ne; + TObjPtr name(pname); + TObjPtr sr; + + + // split the name + sr.create(); + if (!SplitObject(pInterp, name, ".", &sr)) + return false; + + ne = sr.llength(); + if (ne <= 0) + return false; + + // check for a split on strings ending with a token + if ((*(char*)(sr.lindex(ne - 1))) == '\0') { + if (--ne <= 0) + return false; + } + + if (ne != 1 && ne != 3) { + Tcl_SetResult (pInterp, "wrong event format: should be either 'eventname' or 'lib.type.eventname'", TCL_STATIC); + return NULL; + } + + if (ne == 1 && !FindDefaultEventInterface(pInterp, &pti, &guid)) + return false; + else if (ne == 3 && FindEventInterface (pInterp, sr.lindex(0), sr.lindex(1), &pti, &guid)) + return false; + + if (m_bindings.find(&guid, &pbinding) == NULL) { + Tcl_ResetResult (pInterp); + return true; + } + else + return pbinding->GetBinding (pInterp, name); +} + + + +/* + *------------------------------------------------------------------------- + * OptclObj::SetBinding -- + * Sets an event binding for the event pointed by 'pname' to the tcl command + * stored in 'pcmd'. + * Result: + * true iff successful. Else error in interpreter. + * Side effects: + * Any earlier binding for this event will be removed. + *------------------------------------------------------------------------- + */ +bool OptclObj::SetBinding (Tcl_Interp *pInterp, char *pname, Tcl_Obj *pcmd) +{ + ASSERT (pInterp != NULL && pname != NULL && pcmd != NULL); + ASSERT (m_punk != NULL); + + TObjPtr name(pname); + TObjPtr cmd(pcmd, false); + + TObjPtr sr; // split result + int ne; // name elements + GUID guid; // id of the event interface + HRESULT hr; + + CComPtr + pti; // typeinfo for the event interface + + EventBindings * // the bindings for this interface + pbinding = NULL; + + + // split the name + sr.create(); + if (!SplitObject(pInterp, name, ".", &sr)) + return false; + + ne = sr.llength(); + if (ne <= 0) + return false; + + // check for a split on strings ending with a token + if ((*(char*)(sr.lindex(ne - 1))) == '\0') { + if (--ne <= 0) + return false; + } + + if (ne != 1 && ne != 3) { + Tcl_SetResult (pInterp, "wrong event format: should be either 'eventname' or 'lib.type.eventname'", TCL_STATIC); + return NULL; + } + + if (ne == 1 && !FindDefaultEventInterface(pInterp, &pti, &guid)) + return false; + else if (ne == 3 && !FindEventInterface (pInterp, sr.lindex(0), sr.lindex(1), &pti, &guid)) + return false; + + + if (m_bindings.find(&guid, &pbinding) == NULL) + { + pbinding = new EventBindings (this, guid, pti); + // initiate the advise + hr = m_punk.Advise((IUnknown*)(pbinding), guid, &(pbinding->m_cookie)); + if (FAILED(hr)) { + delete pbinding; + Tcl_SetResult (pInterp, HRESULT2Str (hr), TCL_DYNAMIC); + return false; + } + m_bindings.set(&guid, pbinding); + } + + // deleting a single event binding + if ((*(char*)cmd) == '\0') { + if (!pbinding->DeleteBinding (pInterp, sr.lindex(ne==1?0:2))) + return false; + // total number of bindings for this interface is now zero? + if (pbinding->TotalBindings() == 0) { + // unadvise - CComPtr doesn't have this!! + CComQIPtr pcpc; + CComPtr pcp; + pcpc = m_punk; + ASSERT (pcpc != NULL); + pcpc->FindConnectionPoint (guid, &pcp); + ASSERT (pcp != NULL); + pcp->Unadvise (pbinding->m_cookie); + m_bindings.delete_entry(&guid); + delete pbinding; + } + } + else if (!pbinding->SetBinding (pInterp, sr.lindex(ne==1?0:2), pcmd)) + return false; + + return true; +} + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::FindDefaultEventInterface -- + * Retrieves the default event interface for this object. + * Result: + * true iff successful. Else, error string in interpreter. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +bool OptclObj::FindDefaultEventInterface (Tcl_Interp *pInterp, ITypeInfo **ppinfo, GUID *pguid) +{ + ASSERT (pInterp != NULL && ppinfo != NULL && pguid != NULL); + ASSERT (m_punk != NULL); + + bool bOk = false; + TYPEATTR * pattr = NULL; + HRESULT hr; + USHORT impltypes; + CComPtr peti; + + + if (m_pti_class == NULL) + Tcl_SetResult (pInterp, "class-less object doesn't have a default event interface", TCL_STATIC); + else + { + hr = m_pti_class->GetTypeAttr (&pattr); + CHECKHR_TCL(hr, pInterp, false); + impltypes = pattr->cImplTypes; + m_pti_class->ReleaseTypeAttr(pattr); pattr = NULL; + + for (USHORT i = 0; i < impltypes; i++) + { + INT flags; + HREFTYPE href; + if (SUCCEEDED(m_pti_class->GetImplTypeFlags (i, &flags)) + && (flags & IMPLTYPEFLAG_FDEFAULT) // default interface and .. + && (flags & IMPLTYPEFLAG_FSOURCE) // an event source + && SUCCEEDED(m_pti_class->GetRefTypeOfImplType(i, &href)) + && SUCCEEDED(m_pti_class->GetRefTypeInfo (href, &peti))) + { + i = impltypes; // quits this loop + // while we're here, we'll make sure that this type is cached + g_libs.EnsureCached(peti); + } + } + + if (peti != NULL) + { + hr = peti->GetTypeAttr (&pattr); + CHECKHR_TCL(hr, pInterp, false); + *pguid = pattr->guid; + peti->ReleaseTypeAttr(pattr); pattr = NULL; + *ppinfo = peti; + (*ppinfo)->AddRef(); + bOk = true; + } + } + return bOk; +} + + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::FindEventInterface -- + * Called to find an event type info and guid given library and type of + * event interface. + * + * Result: + * true iff successful. Else, error string in interpreter. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +bool OptclObj::FindEventInterface (Tcl_Interp *pInterp, const char * lib, const char *type, + ITypeInfo **ppinfo, GUID * pguid) +{ + + ASSERT (pInterp != NULL && lib != NULL && type != NULL && ppinfo != NULL); + ASSERT (pguid != NULL); + ASSERT (m_punk != NULL); + + USES_CONVERSION; + CComPtr peti; + CComPtr petl; + + bool bOk = false; + TYPEATTR * pattr = NULL; + BSTR bType = NULL; + BSTR bLib = NULL; + HRESULT hr; + UINT dummy; + + + if (m_pti_class == NULL) { + // we don't have any class information + // try going through the typelibraries + try { + TypeLib_ResolveName (lib, type, NULL, &peti); + if (peti == NULL) + Tcl_SetResult (pInterp, "binding through typelib for class-less object failed", TCL_STATIC); + } + + catch (char *err) { + Tcl_SetResult (pInterp, err, TCL_VOLATILE); + } + + catch (HRESULT hr) { + Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC); + } + } + + else + { + // we do have class information + // this will ensure that even if the type library for the event + // interface is not loaded (yes, it can be different to that of the + // object that's using it, it will still be found. + + // convert the event interface name to a bstring + bType = A2BSTR(type); + bLib = A2BSTR(lib); + // get the number of implemented types + hr = m_pti_class->GetTypeAttr (&pattr); + CHECKHR_TCL(hr, pInterp, false); // beware, conditional return here + USHORT types = pattr->cImplTypes; + m_pti_class->ReleaseTypeAttr (pattr); pattr = NULL; + + // loop throught the implemented types + for (USHORT intf = 0; intf < types; intf++) + { + INT flags; + HREFTYPE href; + CComBSTR btypename, + blibname; + + // if we the implementation flags is an event source and + // the name of the referenced type is the same + if (SUCCEEDED(m_pti_class->GetImplTypeFlags (intf, &flags)) + && (flags&IMPLTYPEFLAG_FSOURCE) + && SUCCEEDED(m_pti_class->GetRefTypeOfImplType (intf, &href)) + && SUCCEEDED(m_pti_class->GetRefTypeInfo (href, &peti)) + && SUCCEEDED(peti->GetContainingTypeLib(&petl, &dummy)) + && SUCCEEDED(peti->GetDocumentation(MEMBERID_NIL, &btypename, NULL, NULL, NULL)) + && SUCCEEDED(petl->GetDocumentation(-1, &blibname, NULL, NULL, NULL))) + { + if ((btypename == bType) && (blibname == bLib)) { + intf = types; // quits this loop + // while we're at it, lets make sure that this typelibrary is + // registered. + g_libs.EnsureCached(petl); + } + } + else { + peti = NULL; + petl = NULL; + } + btypename.Empty(); + blibname.Empty(); + } + + if (peti == NULL) + Tcl_SetResult (pInterp, "couldn't find event interface", TCL_STATIC); + } + + if (peti != NULL) { + // if we've got a typeinfo, find the GUID + hr = peti->GetTypeAttr (&pattr); + CHECKHR_TCL (hr, pInterp, false); + *pguid = pattr->guid; + peti->ReleaseTypeAttr(pattr); pattr = NULL; + *ppinfo = peti; + (*ppinfo)->AddRef(); + bOk = true; + } + return bOk; +} + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::ReleaseBindingTable -- + * Releases the bindings withing the event bindings hash table. + * It's probably very important that this isn't called within the + * evaluation of an event. + * + * Result: + * None. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void OptclObj::ReleaseBindingTable() +{ + CComQIPtr pcpc; + EventBindings * pbinding; + CComPtr pcp; + + + pcpc = m_punk; + if (pcpc == NULL) + return; + + EventBindingsTbl::iterator i; + for (i = m_bindings.begin(); i != m_bindings.end(); i++) + { + pbinding = *i; + pcpc->FindConnectionPoint (*(i.key()), &pcp); + if (pcp != NULL) { + pcp->Unadvise(pbinding->m_cookie); + pcp = NULL; + } + else { + // this case occurs when the com object has been destroyed + // before this object is destroyed + } + delete pbinding; + } +} + + + + +/* + *------------------------------------------------------------------------- + * OptclObj::GetState -- + * This is some prelim code for persistence support - yanked out of the + * old container code - more soon! + * + * Result: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ +bool OptclObj::GetState (Tcl_Interp *pInterp) +{ + ASSERT (pInterp != NULL); + USES_CONVERSION; + + CComPtr pStream; + CComQIPtr pPS; + CComQIPtr pPSI; + + HGLOBAL hMem; // handle to memory + LPVOID pMem; // pointer to memory + HRESULT hr; + DWORD dwSize; // size of memory used + TObjPtr pObjs[2]; // objects to automanage the tcl_obj lifetimes + Tcl_Obj * pResult; // pointers used to create the result list + CLSID clsid; + LPOLESTR lpOleStr; + + + pPS = m_punk; + pPSI = m_punk; + if (!pPS && !pPSI) { + Tcl_SetResult (pInterp, "object does not support stream persistance model", TCL_STATIC); + return false; + } + + hMem = GlobalAlloc (GHND, 0); + if (hMem == NULL) { + Tcl_SetResult (pInterp, "unable to initialise global memory", TCL_STATIC); + return false; + } + + hr = CreateStreamOnHGlobal (hMem, TRUE, &pStream); + if (FAILED(hr)) { + GlobalFree (hMem); + Tcl_SetResult (pInterp, "unable to create a stream on global memory", TCL_STATIC); + return false; + } + + if (pPS) + hr = pPS->Save (pStream, TRUE); + else + hr = pPSI->Save(pStream, TRUE); + + + if (FAILED(hr)) { + if (hr == STG_E_CANTSAVE) + Tcl_SetResult (pInterp, "failed to save object", TCL_STATIC); + else if (hr == STG_E_MEDIUMFULL) + Tcl_SetResult (pInterp, "failed to aquire enough memory", TCL_STATIC); + return false; + } + dwSize = GlobalSize(hMem); + pMem = GlobalLock (hMem); + + ATLASSERT (pMem); + pObjs[1] = Tcl_NewStringObj ((char*)pMem, dwSize); + GlobalUnlock (hMem); + + // now get the clsid + if (pPS) + hr = pPS->GetClassID (&clsid); + else + hr = pPSI->GetClassID (&clsid); + + if (FAILED(hr)) + { + Tcl_SetResult (pInterp, "failed to retrieve the clsid", TCL_STATIC); + return false; + } + + hr = StringFromCLSID (clsid, &lpOleStr); + if (FAILED(hr)) { + Tcl_SetResult (pInterp, "failed to convert clsid to a string", TCL_STATIC); + return false; + } + pObjs[0] = Tcl_NewStringObj (OLE2A(lpOleStr), -1); + pResult = Tcl_NewListObj (0, NULL); + Tcl_ListObjAppendElement (NULL, pResult, pObjs[0]); + Tcl_ListObjAppendElement (NULL, pResult, pObjs[1]); + Tcl_SetObjResult (pInterp, pResult); + return true; +} + + +/* + *------------------------------------------------------------------------- + * OptclObj::ContainerWantsToDie -- + * Called by the Tk widget container, when it is about to be destroyed. + * If we are not currently destroying this object, then instigate it. + * + * Result: + * None. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void OptclObj::ContainerWantsToDie () +{ + if (!m_destroypending) + g_objmap.Delete(this); +} + + diff --git a/src/OptclObj.h b/src/OptclObj.h new file mode 100644 index 0000000..5d296f0 --- /dev/null +++ b/src/OptclObj.h @@ -0,0 +1,142 @@ +/* + *------------------------------------------------------------------------------ + * optclobj.cpp + * Declares the functionality for the internal representation of + * an optcl object. + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ + +#if !defined(AFX_OPTCLOBJ_H__8A11BC04_616B_11D4_8004_0040055861F2__INCLUDED_) +#define AFX_OPTCLOBJ_H__8A11BC04_616B_11D4_8004_0040055861F2__INCLUDED_ + +#if _MSC_VER > 1000 +#pragma once +#endif // _MSC_VER > 1000 + +// forward declarations of used classes +#include "container.h" +#include + +class ObjMap; +class EventBindings; +class OptclBindPtr; +class DispParams; + +typedef THash EventBindingsTbl; + + +class OptclObj { +friend ObjMap; +friend CContainer; + + +public: + OptclObj (); + virtual ~OptclObj (); + + bool Create (Tcl_Interp *pInterp, const char *strid, const char *windowpath, bool start); + bool Attach (Tcl_Interp *pInterp, LPUNKNOWN punk); + + operator LPUNKNOWN(); + operator const char * (); + + void CoClassName (TObjPtr &pObj); + void InterfaceName (TObjPtr &pObj); + void SetInterfaceName (TObjPtr &pObj); + + bool InvokeCmd (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST objv[]); + + bool OptclObj::ResolvePropertyObject (Tcl_Interp *pInterp, const char *sname, + IDispatch **ppdisp, ITypeInfo **ppinfo, ITypeComp **ppcmp); + + bool GetBinding (Tcl_Interp *pInterp, char *name); + bool SetBinding (Tcl_Interp *pInterp, char *name, Tcl_Obj *command); + + bool GetState (Tcl_Interp *pInterp); + + + +protected: // methods + void CreateName (LPUNKNOWN punk); + void InitialiseUnknown (LPUNKNOWN punk); + void InitialiseClassInfo (LPUNKNOWN punk); + void InitialisePointers (LPUNKNOWN punk, ITypeLib *pLib = NULL, ITypeInfo *pinfo = NULL); + void CreateCommand(); + HRESULT InitialisePointersFromCoClass (); + HRESULT SetInterfaceFromType (ITypeInfo *pinfo); + HRESULT GetTypeAttr(); + void ReleaseTypeAttr(); + void ReleaseBindingTable(); + + + + bool BuildParamsWithBindPtr (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST objv[], + OptclBindPtr & bp, DispParams & dp); + bool RetrieveOutParams (Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST objv[], + OptclBindPtr & bp, DispParams & dp); + + bool InvokeNoTypeInfVariant (Tcl_Interp *pInterp, long ik, int objc, Tcl_Obj *CONST objv[], + IDispatch *pDisp, VARIANT &varResult); + bool InvokeNoTypeInf (Tcl_Interp *pInterp, long ik, int objc, Tcl_Obj *CONST objv[], + IDispatch *pDisp); + + bool InvokeWithTypeInfVariant (Tcl_Interp *pInterp, long invokekind, + int objc, Tcl_Obj *CONST objv[], + IDispatch *pDisp, ITypeInfo *pti, ITypeComp *pCmp, VARIANT &varResult); + bool InvokeWithTypeInf (Tcl_Interp *pInterp, long ik, int objc, Tcl_Obj *CONST objv[], + IDispatch *pDisp, ITypeInfo *pti, ITypeComp *pcmp); + + bool CheckInterface (Tcl_Interp *pInterp); + + bool SetProp (Tcl_Interp *pInterp, int paircount, Tcl_Obj * CONST namevalues[], + IDispatch *pdisp, ITypeInfo *pti, ITypeComp *ptc); + + bool GetProp (Tcl_Interp *pInterp, Tcl_Obj *name, IDispatch *pDisp, ITypeInfo *pti, ITypeComp *ptc); + bool GetIndexedVariant (Tcl_Interp *pInterp, Tcl_Obj *name, + IDispatch *pdisp, ITypeInfo *pti, ITypeComp *ptc, VARIANT &varResult); + + bool GetPropVariantDispatch (Tcl_Interp *pInterp, const char*name, + IDispatch * pcurrent, VARIANT &varResult); + + bool FindEventInterface (Tcl_Interp *pInterp, const char * lib, const char * type, + ITypeInfo **ppinfo, GUID * pguid); + + bool FindDefaultEventInterface (Tcl_Interp *pInterp, ITypeInfo **ppinfo, GUID *pguid); + + void ContainerWantsToDie (); +protected: // properties + CComQIPtr m_pcurrent; // Current interface + CComPtr m_punk; // the 'true' IUnknown; reference purposes only + CComPtr m_ptl; // the type library for this object + CComPtr m_pti; // the type interface for the current interface + CComPtr m_ptc; // the type info's compiler interface + CComPtr m_pti_class;// the type interface for the this coclass + TYPEATTR * m_pta; // the type attribute for the current typeinfo + + std::string m_name; + unsigned long m_refcount; // reference count of this optcl object + Tcl_Interp * m_pInterp; // interpreter that created this object + Tcl_Command m_cmdtoken; // command token of the tcl command within the above interpreter + EventBindingsTbl m_bindings; // bindings for event interfaces of this object + CContainer m_container;// container + bool m_destroypending; // true during a final delete operation +}; + + +#endif // !defined(AFX_OPTCLOBJ_H__8A11BC04_616B_11D4_8004_0040055861F2__INCLUDED_) diff --git a/src/OptclTypeAttr.cpp b/src/OptclTypeAttr.cpp new file mode 100644 index 0000000..452b04b --- /dev/null +++ b/src/OptclTypeAttr.cpp @@ -0,0 +1,84 @@ +/* + *------------------------------------------------------------------------------ + * optcltypeattr.cpp + * Implementation of the OptclTypeAttr class, a wrapper for the TYPEATTR + * pointer type. + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ + +#include "stdafx.h" +#include "tbase.h" +#include "optcl.h" +#include "utility.h" +#include "OptclTypeAttr.h" + +////////////////////////////////////////////////////////////////////// +// Construction/Destruction +////////////////////////////////////////////////////////////////////// + +OptclTypeAttr::OptclTypeAttr() : m_pattr(NULL) +{ + +} + +OptclTypeAttr::~OptclTypeAttr() +{ + ReleaseTypeAttr(); +} + + +HRESULT OptclTypeAttr::GetTypeAttr () +{ + HRESULT hr = S_OK; + // only get if we haven't already + if (m_pattr == NULL) { + ASSERT (m_pti != NULL); + hr = m_pti->GetTypeAttr (&m_pattr); + } + return hr; +} + + +void OptclTypeAttr::ReleaseTypeAttr () +{ + if (m_pattr != NULL) + { + ASSERT (m_pti != NULL); + m_pti->ReleaseTypeAttr(m_pattr);; + m_pattr = NULL; + } +} + + +OptclTypeAttr & OptclTypeAttr::operator= (ITypeInfo *pti) +{ + ReleaseTypeAttr(); + m_pti = pti; + if (m_pti != NULL) + GetTypeAttr(); + return *this; +} + + +TYPEATTR * OptclTypeAttr::operator -> () +{ + ASSERT (m_pattr != NULL); + return m_pattr; +} + diff --git a/src/OptclTypeAttr.h b/src/OptclTypeAttr.h new file mode 100644 index 0000000..5ed6917 --- /dev/null +++ b/src/OptclTypeAttr.h @@ -0,0 +1,47 @@ +/* + *------------------------------------------------------------------------------ + * optcltypeattr.h + * Definition of the OptclTypeAttr class, a wrapper for the TYPEATTR + * pointer type. + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ + +#if !defined(AFX_OPTCLTYPEATTR_H__5826EED2_5FA7_11D3_86E8_0000B482A708__INCLUDED_) +#define AFX_OPTCLTYPEATTR_H__5826EED2_5FA7_11D3_86E8_0000B482A708__INCLUDED_ + +#if _MSC_VER > 1000 +#pragma once +#endif // _MSC_VER > 1000 + +class OptclTypeAttr +{ +public: + CComPtr m_pti; + TYPEATTR * m_pattr; + +public: + OptclTypeAttr(); + virtual ~OptclTypeAttr(); + HRESULT GetTypeAttr (); + void ReleaseTypeAttr (); + OptclTypeAttr & operator= (ITypeInfo *pti); + TYPEATTR * operator -> (); +}; + +#endif // !defined(AFX_OPTCLTYPEATTR_H__5826EED2_5FA7_11D3_86E8_0000B482A708__INCLUDED_) diff --git a/src/StdAfx.cpp b/src/StdAfx.cpp new file mode 100644 index 0000000..4f7f50b --- /dev/null +++ b/src/StdAfx.cpp @@ -0,0 +1,27 @@ +/* + *------------------------------------------------------------------------------ + * stdafx.cpp + * source file that includes just the standard includes + * optcl.pch will be the pre-compiled header + * stdafx.obj will contain the pre-compiled type information + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ + + +#include "stdafx.h" diff --git a/src/StdAfx.h b/src/StdAfx.h new file mode 100644 index 0000000..93fcdcf --- /dev/null +++ b/src/StdAfx.h @@ -0,0 +1,56 @@ +/* + *------------------------------------------------------------------------------ + * stdafx.cpp + * include file for standard system include files, or project specific + * include files that are used frequently, but are changed infrequently + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ + + +// stdafx.h : include file for standard system include files, +// or project specific include files that are used frequently, but +// are changed infrequently +// + +#if !defined(AFX_STDAFX_H__1363E007_C12C_11D2_8003_0040055861F2__INCLUDED_) +#define AFX_STDAFX_H__1363E007_C12C_11D2_8003_0040055861F2__INCLUDED_ + +#if _MSC_VER > 1000 +#pragma once +#endif // _MSC_VER > 1000 + + +// Insert your headers here +//#define WIN32_LEAN_AND_MEAN // Exclude rarely-used stuff from Windows headers + +#include +extern CComModule _Module; +#include +#include +#include + +#include +#include +#include +#include + +//{{AFX_INSERT_LOCATION}} +// Microsoft Visual C++ will insert additional declarations immediately before the previous line. + +#endif // !defined(AFX_STDAFX_H__1363E007_C12C_11D2_8003_0040055861F2__INCLUDED_) diff --git a/src/conversion.txt b/src/conversion.txt new file mode 100644 index 0000000..5027cfd --- /dev/null +++ b/src/conversion.txt @@ -0,0 +1,51 @@ +Conversion + VT_EMPTY = 0, // 0 + VT_VOID = 24, // 0 + VT_NULL = 1, // 0 + + + VT_VARIANT = 12, // VARIANT * - decode by reference + + VT_ERROR = 10, // short + VT_I2 = 2, // short + VT_UI1 = 17, // short + + VT_I4 = 3, // long + VT_UI2 = 18, // long + VT_INT = 22, // long + + VT_R4 = 4, // float + VT_R8 = 5, // real + + VT_BOOL = 11, // boolean + + VT_UNKNOWN = 13, // object + VT_DISPATCH = 9, // object + + VT_I1 = 16, // char + + + *** VT_DECIMAL = 14, // can't - string? no + *** VT_CARRAY = 28, // ? + + + VT_CY = 6, // string + VT_DATE = 7, // string + VT_BSTR = 8, // string + + VT_UI4 = 19, // string + VT_I8 = 20, // string + VT_UI8 = 21, // string + VT_UINT = 23, // string + + VT_HRESULT = 25, // HRESULT2Str + VT_SAFEARRAY = 27, // tcl list + VT_USERDEFINED = 29, // type info require + VT_RECORD = 36, // tcl list? - creating might be a bit hard + VT_VECTOR = 0x1000, // tcl list? + VT_ARRAY = 0x2000, // tcl list + VT_BYREF = 0x4000, // pointer to value - eek + + +convert an object to a variant using type k +template f (VARIANT *p \ No newline at end of file diff --git a/src/initonce.cpp b/src/initonce.cpp new file mode 100644 index 0000000..f473480 --- /dev/null +++ b/src/initonce.cpp @@ -0,0 +1,26 @@ +/* + *------------------------------------------------------------------------------ + * initonce.cpp + * This file is used to correctly perform the one-time initialisation + * of standard GUIDs. + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ + +#include +#include diff --git a/src/optcl.cpp b/src/optcl.cpp new file mode 100644 index 0000000..d2fa2e1 --- /dev/null +++ b/src/optcl.cpp @@ -0,0 +1,671 @@ +/* + *------------------------------------------------------------------------------ + * optcl.cpp + * Tcl gateway functions are placed here. De/Initialisation + * of the object map occurs here, together with registration of many of + * optcl's commands. + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ + + +#include "stdafx.h" +#include "tbase.h" +#include "utility.h" +#include "optcl.h" +#include "resource.h" +#include "optclobj.h" +#include "objmap.h" +#include "dispparams.h" +#include "typelib.h" + +//---------------------------------------------------------------- +HINSTANCE ghDll = NULL; +CComModule _Module; +CComPtr g_pmalloc; + +//---------------------------------------------------------------- + +// Function declarations +void Optcl_Exit (ClientData); + + +TCL_CMDEF(OptclNewCmd); +TCL_CMDEF(OptclLockCmd); +TCL_CMDEF(OptclUnlockCmd); +TCL_CMDEF(OptclClassCmd); +TCL_CMDEF(OptclInterfaceCmd); +TCL_CMDEF(OptclBindCmd); +TCL_CMDEF(OptclIsObjectCmd); +TCL_CMDEF(OptclInvokeLibFunction); + + +//---------------------------------------------------------------- + +/* + *------------------------------------------------------------------------- + * DllMain -- + * Windows entry point - ensures that ATL's ax containement are + * initialised. + * + * Result: + * TRUE. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +BOOL WINAPI DllMain (HINSTANCE hinstDLL, DWORD fdwReason, LPVOID lpvReserved) +{ +#ifdef _DEBUG + int tmpFlag; +#endif // _DEBUG + + switch (fdwReason) + { + case DLL_PROCESS_ATTACH: + ghDll = hinstDLL; + _Module.Init (NULL, (HINSTANCE)hinstDLL); + AtlAxWinInit(); + + #ifdef _DEBUG + // memory leak detection - only in the debug build + tmpFlag = _CrtSetDbgFlag( _CRTDBG_REPORT_FLAG ); + tmpFlag |= _CRTDBG_LEAK_CHECK_DF; + _CrtSetDbgFlag( tmpFlag ); + #endif // _DEBUG + break; + case DLL_PROCESS_DETACH: + _Module.Term(); + break; + } + + return TRUE; +} + + +/* + *------------------------------------------------------------------------- + * Optcl_Exit -- + * Called by Tcl pending exit. Removes all optcl objects. Uninits OLE. + * Result: + * None. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void Optcl_Exit (ClientData) +{ + // remove all the elements of the table + g_objmap.DeleteAll (); + g_pmalloc.Release(); + OleUninitialize(); +} + + + +/* + *------------------------------------------------------------------------- + * OptclNewCmd -- + * Implements the optcl::new command. Format of this command currently is: + * ?-start? ?-window path? ProgIdOrClsidOrDocument + * For the time being, documents require the -window option to be used + * as this code relies on ATL containement to locate the document server. + * This constraint is not ensured by this code. + * This can easily be implemented for documents that are not to be contained. + * + * Result: + * Standard Tcl result. + * Side effects: + * Depends on parameters. + *------------------------------------------------------------------------- + */ +TCL_CMDEF(OptclNewCmd) +{ + OptclObj *pObj = NULL; + TObjPtr id; + Tcl_Obj ** old = (Tcl_Obj**)objv; + + char *path = NULL; + bool start = false; + static const char * err = "?-start? ?-window path? ProgIdOrClsidOrDocument"; + static const char * errcreate = "error in creating object"; + + if (objc < 2 || objc > 5) { + Tcl_WrongNumArgs (pInterp, 1, objv, (char*)err); + return TCL_ERROR; + } + + // do we have flags? + // process each one + while (objc >= 3) + { + TObjPtr element; + element.attach(objv[1]); + int len = strlen(element); + if (strncmp (element, "-start", len) == 0) { + start = true; + } + else if (strncmp (element, "-window", len) == 0) { + if (--objc <= 0) { + Tcl_SetResult (pInterp, "expected path after -window", TCL_STATIC); + return TCL_ERROR; + } + objv++; + element.attach(objv[1]); + path = (char*)element; + } + else { + Tcl_SetResult (pInterp, "unknown flag: ", TCL_STATIC); + Tcl_AppendResult (pInterp, (char*)element, NULL); + return TCL_ERROR; + } + if (--objc <= 0) { + Tcl_WrongNumArgs (pInterp, 1, old, (char*) err); + return TCL_ERROR; + } + objv++; + } + + id.attach (objv[1]); + + try { + // try creating the object + pObj = g_objmap.Create (pInterp, id, path, start); + if (pObj == NULL) + Tcl_SetResult (pInterp, (char*)errcreate, TCL_STATIC); + } + + catch (HRESULT hr) { + Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC); + } + + catch (char *err) { + Tcl_SetResult (pInterp, err, TCL_VOLATILE); + } + + catch (...) + { + Tcl_SetResult (pInterp, (char*)errcreate, TCL_STATIC); + } + + if (pObj != NULL) { + Tcl_SetResult (pInterp, (char*)(const char*)(*pObj), TCL_VOLATILE); + return TCL_OK; + } + else + return TCL_ERROR; +} + + + + + + +/* + *------------------------------------------------------------------------- + * OptclLockCmd -- + * Implements the optcl::lock command. + * Result: + * Standard Tcl result + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +TCL_CMDEF(OptclLockCmd) +{ + if (objc != 2) { + Tcl_WrongNumArgs (pInterp, 1, objv, "object"); + return TCL_ERROR; + } + TObjPtr name; + name.attach(objv[1]); + if (!g_objmap.Lock(name)) { + return ObjectNotFound(pInterp, name); + } + return TCL_OK; +} + + + + + +/* + *------------------------------------------------------------------------- + * OptclUnlockCmd -- + * Implements the optcl::unlock command. + * + * Result: + * Standard Tcl result. + * + * Side effects: + * If the reference count of the object hits zero, then the object will be + * deleted, together with its Tcl command and its container window, if it + * exists. + *------------------------------------------------------------------------- + */ +TCL_CMDEF(OptclUnlockCmd) +{ + if (objc < 2) { + Tcl_WrongNumArgs (pInterp, 1, objv, "object ..."); + return TCL_ERROR; + } + + TObjPtr name; + for (int i = 1; i < objc; i++) { + name.attach(objv[1]); + g_objmap.Unlock(name); + } + return TCL_OK; +} + + + +/* + *------------------------------------------------------------------------- + * OptclInvokeLibFunction -- + * Wild and useless attempt at calling ITypeInfo declared static DLL + * functions. Sigh! + * Result: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ +TCL_CMDEF(OptclInvokeLibFunction) +{ + USES_CONVERSION; + DispParams dp; + LPOLESTR olename; + TObjPtr name, + presult; + CComPtr pinfo; + CComPtr pti; + CComPtr pcmp; + HRESULT hr; + DESCKIND dk; dk = DESCKIND_NONE; + BINDPTR bp; bp.lpfuncdesc = NULL; + DISPID dispid; + EXCEPINFO ei; + UINT ea = 0; + VARIANT varResult; + bool bOk = false; + VOID * pFunc = NULL; + + if (objc < 3) { + Tcl_WrongNumArgs (pInterp, 1, objv, "typename function args..."); + return TCL_ERROR; + } + + try { + // attempt to resolve the type + name.attach(objv[1]); + TypeLib_ResolveName (name, NULL, &pinfo); + + hr = pinfo->GetTypeComp (&pcmp); + CHECKHR_TCL(hr, pInterp, TCL_ERROR); + + name.attach(objv[2]); + olename = A2OLE(name); + hr = pcmp->Bind (olename, LHashValOfName(LOCALE_SYSTEM_DEFAULT, olename), + INVOKE_FUNC, &pti, &dk, &bp); + + CHECKHR(hr); + if (dk != DESCKIND_FUNCDESC || bp.lpfuncdesc->funckind != FUNC_STATIC) { + Tcl_SetResult (pInterp, "static method not found: ", TCL_STATIC); + Tcl_AppendResult (pInterp, (char*)name, NULL); + } else { + ASSERT (bp.lpfuncdesc != NULL); + dispid = bp.lpfuncdesc->memid; + hr = pinfo->AddressOfMember (dispid, INVOKE_FUNC, &pFunc); + CHECKHR_TCL(hr, pInterp, TCL_ERROR); + int params = objc - 3; + + // check for the last parameter being the return value and take + // this into account when checking parameter counts + int reqparams = bp.lpfuncdesc->cParams; + if (reqparams > 0 && bp.lpfuncdesc->lprgelemdescParam[reqparams - 1].paramdesc.wParamFlags & PARAMFLAG_FRETVAL) + --reqparams; + + + if (params <= reqparams && + params >= (reqparams -bp.lpfuncdesc->cParamsOpt)) + { + VariantInit (&varResult); + + // set up the dispatch arguments - must be in reverse order + dp.Args (params); + for (int i = params-1; i >= 0; i--) + { + bool con_ok; + LPVARIANT pv; + + name.attach(objv[i+3]); + // are we dealing with referenced parameter? + if (bp.lpfuncdesc->lprgelemdescParam[i].tdesc.vt == VT_PTR) { + ASSERT (bp.lpfuncdesc->lprgelemdescParam[i].tdesc.lptdesc != NULL); + + // allocate a variant to store the *value* + pv = new VARIANT; + VariantInit (pv); + con_ok = obj2var_ti(pInterp, name, *pv, pti, &(bp.lpfuncdesc->lprgelemdescParam[i].tdesc)); + // we'll now set it as a reference for the dispatch parameters array + // on destruction, the array will take care of clearing the variant + dp.Set(params - i - 1, pv); + } + + else + con_ok = obj2var_ti(pInterp, name, dp[params - i - 1], pti, &(bp.lpfuncdesc->lprgelemdescParam[i].tdesc)); + + + if (!con_ok) + { + ReleaseBindPtr (pti, dk, bp); + return false; // error in type conversion + } + } + hr = pinfo->Invoke (pFunc, dispid, DISPATCH_METHOD, &dp, &varResult, &ei, &ea); + //hr = pDisp->Invoke(dispid, IID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_METHOD, + // &dp, &varResult, &ei, &ea); + + if (hr == DISP_E_EXCEPTION) + Tcl_SetResult (pInterp, ExceptInfo2Str (&ei), TCL_DYNAMIC); + else if (hr == DISP_E_TYPEMISMATCH) { + TDString td("type mismatch in parameter #"); + td << (long)(ea); + Tcl_SetResult (pInterp, td, TCL_VOLATILE); + } + else + CHECKHR_TCL(hr, pInterp, TCL_ERROR); + if (FAILED(hr)) + return TCL_ERROR; + if (bOk = var2obj(pInterp, varResult, presult)) + Tcl_SetObjResult (pInterp, presult); + VariantClear(&varResult); + } + else + { + Tcl_SetResult (pInterp, "wrong # args", TCL_STATIC); + } + } + } + + catch (HRESULT hr) { + Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC); + } + return bOk?TCL_OK:TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * OptclClassCmd -- + * Implements the optcl::class command. + * + * Result: + * Standard Tcl result + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +TCL_CMDEF(OptclClassCmd) +{ + if (objc != 2) { + Tcl_WrongNumArgs (pInterp, 1, objv, "object"); + return TCL_ERROR; + } + OptclObj *pObj = NULL; + TObjPtr name; + TObjPtr classname; + + name.attach (objv[1]); + pObj = g_objmap.Find (name); + if (pObj == NULL) + return ObjectNotFound (pInterp, name); + try { + pObj->CoClassName(classname); + } + + catch (HRESULT hr) { + Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC); + return TCL_ERROR; + } + Tcl_SetObjResult (pInterp, classname); + return TCL_OK; +} + + + + +/* + *------------------------------------------------------------------------- + * OptclInterfaceCmd -- + * Implements the optcl::interface command. Will either retrieve the + * current active interface or set it: + * optcl::interface objid ?newinterface? + * + * The new interface must be a proper typename. i.e. lib.type + * Result: + * Standard Tcl result. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +TCL_CMDEF(OptclInterfaceCmd) +{ + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs (pInterp, 1, objv, "object ?interface?"); + return TCL_ERROR; + } + + OptclObj *pObj = NULL; + TObjPtr name; + TObjPtr intfname; + + name.attach (objv[1]); + pObj = g_objmap.Find (name); + if (pObj == NULL) + return ObjectNotFound (pInterp, name); + try { + if (objc == 2) // get the current interface name + pObj->InterfaceName(intfname); + else // we are setting the interface + { + intfname.attach(objv[2]); + pObj->SetInterfaceName(intfname); + } + } + + catch (HRESULT hr) { + Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC); + return TCL_ERROR; + } + catch (char *error) { + Tcl_SetResult (pInterp, error, TCL_VOLATILE); + return TCL_ERROR; + } + + Tcl_SetObjResult (pInterp, intfname); + return TCL_OK; +} + + + + +/* + *------------------------------------------------------------------------- + * OptclBindCmd -- + * Implements the optcl::bind command. This enables the setting, unsetting + * and retrieving of a binding to an objects event, either on its default + * interface (in which case the interface type is not required) or on + * a non-default event interface. e.g. + * optcl::bind $obj NewDoc OnNewDocTclhandler + * optcl::bind $obj NewDoc ==> OnNewDocTclhandler + * optcl::bind $obj ICustomInterface.Foo FooHandler + * + * The tcl command is then called when the specified event is fired. + * The parameter list of the event is prepended with the identifier + * object that fired event. If a parameter of an event is an object, + * it's lifetime is only within the duration of the execution of the + * tcl handler. To allow for the object to persist after the handler has + * completed, the tcl script must call optcl::lock on the object. + * + * Result: + * Standard Tcl result. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +TCL_CMDEF(OptclBindCmd) +{ + if (objc != 3 && objc != 4) + { + Tcl_WrongNumArgs (pInterp, 1, objv, "object event_name ?tcl_command?"); + return TCL_ERROR; + } + + OptclObj *pObj = NULL; + TObjPtr name; + TObjPtr value; + bool bOk = false; + + name.attach (objv[1]); + pObj = g_objmap.Find (name); + if (pObj == NULL) + return ObjectNotFound (pInterp, name); + + name.attach(objv[2]); // the event name + if (objc == 3) // get the current binding (if any) for an event + bOk = pObj->GetBinding (pInterp, name); + else // we are setting the interface + { + value.attach(objv[3]); + if (bOk = pObj->SetBinding(pInterp, name, value)) + Tcl_SetObjResult (pInterp, value); + } + return (bOk?TCL_OK:TCL_ERROR); +} + + + +/* + *------------------------------------------------------------------------- + * OptclIsObjectCmd -- + * Returns a boolean in the interpreter - true iff the only parameter + * for this command is an object. + * + * Result: + * TCL_OK always for the correct number of parameters. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +TCL_CMDEF(OptclIsObjectCmd) +{ + if (objc != 2) { + Tcl_WrongNumArgs (pInterp, 1, objv, "object"); + return TCL_ERROR; + } + TObjPtr name(objv[1], false); + TObjPtr found(false, false); + if (g_objmap.Find (name)) + { + found = true; + } + Tcl_SetObjResult (pInterp, found); + return TCL_OK; +} + + +/* + *------------------------------------------------------------------------- + * Optcl_Init -- + * Tcl's first entry point. Initialises ole, sets up the exit handler, + * invokes the startup script (stored in a windows resource) and setsup + * the optcl namespace. Finally, it initialises the type library system. + * + * Result: + * Standard Tcl result. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +int Optcl_Init (Tcl_Interp *pInterp) +{ + Tcl_CmdInfo *pinfo = NULL; + +#ifdef USE_TCL_STUBS +#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION >= 1) + // initialise the Tcl stubs - failure is very bad + if (Tcl_InitStubs (pInterp, "8.0", 0) == NULL) + return TCL_ERROR; + + // if Tk is loaded then initialise the Tk stubs + if (Tcl_Eval (pInterp, "package present Tk") != TCL_ERROR) { + // initialise the Tk stubs - failure + if (Tk_InitStubs (pInterp, "8.0", 0) == NULL) + return TCL_ERROR; + } +#else +#error Wrong Tcl version for Stubs +#endif // (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION >= 1) +#endif // USE_TCL_STUBS + + HRESULT hr; + OleInitialize(NULL); + hr = CoGetMalloc(1, &g_pmalloc); + CHECKHR_TCL(hr, pInterp, TCL_ERROR); + + Tcl_CreateExitHandler (Optcl_Exit, NULL); + HRSRC hrsrc = FindResource (ghDll, MAKEINTRESOURCE(IDR_TYPELIB), _T("TCL_SCRIPT")); + if (hrsrc == NULL) { + Tcl_SetResult (pInterp, "failed to locate internal script", TCL_STATIC); + return TCL_ERROR; + } + HGLOBAL hscript = LoadResource (ghDll, hrsrc); + if (hscript == NULL) { + Tcl_SetResult (pInterp, "failed to load internal script", TCL_STATIC); + return TCL_ERROR; + } + + ASSERT (hscript != NULL); + char *szscript = (char*)LockResource (hscript); + + ASSERT (szscript != NULL); + if (Tcl_GlobalEval (pInterp, szscript) == TCL_ERROR) + return TCL_ERROR; + + Tcl_CreateObjCommand (pInterp, "optcl::new", OptclNewCmd, NULL, NULL); + Tcl_CreateObjCommand (pInterp, "optcl::lock", OptclLockCmd, NULL, NULL); + Tcl_CreateObjCommand (pInterp, "optcl::unlock", OptclUnlockCmd, NULL, NULL); + Tcl_CreateObjCommand (pInterp, "optcl::class", OptclClassCmd, NULL, NULL); + Tcl_CreateObjCommand (pInterp, "optcl::interface", OptclInterfaceCmd, NULL, NULL); + Tcl_CreateObjCommand (pInterp, "optcl::bind", OptclBindCmd, NULL, NULL); + Tcl_CreateObjCommand (pInterp, "optcl::module", OptclInvokeLibFunction, NULL, NULL); + Tcl_CreateObjCommand (pInterp, "optcl::isobject", OptclIsObjectCmd, NULL, NULL); + + + /// TESTS /// + Tcl_CreateObjCommand (pInterp, "optcl::vartest", Obj2VarTest, NULL, NULL); + + return TypeLib_Init(pInterp); +} + diff --git a/src/optcl.dsp b/src/optcl.dsp new file mode 100644 index 0000000..c4407bd --- /dev/null +++ b/src/optcl.dsp @@ -0,0 +1,414 @@ +# Microsoft Developer Studio Project File - Name="optcl" - Package Owner=<4> +# Microsoft Developer Studio Generated Build File, Format Version 6.00 +# ** DO NOT EDIT ** + +# TARGTYPE "Win32 (x86) Dynamic-Link Library" 0x0102 + +CFG=optcl - Win32 Debug_NoStubs +!MESSAGE This is not a valid makefile. To build this project using NMAKE, +!MESSAGE use the Export Makefile command and run +!MESSAGE +!MESSAGE NMAKE /f "optcl.mak". +!MESSAGE +!MESSAGE You can specify a configuration when running NMAKE +!MESSAGE by defining the macro CFG on the command line. For example: +!MESSAGE +!MESSAGE NMAKE /f "optcl.mak" CFG="optcl - Win32 Debug_NoStubs" +!MESSAGE +!MESSAGE Possible choices for configuration are: +!MESSAGE +!MESSAGE "optcl - Win32 Release" (based on "Win32 (x86) Dynamic-Link Library") +!MESSAGE "optcl - Win32 Debug" (based on "Win32 (x86) Dynamic-Link Library") +!MESSAGE "optcl - Win32 Release_NoStubs" (based on "Win32 (x86) Dynamic-Link Library") +!MESSAGE "optcl - Win32 Debug_NoStubs" (based on "Win32 (x86) Dynamic-Link Library") +!MESSAGE + +# Begin Project +# PROP AllowPerConfigDependencies 0 +# PROP Scc_ProjName "" +# PROP Scc_LocalPath "" +CPP=cl.exe +MTL=midl.exe +RSC=rc.exe + +!IF "$(CFG)" == "optcl - Win32 Release" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 0 +# PROP BASE Output_Dir "Release" +# PROP BASE Intermediate_Dir "Release" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 0 +# PROP Output_Dir "Release" +# PROP Intermediate_Dir "Release" +# PROP Ignore_Export_Lib 0 +# PROP Target_Dir "" +# ADD BASE CPP /nologo /MT /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "OPTCL_EXPORTS" /YX /FD /c +# ADD CPP /nologo /MT /W3 /GX /O2 /Ob2 /I "c:\progra~1\tcl\include" /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "OPTCL_EXPORTS" /D "USE_TCL_STUBS" /D "USE_TK_STUBS" /FR /Yu"stdafx.h" /FD /c +# ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32 +# ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32 +# ADD BASE RSC /l 0x809 /d "NDEBUG" +# ADD RSC /l 0x809 /d "NDEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /machine:I386 +# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib tclstub82.lib tkstub82.lib /nologo /dll /machine:I386 /out:"../install/optclstubs.dll" /libpath:"c:\progra~1\tcl\lib" + +!ELSEIF "$(CFG)" == "optcl - Win32 Debug" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 1 +# PROP BASE Output_Dir "optcl___Win32_Debug" +# PROP BASE Intermediate_Dir "optcl___Win32_Debug" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 1 +# PROP Output_Dir "Debug" +# PROP Intermediate_Dir "Debug" +# PROP Ignore_Export_Lib 0 +# PROP Target_Dir "" +# ADD BASE CPP /nologo /MTd /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "OPTCL_EXPORTS" /YX /FD /GZ /c +# ADD CPP /nologo /MTd /W3 /Gm /Gi /GX /ZI /Od /I "c:\progra~1\tcl\include" /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "OPTCL_EXPORTS" /D "USE_TCL_STUBS" /D "USE_TK_STUBS" /FR /Yu"stdafx.h" /FD /GZ /c +# ADD BASE MTL /nologo /D "_DEBUG" /mktyplib203 /win32 +# ADD MTL /nologo /D "_DEBUG" /mktyplib203 /win32 +# ADD BASE RSC /l 0x809 /d "_DEBUG" +# ADD RSC /l 0x809 /d "_DEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /pdbtype:sept +# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib tclstub84.lib tkstub84.lib /nologo /dll /debug /machine:I386 /out:"../install/optclstubs.dll" /pdbtype:sept /libpath:"c:\progra~1\tcl\lib" + +!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 0 +# PROP BASE Output_Dir "optcl___Win32_Release_NoStubs" +# PROP BASE Intermediate_Dir "optcl___Win32_Release_NoStubs" +# PROP BASE Ignore_Export_Lib 0 +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 0 +# PROP Output_Dir "Release_NoStubs" +# PROP Intermediate_Dir "Release_NoStubs" +# PROP Ignore_Export_Lib 0 +# PROP Target_Dir "" +# ADD BASE CPP /nologo /MT /W3 /GX /O2 /Ob2 /I "c:\progra~1\tcl\include" /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "OPTCL_EXPORTS" /D "USE_TCL_STUBS" /D "USE_TK_STUBS" /FR /Yu"stdafx.h" /FD /c +# ADD CPP /nologo /MT /W3 /GX /O2 /Ob2 /I "c:\progra~1\tcl\include" /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "OPTCL_EXPORTS" /FR /Yu"stdafx.h" /FD /c +# ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32 +# ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32 +# ADD BASE RSC /l 0x809 /d "NDEBUG" +# ADD RSC /l 0x809 /d "NDEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib tclstub82.lib tkstub82.lib /nologo /dll /machine:I386 /libpath:"c:\progra~1\tcl\lib" +# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib tcl80.lib tk80.lib /nologo /dll /machine:I386 /out:"../install/optcl80.dll" /libpath:"c:\progra~1\tcl\lib" + +!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 1 +# PROP BASE Output_Dir "optcl___Win32_Debug_NoStubs" +# PROP BASE Intermediate_Dir "optcl___Win32_Debug_NoStubs" +# PROP BASE Ignore_Export_Lib 0 +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 1 +# PROP Output_Dir "Debug_NoStubs" +# PROP Intermediate_Dir "Debug_NoStubs" +# PROP Ignore_Export_Lib 0 +# PROP Target_Dir "" +# ADD BASE CPP /nologo /MTd /W3 /Gm /Gi /GX /ZI /Od /I "c:\progra~1\tcl\include" /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "OPTCL_EXPORTS" /D "USE_TCL_STUBS" /D "USE_TK_STUBS" /FR /Yu"stdafx.h" /FD /GZ /c +# ADD CPP /nologo /MTd /W3 /Gm /Gi /GX /ZI /Od /I "c:\progra~1\tcl\include" /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "OPTCL_EXPORTS" /FR /Yu"stdafx.h" /FD /GZ /c +# ADD BASE MTL /nologo /D "_DEBUG" /mktyplib203 /win32 +# ADD MTL /nologo /D "_DEBUG" /mktyplib203 /win32 +# ADD BASE RSC /l 0x809 /d "_DEBUG" +# ADD RSC /l 0x809 /d "_DEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib tclstub82.lib tkstub82.lib /nologo /dll /debug /machine:I386 /pdbtype:sept /libpath:"c:\progra~1\tcl\lib" +# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib tcl80.lib tk80.lib /nologo /dll /debug /machine:I386 /out:"../install/optcl80.dll" /pdbtype:sept /libpath:"c:\progra~1\tcl\lib" + +!ENDIF + +# Begin Target + +# Name "optcl - Win32 Release" +# Name "optcl - Win32 Debug" +# Name "optcl - Win32 Release_NoStubs" +# Name "optcl - Win32 Debug_NoStubs" +# Begin Group "Source" + +# PROP Default_Filter "cpp" +# Begin Source File + +SOURCE=.\Container.cpp + +!IF "$(CFG)" == "optcl - Win32 Release" + +# ADD CPP /Yu"StdAfx.h" + +!ELSEIF "$(CFG)" == "optcl - Win32 Debug" + +!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs" + +# ADD BASE CPP /Yu"StdAfx.h" +# ADD CPP /Yu"StdAfx.h" + +!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs" + +!ENDIF + +# End Source File +# Begin Source File + +SOURCE=.\DispParams.cpp + +!IF "$(CFG)" == "optcl - Win32 Release" + +# ADD CPP /Yu"stdafx.h" + +!ELSEIF "$(CFG)" == "optcl - Win32 Debug" + +# ADD CPP /Yu"StdAfx.h" + +!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs" + +# ADD BASE CPP /Yu"stdafx.h" +# ADD CPP /Yu"stdafx.h" + +!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs" + +# ADD BASE CPP /Yu"StdAfx.h" +# ADD CPP /Yu"StdAfx.h" + +!ENDIF + +# End Source File +# Begin Source File + +SOURCE=.\EventBinding.cpp + +!IF "$(CFG)" == "optcl - Win32 Release" + +# ADD CPP /Yu"stdafx.h" + +!ELSEIF "$(CFG)" == "optcl - Win32 Debug" + +!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs" + +# ADD BASE CPP /Yu"stdafx.h" +# ADD CPP /Yu"stdafx.h" + +!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs" + +!ENDIF + +# End Source File +# Begin Source File + +SOURCE=.\initonce.cpp +# SUBTRACT CPP /YX /Yc /Yu +# End Source File +# Begin Source File + +SOURCE=.\ObjMap.cpp + +!IF "$(CFG)" == "optcl - Win32 Release" + +# ADD CPP /Yu"stdafx.h" + +!ELSEIF "$(CFG)" == "optcl - Win32 Debug" + +# ADD CPP /Yu"StdAfx.h" + +!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs" + +# ADD BASE CPP /Yu"stdafx.h" +# ADD CPP /Yu"stdafx.h" + +!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs" + +# ADD BASE CPP /Yu"StdAfx.h" +# ADD CPP /Yu"StdAfx.h" + +!ENDIF + +# End Source File +# Begin Source File + +SOURCE=.\optcl.cpp + +!IF "$(CFG)" == "optcl - Win32 Release" + +# ADD CPP /Yu"stdafx.h" + +!ELSEIF "$(CFG)" == "optcl - Win32 Debug" + +# ADD CPP /Yu"StdAfx.h" + +!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs" + +# ADD BASE CPP /Yu"stdafx.h" +# ADD CPP /Yu"stdafx.h" + +!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs" + +# ADD BASE CPP /Yu"StdAfx.h" +# ADD CPP /Yu"StdAfx.h" + +!ENDIF + +# End Source File +# Begin Source File + +SOURCE=.\OptclBindPtr.cpp +# End Source File +# Begin Source File + +SOURCE=.\OptclObj.cpp + +!IF "$(CFG)" == "optcl - Win32 Release" + +# ADD CPP /Yu"stdafx.h" + +!ELSEIF "$(CFG)" == "optcl - Win32 Debug" + +# ADD CPP /Yu"StdAfx.h" + +!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs" + +# ADD BASE CPP /Yu"stdafx.h" +# ADD CPP /Yu"stdafx.h" + +!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs" + +# ADD BASE CPP /Yu"StdAfx.h" +# ADD CPP /Yu"StdAfx.h" + +!ENDIF + +# End Source File +# Begin Source File + +SOURCE=.\OptclTypeAttr.cpp +# End Source File +# Begin Source File + +SOURCE=.\StdAfx.cpp +# ADD CPP /Yc"StdAfx.h" +# End Source File +# Begin Source File + +SOURCE=.\typelib.cpp +# ADD CPP /Yu"StdAfx.h" +# End Source File +# Begin Source File + +SOURCE=.\utility.cpp +# ADD CPP /Yu"StdAfx.h" +# End Source File +# End Group +# Begin Group "Header" + +# PROP Default_Filter "h" +# Begin Source File + +SOURCE=.\Container.h +# End Source File +# Begin Source File + +SOURCE=.\DispParams.h +# End Source File +# Begin Source File + +SOURCE=.\EventBinding.h +# End Source File +# Begin Source File + +SOURCE=.\ObjMap.h +# End Source File +# Begin Source File + +SOURCE=.\optcl.h +# End Source File +# Begin Source File + +SOURCE=.\OptclBindPtr.h +# End Source File +# Begin Source File + +SOURCE=.\OptclObj.h +# End Source File +# Begin Source File + +SOURCE=.\OptclTypeAttr.h +# End Source File +# Begin Source File + +SOURCE=.\resource.h +# End Source File +# Begin Source File + +SOURCE=.\StdAfx.h +# End Source File +# Begin Source File + +SOURCE=.\tbase.h +# End Source File +# Begin Source File + +SOURCE=.\typelib.h +# End Source File +# Begin Source File + +SOURCE=.\utility.h +# End Source File +# End Group +# Begin Group "Resource" + +# PROP Default_Filter "" +# Begin Source File + +SOURCE=.\resource.rc +# End Source File +# Begin Source File + +SOURCE=.\typelib.tcl +# End Source File +# End Group +# Begin Source File + +SOURCE=.\test.tcl + +!IF "$(CFG)" == "optcl - Win32 Release" + +# PROP Exclude_From_Build 1 + +!ELSEIF "$(CFG)" == "optcl - Win32 Debug" + +# PROP Exclude_From_Build 1 + +!ELSEIF "$(CFG)" == "optcl - Win32 Release_NoStubs" + +# PROP BASE Exclude_From_Build 1 +# PROP Exclude_From_Build 1 + +!ELSEIF "$(CFG)" == "optcl - Win32 Debug_NoStubs" + +# PROP BASE Exclude_From_Build 1 +# PROP Exclude_From_Build 1 + +!ENDIF + +# End Source File +# End Target +# End Project diff --git a/src/optcl.h b/src/optcl.h new file mode 100644 index 0000000..7e21c66 --- /dev/null +++ b/src/optcl.h @@ -0,0 +1,45 @@ +/* + *------------------------------------------------------------------------------ + * optcl.cpp + * Declares the OpTcl's main entry points. + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ + +#ifndef _OPTCL_H_B229D2A0_616A_11d4_8004_0040055861F2 +#define _OPTCL_H_B229D2A0_616A_11d4_8004_0040055861F2 + + + +// debugging symbols +#ifdef _DEBUG +#define _ATL_DEBUG_INTERFACES +#define _ATL_DEBUG_REFCOUNT +#define _ATL_DEBUG_QI +#endif + + + +extern "C" DLLEXPORT int Optcl_Init (Tcl_Interp *pInterp); +extern "C" DLLEXPORT BOOL WINAPI DllMain (HINSTANCE hinstDLL, DWORD fdwReason, LPVOID lpvReserved); +int TypeLib_Init (Tcl_Interp *pInterp); + + +extern CComPtr g_pmalloc; + +#endif// _OPTCL_H_B229D2A0_616A_11d4_8004_0040055861F2 \ No newline at end of file diff --git a/src/resource.aps b/src/resource.aps new file mode 100644 index 0000000..28c86bb Binary files /dev/null and b/src/resource.aps differ diff --git a/src/resource.h b/src/resource.h new file mode 100644 index 0000000..d253af9 --- /dev/null +++ b/src/resource.h @@ -0,0 +1,17 @@ +//{{NO_DEPENDENCIES}} +// Microsoft Developer Studio generated include file. +// Used by resource.rc +// +#define IDR_TCL_SCRIPT1 101 +#define IDR_TYPELIB 101 + +// Next default values for new objects +// +#ifdef APSTUDIO_INVOKED +#ifndef APSTUDIO_READONLY_SYMBOLS +#define _APS_NEXT_RESOURCE_VALUE 103 +#define _APS_NEXT_COMMAND_VALUE 40001 +#define _APS_NEXT_CONTROL_VALUE 1000 +#define _APS_NEXT_SYMED_VALUE 101 +#endif +#endif diff --git a/src/resource.rc b/src/resource.rc new file mode 100644 index 0000000..52e366d --- /dev/null +++ b/src/resource.rc @@ -0,0 +1,116 @@ +//Microsoft Developer Studio generated resource script. +// +#include "resource.h" + +#define APSTUDIO_READONLY_SYMBOLS +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 2 resource. +// +#include "afxres.h" + +///////////////////////////////////////////////////////////////////////////// +#undef APSTUDIO_READONLY_SYMBOLS + +///////////////////////////////////////////////////////////////////////////// +// English (U.K.) resources + +#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_ENG) +#ifdef _WIN32 +LANGUAGE LANG_ENGLISH, SUBLANG_ENGLISH_UK +#pragma code_page(1252) +#endif //_WIN32 + +///////////////////////////////////////////////////////////////////////////// +// +// TCL_SCRIPT +// + +IDR_TYPELIB TCL_SCRIPT DISCARDABLE "typelib.tcl" + +#ifdef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// TEXTINCLUDE +// + +1 TEXTINCLUDE DISCARDABLE +BEGIN + "resource.h\0" +END + +2 TEXTINCLUDE DISCARDABLE +BEGIN + "#include ""afxres.h""\r\n" + "\0" +END + +3 TEXTINCLUDE DISCARDABLE +BEGIN + "\r\n" + "\0" +END + +#endif // APSTUDIO_INVOKED + + +#ifndef _MAC +///////////////////////////////////////////////////////////////////////////// +// +// Version +// + +VS_VERSION_INFO VERSIONINFO + FILEVERSION 1,0,0,1 + PRODUCTVERSION 1,0,0,1 + FILEFLAGSMASK 0x3fL +#ifdef _DEBUG + FILEFLAGS 0x29L +#else + FILEFLAGS 0x28L +#endif + FILEOS 0x40004L + FILETYPE 0x2L + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "080904b0" + BEGIN + VALUE "Comments", "Requires Tcl/Tk major version 8, minor version >= 1\0" + VALUE "CompanyName", "University of East Anglia\0" + VALUE "FileDescription", "A Tcl extension for manipulating COM objects.\0" + VALUE "FileVersion", "3,0,0,2\0" + VALUE "InternalName", "optcl\0" + VALUE "LegalCopyright", "Copyright © 1999\0" + VALUE "LegalTrademarks", "-\0" + VALUE "OriginalFilename", "optcl.dll\0" + VALUE "PrivateBuild", "-\0" + VALUE "ProductName", "OpTcl\0" + VALUE "ProductVersion", "3,0,0,2\0" + VALUE "SpecialBuild", "-\0" + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x809, 1200 + END +END + +#endif // !_MAC + +#endif // English (U.K.) resources +///////////////////////////////////////////////////////////////////////////// + + + +#ifndef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 3 resource. +// + + +///////////////////////////////////////////////////////////////////////////// +#endif // not APSTUDIO_INVOKED + diff --git a/src/tbase.h b/src/tbase.h new file mode 100644 index 0000000..8dba129 --- /dev/null +++ b/src/tbase.h @@ -0,0 +1,837 @@ +/* + *------------------------------------------------------------------------------ + * tbase.h + * C++ Wrapper classes for common Tcl types. + * + * Updated: 1999.03.08 - Removed a few bugs from TObjPtr + * Updated: 1999.07.11 - Added isnull and isnotnull to TObjPtr + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ + + +#ifndef _3CC705E0_BA28_11d2_8003_0040055861F2_ +#define _3CC705E0_BA28_11d2_8003_0040055861F2_ + + +#include +#include +#include + + +#ifndef ASSERT +# ifdef _DEBUG +# include +# define ASSERT(x) _ASSERTE(x) +# else +# define ASSERT(x) +# endif +#endif + + + + +class TObjPtr +{ +protected: + Tcl_Obj *m_po; + bool m_ba; +public: + TObjPtr() : m_po(NULL), m_ba(true) + { + } + + TObjPtr (int i, Tcl_Obj *const objs[], bool bauto = true) : m_po (NULL), m_ba(bauto) + { + ASSERT (i >= 0 && (i == 0 || objs!=NULL)); + m_po = Tcl_NewListObj (i, objs); + if (m_ba) + incr(); + } + + TObjPtr(Tcl_Obj *ptr, bool bauto =true) : m_po(ptr), m_ba(bauto) + { + if (m_ba) + incr(); + } + + TObjPtr(const TObjPtr &src, bool bauto=false) : m_po(NULL), m_ba(bauto) + { + copy (src, bauto); + } + + TObjPtr(const char *string, bool bauto=true) : m_po(NULL), m_ba(bauto) + { + m_po = Tcl_NewStringObj ((char*)string, -1); + if (m_po==NULL) + throw ("failed to create string object"); + if (m_ba) + incr(); + } + + TObjPtr(const long l, bool bauto=true) : m_po(NULL), m_ba(bauto) + { + m_po = Tcl_NewLongObj (l); + if (m_po==NULL) + throw ("failed to create long tcl object"); + if (m_ba) + incr(); + } + + + TObjPtr(const int i, bool bauto=true) : m_po(NULL), m_ba(bauto) + { + m_po = Tcl_NewIntObj (i); + if (m_po==NULL) + throw ("failed to create int tcl object"); + if (m_ba) + incr(); + } + + TObjPtr(const bool b, bool bauto=true) : m_po(NULL), m_ba(bauto) + { + m_po = Tcl_NewBooleanObj (b); + if (m_po==NULL) + throw ("failed to create long tcl object"); + if (m_ba) + incr(); + } + + TObjPtr(const double d, bool bauto=true) : m_po(NULL), m_ba(bauto) + { + m_po = Tcl_NewDoubleObj (d); + if (m_po==NULL) + throw ("failed to create double object"); + if (m_ba) + incr(); + } + + + virtual ~TObjPtr() + { + if (m_ba!=NULL && m_po != NULL) { + if (m_po->refCount == 0) + incr(); + decr(); + } + m_po = NULL; + } + + Tcl_Obj* create (bool bauto=true) + { + if (m_ba!=NULL && m_po != NULL) { + if (m_po->refCount == 0) + incr(); + decr(); + } + m_ba = bauto; + m_po = Tcl_NewObj (); + if (m_ba) + incr(); + return m_po; + } + + + void incr() + { + if (m_po) + Tcl_IncrRefCount(m_po); + } + + void decr() + { + if (m_po) + Tcl_DecrRefCount(m_po); + } + + bool isnull () + { + return (m_po == NULL); + } + + bool isnotnull() + { + return (m_po != NULL); + } + + void attach (Tcl_Obj *ptr, bool bauto=false) + { + if (m_ba) + decr(); + m_po = ptr; + m_ba = bauto; + } + + Tcl_Obj *detach () + { + Tcl_Obj *p = m_po; + m_po = NULL; + return p; + } + + void copy (const Tcl_Obj *src, bool bauto = true) + { + ASSERT (src!=NULL); + if (m_ba) + decr(); + + m_po = Tcl_DuplicateObj((Tcl_Obj*)src); + ASSERT (m_po); + m_ba = bauto; + if (m_ba) + incr(); + } + + int llength (Tcl_Interp *pInterp = NULL) + { + ASSERT (m_po!=NULL); + int length; + if (TCL_OK != Tcl_ListObjLength (pInterp, m_po, &length)) { + if (pInterp != NULL) + throw (Tcl_GetStringResult (pInterp)); + else + throw ("failed to get length of list"); + } + return length; + } + + + TObjPtr lindex (int index, Tcl_Interp *pInterp = NULL) + { + ASSERT (m_po); + Tcl_Obj *pObj = NULL; + if (TCL_OK != Tcl_ListObjIndex (pInterp, m_po, index, &pObj)) { + if (pInterp != NULL) + throw (Tcl_GetStringResult (pInterp)); + else + throw ("failed to get list item"); + } + return TObjPtr(pObj, false); + } + + + TObjPtr& lappend (TObjPtr &pObj, Tcl_Interp *pInterp = NULL) + { + return lappend ((Tcl_Obj*)pObj, pInterp); + } + + TObjPtr& lappend (Tcl_Obj *pObj, Tcl_Interp *pInterp = NULL) + { + ASSERT (pObj!=NULL && m_po!=NULL); + if (TCL_OK != Tcl_ListObjAppendElement (pInterp, m_po, pObj)) { + if (pInterp != NULL) + throw (Tcl_GetStringResult (pInterp)); + else + throw ("failed to add element to list"); + } + return *this; + } + + TObjPtr& lappend(const char *string, Tcl_Interp *pInterp = NULL) + { + ASSERT (string!=NULL && m_po != NULL); + return lappend (TObjPtr(string), pInterp); + } + + TObjPtr& lappend(const int i, Tcl_Interp *pInterp = NULL) + { + ASSERT (m_po != NULL); + return lappend (TObjPtr(i), pInterp); + } + + TObjPtr& lappend(const long l, Tcl_Interp *pInterp = NULL) + { + ASSERT (m_po != NULL); + return lappend (TObjPtr (l), pInterp); + } + + TObjPtr& lappend(const double d, Tcl_Interp *pInterp = NULL) + { + ASSERT (m_po != NULL); + return lappend (TObjPtr (d), pInterp); + } + + TObjPtr& lappend(const bool b, Tcl_Interp *pInterp = NULL) + { + ASSERT (m_po != NULL); + return lappend (TObjPtr (b), pInterp); + } + + + operator int() + { + ASSERT (m_po != NULL); + int n; + if (TCL_OK != Tcl_GetIntFromObj (NULL, m_po, &n)) + // perform a cast + n = (int) double (*this); + return n; + } + + + operator long() + { + long n; + ASSERT (m_po != NULL); + if (TCL_OK != Tcl_GetLongFromObj (NULL, m_po, &n)) + // perform a cast + n = (long) double (*this); + return n; + } + + + operator bool() + { + int b; + ASSERT (m_po != NULL); + if (TCL_OK != Tcl_GetBooleanFromObj (NULL, m_po, &b)) + throw ("failed to convert object to bool"); + return (b!=0); + } + + operator double () + { + double d; + ASSERT (m_po != NULL); + if (TCL_OK != Tcl_GetDoubleFromObj (NULL, m_po, &d)) + throw ("failed to convert object to double"); + return d; + } + + operator char*() const + { + if (m_po == NULL) return NULL; + return Tcl_GetStringFromObj(m_po, NULL); + } + + operator Tcl_Obj*() const + { + return m_po; + } + + + TObjPtr &operator= (Tcl_Obj *ptr) + { + attach(ptr, true); // automatically sets reference management + if (m_po != NULL) + incr(); + return *this; + } + + TObjPtr &operator= (const char *string) + { + ASSERT(string!=NULL && m_po != NULL); + Tcl_SetStringObj (m_po, (char*)string, -1); + return *this; + } + + TObjPtr &operator= (const long l) + { + ASSERT (m_po != NULL); + Tcl_SetLongObj (m_po, l); + return *this; + } + + TObjPtr &operator= (const int i) + { + ASSERT (m_po != NULL); + Tcl_SetIntObj (m_po, i); + return *this; + } + + TObjPtr &operator= (const bool b) + { + ASSERT (m_po != NULL); + Tcl_SetBooleanObj (m_po, b?1:0); + return *this; + } + + TObjPtr &operator= (const double d) + { + ASSERT (m_po != NULL); + Tcl_SetDoubleObj (m_po, d); + return *this; + } + + + bool operator== (Tcl_Obj *ptr) + { + return (ptr == m_po); + } + + + TObjPtr &operator+= (const char *string) + { + ASSERT (string && m_po); + Tcl_AppendToObj(m_po, (char*)string, -1); + return *this; + } + + TObjPtr& operator+= (Tcl_Obj *pObj) + { + ASSERT (m_po != NULL); + return lappend (pObj); + } + + TObjPtr &operator+= (TObjPtr &pObj) + { + ASSERT (m_po != NULL); + return lappend (pObj); + } + + TObjPtr &operator+= (int i) + { + ASSERT (m_po != NULL); + (*this) = int(*this) + i; + return *this; + } + + TObjPtr &operator+= (long l) + { + ASSERT (m_po != NULL); + (*this) = long(*this) + l; + return *this; + } + + + TObjPtr &operator+= (double d) + { + ASSERT (m_po != NULL); + (*this) = double(*this) + d; + return *this; + } + + TObjPtr &operator-= (Tcl_Obj *pObj) + { + ASSERT (m_po != NULL && pObj != NULL); + Tcl_Obj ** objv; + int objc; + char *sObj = Tcl_GetStringFromObj (pObj, NULL), + *sTemp; + + if (sObj == NULL) + return *this; + + Tcl_ListObjGetElements (NULL, m_po, &objc, &objv); + for (int i = 0; i < objc; i++) + { + if (objv[i] != NULL) { + sTemp = Tcl_GetStringFromObj (objv[i], NULL); + if (sTemp != NULL && strcmp (sObj, sTemp) == 0) + Tcl_ListObjReplace ( NULL, m_po, i, 1, 0, NULL); + } + } + return *this; + } + + TObjPtr &operator-= (TObjPtr &obj) + { + return operator-=((Tcl_Obj*)obj); + } + + TObjPtr &operator-= (int i) + { + return operator=(int(*this) - i); + } + + TObjPtr &operator-= (long l) + { + return operator=(long(*this) - l); + } + + TObjPtr &operator-= (double d) + { + return operator=(double(*this) - d); + } + + TObjPtr &operator *= (double d) + { + return operator=(double(*this) * d); + } + + TObjPtr &operator *= (int i) + { + return operator=(int(*this) * i); + } + + TObjPtr &operator *= (long l) + { + return operator=(long(*this) * l); + } + + + TObjPtr &operator /= (double d) + { + return operator=(double(*this) / d); + } + + TObjPtr &operator /= (int i) + { + return operator=(int(*this) / i); + } + + TObjPtr &operator /= (long l) + { + return operator=(long(*this) / l); + } + + Tcl_Obj **operator &() + { + return &m_po; + } + + + Tcl_Obj *operator ->() const + { + return m_po; + } + + bool operator!= (Tcl_Obj *p) + { + return (m_po != p); + } + +}; + + + + + + + +template +class THashIterator +{ +protected: + Tcl_HashTable *m_pt; + Tcl_HashEntry *m_pe; + Tcl_HashSearch m_s; + +public: + THashIterator () : m_pt(NULL), + m_pe(NULL) + {} + + THashIterator (Tcl_HashTable *pTable) : + m_pt(pTable) + { + ASSERT (m_pt!=NULL); + m_pe = Tcl_FirstHashEntry (m_pt, &m_s); + } + + THashIterator (THashIterator &src) + { + *this = src; + } + + virtual ~THashIterator () + {} + + V operator * () + { + if (m_pe == NULL) + throw ("null hash iterator"); + return (V)Tcl_GetHashValue (m_pe); + } + + THashIterator &operator ++ () + { + if (m_pe != NULL) + m_pe = Tcl_NextHashEntry (&m_s); + return *this; + } + + + THashIterator &operator ++ (int) + { + if (m_pe != NULL) + m_pe = Tcl_NextHashEntry (&m_s); + return *this; + } + + operator Tcl_HashEntry* () + { + return m_pe; + } + + bool operator!= (Tcl_HashEntry *pEntry) + { + return m_pe != pEntry; + } + + bool operator== (Tcl_HashEntry *pEntry) + { + return m_pe == pEntry; + } + + K* key () { + ASSERT (m_pt != NULL); + if (m_pe == NULL) + throw ("null hash iterator"); + return (K*)Tcl_GetHashKey (m_pt, m_pe); + } + + THashIterator &operator = (THashIterator &i) + { + m_pt = i.m_pt; + m_pe = i.m_pe; + m_s = i.m_s; + return *this; + } +}; + + + + +template +class THash +{ +public: + typedef THashIterator iterator; +protected: + int m_keytype; + bool m_bCreated; + Tcl_HashTable m_tbl; +public: + THash (): + m_keytype(Size), + m_bCreated(false) + { + } + + ~THash () + { + deltbl(); + } + + + + iterator begin () + { + createtbl(); + iterator i(&m_tbl); + return i; + } + + iterator end () + { + createtbl(); + iterator i; + return i; + } + + + Tcl_HashEntry *find (const K *key, V *value = NULL) + { + Tcl_HashEntry *p = NULL; + createtbl(); + + p = Tcl_FindHashEntry (&m_tbl, (char*)key); + if (value != NULL && p!=NULL) + *value = (V)Tcl_GetHashValue (p); + return p; + } + + + bool delete_entry (const K *key) + { + Tcl_HashEntry *p = find (key); + if (p!=NULL) + Tcl_DeleteHashEntry (p); + return (p!=NULL); + } + + + Tcl_HashEntry * create_entry (const K *key, int *created = NULL) + { + ASSERT (key != NULL); + createtbl(); + + int c; + Tcl_HashEntry *p; + + if (created == NULL) + p = Tcl_CreateHashEntry (&m_tbl, (char*)key, &c); + else + p = Tcl_CreateHashEntry (&m_tbl, (char*)key, created); + return p; + } + + Tcl_HashEntry * set (const K *key, const V &value) + { + ASSERT (key != NULL); + createtbl(); + + Tcl_HashEntry *p = create_entry (key); + if (p!=NULL) + Tcl_SetHashValue (p, (ClientData)value); + return p; + } + + K *key (const Tcl_HashEntry *p) + { + ASSERT (p!=NULL); + if (!m_bCreated) return NULL; + return (K*)Tcl_GetHashKey (&m_tbl, p); + } + + operator Tcl_HashTable*() + { + return &m_tbl; + } + + void deltbl () + { + if (m_bCreated) { + Tcl_DeleteHashTable (&m_tbl); + m_bCreated = false; + } + } + + void createtbl () + { + if (!m_bCreated) { + Tcl_InitHashTable (&m_tbl, m_keytype); + m_bCreated = true; + } + } + +}; + + + +class TDString { +protected: + Tcl_DString ds; +public: + TDString () + { + Tcl_DStringInit(&ds); + } + + TDString (const char *init) + { + Tcl_DStringInit(&ds); + append(init); + } + + ~TDString () + { + Tcl_DStringFree(&ds); + } + + TDString& set (const char *string = "") + { + ASSERT (string != NULL); + Tcl_DStringFree (&ds); + Tcl_DStringInit(&ds); + append(string); + return *this; + } + + char *append (const char *string, int length = -1) + { + ASSERT (string != NULL); + return Tcl_DStringAppend (&ds, (char*)string, length); + } + + TDString& operator<< (const char *string) + { + ASSERT (string!=NULL); + append(string); + return *this; + } + + TDString& operator<< (const long val) + { + TObjPtr p(val); + append((char*)p); + return *this; + } + + TDString& operator<< (const int val) + { + TObjPtr p(val); + append((char*)p); + return *this; + } + + TDString& operator<< (const double fval) + { + TObjPtr d(fval); + append((char*)d); + return *this; + } + + operator const char*() + { + return value(); + } + + // type unsafe, as the string still belongs to this object + operator char*() + { + return (char*)(value()); + } + + TDString& operator= (TDString & src) + { + set (src.value()); + return *this; + } + + char *append_element(char *string) + { + ASSERT (string != NULL); + return Tcl_DStringAppendElement (&ds, (char*)string); + } + + void start_sublist () + { + Tcl_DStringStartSublist (&ds); + } + + void end_sublist () + { + Tcl_DStringEndSublist (&ds); + } + + int length () + { + return Tcl_DStringLength (&ds); + } + + const char *value () + { + return Tcl_DStringValue (&ds); + } + + void set_result (Tcl_Interp *pInterp) + { + Tcl_DStringResult (pInterp, &ds); + } + + void get_result (Tcl_Interp *pInterp) + { + Tcl_DStringGetResult (pInterp, &ds); + } +}; + + + +#endif // _3CC705E0_BA28_11d2_8003_0040055861F2_ diff --git a/src/test.tcl b/src/test.tcl new file mode 100644 index 0000000..86b8d60 --- /dev/null +++ b/src/test.tcl @@ -0,0 +1,100 @@ +console show +load optcl + + + +proc ie_test {} { + global ie + set ie [optcl::new -window .ie {{8856F961-340A-11D0-A96B-00C04FD705A2}}] + pack .ie + $ie navigate www.wired.com +} + +proc vrml_test {} { + global vrml + set vrml [optcl::new -window .vrml {{4B6E3013-6E45-11D0-9309-0020AFE05CC8}}] + pack .vrml +} + +proc tree_test {} { + global tv + set tv [optcl::new -window .tv {{C74190B6-8589-11D1-B16A-00C0F0283628}}] + pack .tv + set n1 [$tv -with nodes add] + $n1 : text "Node 1" key "1 Node" + optcl::unlock $n1 + set n2 [$tv -with nodes add "1 Node" 4 "2 Node" "Node 2"] + $n2 : text "Node 2.5" + optcl::unlock $n2 +} + +proc dp_test {} { + global dp + destroy .date + set dp [optcl::new -window .date MSComCtl2.DTPicker] + .date config -width 100 -height 20 + pack .date + tlview::viewtype [optcl::class $dp] +} + +proc cal_test {} { + global cal + destroy .cal + set cal [optcl::new -window .cal MSCAL.Calendar] + pack .cal +} + + +proc pb_test {} { + global pb mousedown + + proc PBMouseDown {obj args} { + global mousedown + set mousedown $obj + } + + proc PBMouseUp {args} { + global mousedown + set mousedown {} + } + + proc PBMouseMove {obj button shift x y} { + global mousedown + if {$mousedown == {}} return + if {[string compare $mousedown $obj]==0} { + $obj : value $x + } + } + destroy .pb + set pb [optcl::new -window .pb MSComctlLib.ProgCtrl] + pack .pb + .pb config -width 100 -height 10 + optcl::bind $pb MouseDown PBMouseDown + optcl::bind $pb MouseUp PBMouseUp + optcl::bind $pb MouseMove PBMouseMove +} + + + + +proc word_test {} { + global word + + set word [optcl::new word.application] + $word : visible 1 +} + + +proc tl_test {} { + typelib::load {Microsoft Shell Controls And Automation (Ver 1.0)} + tlview::refview .r + tlview::loadedlibs .l +} + + + +proc cosmo_test {} { + global co + set co [optcl::new -window .co SGI.CosmoPlayer.2] + pack .co +} diff --git a/src/typelib.cpp b/src/typelib.cpp new file mode 100644 index 0000000..4e2ec52 --- /dev/null +++ b/src/typelib.cpp @@ -0,0 +1,2008 @@ +/* + *------------------------------------------------------------------------------ + * typelib.cpp + * Implements access to typelibraries. Currently this only includes + * browsing facilities. In the future, this may contain typelib building + * functionality. + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ + + + +#include "stdafx.h" +#include "tbase.h" +#include "utility.h" +#include "optcl.h" +#include "typelib.h" +#include "objmap.h" +#include "optclbindptr.h" + + +//---------------------------------------------------------------- +// \/\/\/\/\/\ Declarations /\/\/\/\/\/\/ + + +void TypeLib_Exit (ClientData); +const char *TYPEKIND2Str (TYPEKIND tkind); +void FUNCDESC2Obj (ITypeInfo *pti, FUNCDESC *pfd, TObjPtr &fdesc); +void VARDESC2Obj (ITypeInfo *pti, VARDESC *pdesc, TObjPtr &presult); +bool TYPEDESC2Obj (ITypeInfo *pti, TYPEDESC *pdesc, TObjPtr &pobj); + +void VariantToObj (VARIANT *pvar, TObjPtr &obj); + +inline void ReleaseTypeAttr (ITypeInfo *pti, TYPEATTR *&pta); + +void Guid2LibName (GUID &guid, TObjPtr &plibname); + +void TypeLib_GetImplTypes (ITypeInfo *pti, TObjPtr &inherited); +void TypeLib_ProcessFunctions (ITypeInfo *pti, TObjPtr &methods, TObjPtr &properties); +void TypeLib_ProcessVariables (ITypeInfo *pti, TObjPtr &properties); +void TypeLib_GetVariable (ITypeInfo *pti, UINT index, TObjPtr &properties); + +HRESULT BindTypeInfo (ITypeComp *, const char *, ITypeInfo **); + +TCL_CMDEF(TypeLib_LoadedLibs); +TCL_CMDEF(TypeLib_LoadLib); +TCL_CMDEF(TypeLib_UnloadLib); +TCL_CMDEF(TypeLib_IsLibLoaded); +TCL_CMDEF(TypeLib_TypesInLib); +TCL_CMDEF(TypeLib_TypeInfo); + + +//// TEST CODE //// +TCL_CMDEF(TypeLib_ResolveConstantTest); + +//---------------------------------------------------------------- +// \/\/\/\/\/\/ Globals \/\/\/\/\/\/\/ + +// this class uses a Tcl hash table - this usually wouldn't be +// safe, except that this hash table is initialised (courtsey of THash<>) +// only on first uses (lazy). So it should be okay. Not sure how +// this will behave in a multithreaded application + +TypeLibsTbl g_libs; + +//---------------------------------------------------------------- +// Implementation for TypeLibsTbl class + +TypeLibsTbl::TypeLibsTbl () : THash () +{ + +} + + +TypeLibsTbl::~TypeLibsTbl () +{ + DeleteAll(); +} + +void TypeLibsTbl::DeleteAll () +{ + for (iterator i = begin(); i != end(); i++) + { + ASSERT ((*i) != NULL); + delete (*i); + } + deltbl(); +} + + +ITypeLib * TypeLibsTbl::LoadLib (Tcl_Interp *pInterp, const char *fullname) +{ + USES_CONVERSION; + CComPtr pLib; + CComPtr pComp; + + TObjPtr cmd, // used to build up a command string + result, // attaches to the result of the above commands' execution + progname; // the programmatic name of the library + GUID guid; + int maj, min; + HRESULT hr; + + Tcl_HashEntry *pEntry = NULL; + TypeLib *ptl; + + if (m_loadedlibs.find(fullname, &pEntry) != NULL) { + ASSERT (pEntry != NULL); + ptl = (TypeLib *)Tcl_GetHashValue (pEntry); + ASSERT (ptl != NULL); + Tcl_SetResult (pInterp, Tcl_GetHashKey (&m_tbl, pEntry), TCL_VOLATILE); + pLib = ptl->m_ptl; + ASSERT (pLib != NULL); + return pLib; + } + + + try { + // get the guid, max and min version numbers + cmd.create(); + cmd = "typelib::libdetail"; + cmd.lappend (fullname); + if (Tcl_GlobalEvalObj (pInterp, cmd) == TCL_ERROR) return NULL; + result.attach(Tcl_GetObjResult(pInterp), false); + if (result.llength() != 3) + throw ("expected three elements in the library description"); + + maj = result.lindex (1); + min = result.lindex (2); + hr = CLSIDFromString (A2OLE(result.lindex(0)), &guid); + if (FAILED(hr)) + throw ("failed to convert identifier"); + + // load the library + hr = LoadRegTypeLib (guid, maj, min, LOCALE_SYSTEM_DEFAULT, &pLib); + CHECKHR(hr); + if (pLib == NULL) + throw ("failed to bind to a type library"); + + // get the programmatic name of the library + TypeLib_GetName (pLib, NULL, progname); + + hr = pLib->GetTypeComp(&pComp); + if (FAILED(hr)) + throw ("failed to get the compiler interface for library"); + + Cache (progname, fullname, pLib, pComp); + Tcl_SetResult (pInterp, (char*)(const char*)progname, TCL_VOLATILE); + } + + catch (char *error) { + Tcl_SetResult (pInterp, error, TCL_VOLATILE); + } + catch (HRESULT hr) { + Tcl_SetResult (pInterp, (char*)HRESULT2Str(hr), TCL_DYNAMIC); + } + + return pLib; +} + + + + +/* + *------------------------------------------------------------------------- + * TypeLibsTbl::Cache -- + * Called in order to cache a library. + * Pre: The library does *not* exist in the cache + * + * Result: + * A standard OLE HRESULT + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +TypeLib* TypeLibsTbl::Cache (const char *szname, const char *szfullname, ITypeLib *ptl, ITypeComp *ptc) +{ + ASSERT(szname != NULL && szfullname != NULL); + ASSERT (ptl != NULL && ptc != NULL); + TypeLib *pLib = NULL; + Tcl_HashEntry *pEntry = NULL; + + pLib = new TypeLib (ptl, ptc); + pEntry = set(szname, pLib); + ASSERT (pEntry != NULL); + + m_loadedlibs.set (szfullname, pEntry); + return pLib; +} + + +bool TypeLibsTbl::IsLibLoaded (const char *fullname) +{ + ASSERT (fullname != NULL); + return (m_loadedlibs.find (fullname) != NULL); +} + +/* + *------------------------------------------------------------------------- + * TypeLibsTbl::UnloadLib -- + * Given the fullname of a library, the routine unloads it, if it is + * loaded. + * + * Result: + * None. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void TypeLibsTbl::UnloadLib (Tcl_Interp *pInterp, const char *fullname) +{ + Tcl_HashEntry *pEntry = NULL; + TypeLib *ptl = NULL; + + if (!m_loadedlibs.find (fullname, &pEntry)) + return; + + ASSERT (pEntry != NULL); + ptl = (TypeLib*)Tcl_GetHashValue (pEntry); + ASSERT (ptl != NULL); + delete ptl; + m_loadedlibs.delete_entry(fullname); + Tcl_DeleteHashEntry (pEntry); +} + + + + +/* + *------------------------------------------------------------------------- + * TypeLibsTbl::EnsureCached -- + * Given a typelibrary, the routine ensures that it is stored in the cache. + * + * Result: + * A pointer to the caches TypeLib object. + * + * Side effects: + * Throws HRESULT. + *------------------------------------------------------------------------- + */ +TypeLib *TypeLibsTbl::EnsureCached (ITypeLib *ptl) +{ + USES_CONVERSION; + + ASSERT (ptl != NULL); + TDString verfullname; + TypeLib *pLib = NULL; + TLIBATTR *pattr = NULL; + HRESULT hr; + BSTR name = NULL, + fullname = NULL; + char *szname, *szfullname; + Tcl_HashEntry *pEntry = NULL; + CComPtr ptc; + + // get the libraries different names + hr = ptl->GetDocumentation(-1, &name, &fullname, NULL, NULL); + CHECKHR(hr); + szname = W2A(name); + szfullname = W2A(fullname); + FreeBSTR(name); + FreeBSTR(fullname); + if (find(szname, &pLib)) + return pLib; // cached already + + // build the fullname+version string + hr = ptl->GetLibAttr(&pattr); + CHECKHR(hr); + verfullname.set (szfullname) << " (Ver " << short(pattr->wMajorVerNum) << "." << + short(pattr->wMinorVerNum) << ")"; + ptl->ReleaseTLibAttr (pattr); pattr = NULL; + + // get the compiler interface + hr = ptl->GetTypeComp (&ptc); + CHECKHR(hr); + // now cache the lot + pLib = Cache (szname, verfullname, ptl, ptc); + return pLib; +} + + +/* + *------------------------------------------------------------------------- + * TypeLibsTbl::EnsureCached -- + * Sames as EnsureChached(ITypeLib *), but uses a type info. + * + * Result: + * Non NULL iff successful - result points to the cached TypeLib structure. + * + * Side effects: + * Throws HRESULT. + *------------------------------------------------------------------------- + */ +TypeLib *TypeLibsTbl::EnsureCached (ITypeInfo *pInfo) +{ + ASSERT (pInfo != NULL); + CComPtr pLib; + UINT tmp; + HRESULT hr; + hr = pInfo->GetContainingTypeLib(&pLib, &tmp); + CHECKHR(hr); + return EnsureCached (pLib); +} + + + + + + + +// ------------------- TypeLib initialisation and shutdown routines ------------------------- +int TypeLib_Init (Tcl_Interp *pInterp) +{ + OleInitialize(NULL); + Tcl_CreateExitHandler (TypeLib_Exit, NULL); + Tcl_CreateObjCommand (pInterp, "typelib::loaded", TypeLib_LoadedLibs, NULL, NULL); + Tcl_CreateObjCommand (pInterp, "typelib::load", TypeLib_LoadLib, NULL, NULL); + Tcl_CreateObjCommand (pInterp, "typelib::unload", TypeLib_UnloadLib, NULL, NULL); + Tcl_CreateObjCommand (pInterp, "typelib::types", TypeLib_TypesInLib, NULL, NULL); + Tcl_CreateObjCommand (pInterp, "typelib::typeinfo", TypeLib_TypeInfo, NULL, NULL); + Tcl_CreateObjCommand (pInterp, "typelib::isloaded", TypeLib_IsLibLoaded, NULL, NULL); + + //// TESTS //// + Tcl_CreateObjCommand (pInterp, "typelib::resolveconst", TypeLib_ResolveConstantTest, NULL, NULL); + + return TCL_OK; +} + + + +void TypeLib_Exit (ClientData) +{ + g_libs.DeleteAll (); + OleUninitialize(); +} +// ------------------------------------------------------------------------------------------ + + + + +/* + *------------------------------------------------------------------------- + * ReleaseTypeAttr -- + * Release at type attribute from the specified type info. + * + * Result: + * None. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +inline void ReleaseTypeAttr (ITypeInfo *pti, TYPEATTR *&pta) +{ + ASSERT (pti != NULL); + if (pta != NULL) { + pti->ReleaseTypeAttr(pta); + pta = NULL; + } +} + + + + +/* + *------------------------------------------------------------------------- + * ReleaseBindPtr -- + * Releases a bind ptr (if not null), according to its type description. + * Sets the value of the pointer to null. + * + * Result: + * None + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void ReleaseBindPtr (ITypeInfo *pti, DESCKIND dk, BINDPTR &ptr) +{ + if (ptr.lpfuncdesc != NULL) { + switch (dk) { + case DESCKIND_FUNCDESC: + ASSERT (pti != NULL); + pti->ReleaseFuncDesc (ptr.lpfuncdesc); + ptr.lpfuncdesc = NULL; + break; + case DESCKIND_IMPLICITAPPOBJ: // same as a vardesc + case DESCKIND_VARDESC: + ASSERT (pti != NULL); + pti->ReleaseVarDesc (ptr.lpvardesc); + ptr.lpvardesc = NULL; + break; + case DESCKIND_TYPECOMP: + ptr.lptcomp->Release(); + ptr.lptcomp = NULL; + break; + } + } +} + + + +const char *TYPEKIND2Str (TYPEKIND tkind) +{ + switch (tkind) + { + case TKIND_ENUM: + return "enum"; + case TKIND_RECORD: + return "struct"; + case TKIND_MODULE: + return "module"; + case TKIND_INTERFACE: + return "interface"; + case TKIND_DISPATCH: + return "dispatch"; + case TKIND_COCLASS: + return "class"; + case TKIND_ALIAS: + return "typedef"; + case TKIND_UNION: + return "union"; + default: + return "???"; + } +} + + + + + + +const char *VARTYPE2Str (VARTYPE vt) +{ + vt = vt & ~VT_ARRAY & ~VT_BYREF; + switch (vt) { + case VT_EMPTY: + case VT_NULL: + return "_null_"; + case VT_I1: + return "char"; + case VT_UI1: + return "uchar"; + case VT_I2: + return "short"; + case VT_UI2: + return "ushort"; + case VT_INT: + case VT_I4: + case VT_ERROR: + return "long"; + case VT_UI4: + case VT_UINT: + return "ulong"; + case VT_I8: + return "super_long"; + case VT_UI8: + return "usuper_long"; + case VT_R4: + return "float"; + case VT_R8: + return "double"; + case VT_CY: + return "currency"; + case VT_DATE: + return "date"; + case VT_BSTR: + return "string"; + case VT_DISPATCH: + return "dispatch"; + case VT_BOOL: + return "bool"; + case VT_VARIANT: + return "any"; + case VT_UNKNOWN: + return "interface"; + case VT_DECIMAL: + return "decimal"; + case VT_VOID: + return "void"; + case VT_HRESULT: + return "scode"; + case VT_LPSTR: + case VT_LPWSTR: + return "string"; + case VT_CARRAY: + return "carray"; + default: + return "???"; + } +} + + + + + +/* + *------------------------------------------------------------------------- + * TYPEDESC2Obj -- + * + * Result: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ +bool TYPEDESC2Obj (ITypeInfo *pti, TYPEDESC *pdesc, TObjPtr &pobj) +{ + USES_CONVERSION; + ASSERT (pdesc != NULL && pti != NULL); + bool array = ((pdesc->vt & VT_ARRAY) != 0); + pdesc->vt = pdesc->vt & ~VT_ARRAY; + HRESULT hr; + + if (pdesc->vt == VT_USERDEFINED) { + // resolve the referenced type + CComPtr prefti; + TYPEATTR *pta = NULL; + WORD flags; + hr = pti->GetRefTypeInfo (pdesc->hreftype, &prefti); + CHECKHR(hr); + hr = prefti->GetTypeAttr (&pta); + CHECKHR(hr); + flags = pta->wTypeFlags; + + ReleaseTypeAttr (prefti, pta); + if ((flags & TYPEFLAG_FRESTRICTED)) { + pobj.create(); + pobj = "!!!"; // unaccessable type + return false; + } + g_libs.EnsureCached(prefti); + TypeLib_GetName (NULL, prefti, pobj); + } else if ((pdesc->vt == VT_SAFEARRAY) || (pdesc->vt == VT_PTR)) { + if (!TYPEDESC2Obj (pti, pdesc->lptdesc, pobj)) + return false; + ASSERT (pobj.isnotnull()); + if (pdesc->vt == VT_SAFEARRAY) + pobj += " []"; + } else { + pobj.create(); + pobj = VARTYPE2Str(pdesc->vt); + } + + return true; +} + + + + + +/* + *------------------------------------------------------------------------- + * TypeLib_GetName -- + * Converts a library or type to a name stored in a Tcl_Obj. If pLib + * is not NULL and pInfo is, then the name is the name of the library. + * Otherwise, pInfo must be non-null (pLib can always be derived from pInfo) + * The result is stored in pname. + * + * Result: + * None. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void TypeLib_GetName (ITypeLib *pLib, ITypeInfo *pInfo, TObjPtr &pname) +{ + ASSERT (pLib!=NULL || pInfo!=NULL); + + USES_CONVERSION; + BSTR progname = NULL, + typname = NULL; + HRESULT hr; + + UINT tmp; + bool bLibcreate = false; + + // ensure we have a library to work with + if (pLib == NULL) { + hr = pInfo->GetContainingTypeLib(&pLib, &tmp); + CHECKHR(hr); + bLibcreate = true; + } + // get the library programmatic name + hr = pLib->GetDocumentation (-1, &progname, NULL, NULL, NULL); + CHECKHR(hr); + + if (pInfo == NULL) { + pname.create(); + pname = W2A(progname); + } else { + hr = pInfo->GetDocumentation(MEMBERID_NIL, &typname, NULL, NULL, NULL); + CHECKHR(hr); + TDString str; + str.set(W2A(progname)) << "." << W2A(typname); + pname.create(); + pname = str; + } + + FreeBSTR(progname); + FreeBSTR(typname); + if (bLibcreate) + pLib->Release(); +} + + + + + +/* + *------------------------------------------------------------------------- + * BindTypeInfo -- + * Given a type compiling interface (ptc) and a typename (szTypeName), + * resolves to a ITypeInfo interface (stored in ppti). + * + * Result: + * Returns a standard OLE HRESULT. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +HRESULT BindTypeInfo (ITypeComp *ptc, const char *szTypeName, ITypeInfo **ppti) +{ + USES_CONVERSION; + LPOLESTR oleTypename = NULL; + UINT hash; + ASSERT (ptc != NULL && ppti != NULL); + CComPtr ptemp; + oleTypename = A2OLE(szTypeName); + hash = LHashValOfName(LOCALE_SYSTEM_DEFAULT, oleTypename); + return ptc->BindType (oleTypename, hash, ppti, &ptemp); +} + + + + + + +/* + *------------------------------------------------------------------------- + * FUNCDESC2Obj -- + * + * Result: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ +void FUNCDESC2Obj (ITypeInfo *pti, FUNCDESC *pfd, TObjPtr &fdesc) +{ + ASSERT (pfd != NULL && pti != NULL); + ASSERT (!(pfd->wFuncFlags & FUNCFLAG_FRESTRICTED)); + USES_CONVERSION; + BSTR * fnames = NULL; + char * szfname = NULL; + HRESULT hr; + UINT totalread = 0; + UINT total = 0; + TObjPtr type; + TObjPtr flags; + TObjPtr param; + TObjPtr optionparam; + + fdesc.create(); + + try { + // get the names + total = pfd->cParams + 1; + fnames = new BSTR[total]; + hr = pti->GetNames(pfd->memid, fnames, total, &totalread); + CHECKHR(hr); + if (totalread != total) + throw ("couldn't retrieve all the parameter names"); + + + + TYPEDESC2Obj(pti, &(pfd->elemdescFunc.tdesc), type); + fdesc.lappend (type); // return type + fdesc.lappend (W2A(fnames[0])); // the function name + + + // now build up the parameters + for (SHORT index = 0; index < pfd->cParams; index++) + { + ELEMDESC *pdesc = pfd->lprgelemdescParam + index; + flags.create(); + if ((pdesc->paramdesc.wParamFlags & PARAMFLAG_FIN) || + (pdesc->paramdesc.wParamFlags == PARAMFLAG_NONE)) + flags.lappend("in"); + if (pdesc->paramdesc.wParamFlags & PARAMFLAG_FOUT) + flags.lappend("out"); + if (pdesc->paramdesc.wParamFlags & PARAMFLAG_FRETVAL) + flags.lappend("retval"); + + // type of parameter + TYPEDESC2Obj(pti, &(pdesc->tdesc), type); + + // setup the result + param.create(); + param.lappend(flags).lappend(type).lappend(W2A(fnames[index+1])); + + + // is it optional and does it have a default value + if ((pdesc->paramdesc.wParamFlags & PARAMFLAG_FHASDEFAULT) + && (pdesc->paramdesc.wParamFlags & PARAMFLAG_FOPT)) { + VariantToObj (&(pdesc->paramdesc.pparamdescex->varDefaultValue), optionparam); + param.lappend(optionparam); + } + else + if ((pfd->cParams - index)<=pfd->cParamsOpt) + param.lappend ("?"); + + fdesc.lappend(param); + } + + + FreeBSTRArray (fnames, totalread); + delete fnames; + } + + catch (char *error) { + FreeBSTRArray (fnames, totalread); + delete fnames; + throw (error); + } + + catch (HRESULT hr) { + FreeBSTRArray (fnames, totalread); + delete fnames; + throw (hr); + } +} + + + +/* + *------------------------------------------------------------------------- + * VARDESC2Obj -- + * + * Result: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ +void VARDESC2Obj (ITypeInfo *pti, VARDESC *pdesc, TObjPtr &presult) +{ + ASSERT (pti != NULL && pdesc != NULL); + + USES_CONVERSION; + HRESULT hr; + BSTR name = NULL; + char * szname = NULL; + TObjPtr tdesc; // stores the description of the type + TObjPtr tflags;// read write flags for this variable + + hr = pti->GetDocumentation(pdesc->memid, &name, NULL, NULL, NULL); + CHECKHR(hr); + szname = W2A (name); + FreeBSTR (name); + + TYPEDESC2Obj (pti, &(pdesc->elemdescVar.tdesc), tdesc); + tflags.create(); + if (pdesc->wVarFlags & VARFLAG_FREADONLY) + tflags = "read"; + else + tflags = "read write"; + + presult.create(); + presult.lappend (tflags).lappend(tdesc).lappend(szname); + if (pdesc->varkind == VAR_CONST) { // its a constant + TObjPtr cnst; + VariantToObj (pdesc->lpvarValue, cnst); + presult.lappend (cnst); + } +} + + +void VariantToObj (VARIANT *pvar, TObjPtr &obj) +{ + ASSERT (pvar != NULL); + + USES_CONVERSION; + + VARTYPE vt = pvar->vt; + CComVariant var; + HRESULT hr; + + vt = vt & ~VT_BYREF; + obj.create(); + + if (vt == VT_UNKNOWN || vt == VT_DISPATCH) + obj = "object"; + else if ((vt & VT_ARRAY) == VT_ARRAY) + obj = "array"; + else { + hr = var.Copy (pvar); + CHECKHR(hr); + var.ChangeType(VT_BSTR); + ASSERT (var.bstrVal != NULL); + obj = W2A (var.bstrVal); + } +} + + + +/* + *------------------------------------------------------------------------- + * ImplFlags2Obj -- + * + * Converts implementation flags to a tcl object. + * + * Result: + * None. + * + * Side effects: + * Uses TObjPtr functions, and hence throws (char *) in case of any errors. + *------------------------------------------------------------------------- + */ +void ImplFlags2Obj (UINT implflags, TObjPtr &flags) +{ + flags.create(); + if (implflags & IMPLTYPEFLAG_FDEFAULT) + flags.lappend("default"); + if (implflags & IMPLTYPEFLAG_FSOURCE) + flags.lappend("source"); +} + + + + +/* + *------------------------------------------------------------------------- + * TypeLib_DescOfRefType -- + * + * Called to describe a referenced type from another type. If bclassinfo + * is true, the function prepends additional flags to describe the role of + * the referenced type to the class type. + * + * Result: + * return true iff successful. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +bool TypeLib_DescOfRefType (ITypeInfo *pti, UINT index, TObjPtr &desc, bool bclassinf) +{ + ASSERT (pti != NULL); + + HRESULT hr; + TObjPtr name; + TObjPtr flags; + CComPtr ptmp; + HREFTYPE href; + INT implflags; + TYPEATTR * pta = NULL; + WORD typeflags; + + hr = pti->GetRefTypeOfImplType (index , &href); + CHECKHR(hr); + + hr = pti->GetRefTypeInfo (href, &ptmp); + CHECKHR(hr); + + g_libs.EnsureCached(ptmp); + hr = pti->GetImplTypeFlags(index, &implflags); + CHECKHR(hr); + + hr = ptmp->GetTypeAttr (&pta); + CHECKHR(hr); + typeflags = pta->wTypeFlags; + ReleaseTypeAttr(pti, pta); + + if ((typeflags & TYPEFLAG_FRESTRICTED) || + (implflags & IMPLTYPEFLAG_FRESTRICTED)) + return false; + + + TypeLib_GetName (NULL, ptmp, name); + if (bclassinf) { + ImplFlags2Obj (implflags, flags); + } else { + flags.create(); + } + + desc.create(); + desc.lappend(flags).lappend(name); + return true; +} + + + + + +/* + *------------------------------------------------------------------------- + * TypeLib_GetImplTypes -- + * Compiles a list of inherited interfaces from a type information pointer. + * + * Result: + * None. + * + * Side effects: + * throws char * and HRESULT. + *------------------------------------------------------------------------- + */ +void TypeLib_GetImplTypes (ITypeInfo *pti, TObjPtr &inherited) +{ + ASSERT (pti!=NULL && inherited.isnotnull()); + + HRESULT hr; + TYPEATTR * pattr = NULL; + WORD count; // total number of references + TObjPtr desc; + TYPEKIND tkind; + + + hr = pti->GetTypeAttr (&pattr); + CHECKHR(hr); + + count = pattr->cImplTypes; + tkind = pattr->typekind; + ReleaseTypeAttr (pti, pattr); + + for (WORD index = 0; index < count; index++) + { + if (TypeLib_DescOfRefType (pti, index, desc, (tkind == TKIND_COCLASS))) + inherited.lappend(desc); + } +} + + + + + + + +/* + *------------------------------------------------------------------------- + * TypeLib_GetVariable -- + * Gets the description for a variable (VARDESC) property, based on an + * index. + * + * Result: + * None. + * + * Side effects: + * Throws HRESULT and char *. + *------------------------------------------------------------------------- + */ +void TypeLib_GetVariable (ITypeInfo *pti, UINT index, TObjPtr &properties) +{ + USES_CONVERSION; + + ASSERT (pti != NULL && properties.isnotnull()); + VARDESC * pDesc; + HRESULT hr; + BSTR name = NULL; + char * szName = NULL; + + try { + hr = pti->GetVarDesc(index, &pDesc); + CHECKHR(hr); + + ASSERT (pDesc != NULL); + + if (!(pDesc->wVarFlags & VARFLAG_FHIDDEN)) // not a hidden variable + { + hr = pti->GetDocumentation(pDesc->memid, &name, NULL, NULL, NULL); + CHECKHR(hr); + + szName = W2A(name); + FreeBSTR(name); + properties.lappend(szName); + } + pti->ReleaseVarDesc(pDesc); + } + + catch (HRESULT hr) { + if (pDesc != NULL) { + pti->ReleaseVarDesc(pDesc); + pDesc = NULL; + } + throw (hr); + } + + catch (char *error) { + if (pDesc != NULL) { + pti->ReleaseVarDesc(pDesc); + pDesc = NULL; + } + throw (error); + } +} + + + + + + + +/* + *------------------------------------------------------------------------- + * TypeLib_ProcessVariables -- + * Appends to a tcl list object, a the set of VARDESC defined properties. + * + * Result: + * None. + * + * Side effects: + * Uses functions that throw HRESULT and char * + *------------------------------------------------------------------------- + */ +void TypeLib_ProcessVariables (ITypeInfo *pti, TObjPtr &properties) +{ + ASSERT (pti != NULL && properties.isnotnull()); + TYPEATTR *pattr = NULL; + HRESULT hr; + UINT count; + + hr = pti->GetTypeAttr(&pattr); + CHECKHR(hr); + count = pattr->cVars; + ReleaseTypeAttr (pti, pattr); + + for (UINT index = 0; index < count; index++) { + TypeLib_GetVariable (pti, index, properties); + } +} + + + + +/* + *------------------------------------------------------------------------- + * TypeLib_ProcessFunctions -- + * Scans the functions within the type and separates them into two lists: + * Methods functions, and property functions. Read/Write access to + * properties are not determined here. + * + * Result: + * None. + * + * Side effects: + * Can throw HRESULT and char *. + *------------------------------------------------------------------------- + */ +void TypeLib_ProcessFunctions (ITypeInfo *pti, TObjPtr &methods, TObjPtr &properties) +{ + USES_CONVERSION; + ASSERT (pti != NULL && properties.isnotnull() && methods.isnotnull()); + + HRESULT hr; + TYPEATTR * pattr = NULL; + WORD count; + FUNCDESC * pfd = NULL; + BSTR name; + char * szname; + THash proptbl; + + hr = pti->GetTypeAttr (&pattr); + CHECKHR(hr); + + count = pattr->cFuncs; + ReleaseTypeAttr (pti, pattr); + + + try { + for (WORD index = 0; index < count; index++) + { + hr = pti->GetFuncDesc (index, &pfd); + CHECKHR(hr); + // if the function shouldn't be shown, skip this iteration + if ((pfd->wFuncFlags & FUNCFLAG_FRESTRICTED)) { + pti->ReleaseFuncDesc (pfd); pfd = NULL; + continue; + } + + hr = pti->GetDocumentation(pfd->memid, &name, NULL, NULL, NULL); + CHECKHR(hr); + + szname = W2A (name); + FreeBSTR (name); + if (pfd->invkind == INVOKE_FUNC) { + methods.lappend(szname); + } else { + proptbl.set(szname, 0); + } + pti->ReleaseFuncDesc (pfd); pfd = NULL; + } + // now process the properties + for (THash::iterator e = proptbl.begin(); e != proptbl.end(); e++) + properties.lappend(e.key()); + } + + catch (char *error) { + if (pfd != NULL) { + pti->ReleaseFuncDesc (pfd); pfd = NULL; + } + throw (error); + } + catch (HRESULT hr) { + if (pfd != NULL) { + pti->ReleaseFuncDesc (pfd); pfd = NULL; + } + throw (hr); + } +} + + + + + + +/* + *------------------------------------------------------------------------- + * TypeLib_DescribeTypeInfo -- + * Describe the type info in terms of the types kind, its methods, + * properties and inherited types. + * + * Result: + * Std Tcl return. + * + * Side effects: + * Can throw either HRESULT and char *. These probably can be removed + * and returned directly in the interpreter. I've left them to be + * picked up by the calling procedure, as that has its own exception + * handling code. + *------------------------------------------------------------------------- + */ +int TypeLib_DescribeTypeInfo (Tcl_Interp *pInterp, ITypeInfo *pti) +{ + int cmdresult = TCL_ERROR; + USES_CONVERSION; + + ASSERT (pti != NULL && pInterp != NULL); + TYPEATTR *pta = NULL; + HRESULT hr; + TObjPtr presult, + inherited, + methods, + properties; + BSTR bdoc = NULL; + + hr = pti->GetTypeAttr(&pta); + CHECKHR(hr); + + try { + if (pta->typekind == TKIND_ALIAS) { + presult.create (); + presult.lappend("typedef").lappend("").lappend(""); + + //TypeLib_GetImplTypes (pti, inherited); + TYPEDESC2Obj (pti, &(pta->tdescAlias), inherited); + presult.lappend (inherited); + cmdresult = TCL_OK; + } + + else { + inherited.create(); + methods.create(); + properties.create(); + TypeLib_GetImplTypes (pti, inherited); + TypeLib_ProcessFunctions (pti, methods, properties); + TypeLib_ProcessVariables (pti, properties); + + presult.create(); + switch (pta->typekind) + { + case TKIND_ENUM: + presult = "enum"; break; + case TKIND_RECORD: + presult = "struct"; break; + case TKIND_MODULE: + presult = "module"; break; + case TKIND_INTERFACE: + presult = "interface"; break; + case TKIND_DISPATCH: + presult = "dispatch"; break; + case TKIND_COCLASS: + presult = "class"; break; + case TKIND_UNION: + presult = "union"; break; + default: + presult = "???"; break; + } + + presult.lappend(methods).lappend(properties).lappend(inherited); + cmdresult = TCL_OK; + } + ReleaseTypeAttr (pti, pta); + } + catch (HRESULT hr) { + ReleaseTypeAttr (pti, pta); + throw (hr); + } + catch (char *error) { + ReleaseTypeAttr (pti, pta); + throw (error); + } + + if (cmdresult == TCL_OK) { + if (SUCCEEDED(pti->GetDocumentation (MEMBERID_NIL, NULL, &bdoc, NULL, NULL)) && bdoc != NULL) + { + presult.lappend (OLE2A(bdoc)); + SysFreeString (bdoc); + } + else + presult.lappend (""); + + Tcl_SetObjResult (pInterp, presult); + } + + return cmdresult; +} + + + + +/* + *------------------------------------------------------------------------- + * DescPropertyFuncDesc -- + * Helper function to provides a description in a tcl object, + * of a accessor based property. The property name, hash, typeinfo, + * compiler interface, funcdesc are already provided. The function evaluates + * the read/write priviliges, and type of the property, before building the + * resultant list. + * + * Result: + * None. + * + * Side effects: + * throws HRESULT or char* + *------------------------------------------------------------------------- + */ +void DescPropertyFuncDesc (BSTR name, ULONG hash, ITypeInfo *pti, + ITypeComp *pcmp, FUNCDESC *pfd, TObjPtr &pdesc) +{ + ASSERT (pti != NULL && pcmp != NULL); + + USES_CONVERSION; + + bool bRead = false, + bWrite = false; + BSTR * fnames = NULL; + char * szname = NULL; + OptclBindPtr obp; + HRESULT hr; + + UINT totalread = 0; + UINT total = 0; + TObjPtr fdesc, param, type, optionparam, flags; + + try { + // find out read/write access of this property + bWrite = (pfd->invkind==INVOKE_PROPERTYPUT || + pfd->invkind==INVOKE_PROPERTYPUTREF); + + // assertion: due to the order of computation, + // if bWrite is TRUE, then bRead will be false + bRead = !bWrite; + + if (!bWrite) { + hr = pcmp->Bind (name, hash, INVOKE_PROPERTYPUT | INVOKE_PROPERTYPUTREF, + &obp.m_pti, &obp.m_dk, &obp.m_bp); + bWrite = SUCCEEDED(hr) && (obp.m_bp.lpfuncdesc->invkind==INVOKE_PROPERTYPUT || + obp.m_bp.lpfuncdesc->invkind==INVOKE_PROPERTYPUTREF); + } + + total = pfd->cParams + 1; + fnames = new BSTR[total]; + hr = pti->GetNames(pfd->memid, fnames, total, &totalread); + CHECKHR(hr); + if (totalread != total) + throw ("couldn't retrieve all the parameter names"); + + pdesc.create(); + flags.create(); + if (bRead) + flags.lappend ("read"); + if (bWrite) + flags.lappend ("write"); + if (bRead) { // its a propertyget - use the return value of the function as the type + TYPEDESC2Obj (pti, &(pfd->elemdescFunc.tdesc), type); + } else { // its a propertyput only - use the first parameter + TYPEDESC2Obj (pti, &(pfd->lprgelemdescParam->tdesc), type); + } + pdesc.lappend(flags).lappend(type).lappend(W2A(fnames[0])); + + + // now build up the parameters + for (SHORT index = 0; index < pfd->cParams; index++) + { + ELEMDESC *elemdesc = pfd->lprgelemdescParam + index; + + flags.create(); + if (elemdesc->paramdesc.wParamFlags & PARAMFLAG_FIN) + flags.lappend("in"); + if (elemdesc->paramdesc.wParamFlags & PARAMFLAG_FOUT) + flags.lappend("out"); + if (elemdesc->paramdesc.wParamFlags & PARAMFLAG_FRETVAL) + flags.lappend("retval"); + + // type of parameter + TYPEDESC2Obj(pti, &(elemdesc->tdesc), type); + + // setup the result + param.create(); + param.lappend(flags).lappend(type).lappend(W2A(fnames[index+1])); + + // is it optional and does it have a default value + if ((elemdesc->paramdesc.wParamFlags & PARAMFLAG_FHASDEFAULT) + && (elemdesc->paramdesc.wParamFlags & PARAMFLAG_FOPT)) { + VariantToObj (&(elemdesc->paramdesc.pparamdescex->varDefaultValue), optionparam); + param.lappend(optionparam); + } + else + if ((pfd->cParams - index)<=pfd->cParamsOpt) + param.lappend ("?"); + + pdesc.lappend(param); + } + + FreeBSTRArray (fnames, totalread); + delete fnames; + } + catch (char *error) { + FreeBSTRArray (fnames, totalread); + delete fnames; + throw (error); + } + + catch (HRESULT hr) { + FreeBSTRArray (fnames, totalread); + delete fnames; + throw (hr); + } +} + + + + + +/* + *------------------------------------------------------------------------- + * TypeLib_DescribeTypeInfoElement -- + * Called to describe an element of a type information pointer. Identifies + * it's role (currently only property or method), and retrieves a + * description. + * + * Result: + * Std Tcl result. + * + * Side effects: + * Throws HRESULT and char *. + *------------------------------------------------------------------------- + */ +int TypeLib_DescribeTypeInfoElement (Tcl_Interp *pInterp, ITypeInfo *pti, + const char *elem) +{ + ASSERT (pInterp != NULL && pti != NULL && elem != NULL); + + USES_CONVERSION; + + int cmdresult = TCL_ERROR; + HRESULT hr; + OptclBindPtr bp; + ULONG hash; + LPOLESTR name = A2OLE(elem); + CComPtr pcmp; + TObjPtr presult, + pdesc; + BSTR bdoc; + + try { + hr = pti->GetTypeComp (&pcmp); + CHECKHR(hr); + + hash = LHashValOfName (LOCALE_SYSTEM_DEFAULT, name); + hr = pcmp->Bind (name, hash, INVOKE_FUNC | INVOKE_PROPERTYGET, &bp.m_pti, &bp.m_dk, &bp.m_bp); + if (FAILED(hr) || (bp.m_dk == DESCKIND_NONE)) { + bp.ReleaseBindPtr(); + hr = pcmp->Bind (name, hash, INVOKE_PROPERTYPUT | INVOKE_PROPERTYPUTREF, &bp.m_pti, &bp.m_dk, &bp.m_bp); + } + + CHECKHR(hr); + + + cmdresult = TCL_OK; + switch (bp.m_dk) { + case DESCKIND_FUNCDESC: + // check access restrictions on the function + if (bp.m_bp.lpfuncdesc->wFuncFlags & FUNCFLAG_FRESTRICTED) { + Tcl_SetResult(pInterp, "you aren't allowed to view: '", TCL_STATIC); + Tcl_AppendResult (pInterp, (char*)elem, "'", NULL); + cmdresult = TCL_ERROR; + } else { + presult.create(); + if (bp.m_bp.lpfuncdesc->invkind == INVOKE_FUNC) {// its a standard function + FUNCDESC2Obj (bp.m_pti, bp.m_bp.lpfuncdesc, pdesc); + presult.lappend ("method").lappend(pdesc); + } + else {// its an implicit variable with accessor function + DescPropertyFuncDesc(name, hash, bp.m_pti, pcmp, bp.m_bp.lpfuncdesc, pdesc); + presult.lappend ("property").lappend(pdesc); + } + } + break; + + case DESCKIND_VARDESC: + if ((bp.m_bp.lpvardesc->wVarFlags & VARFLAG_FRESTRICTED)) { + Tcl_SetResult (pInterp, "you aren't allowed to view: '", TCL_STATIC); + Tcl_AppendResult (pInterp, (char*)elem, "'", NULL); + cmdresult = TCL_ERROR; + } else { + VARDESC2Obj (bp.m_pti, bp.m_bp.lpvardesc, pdesc); + presult.create(); + presult.lappend ("property").lappend(pdesc); + } + break; + + case DESCKIND_TYPECOMP: // don't know how to handle these ones at the moment + Tcl_SetResult (pInterp, "typecomp", TCL_STATIC); + break; + + case DESCKIND_IMPLICITAPPOBJ: // don't know how to handle these ones at the moment + Tcl_SetResult (pInterp, "appobj", TCL_STATIC); + break; + + case DESCKIND_NONE: + default: + Tcl_SetResult (pInterp, "can't find a description for '", TCL_STATIC); + Tcl_AppendResult (pInterp, (char*)elem, "'", NULL); + cmdresult = TCL_ERROR; + } + } + catch (HRESULT hr) { + Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC); + cmdresult = TCL_ERROR; + } + catch (char *err) { + Tcl_SetResult (pInterp, err, TCL_VOLATILE); + cmdresult = TCL_ERROR; + } + + // get the documentation string + + if (cmdresult == TCL_OK && (bp.m_dk == DESCKIND_FUNCDESC || bp.m_dk == DESCKIND_VARDESC)) { + if (SUCCEEDED( + bp.m_pti->GetDocumentation (bp.m_dk==DESCKIND_FUNCDESC?bp.m_bp.lpfuncdesc->memid:bp.m_bp.lpvardesc->memid, + NULL, &bdoc, NULL, NULL)) && bdoc != NULL) + { + presult.lappend(OLE2A(bdoc)); + SysFreeString (bdoc); + } + else + { + presult.lappend (""); + } + Tcl_SetObjResult (pInterp, presult); + } + + return cmdresult; +} + + + + + +/* + *------------------------------------------------------------------------- + * TypeLib_LoadedLibs -- + * Lists the currently loaded libraries + * Result: + * TCL_OK iff ok. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +TCL_CMDEF(TypeLib_LoadedLibs) +{ + if (objc != 1) { + Tcl_WrongNumArgs (pInterp, 1, objv, ""); + return TCL_ERROR; + } + TObjPtr presult; + presult.create(false); + try { + for (TypeLibsTbl::iterator i = g_libs.begin();i != g_libs.end(); i++) + presult.lappend(i.key(), pInterp); + } + catch (char *error) { + Tcl_SetResult (pInterp, error, TCL_VOLATILE); + return TCL_ERROR; + } + Tcl_SetObjResult (pInterp, presult); + return TCL_OK; +} + + + +/* + *------------------------------------------------------------------------- + * TypeLib_LoadLib -- + * Ensures that a given library is loaded. A library is described in terms + * of its full human-readable name. + * + * Result: + * TCL_OK iff successful. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +TCL_CMDEF(TypeLib_LoadLib) +{ + if (objc != 2) { + Tcl_WrongNumArgs (pInterp, 1, objv, "full_libname"); + return TCL_ERROR; + } + TObjPtr libname; + libname.attach(objv[1], false); + if (g_libs.LoadLib (pInterp, libname) != NULL) + return TCL_OK; + else + return TCL_ERROR; +} + + + +/* + *------------------------------------------------------------------------- + * TypeLib_UnloadLib -- + * Unloads a loaded library, specified in its human readable description. + * Perhaps this could be extended to take multiple arguments. + * + * Result: + * Always TCL_OK + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +TCL_CMDEF(TypeLib_UnloadLib) +{ + if (objc != 2) { + Tcl_WrongNumArgs (pInterp, 1, objv, "full_libname"); + return TCL_ERROR; + } + TObjPtr libname; + libname.attach(objv[1], false); + g_libs.UnloadLib (pInterp, libname); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * TypeLib_IsLibLoaded -- + * Returns true in the interpreter if the library (specifed in the first + * parameter) is correct. + * Result: + * TCL_OK iff # of params ok + * Side effects: + * None + *------------------------------------------------------------------------- + */ +TCL_CMDEF(TypeLib_IsLibLoaded) +{ + if (objc != 2) { + Tcl_WrongNumArgs (pInterp, 1, objv, "fullname_library"); + return TCL_ERROR; + } + TObjPtr name; + TObjPtr value; + value.create(false); + name.attach(objv[1]); + value = g_libs.IsLibLoaded(name); + Tcl_SetObjResult (pInterp, value); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * TypeLib_TypesInLib -- + * Returns a list in the interpreter holding the name and typekind of each + * type described in the library referenced by the first parameter to this + * command. + * Result: + * Std Tcl return results. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +TCL_CMDEF (TypeLib_TypesInLib) +{ + USES_CONVERSION; + + if (objc != 2) { + Tcl_WrongNumArgs (pInterp, 1, objv, "programmatic_libname"); + return TCL_ERROR; + } + + + TypeLib *ptl = NULL; + TObjPtr name, typedesc, types, tname; + HRESULT hr; + TYPEKIND tkind; + CComPtr pti; + int retresult = TCL_ERROR; + TYPEATTR *pta = NULL; + ULONG flags; + + + + types.create(); + name.attach(objv[1]); + if (!g_libs.find(name, &ptl)) { + Tcl_SetResult (pInterp, "can't find library name: ", TCL_STATIC); + Tcl_AppendResult (pInterp, (char*)name, NULL); + return TCL_ERROR; + } + + ASSERT (ptl != NULL && ptl->m_ptl != NULL); + UINT count = ptl->m_ptl->GetTypeInfoCount(); + try { + for (UINT index = 0; index < count; index++) { + + + // get the type of the typeinfo + hr = ptl->m_ptl->GetTypeInfoType (index, &tkind); + CHECKHR(hr); + + // get the next typeifo + pti = NULL; // free the last typeinfo + hr = ptl->m_ptl->GetTypeInfo (index, &pti); + CHECKHR(hr); + + ASSERT (pti != NULL); + + // check whether this is a restricted type + hr = pti->GetTypeAttr (&pta); + CHECKHR(hr); + flags = pta->wTypeFlags; + ReleaseTypeAttr(pti, pta); + + if (flags & TYPEFLAG_FRESTRICTED) + continue; // it is so skip the rest of this iteration + TypeLib_GetName(ptl->m_ptl, pti, tname); + + typedesc.create(); + typedesc.lappend (TYPEKIND2Str(tkind)).lappend(tname); + types.lappend (typedesc); + } + Tcl_SetObjResult (pInterp, types); + retresult = TCL_OK; + } + + catch (char *error) { + Tcl_SetResult (pInterp, error, TCL_VOLATILE); + } + catch (HRESULT hr) { + Tcl_SetResult (pInterp, (char*)HRESULT2Str(hr), TCL_DYNAMIC); + } + + return retresult; +} + + + + + + + + + +/* + *------------------------------------------------------------------------- + * TypeLib_TypeInfo -- + * Implements the typelib::typeinfo command. + * + * Result: + * Std Tcl result. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +TCL_CMDEF(TypeLib_TypeInfo) +{ + USES_CONVERSION; + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs (pInterp, 1, objv, "typename ?type_element_name?"); + return TCL_ERROR; + } + + TObjPtr tname; + TypeLib *ptl = NULL; + BSTR bsTypename = NULL; + + CComPtr pti; + CComPtr ptc; + int cmdresult = TCL_ERROR; + + try { + tname.attach(objv[1]); + TypeLib_ResolveName (tname, &ptl, &pti); + + + if (objc == 2) { // describing the entire type + cmdresult = TypeLib_DescribeTypeInfo (pInterp, pti); + } else { // describing a single element within the type + TObjPtr item; + item.attach (objv[2]); + cmdresult = TypeLib_DescribeTypeInfoElement (pInterp, pti, item); + } + } + + catch (char *error) { + if (error != NULL) + Tcl_SetResult (pInterp, error, TCL_VOLATILE); + } + + catch (HRESULT hr) { + Tcl_SetResult (pInterp, (char*)HRESULT2Str(hr), TCL_DYNAMIC); + } + + return cmdresult; +} + + +/* + *------------------------------------------------------------------------- + * TypeLib_ResolveName -- + * Resolves a library name and type name to a typeinfo. + * if pptl is not NULL then the TypeLib structure for this type is provided + * as the result, also. + * May throw an HRESULT or char*. + * + * Result: + * None. + * Side effects: + * + *------------------------------------------------------------------------- + */ +void TypeLib_ResolveName (const char * lib, const char * type, + TypeLib **pptl, ITypeInfo **ppinfo) +{ + ASSERT (lib != NULL && type != NULL && ppinfo != NULL); + HRESULT hr; + + TypeLib * ptl = NULL; + + // bind to the library + if (g_libs.find (lib, &ptl) == NULL) + throw ("failed to bind to library"); + + ASSERT (ptl != NULL && ptl->m_ptl != NULL); + if (ptl->m_ptc == NULL) + throw("library doesn't provide a compiling interface"); + if (pptl != NULL) + *pptl = ptl; + + // find the type info if required + if (ppinfo != NULL && type != NULL) { + hr = BindTypeInfo(ptl->m_ptc, type, ppinfo); + CHECKHR(hr); + if (*ppinfo == NULL) + throw ("failed to bind to type"); + } +} + + +/* + *------------------------------------------------------------------------- + * TypeLib_ResolveName -- + * Resolves a fully formed type name (ie lib.type) to its type info. + * if pptl is not NULL then the TypeLib structure for this type is provided + * as the result, also. + * Throws HRESULT or (char*) in case of error. Apologies for this error style - + * I know that its predominant in this file - I was simply experimenting :) + * + * Result: + * None. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void TypeLib_ResolveName (const char *name, TypeLib **pptl, ITypeInfo **ppinfo) +{ + ASSERT (name != NULL); + char * lib = NULL, + * type = NULL; + char * copy = new char [strlen (name) + 1]; + strcpy (copy, name); + + try { + lib = strtok (copy, "."); + type = strtok (NULL, "."); + if (type == NULL && ppinfo != NULL) + throw ("string is not properly formatted"); + TypeLib_ResolveName (lib, type, pptl, ppinfo); + delete_ptr (copy); + } + + catch (HRESULT hr) { + delete_ptr (copy); + throw (hr); + } + + catch (char * error) { + delete_ptr (copy); + throw (error); + } +} + + + + +/* + *------------------------------------------------------------------------- + * TypeLib_ResolveConstant -- + * + * Result: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ +bool TypeLib_ResolveConstant (Tcl_Interp *pInterp, ITypeInfo *pti, + const char *member, TObjPtr &pObj) +{ + ASSERT (pInterp != NULL && pti != NULL && member != NULL); + + USES_CONVERSION; + CComPtr ptc; + CComPtr ptmpti; + DESCKIND dk; + BINDPTR bp; bp.lpvardesc = NULL; + HRESULT hr; + LPOLESTR cnst = A2OLE (member); + +#ifdef _DEBUG + // *** TypeInfo must be an enumeration + TYPEATTR * pattr; + hr = pti->GetTypeAttr (&pattr); + CHECKHR(hr); + ASSERT (pattr->typekind == TKIND_ENUM); + pti->ReleaseTypeAttr (pattr); +#endif + + + try { + hr = pti->GetTypeComp (&ptc); + CHECKHR(hr); + + hr = ptc->Bind (cnst, LHashValOfName (LOCALE_SYSTEM_DEFAULT, cnst), + DISPATCH_PROPERTYGET, &ptmpti, &dk, &bp); + CHECKHR(hr); + if (dk == DESCKIND_NONE) + throw ("can't find constant"); + ASSERT (dk == DESCKIND_VARDESC || dk == DESCKIND_IMPLICITAPPOBJ); + + if (bp.lpvardesc->varkind != VAR_CONST) + throw ("member is not a constant"); + ASSERT (bp.lpvardesc->lpvarValue != NULL); + if (bp.lpvardesc->lpvarValue == NULL) + throw ("constant didn't have a associated value!"); + var2obj (pInterp, *(bp.lpvardesc->lpvarValue), pObj); + pti->ReleaseVarDesc (bp.lpvardesc); + return true; + } + + catch (char *e) { + if (bp.lpvardesc != NULL) + pti->ReleaseVarDesc (bp.lpvardesc); + + Tcl_SetResult (pInterp, (char*)member, TCL_VOLATILE); + Tcl_AppendResult (pInterp, ": ", e, NULL); + } + + catch (HRESULT hr) { + if (bp.lpvardesc != NULL) + pti->ReleaseVarDesc (bp.lpvardesc); + Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC); + } + return false; +} + + + + + +/* + *------------------------------------------------------------------------- + * TypeLib_ResolveConstant -- + * Attempts to resolve the name of a constant to its value, to be stored + * in pObj. An optional type info constrains the binding. + * Result: + * true iff successful. Else error in interpreter. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +bool TypeLib_ResolveConstant (Tcl_Interp *pInterp, char *szname, + TObjPtr &pObj, ITypeInfo *pTypeInfo /* = NULL */) +{ + ASSERT (pInterp != NULL && szname != NULL); + + const char *token = "."; + char *name; + char *szfirst; + TypeLib * ptl; + CComPtr pti; + + try { + if (pTypeInfo == NULL) + { + // we'll use the stack for our allocation - saves on clean-up code + name = (char*)alloca (strlen(szname) + 1); + if (name == NULL) throw (HRESULT(E_OUTOFMEMORY)); + + strcpy (name, szname); + SplitTypedString (name, &szfirst); + if (szfirst == NULL) + throw ("badly formed constant"); + + // at this point, name points to the name of the type, and + // szfirst points to the name of the constant + + // retrieve the typelibrary, info and compiler interfaces + TypeLib_ResolveName (name, &ptl, &pti); + return TypeLib_ResolveConstant (pInterp, pti, szfirst, pObj); + } else { + return TypeLib_ResolveConstant (pInterp, pTypeInfo, szname, pObj); + } + + + } + + catch (char *e) { + Tcl_SetResult (pInterp, szname, TCL_VOLATILE); + Tcl_AppendResult (pInterp, ": ", e, NULL); + } + + catch (HRESULT hr) { + Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC); + } + + return false; +} + + + +///// TEST CODE ///// + + +TCL_CMDEF(TypeLib_ResolveConstantTest) +{ + if (objc != 2 && objc != 3) + { + Tcl_WrongNumArgs (pInterp, 1, objv, "lib.type.member or lib.type member"); + return TCL_ERROR; + } + + TObjPtr result; + TObjPtr p1; + TObjPtr p2; + bool bOk; + + if (objc == 2) { + p1.attach(objv[1]); + bOk = TypeLib_ResolveConstant(pInterp, p1, result, NULL); + } else { + CComPtr pti; + TypeLib * ptl; + + p1.attach(objv[1]); + p2.attach(objv[2]); + + TypeLib_ResolveName (p1, &ptl, &pti); + bOk = TypeLib_ResolveConstant (pInterp, p2, result, pti); + } + if (bOk) { + Tcl_SetObjResult (pInterp, result); + return TCL_OK; + } else + return TCL_ERROR; +} + diff --git a/src/typelib.h b/src/typelib.h new file mode 100644 index 0000000..907709a --- /dev/null +++ b/src/typelib.h @@ -0,0 +1,81 @@ +/* + *------------------------------------------------------------------------------ + * typelib.h + * Declares a collection of function for accessing typelibraries. + * Currently this only includes browsing facilities. + * In the future, this may contain typelib building functionality. + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ + + +#ifndef _TYPELIB_H_62518A80_624A_11d4_8004_0040055861F2 +#define _TYPELIB_H_62518A80_624A_11d4_8004_0040055861F2 + +#include "tbase.h" + +// TypeLib provides the structure that holds the main pointer to the library ITypeLib +// interface, together with its compiler interface +struct TypeLib { + CComPtr m_ptl; + CComPtr m_ptc; + + TypeLib (ITypeLib *ptl, ITypeComp *ptc) { + m_ptl = ptl; + m_ptc = ptc; + } +}; + + + +// TypeLibsTbl - a hash table mapping library programmatic name to a TypeLib structure +// Internally it also holds a mapping from the a libraries human readable name to +// the same structure +class TypeLibsTbl : public THash +{ +public: + TypeLibsTbl (); + virtual ~TypeLibsTbl (); + void DeleteAll (); + ITypeLib* LoadLib (Tcl_Interp *pInterp, const char *fullname); + void UnloadLib (Tcl_Interp *pInterp, const char *fullname); + bool IsLibLoaded (const char *fullname); + TypeLib* EnsureCached (ITypeLib *pLib); + TypeLib* EnsureCached (ITypeInfo *pInfo); +protected: // methods + TypeLib* Cache (const char *szname, const char *szfullname, ITypeLib *ptl, ITypeComp *ptc); + +protected: // properties + THash m_loadedlibs; // by name +}; + +// globals +extern TypeLibsTbl g_libs; + + +void TypeLib_GetName (ITypeLib *, ITypeInfo *, TObjPtr &pname); +void TypeLib_ResolveName (const char *name, TypeLib **pptl, ITypeInfo **ppinfo); +void TypeLib_ResolveName (const char * lib, const char * type, TypeLib **pptl, ITypeInfo **ppinfo); +void ReleaseBindPtr (ITypeInfo *pti, DESCKIND dk, BINDPTR &ptr); +bool TypeLib_ResolveConstant (Tcl_Interp *pInterp, char *fullformatname, + TObjPtr &pObj, ITypeInfo *pInfo = NULL); +bool TypeLib_ResolveConstant (Tcl_Interp *pInterp, ITypeInfo *pti, + const char *member, TObjPtr &pObj); + + +#endif // _TYPELIB_H_62518A80_624A_11d4_8004_0040055861F2 \ No newline at end of file diff --git a/src/typelib.tcl b/src/typelib.tcl new file mode 100644 index 0000000..ac19136 --- /dev/null +++ b/src/typelib.tcl @@ -0,0 +1,622 @@ +package require registry +package provide optcl 3.0 + +namespace eval typelib { + variable syslibs + variable syslibguids + array set syslibs {} + array set syslibguids {} + + + # ----------------------------------------------------------------------------- + + # updatelibs -- called to enumerate and store the system libraries + proc updatelibs {} { + + variable syslibs; + catch {unset syslibs} + array set syslibs {} + + + set root {HKEY_CLASSES_ROOT\TypeLib} + foreach id [registry keys $root] { + catch { + foreach v [registry keys $root\\$id] { + scan $v "%d.%d" maj min; + if [catch { + set flags [registry get $root\\$id\\$v\\FLAGS {}]; + }] { set flags 0;} + + # check for restricted or hidden libraries + if {[expr ($flags & 1) || ($flags & 4)]} { + continue; + } + + set name "[registry get $root\\$id\\$v {}] (Ver $maj.$min)" + set syslibs($name) [list $id $maj $min] + } + } + } + } + + # ----------------------------------------------------------------------------- + + # categories -- returns the component categories + proc categories {} { + + set alldata {} + set k "HKEY_CLASSES_ROOT\\Component Categories" + set cats [registry keys $k] + + foreach cat $cats { + set values [registry values $k\\$cat] + set data {} + foreach value $values { + lappend data [registry get $k\\$cat $value] + } + lappend alldata $data + } + + return $alldata + } + + + + + # ----------------------------------------------------------------------------- + + # libdetail -- returns a the id, maj and min version number + # in a list if it exists, else throws an error + proc libdetail {name} { + variable syslibs + + if {[array names syslibs $name] == {}} { + error "could not find the library '$name'" + } + + return [lindex [array get syslibs $name] 1] + } + + + #------------------------------------------------------------------------------ + + # alllibs -- returns all the registered libraries by name + proc alllibs {} { + variable syslibs + return [array names syslibs] + } + + proc defaultinterface {classtype} { + set desc [typelib::typeinfo $classtype] + if {[llength $desc] != 3} { + error "$classtype is not a class" + } + set implintf [lindex $desc 2] + foreach intf $implintf { + if {[lsearch -exact [lindex $intf 0] default] >= 0} { + return [lindex $intf 1] + } + } + error "object doesn't have a default interface" + } + + #------------------------------------------------------------------------------ + updatelibs + +} + + + + + +if {[info commands tk] != {}} { + namespace eval tlview { + catch {font delete tlviewertext} + catch {font delete tlviewerhigh} + catch {font delete tlviewerbold} + font create tlviewertext -family Arial -size 9 -weight normal + font create tlviewerhigh -family Arial -size 9 -weight bold + font create tlviewerbold -family Arial -size 9 -weight bold + + variable bgcolor white + variable textcolor black + variable highlightcolor blue + variable selectcolor red + variable labelcolor red + + array set viewedtypes {} + + #------------------------------------------------------------------------------ + proc scrltxt {w {sb {x y}}} { + variable bgcolor; + frame $w -bd 2 -relief sunken; + + text $w.t -bg $bgcolor -bd 0 -relief flat -cursor arrow -width 40 -height 20 + grid $w.t -column 0 -row 0 -sticky nsew; + + if {[lsearch $sb x] >= 0} { + scrollbar $w.x -orient horizontal -command [list $w.t xview] + $w.t config -xscrollcommand [list $w.x set] -wrap none + grid $w.x -column 0 -row 1 -sticky ew; + } + if {[lsearch $sb y] >= 0} { + scrollbar $w.y -orient vertical -command [list $w.t yview] + $w.t config -yscrollcommand [list $w.y set] + grid $w.y -column 1 -row 0 -sticky ns; + } + + grid columnconfigure $w 0 -weight 1; + grid rowconfigure $w 0 -weight 1; + } + + + #------------------------------------------------------------------------------ + proc cl_list {w} { + variable bgcolor + frame $w -bd 2 -relief sunken + canvas $w.c -yscrollcommand "$w.v set" -xscrollcommand "$w.h set" -bd 0 -relief flat -cursor arrow -bg $bgcolor -highlightthickness 0 + scrollbar $w.h -orient horizontal -command "$w.c xview" + scrollbar $w.v -orient vertical -command "$w.c yview" + + grid $w.c -column 0 -row 0 -sticky news + grid $w.h -column 0 -row 1 -sticky ew + grid $w.v -column 1 -row 0 -sticky ns + grid columnconfigure $w 0 -weight 1 + grid rowconfigure $w 0 -weight 1 + bind $w.c <1> { focus %W } + bind $w.c { %W yview scroll -1 pages} + bind $w.c { %W yview scroll 1 pages} + return $w + } + + + + proc cl_list_update {w} { + variable ::typelib::syslibs + variable bgcolor + + if {![winfo exists $w]} { + error "expected to find a TypeLib list widget: $w" + } + + set c $w.c + $c delete all + + foreach tl [lsort [array names ::typelib::syslibs]] { + cl_list_addlib $w $tl + } + } + + + + proc cl_list_addlib {w tl} { + variable bgcolor + + set c $w.c + set bbox [$c bbox entry] + if {$bbox == {}} {set bbox {0 0 10 10}} + set bottom [lindex $bbox 3] + set bottom [expr int($bottom) + 3] + set tag [$c create text 10 $bottom -anchor nw -fill black -font tlviewertext -justify left -text $tl -tags entry] + $c bind $tag <1> [namespace code "cl_list_press $w $tag"] + cl_list_updatetag $w $tag + + set bbox [$c bbox entry] + set sr [list 0 0 [lindex $bbox 2] [expr $bottom + 20]] + $c config -scrollregion $sr + } + + + proc cl_list_updatetag {w tag} { + variable textcolor + variable highlightcolor + + set c $w.c + set tl [$c itemcget $tag -text] + + if {![typelib::isloaded $tl]} { + $c itemconfig $tag -fill $textcolor -font tlviewertext + } else { + $c itemconfig $tag -fill $highlightcolor -font tlviewerhigh + } + } + + + proc cl_list_press {w tag} { + set c $w.c + set tl [$c itemcget $tag -text] + set parent [winfo parent $w] + + if {![typelib::isloaded $tl]} { + # loading typelib + if {[catch {typelib::load $tl} progname]} { + puts $progname + $parent.error config -text [string trim $progname] + } else { + puts "loaded $progname" + $parent.error config -text "loaded $progname" + loadedlibs_updateall + } + } else { + typelib::unload $tl + puts "unloaded $tl" + $parent.error config -text "unloaded $tl" + loadedlibs_updateall + } + + cl_list_updatetag $w $tag + } + + + + proc refview {w} { + toplevel $w + wm title $w "Referenced Type Libraries" + bind $w "destroy $w" + bind $w "$w.close invoke" + bind $w "$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 "$w.l.t config -cursor hand2; $w.l.t tag config tag$lib -underline 1" + $w.l.t tag bind tag$lib "$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 [namespace code "loadedlibs_update $w"] + } + + #------------------------------------------------------------------------------ + proc viewlib_onenter {txt tag} { + $txt config -cursor hand2 + $txt tag config $tag -underline 1 + } + + proc viewlib_onleave {txt tag} { + $txt config -cursor arrow + $txt tag config $tag -underline 0 + } + + proc viewlib_unselect {txt lib} { + variable viewedtypes + variable textcolor + if {[array name viewedtypes $lib] != {}} { + set type $viewedtypes($lib) + $txt tag config tag$type -foreground $textcolor -font tlviewertext + set viewedtypes($lib) {} + } + } + + + + proc viewlib_select {fulltype } { + variable viewedtypes + variable highlightcolor + + puts $fulltype + set sp [split $fulltype .] + if {[llength $sp] != 2} { + return + } + + set lib [lindex $sp 0] + set type [lindex $sp 1] + + set w [viewlib $lib] + set txt $w.types.t + + viewlib_unselect $txt $lib + $txt tag config tag$type -foreground $highlightcolor -font tlviewerhigh + + $txt see [lindex [$txt tag ranges tag$type] 0] + set viewedtypes($lib) $type + viewlib_readelems $w $lib $type; + } + + + proc viewlib_selectelem {w fulltype element} { + variable viewedtypes + variable highlightcolor + + puts "$fulltype $element" + set sp [split $fulltype .] + set lib [lindex $sp 0] + set type [lindex $sp 1] + + set txt $w.elems.t + + viewlib_unselect $txt $fulltype + $txt tag config tag$element -foreground $highlightcolor -font tlviewerhigh + $txt see [lindex [$txt tag ranges tag$element] 0] + set viewedtypes($fulltype) $element + viewlib_readdesc $w $lib $type $element + } + + ### + # creates a list of types in some library + proc viewlib_readtypes {w lib} { + variable textcolor + set txt $w.types.t + + $txt config -state normal + $txt del 1.0 end + + foreach tdesc [lsort [typelib::types $lib]] { + $txt insert end "[lindex $tdesc 0]\t" + set full [lindex $tdesc 1] + set type [lindex [split $full .] 1] + $txt tag configure tag$type -foreground $textcolor -font tlviewertext -underline 0 + $txt insert end "$type\n" tag$type + $txt tag bind tag$type <1> [namespace code " + viewlib_select $full; + "] + + $txt tag bind tag$type [namespace code "viewlib_onenter $txt tag$type"] + $txt tag bind tag$type [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 [namespace code "viewlib_onenter $txt tag$fulltype"] + $txt tag bind tag$fulltype [namespace code "viewlib_onleave $txt tag$fulltype"] + $txt tag bind tag$fulltype <1> [namespace code "viewlib_select $fulltype"] + $txt insert end "$fulltype" tag$fulltype + } else { + $txt insert end "$fulltype" + } + } + + + ### + # displays the elements for a type of some library + proc viewlib_readelems {w lib type} { + variable labelcolor + variable textcolor + variable highlightcolor + + set txt $w.elems.t + $txt config -state normal + $txt del 1.0 end + set elems [typelib::typeinfo $lib.$type] + loadedlibs_updateall + + $txt tag configure label -font tlviewerhigh -underline 1 -foreground $labelcolor + + if {[string compare "typedef" [lindex $elems 0]] == 0} { + # --- we are working with a typedef + set t [lindex $elems 3] + $txt insert end "Typedef\n\t" label + viewlib_writetype $txt $t + } else { + if {[llength [lindex $elems 1]] != 0} { + $txt insert end "Methods\n" label + } + + foreach method [lsort [lindex $elems 1]] { + $txt tag configure tag$method -foreground $textcolor -font tlviewertext -underline 0 + $txt tag bind tag$method [namespace code "viewlib_onenter $txt tag$method"] + $txt tag bind tag$method [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 [namespace code "viewlib_onenter $txt tag$prop"] + $txt tag bind tag$prop [namespace code "viewlib_onleave $txt tag$prop"] + $txt tag bind tag$prop <1> [namespace code "viewlib_selectelem $w $lib.$type $prop"] + $txt insert end "\t$prop\n" tag$prop + } + + if {[llength [lindex $elems 3]] != 0} { + $txt insert end "Inherited Types\n" label + } + + foreach impl [lsort -index 1 [lindex $elems 3]] { + # implemented interfaces + set t [lindex $impl 1] + set flags [lindex $impl 0] + if {[lsearch -exact $flags default] != -1} { + $txt insert end "*" + } + + if {[lsearch -exac $flags source] != -1} { + $txt insert end "event" + } + $txt insert end "\t" + + $txt tag configure itag$t -foreground $highlightcolor -font tlviewertext -underline 0 + $txt tag bind itag$t [namespace code "viewlib_onenter $txt itag$t"] + $txt tag bind itag$t [namespace code "viewlib_onleave $txt itag$t"] + $txt tag bind itag$t <1> [namespace code "viewlib_select $t"] + + $txt insert end "$t\n" itag$t + } + } + $txt config -state disabled + viewlib_settypedoc $w [lindex $elems 4] + } + + + proc viewlib_settypedoc {w doc} { + set txt $w.desc.t + $txt config -state normal + $txt delete 1.0 end + $txt insert end $doc + $txt config -state disabled + } + + + ### + # retrieves the description for an element + proc viewlib_readdesc {w lib type elem} { + variable labelcolor + + set txt $w.desc.t + $txt config -state normal + $txt delete 1.0 end + + $txt tag configure label -font tlviewerhigh -underline 1 -foreground $labelcolor + $txt tag configure element -font tlviewerbold + $txt tag bind element [namespace code "viewlib_onenter $txt element"] + $txt tag bind element [namespace code "viewlib_onleave $txt element"] + + $txt tag bind element <1> [namespace code "viewlib_select $lib.$type; viewlib_selectelem $w $lib.$type $elem"] + + set desc [typelib::typeinfo $lib.$type $elem] + set kind [lindex $desc 0] + switch $kind { + property { + $txt insert end "Property" label + $txt insert end "\t[lindex $desc 2]\n" + + set p [lindex $desc 1] + # insert the flags + $txt insert end "[lindex $p 0]\t" + viewlib_writetype $txt [lindex $p 1] + $txt insert end " " + $txt insert end "[lindex $p 2]" element + + set params [lrange $p 3 end] + + foreach param $params { + $txt insert end "\n\t" + + if {[llength $param] == 3} { + $txt insert end "[lindex $param 0]\t" + set param [lrange $param 1 end] + } + viewlib_writetype $txt [lindex $param 0] + $txt insert end " [lrange $param 1 end]" + } + } + + method { + set m [lindex $desc 1] + $txt insert end "Method" label + $txt insert end "\t[lindex $desc 2]\n" + viewlib_writetype $txt [lindex $m 0] + $txt insert end " " + $txt insert end "[lindex $m 1]" element + set params [lrange $m 2 end] + + foreach param $params { + $txt insert end "\n\t" + + if {[llength $param] == 3} { + $txt insert end "[lindex $param 0]\t" + set param [lrange $param 1 end] + } + viewlib_writetype $txt [lindex $param 0] + $txt insert end " [lrange $param 1 end]" + } + } + } + + puts [lindex $desc 1] + $txt config -state disabled + } + + + #### + # Creates a viewer for library + proc viewlib {lib} { + set w ._tlview$lib + if [winfo exists $w] { + raise $w + return $w + } + toplevel $w -class tlview_$lib + wm title $w "Type Library: $lib" + + label $w.tl -text Types; + label $w.el -text Elements; + label $w.dl -text Description; + + scrltxt $w.types; + scrltxt $w.elems + scrltxt $w.desc y + $w.desc.t config -height 5 + $w.desc.t config -state disabled + $w.elems.t config -state disabled + $w.types.t config -state disabled + + grid $w.tl -column 0 -row 0 -sticky nw + grid $w.types -column 0 -row 1 -sticky news -padx 2 -pady 2 + grid $w.el -column 1 -row 0 -sticky nw + grid $w.elems -column 1 -row 1 -sticky news -padx 2 -pady 2 + grid $w.dl -column 0 -row 2 -sticky nw + grid $w.desc -column 0 -row 3 -columnspan 2 -sticky news -padx 2 -pady 2 + + grid columnconfigure $w 0 -weight 1 + grid columnconfigure $w 1 -weight 1 + grid rowconfigure $w 1 -weight 1 + #grid rowconfigure $w 3 -weight 1 + + viewlib_readtypes $w $lib + return $w + } + + + proc viewtype {fullname} { + viewlib_select $fullname + } + } +} \ No newline at end of file diff --git a/src/utility.cpp b/src/utility.cpp new file mode 100644 index 0000000..ea4bba6 --- /dev/null +++ b/src/utility.cpp @@ -0,0 +1,1045 @@ +/* + *------------------------------------------------------------------------------ + * utility.cpp + * Implements a collection of often used, general purpose functions. + * I've also placed the variant/Tcl_Obj conversion functions here. + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ + + +#include "stdafx.h" +#include "tbase.h" +#include "utility.h" +#include "optcl.h" +#include "objmap.h" +#include "typelib.h" +#include "optclobj.h" +#include "optcltypeattr.h" + +#ifdef _DEBUG +/* + *------------------------------------------------------------------------- + * OptclTrace -- + * Performs a debugging service similar to printf. Works only under debug. + * #defined to TRACE(formatstring, ....) + * Result: + * None. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void OptclTrace(LPCTSTR lpszFormat, ...) +{ + va_list args; + va_start(args, lpszFormat); + + int nBuf; + TCHAR szBuffer[512]; + + nBuf = _vsntprintf(szBuffer, _countof(szBuffer), lpszFormat, args); + + // was there an error? was the expanded string too long? + ASSERT(nBuf >= 0); + + OutputDebugString (szBuffer); + va_end(args); +} +#endif //_DEBUG + + +/* + *------------------------------------------------------------------------- + * HRESULT2Str -- + * Converts an HRESULT to a Tcl allocated string. + * + * Result: + * The string if not null. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +char * HRESULT2Str (HRESULT hr) +{ + + USES_CONVERSION; + + LPTSTR szMessage; + char *message; + char *tclmessage; + + if (HRESULT_FACILITY(hr) == FACILITY_WINDOWS) + hr = HRESULT_CODE(hr); + + FormatMessage( + FORMAT_MESSAGE_ALLOCATE_BUFFER | + FORMAT_MESSAGE_FROM_SYSTEM, + NULL, + hr, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), //The user default language + (LPTSTR)&szMessage, + 0, + NULL ); + + // conversion to char * if unicode + message = T2A (szMessage); + tclmessage = Tcl_Alloc(strlen(message)+1); + strcpy(tclmessage, message); + for (char *i = tclmessage; *i != 0; i++) + if (*i == '\r') *i = ' '; + LocalFree(szMessage); + return tclmessage; +} + + + + +/* + *------------------------------------------------------------------------- + * FreeBSTR -- + * If not NULL, releases the BSTR and sets it to NULL. + * + * Result: + * None. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void FreeBSTR (BSTR &bstr) +{ + if (bstr != NULL) { + SysFreeString (bstr); + bstr = NULL; + } +} + + +/* + *------------------------------------------------------------------------- + * FreeBSTRArray -- + * Releases an array of BSTR and sets them to NULL, if not already. + * + * Result: + * None. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void FreeBSTRArray (BSTR * bstr, UINT count) +{ + if (bstr == NULL) return; + for (UINT index = 0; index < count; index++) + { + FreeBSTR (bstr[index]); + } +} + + + +/* + *------------------------------------------------------------------------- + * ExceptInfo2Str -- + * Converts an EXCEPINFO structure to a Tcl allocated string. + * + * Result: + * The string if not null. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +char * ExceptInfo2Str (EXCEPINFO *pe) +{ + USES_CONVERSION; + + ASSERT (pe != NULL); + char * str = NULL; + HRESULT hr; + + char* stderror = "unknown error"; + + if (pe->bstrDescription == NULL) { + if (pe->pfnDeferredFillIn != NULL) { + hr = (pe->pfnDeferredFillIn)(pe); + if (FAILED (hr) || pe->bstrDescription==NULL) + return HRESULT2Str(hr); + } + else + { + str = Tcl_Alloc (strlen(stderror)+1); + strcpy (str, stderror); + return str; + } + } + + TDString s; + s.set("error - "); + + if (pe->bstrSource != NULL) + s << "source: \"" << W2A(pe->bstrSource) << "\" "; + s << "description: \"" << W2A(pe->bstrDescription) << "\""; + str = Tcl_Alloc(s.length () + 1); + strcpy (str, s); + return str; +} + + + +/* + *------------------------------------------------------------------------- + * Name2ID -- + * Converts a name of a dispatch member to an id. + * Result: + * Either DISPID_UNKNOWN if failed or the dispid. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +DISPID Name2ID (IDispatch *pdisp, const char *name) +{ + USES_CONVERSION; + ASSERT (pdisp != NULL && name != NULL); + LPOLESTR olestr = A2OLE ((char*)name); + DISPID dispid = DISPID_UNKNOWN; + + pdisp->GetIDsOfNames (IID_NULL, &olestr, 1, LOCALE_SYSTEM_DEFAULT, &dispid); + return dispid; +} + + +/* + *------------------------------------------------------------------------- + * Name2ID -- + * Converts a name (OLE string) of a dispatch member to an id. + * Result: + * Either DISPID_UNKNOWN if failed or the dispid. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +DISPID Name2ID (IDispatch *pdisp, const LPOLESTR olename) +{ + DISPID dispid = DISPID_UNKNOWN; + pdisp->GetIDsOfNames (IID_NULL, (LPOLESTR*)&olename, 1, LOCALE_SYSTEM_DEFAULT, &dispid); + return dispid; +} + + + +void OptclVariantClear (VARIANT *pvar) +{ + ASSERT (pvar != NULL); + if ((pvar->vt & VT_BYREF) || pvar->vt == VT_VARIANT) { + switch (pvar->vt & (~VT_BYREF)) { + case VT_VARIANT: + OptclVariantClear (pvar->pvarVal); + g_pmalloc->Free (pvar->pvarVal); + break; + case VT_ERROR: + case VT_I2: + case VT_UI1: + g_pmalloc->Free (pvar->piVal); + break; + // long + case VT_HRESULT: + case VT_I4: + case VT_UI2: + case VT_INT: + g_pmalloc->Free (pvar->plVal); + break; + // float + case VT_R4: + g_pmalloc->Free (pvar->pfltVal); + break; + + // double + case VT_R8: + g_pmalloc->Free (pvar->pdblVal); + break; + + // boolean + case VT_BOOL: + g_pmalloc->Free (pvar->pboolVal); + break; + // object + case VT_UNKNOWN: + case VT_DISPATCH: + if (pvar->ppunkVal != NULL) { + (*(pvar->ppunkVal))->Release(); + g_pmalloc->Free (pvar->ppunkVal); + } + break; + case VT_CY: + g_pmalloc->Free (pvar->pcyVal); + break; + case VT_DATE: + g_pmalloc->Free (pvar->pdate); + break; + case VT_BSTR: + if (pvar->pbstrVal != NULL) { + SysFreeString (*(pvar->pbstrVal)); + g_pmalloc->Free (pvar->pbstrVal); + } + break; + case VT_RECORD: + case VT_VECTOR: + case VT_ARRAY: + case VT_SAFEARRAY: + ASSERT (FALSE); // case not handled yet + break; + + default: + ASSERT (FALSE); // unknown type + } + } + else + VariantClear (pvar); +} + + + + +bool var2obj_byref (Tcl_Interp *pInterp, VARIANT &var, TObjPtr &presult, OptclObj **ppObj) +{ + ASSERT (var.ppunkVal != NULL); + + USES_CONVERSION; + + bool bOk = false; + BSTR bstr = NULL; + HRESULT hr = S_OK; + OptclObj * pObj = NULL; + + + presult.create(); + if (var.ppunkVal == NULL) { + presult = 0; + return true; + } + try { + switch (var.vt & ~VT_BYREF) + { + case VT_DISPATCH: + case VT_UNKNOWN: + if (*var.ppunkVal != NULL) { + pObj = g_objmap.Add (pInterp, *var.ppunkVal); + presult = (const char*)(*pObj); // cast to char* + if (ppObj != NULL) + *ppObj = pObj; + } + else + presult = 0; + break; + case VT_BOOL: + presult = (bool)(*var.pboolVal != 0); + break; + + case VT_ERROR: + case VT_I2: + presult = *var.piVal; + break; + + case VT_HRESULT: + case VT_I4: + case VT_UI2: + case VT_INT: + presult = *var.plVal; + break; + case VT_R4: + presult = (double)(*var.pfltVal); + break; + case VT_R8: + presult = (double)(*var.pdblVal); + break; + case VT_BSTR: + presult = OLE2A(*var.pbstrVal); + break; + case VT_CY: + hr = VarBstrFromCy (*var.pcyVal, LOCALE_SYSTEM_DEFAULT, NULL, &bstr); + CHECKHR_TCL(hr, pInterp, false); + break; + case VT_DATE: + hr = VarBstrFromDate (*var.pdblVal, LOCALE_SYSTEM_DEFAULT, NULL, &bstr); + CHECKHR_TCL(hr, pInterp, false); + break; + case VT_VARIANT: + if (var.pvarVal == NULL) { + Tcl_SetResult (pInterp, "pointer to null", TCL_STATIC); + bOk = false; + } else { + bOk = var2obj (pInterp, *var.pvarVal, presult, ppObj); + } + break; + default: + presult = "?unhandledtype?"; + } + bOk = true; + if (bstr != NULL) { + presult = OLE2A(bstr); + SysFreeString (bstr); bstr = NULL; + } + } + catch (char *err) { + Tcl_SetResult (pInterp, err, TCL_VOLATILE); + } + return bOk; +} + + +/* + *------------------------------------------------------------------------- + * var2obj -- + * Converts a variant to a Tcl_Obj without type information. + * Result: + * true iff successful, else interpreter holds error string. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +bool var2obj (Tcl_Interp *pInterp, VARIANT &var, TObjPtr &presult, OptclObj **ppObj /* = NULL*/) +{ + USES_CONVERSION; + + ASSERT (pInterp != NULL); + ASSERT (ppObj == NULL || *ppObj == NULL); + + + OptclObj * pObj = NULL; + _variant_t comvar; + HRESULT hr = S_OK; + _bstr_t name; + bool bOk = false; + + + if ((var.vt & VT_ARRAY) || (var.vt & VT_VECTOR)) { + Tcl_SetResult (pInterp, "can't handle arrays or vectors for now", TCL_STATIC); + return false; + } + + if (var.vt == VT_VARIANT) { + ASSERT (var.pvarVal != NULL); + return var2obj (pInterp, *(var.pvarVal), presult, ppObj); + } + + if (var.vt & VT_BYREF) + return var2obj_byref (pInterp, var, presult, ppObj); + + presult.create(); + + try { + switch (var.vt) + { + case VT_DISPATCH: + case VT_UNKNOWN: + if (var.punkVal != NULL) { + pObj = g_objmap.Add (pInterp, var.punkVal); + presult = (const char*)(*pObj); // cast to char* + if (ppObj != NULL) + *ppObj = pObj; + } + else + presult = 0; + break; + case VT_BOOL: + presult = (bool)(var.boolVal != 0); + break; + case VT_I2: + presult = var.iVal; + break; + case VT_I4: + presult = var.lVal; + break; + case VT_R4: + presult = (double)(var.fltVal); + break; + case VT_R8: + presult = (double)(var.dblVal); + break; + default: // standard string conversion required + comvar = var; + name = comvar; + presult = (char*)name; + } + bOk = true; + } + + catch (HRESULT hr) { + Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC); + } + catch (_com_error ce) { + Tcl_SetResult (pInterp, T2A((TCHAR*)ce.ErrorMessage()), TCL_VOLATILE); + } + catch (char *err) { + Tcl_SetResult (pInterp, err, TCL_VOLATILE); + } + + return bOk; +} + + + + + + + +/* + *------------------------------------------------------------------------- + * obj2var_ti -- + * converts a Tcl_Obj to a variant using type information. + * + * Result: + * true iff successful, else interpreter holds error string. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +// nb - pInfo is the context for pdesc +bool obj2var_ti (Tcl_Interp *pInterp, TObjPtr &obj, VARIANT &var, + ITypeInfo *pInfo, TYPEDESC *pdesc) +{ + ASSERT ((pInfo == NULL && pdesc == NULL) || (pInfo != NULL && pdesc != NULL)); + ASSERT (pInterp != NULL); + + OptclTypeAttr ota; + CComPtr pcurrent; + CComPtr ptmpunk; + HRESULT hr; + TObjPtr ptmp; + bool bOk = false; + OptclObj * pOptclObj = NULL; + long lValue; + + // if no type description has been provided, do a simple conversion + if (pdesc == NULL) { + obj2var (obj, var); + bOk = true; + } + + // a simple type + else if (pdesc->vt != VT_USERDEFINED && pdesc->vt != VT_SAFEARRAY) { + if (pdesc->vt != VT_PTR) + return obj2var_vt (pInterp, obj, var, pdesc->vt); + else { + ASSERT (pdesc->lptdesc->vt != VT_PTR && + pdesc->lptdesc->vt != VT_USERDEFINED && + pdesc->lptdesc->vt != VT_SAFEARRAY); + + if (pdesc->lptdesc->vt == VT_PTR || + pdesc->lptdesc->vt == VT_USERDEFINED || + pdesc->lptdesc->vt == VT_SAFEARRAY) + { + Tcl_SetResult (pInterp, "can't convert - optcl doesn't support level of de-referencing", TCL_STATIC); + return false; + } + return obj2var_vt_byref (pInterp, obj, var, pdesc->lptdesc->vt); + } + } + + // arrays - should be easy to do - not enough time right now... + else if (pdesc->vt == VT_SAFEARRAY) { + // wont do arrays for now. + Tcl_SetResult (pInterp, "optcl doesn't currently handle array types", TCL_STATIC); + } + + else { + // type information provided and it refers to a user defined type + // resolve the initial type + + hr = pInfo->GetRefTypeInfo (pdesc->hreftype, &ota.m_pti); + CHECKHR(hr); + g_libs.EnsureCached (ota.m_pti); + hr = ota.GetTypeAttr(); + CHECKHR(hr); + ASSERT (ota.m_pattr != NULL); + pcurrent = pInfo; + + while (ota->typekind == TKIND_ALIAS && + ota->tdescAlias.vt == VT_USERDEFINED) + { + HREFTYPE href = ota->tdescAlias.hreftype; + pcurrent = ota.m_pti; + ota = NULL; // release the type attribute and type info + pcurrent->GetRefTypeInfo (href, &ota.m_pti); + hr = ota.GetTypeAttr(); + CHECKHR(hr); + } + + // we've now climbed back up the alias chain and have one of the following: + // enum, record, module, interface, dispatch, coclass, union or alias to a basic type + // The following we can't (currently) do anything useful with: record, union, module. + + if (ota.m_pattr->typekind == TKIND_ALIAS) + return obj2var_ti (pInterp, obj, var, pcurrent, &(ota->tdescAlias)); + + + TYPEKIND tk = ota->typekind; // the metaclass + GUID intfguid = ota->guid; + + + switch (tk) + { + case TKIND_ENUM: + if (bOk = (Tcl_GetLongFromObj (NULL, obj, &lValue) == TCL_OK)) + obj2var(obj, var); + else if (bOk = TypeLib_ResolveConstant (pInterp, obj, ptmp, ota.m_pti)) + obj2var (ptmp, var); + break; + + case TKIND_DISPATCH: + case TKIND_INTERFACE: + // both these case require an object with the correct interface + pOptclObj = g_objmap.Find (obj); + if (pOptclObj != NULL) { + ptmpunk = (IUnknown*)(*pOptclObj); + ASSERT (ptmpunk != NULL); + hr = ptmpunk->QueryInterface (intfguid, (void**)&(var.punkVal)); + CHECKHR(hr); + V_VT(&var) = VT_UNKNOWN; + bOk = true; + } else + ObjectNotFound (pInterp, obj); + break; + + case TKIND_COCLASS: + pOptclObj = g_objmap.Find (obj); + if (pOptclObj != NULL) { + var.punkVal = (IUnknown*)(*pOptclObj); + var.punkVal->AddRef(); + V_VT(&var) = VT_UNKNOWN; + bOk = true; + } else + ObjectNotFound (pInterp, obj); + break; + + case TKIND_ALIAS: + ASSERT (FALSE); // should be hanlded above. + break; + + // can't handle these types + case TKIND_MODULE: + case TKIND_RECORD: + case TKIND_UNION: + obj2var (obj, var); + bOk = true; + break; + + default: + break; + } + } + + return bOk; +} + + + + + + + +/* + *------------------------------------------------------------------------- + * obj2var -- + * Converts a Tcl object to a variant without type information. + * If the Tcl object is null, then sets the value to zero. + * Result: + * None. + * + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void obj2var (TObjPtr &obj, VARIANT &var) +{ + _variant_t v; + ASSERT (var.vt == VT_EMPTY); + try { + if (obj.isnull()) { + var.lVal = 0; + var.vt = VT_I4; + } else { + + if (Tcl_GetLongFromObj (NULL, obj, &V_I4(&var)) == TCL_OK) + V_VT(&var) = VT_I4; + + else if (Tcl_GetDoubleFromObj (NULL, obj, &V_R8(&var)) == TCL_OK) + V_VT(&var) = VT_R8; + + else { + v.Attach (var); + v = (char*)(obj); + var = v.Detach(); + } + + #if _DEBUG + if (obj->typePtr != NULL) { + TRACE ("%s\n", obj->typePtr->name); + } + #endif // _DEBUG + } + } + + catch (_com_error ce) { + throw (HRESULT(ce.Error())); + } +} + + +static char memerr[] = "out of memory"; + +#define CHECKMEM_TCL(x, interp, action) if ((x) == NULL) { \ + Tcl_SetResult (interp, memerr, TCL_STATIC); \ + action; \ +} + +bool obj2var_vt_byref (Tcl_Interp *pInterp, TObjPtr &obj, VARIANT &var, VARTYPE vt) +{ + USES_CONVERSION; + + ASSERT ((vt & VT_BYREF) == 0); // we know that this is a BYREF variant - we don't want it in the vt + OptclObj * pOptclObj = NULL; + bool bok = true; + IUnknown * pUnk= NULL; + VARIANT temp; + + + if (vt == VT_VARIANT) { + var.pvarVal = (VARIANT*)g_pmalloc->Alloc (sizeof(VARIANT)); + CHECKMEM_TCL(var.pvarVal, pInterp, return false); + VariantInit (var.pvarVal); + if (!obj2var_vt (pInterp, obj, *var.pvarVal, vt)) { + g_pmalloc->Free(var.pvarVal); + var.pvarVal = NULL; + return false; + } + var.vt = vt | VT_BYREF; + return true; + } + + + VariantInit(&temp); + // perform the conversion into a temporary variant + if (!obj2var_vt (pInterp, obj, temp, vt)) + return false; + + + switch (temp.vt) { + // short + case VT_ERROR: + case VT_I2: + case VT_UI1: + var.piVal = (short*)g_pmalloc->Alloc (sizeof(short)); + CHECKMEM_TCL(var.pvarVal, pInterp, bok = false); + if (bok) *var.piVal = temp.iVal; + break; + + // long + case VT_HRESULT: + case VT_I4: + case VT_UI2: + case VT_INT: + var.plVal = (long*)g_pmalloc->Alloc (sizeof(long)); + CHECKMEM_TCL(var.plVal, pInterp, bok = false); + if (bok) *var.plVal = temp.lVal; + break; + + // float + case VT_R4: + var.pfltVal = (float*)g_pmalloc->Alloc(sizeof(float)); + CHECKMEM_TCL(var.pfltVal, pInterp, bok = false); + if (bok) *var.pfltVal = temp.fltVal; + break; + + // double + case VT_R8: + var.pdblVal = (double*)g_pmalloc->Alloc(sizeof(double)); + CHECKMEM_TCL(var.pdblVal, pInterp, bok = false); + if (bok) *var.pdblVal = temp.dblVal; + break; + + // boolean + case VT_BOOL: + var.pboolVal = (VARIANT_BOOL*)g_pmalloc->Alloc(sizeof(VARIANT_BOOL)); + CHECKMEM_TCL(var.pboolVal, pInterp, bok = false); + if (bok) *var.pboolVal = temp.boolVal; + break; + + // object + case VT_UNKNOWN: + case VT_DISPATCH: + // now allocate the memory + var.ppunkVal = (LPUNKNOWN*)g_pmalloc->Alloc(sizeof (LPUNKNOWN)); + CHECKMEM_TCL(var.ppunkVal, pInterp, bok = false); + if (bok) { + *var.ppunkVal = temp.punkVal; + if (*var.ppunkVal != NULL) + (*var.ppunkVal)->AddRef(); + } + break; + + case VT_CY: + var.pcyVal = (CY*)g_pmalloc->Alloc(sizeof(CY)); + CHECKMEM_TCL(var.pcyVal, pInterp, bok = false); + if (bok) *var.pcyVal = temp.cyVal; + break; + case VT_DATE: + var.pdate = (DATE*)g_pmalloc->Alloc(sizeof(DATE)); + CHECKMEM_TCL(var.pdate, pInterp, bok = false); + if (bok) *var.pdate = temp.date; + break; + case VT_BSTR: + var.pbstrVal = (BSTR*)g_pmalloc->Alloc(sizeof(BSTR)); + CHECKMEM_TCL(var.pdate, pInterp, bok = false); + if (bok) { + *var.pbstrVal = SysAllocStringLen (temp.bstrVal, SysStringLen(temp.bstrVal)); + if (*var.pbstrVal == NULL) { + g_pmalloc->Free (var.pbstrVal); var.pbstrVal = NULL; + Tcl_SetResult (pInterp, memerr, TCL_STATIC); + bok = false; + } + } + + break; + case VT_RECORD: + case VT_VECTOR: + case VT_ARRAY: + case VT_SAFEARRAY: + ASSERT (FALSE); // case not handled yet + break; + + default: + ASSERT (FALSE); // should never get here. + } + + var.vt = temp.vt | VT_BYREF; + VariantClear(&temp); + return bok; +} + + +/* + *------------------------------------------------------------------------- + * obj2var_vt -- + * Converts a Tcl object to a variant of a certain type. + * Result: + * None. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +bool obj2var_vt (Tcl_Interp *pInterp, TObjPtr &obj, VARIANT &var, VARTYPE vt) +{ + ASSERT ((vt & VT_BYREF) == 0); // house rules: no by-reference variants here! + + OptclObj *pOptclObj = NULL; + IUnknown * ptmpunk = NULL; + bool bOk = true; + HRESULT hr; + + switch (vt) + { + case VT_DISPATCH: + case VT_UNKNOWN: + V_VT(&var) = vt; + if (obj.isnull()) + var.punkVal = NULL; + else { + // attempt to cast from an optcl object + pOptclObj = g_objmap.Find (obj); + + + if (pOptclObj != NULL) { // found it? + ptmpunk = (IUnknown*)(*pOptclObj); // pull out the IUnknown pointer + ASSERT (ptmpunk != NULL); + if (vt == VT_DISPATCH) { // query to IDispatch iff required + hr = ptmpunk->QueryInterface (IID_IDispatch, (VOID**)&ptmpunk); + CHECKHR_TCL(hr, pInterp, false); + } + else + ptmpunk->AddRef(); // if not IDispatch, make sure we incr the refcount + var.punkVal = ptmpunk; + } + else { + ObjectNotFound (pInterp, obj); + bOk = false; + } + } + break; + default: + obj2var (obj, var); + if (vt != VT_VARIANT) { + HRESULT hr = VariantChangeType (&var, &var, NULL, vt); + if (FAILED (hr)) { + Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC); + bOk = false; + } + } + break; + } + return bOk; +} + + + +/* + *------------------------------------------------------------------------- + * ObjectNotFound -- + * Standard error message when an optcl object is not found. + * Result: + * TCL_ERROR always. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +int ObjectNotFound (Tcl_Interp *pInterp, const char *name) +{ + Tcl_SetResult (pInterp, "could not find object '", TCL_STATIC); + Tcl_AppendResult (pInterp, (char*)name, "'", NULL); + return TCL_ERROR; +} + + + +/* + *------------------------------------------------------------------------- + * SplitTypedString -- + * If pstr is of the format "a.b.c" then it is modified such that + * pstr == "a.b" and *ppsecond = "c" + * Otherwise, pstr will point to the original string and *ppsecond will + * be NULL. + * Result: + * None. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +void SplitTypedString (char *pstr, char ** ppsecond) +{ + const char * token = "."; + ASSERT (pstr != NULL && ppsecond != NULL); + + char *p = pstr; + while (*p != '.' && *p != '\0') p++; + if (*p == '\0') { + *ppsecond = NULL; + return; + } + + pstr = strtok (pstr, token); + pstr[strlen(pstr)] = '.'; + + for (short i = 0; i < 2; i++) + { + *ppsecond = strtok (NULL, token); + if (*ppsecond == NULL) + break; + } +} + + + +/* + *------------------------------------------------------------------------- + * SplitObject -- + * Splits a string held within a Tcl object (pObj) into its constituent + * objects (ppResult), using a collection tokens. + * + * Result: + * true iff successful. Else, error string in interpreter. + * Side effects: + * None. + *------------------------------------------------------------------------- + */ +bool SplitObject (Tcl_Interp *pInterp, Tcl_Obj *pObj, + const char * tokens, Tcl_Obj **ppResult) +{ + ASSERT (pInterp != NULL && pObj != NULL && tokens != NULL && ppResult != NULL); + TObjPtr cmd; + cmd.create(); + cmd = "split"; + cmd.lappend (pObj); + cmd.lappend(tokens); + if (Tcl_EvalObj (pInterp, cmd) == TCL_ERROR) + return false; + *ppResult = Tcl_GetObjResult (pInterp); + Tcl_IncrRefCount (*ppResult); + return true; +} + + +bool SplitBrackets (Tcl_Interp *pInterp, Tcl_Obj *pObj, + TObjPtr & result) +{ + ASSERT (pInterp != NULL && pObj != NULL); + TObjPtr pcmd ("regexp -nocase {^([^\$\$])+(\$[^\\(\$]+\\))?$} "); + pcmd.lappend(pObj); + + if (Tcl_EvalObj (pInterp, pcmd) == TCL_ERROR) + return false; + + CONST84 char * okstr = Tcl_GetStringResult (pInterp); + if (okstr[0] == '0') { + Tcl_SetResult (pInterp, "property format is incorrect: ", TCL_STATIC); + Tcl_AppendResult (pInterp, Tcl_GetStringFromObj(pObj, NULL), NULL); + return false; + } + + pcmd = "split"; + pcmd.lappend (pObj).lappend("(),"); + if (Tcl_EvalObj (pInterp, pcmd) == TCL_ERROR) + return false; + result.copy(Tcl_GetObjResult (pInterp)); + + // the last element will be a null string + char *str = Tcl_GetStringFromObj (pObj, NULL); + if (str[strlen (str) - 1] == ')') + Tcl_ListObjReplace (NULL, result, result.llength() - 1, 1, 0, NULL); + return true; +} + +/// Tests +TCL_CMDEF (Obj2VarTest) +{ + if (objc < 2) { + Tcl_WrongNumArgs(pInterp, 1, objv, "value"); + return TCL_ERROR; + } + + VARIANT var; + VARIANT * pvar; + HRESULT hr; + + pvar = (VARIANT*)CoTaskMemAlloc(sizeof(VARIANT)); + + VariantInit(pvar); + var.vt = VT_VARIANT; + var.pvarVal = pvar; + + TObjPtr ptr(objv[1], false); + + obj2var (ptr, *pvar); + CoTaskMemFree((LPVOID)pvar); + hr = VariantClear(&var); + Tcl_SetResult (pInterp, HRESULT2Str(hr), TCL_DYNAMIC); + return FAILED(hr)?TCL_ERROR:TCL_OK; +} + + diff --git a/src/utility.h b/src/utility.h new file mode 100644 index 0000000..510c692 --- /dev/null +++ b/src/utility.h @@ -0,0 +1,112 @@ +/* + *------------------------------------------------------------------------------ + * utility.cpp + * Declares a collection of often used, general purpose functions. + * I've also placed the variant/Tcl_Obj conversion functions here. + * + * Copyright (C) 1999 Farzad Pezeshkpour, University of East Anglia + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *------------------------------------------------------------------------------ + */ +#ifndef UTILITY_418A3400_56FC_11d3_86E8_0000B482A708 +#define UTILITY_418A3400_56FC_11d3_86E8_0000B482A708 + + +#ifndef ASSERT +# ifdef _DEBUG +# include +# define ASSERT(x) _ASSERTE(x) +# else +# define ASSERT(x) +# endif +#endif + + + +// TRACE functionality - works like printf, only in debug mode +// - output to the debug console +#ifdef _DEBUG +# define TRACE OptclTrace +void OptclTrace(LPCTSTR lpszFormat, ...); +#else +# define TRACE +#endif + +#define TCL_CMDEF(fname) int fname (ClientData cd, Tcl_Interp *pInterp, int objc, Tcl_Obj *CONST objv[]) +#define CHECKHR(hr) if (FAILED(hr)) throw(hr) +#define CHECKHR_TCL(hr, i, v) if (FAILED(hr)) {Tcl_SetResult (i, HRESULT2Str(hr), TCL_DYNAMIC); return v;} + +#define SETDISPPARAMS(dp, numArgs, pvArgs, numNamed, pNamed) \ + {\ + (dp).cArgs=numArgs;\ + (dp).rgvarg=pvArgs;\ + (dp).cNamedArgs=numNamed;\ + (dp).rgdispidNamedArgs=pNamed;\ + } + +#define SETNOPARAMS(dp) SETDISPPARAMS(dp, 0, NULL, 0, NULL) + +#define _countof(x) (sizeof(x)/sizeof(x[0])) + + +template void delete_ptr (T* &ptr) +{ + if (ptr != NULL) { + delete ptr; + ptr = NULL; + } +} + + +template T* delete_array (T *&ptr) { + if (ptr != NULL) { + delete []ptr; + ptr = NULL; + } + return ptr; +} + + + +class OptclObj; + +bool var2obj (Tcl_Interp *pInterp, VARIANT &var, TObjPtr &presult, OptclObj **ppObj = NULL); +bool obj2var_ti (Tcl_Interp *pInterp, TObjPtr &obj, VARIANT &var, ITypeInfo *pInfo, TYPEDESC *pdesc); +bool obj2var_vt (Tcl_Interp *pInterp, TObjPtr &obj, VARIANT &var, VARTYPE vt); +bool obj2var_vt_byref (Tcl_Interp *pInterp, TObjPtr &obj, VARIANT &var, VARTYPE vt); +void obj2var (TObjPtr &obj, VARIANT &var); + + +void OptclVariantClear (VARIANT *pvar); + + +char * HRESULT2Str (HRESULT hr); +void FreeBSTR (BSTR &bstr); +void FreeBSTRArray (BSTR * bstr, UINT count); +char * ExceptInfo2Str (EXCEPINFO *pe); +DISPID Name2ID (IDispatch *, const LPOLESTR name); +DISPID Name2ID (IDispatch *, const char *name); +int ObjectNotFound (Tcl_Interp *pInterp, const char *name); +void SplitTypedString (char *pstr, char ** ppsecond); +bool SplitObject (Tcl_Interp *pInterp, Tcl_Obj *pObj, + const char * tokens, Tcl_Obj **ppResult); +bool SplitBrackets (Tcl_Interp *pInterp, Tcl_Obj *pObj, + TObjPtr & result); + +/// TESTS +TCL_CMDEF (Obj2VarTest); + +#endif // UTILITY_418A3400_56FC_11d3_86E8_0000B482A708 \ No newline at end of file diff --git a/tests/calendar.tcl b/tests/calendar.tcl new file mode 100644 index 0000000..2ee371b --- /dev/null +++ b/tests/calendar.tcl @@ -0,0 +1,54 @@ +##################################################### +# This file demonstrates the Calendar control being +# integrated within a Tk widget, and bound to a +# an event handler +##################################################### + + +# in case we want to do some debugging +bind . {console show} + + +# optcl load happens here +package require optcl + + +## +# called when an AfterUpdate event is raised. +# the first parameter is the object that raised +# the event +proc onupdate {obj} { + global currentdate + set currentdate [$obj : value] +} + + + +# main script------ + + +# create a status bar to show the current date +label .cd -bd 1 -relief sunken -textvariable currentdate +pack .cd -side bottom -fill x + +# create the calendar object +set cal [optcl::new -window .cal MSCAL.Calendar] +.cal config -width 300 -height 300 +pack .cal + +# bind to the calendar AfterUpdate event +# routing it to the tcl procedure onupdate +# +optcl::bind $cal AfterUpdate onupdate + + +# get the current value +set currentdate [$cal : value] + + +# make a button to view the type information of +# the calendar +button .b -text TypeInfo -command {tlview::viewtype [optcl::class $cal]} +pack .b -side bottom -anchor se + + diff --git a/tests/pdf.tcl b/tests/pdf.tcl new file mode 100644 index 0000000..9304dca --- /dev/null +++ b/tests/pdf.tcl @@ -0,0 +1,18 @@ + + +package require optcl +bind . {console show} + +wm title . {PDF Document in Tk} +set pdf [optcl::new -window .pdf {d:/program files/adobe/acrobat3/acrobat.pdf}] +.pdf config -width 500 -height 300 +pack .pdf -fill both -expand 1 + +# to view the type information for the control +pack [button .b -text "View TypeLibrary for IE container" -command { + tlview::viewtype [ optcl::class $pdf ] + } ] -side bottom + +# can't execute these until the document has loaded... +#set doc [$pdf : document] +#tlview::viewtype [ optcl::class $doc ] diff --git a/tests/word.tcl b/tests/word.tcl new file mode 100644 index 0000000..5f06fdb --- /dev/null +++ b/tests/word.tcl @@ -0,0 +1,45 @@ +################################################################ +# This file demonstrates the automation MS Word +################################################################ + + +# for debuggin +bind . {console show} + +#load optcl +package require optcl + + + +# with this procedure, closing the document closes wish +proc onclose {obj} { + # if the document is closing then exit + # but we can't call exit here as we are processing an event + # so set up a timer on this + after 500 {exit} +} + +set word [optcl::new word.application] +$word : visible 1 + +# create a new doc +set doc [$word -with documents add] + +# bind to its close event of the document +optcl::bind $doc Close onclose + + +# gui + +button .st -text "Set Text" -command {$doc -with content : text [.f.t get 1.0 end]; $doc : saved 1} +pack .st + +frame .f -bd 1 -relief sunken +pack .f -side top -fill both -expand 1 +scrollbar .f.ys -orient vertical -command {.f.t yview} +pack .f.ys -side right -fill y +text .f.t -yscrollcommand {.f.ys set} -bd 0 -relief flat +pack .f.t -fill both -expand 1 + +.f.t insert end "Please type your text here and press 'Set Text'" +

GNU General Public License

Table of Contents

END OF TERMS AND CONDITIONS

Index

The Distribution

Things To Do

Known Bugs/Limitations

Credits

Objects

Description

Type Library Access

Command Line Access of Type Libraries

Description

Type Information

Element Information

Graphical Method for Accessing Type Libraries

Description

Types

Type Libraries

Primitive Types