pax_global_header00006660000000000000000000000064116743536760014534gustar00rootroot0000000000000052 comment=8bf56bf13f863ce7ab99fdab2c9214c6aa838f7e coccinella-0.96.20/000077500000000000000000000000001167435367600140065ustar00rootroot00000000000000coccinella-0.96.20/AUTHORS.txt000066400000000000000000000035451167435367600157030ustar00rootroot00000000000000The Coccinella Team Translations: Czech: David Štancl Danish: Mogens Pedersen German: Hermann J. Beckers Spanish: César Alcalde Agustin Vericat Antonio F. Cano Néstor Díaz French: Dominique Bonjour Nicolas Vérité Italian: Mirko Graziani Korean: Dylan Park, Korea NVC Center Dutch: Sander Devrieze Bart Van Hove Polish: Zbigniew Baniewski Portuguese: Paulo Oliveira Rusian: Rain JabberWorld.info team (review: h31, vlas, cyam) Alexander Balezin Swedish: Mats Bengtsson [http://coccinella.im/mats-bengtsson] Simplified Chinese: Jinhua Lv Zhenzhen Wang ming luo Icons: See themes/Oxygen/AUTHORS Patches: Antonio F. Cano Mirko Graziani Founder and former maintainer: Mats Bengtsson [http://coccinella.im/mats-bengtsson] Developer: Sebastian Reitenbach Maintainer: Sander Devrieze coccinella-0.96.20/CHANGES.txt000066400000000000000000000432031167435367600156210ustar00rootroot00000000000000 Coccinella CHANGES ------------------ Not to mention all bugfixes and rewrites. Coccinella-0.96.20 (20100929) o Better detection of file names (603187) o Fix error when trying to remove the last profile (260661) o Chat state notifications trigger contact actions (270689) o Russion translation of "Close message and main window separatelly" (540176) o Exception when trying to edit contact actions on a offline group (555643) o Automatic reconnection (140408) o Added additional tips (152723) o Verify server certicate (551811) o Speed improvements (552466) o Run Coccinella on 64 bit systems (380289) o Public servers dropdown list is fixed (555902) Coccinella-0.96.18 (20100331) o enabled DnD of contacts within the roster works now with all styles (507360) o enhanced management of contacts which are members of multiple groups (507360) o in IRC, now all participants are shown in the member list (432076) o fix exception trying to enter IRC room with +r mode (434196) o fix exception using nick completion in IRC MUC rooms (516436) o fix exception opening the business card editor (497409) o fix exception opening the item editor in the whiteboard (540445) o fix exception trying to reload broken images in whiteboard (544183) Coccinella-0.96.16 (20091201) o XEP-0202 support Entity Time enabled (441223) o fixed exception on MacOS X regarding sound device selection (427951) o login settings are now saved (180132) o wrong password behaviour fixed (147392) o fixed exception when some plugins were disabled (456982) o removed usage of obsolete clock option -gmt (454856) o enter password dialog: no focus (454527) o when a transport died on the server, a wrong Edit Contact dialog was shown (451037) o edit business card dialog can be opened multiple times (179936) o login to google-talk with wrong username/password leads to segfault on OpenBSD (460499) o business card window, error retrieving client infos (441293) o error opening business card dialog when someone has geoloc info enabled (437700) o automatic login fails (427809) o support for XEP-0145: Annotations (140336) o fixed crash due to tkpath library on Mac OS X 10.6 o enable Totd at startup (145627) Coccinella-0.96.14 (20090923) o /clean and /retain commands o release of new icon themes o option to select sound device o fixed whiteboard file transfer o fixed annoying bug when typing long texts in chat dialog o fixed external IP detection Coccinella-0.96.12 (20090318) o switch to gettext for translations o encoding issues should be fixed in binary distributions o removed unused libraries for smaller download o improved transport integration o clarifying credits and fixing possible license issues Coccinella-0.96.10 (20080924) o optimized program startup to be faster o many icons and icon sets now moved inside the theme hierarchy o sound themes now belongs to a theme o the login dialog can now be used to edit and create profiles o Oxygen icon and emoticon theme o control panel with slots o search people slot o experimental support for chat styles enabled by default Coccinella-0.96.8 (20080430) o all toolbars collapsable on mac o menu option to select what to display in status line (JID, status, host) o handles multiple DNS SRV records o undo/redo of text o better support for processing multiple selected contacts in roster o native chasing arrows on platforms where this is supported (Mac) o improved support for transports o chat tab close buttons now on the tabs o cleaner transport registration dialogs o redesigned themeing directory structure Coccinella-0.96.6 (20080312) o all universal builds on macosx o HTTP transport more reliable and optimized o compatible with Tcl/Tk 8.5 Coccinella-0.96.4.1 (20080108) o disco info results are cached Coccinella-0.96.4 (20071214) o enabled stream image file transfer in whiteboard SVG mode o colored nicknames with user selected color schemes o drag-and-drop roster items inside roster o drag-and-drop files to roster items o drag-and-drop roster items to desktop or other applications as text/plain o xml console o spell checking o secure (sasl) indicator o major rework of subscription dialogs o improved component/plugin control o si-pub support, used by whiteboard svg mode o improved responsiveness during file transfer Coccinella-0.96.2 (20070919) o added support for XEP-0172: User Nickname o added autoaway which detects any system inactivity like mouse and keyboard o added user activity XEP-0108: User Activity o added support for XEP-0106: JID Escaping o vCards can be exported to xml files o major revision of user experience o easier way to manage background images o major restructure of menus o better consistency among themes (skins) Coccinella-0.96.0 (20070525) o removed the p2p whiteboard mode o the whiteboard code can now optionally be removed from the application o added settings on unix for default web browser and email client o automatically gets a list with free jabber servers when registering new account o updated pep/mood code to version 1.0 of the PEP protocol o support for geolocation o much faster roster population code o added roster search method o added md5 hash checks for file transfer (bytestreams) o added proxy support for bytestreams o added support for XEP-0050: Ad-Hoc Commands Coccinella-0.95.16 (20070214): o new dynamic status menus o new basic dialogs on unix o new avatar settings button and menu o configurable JID or status entry in main window o added file/import/emoticons menu command o added file/export/roster menu command o added search previous o added menu to increase the smallest font sizes in two steps o added SOCKS proxy, compatible with SimpLite-Jabber o cleaner groupchat dialog with new methods to set subject and nickname o added collapsable and flexible toolbars o chat subject now set by pressing Return in subject field o users name attribute can now be edited directly in situ (in roster) o faster chat history parsing o added uri support for the KDE desktop environment o added support to handle xdata forms embedded in normal messages Coccinella-0.95.15 (20061117): o added option to avoid saving password when registering o added Jabber/Register/ICQ,MSN,... sub menus o lot of fixes to iaxclient voip part o more robust TLS negotiation on slow networks o now the complete prefs folder can be stored on a removable drive Coccinella-0.95.14 (20061010): o support for DNS SRV and TXT (HTTP) lookup o pubsub library support o library support for JEP-0138: Stream Compression o text search in history and chat dialogs o parsing xmpp URIs updated to RFC 4622; added in text xmpp URI parsing o added code for JEP-0147: XMPP URI Scheme Query Components o in-text parsing of mailto and im URI's o added metakit whiteboard file format for single file storage o complete inbox now stored as a single file metakit database o inbox can be exported to xml file o new xml based chat log format o added support for pep/mood Coccinella-0.95.13 (20060622): o Critical bugfix for iaxclient on linux systems without audio support Coccinella-0.95.12 (20060616): o new application theme engine o systray support on X11 (linux) o features on MacOSX: overlay number of received messages in dock; logouts on sleep and power down o status shortcut can be used to login o auto join option for groupchat bookmarks o reworked the details of TLS/SSL/SASL connection methods o avatar in chat dialogs o in tabbed chat dialog close commands only close tab o added switch for storing prefs on usb stick etc. o toggle chat history o tabbed groupchats o removed all old agents/browse/conference code o support for vcard based avatars o file cache for avatars o new (flat) minimalistic roster styles o added fast bytestreams protocol (Psi) o added stun support to get NAT external address. o added jingle library support o test version of iaxclient/jingle for voip (JEP-0166 and JEP-0179) o chat state notification (JEP-0085) o new Qt theme on linux (KDE) Coccinella-0.95.11 (20060115): o added support for Growl on mac o using treectrl widget in a number of places o the roster tree component based with different styles o an avatar roster style o support for multiple roster iconsets o main window configurable toolbar/notebook UI o extensive build configuration possible o integrated Jive/Asterisk phone presence status Coccinella-0.95.10 (20051018): o server connections using http possible; http proxy added o added the tkpng package; png support now required o new icons from Everaldo o file transfer using si/bytestreams/ibb/file-transfer protocol o notification using bouncing dock icon on Mac OS X o ignore menu option in groupchat o number of unread chat messages shown in tabs and title o historic chat messages in lighter color o support for conference bookmarks according to JEP-0048 o whiteboard actions are now constrained to the actual scroll region Coccinella-0.95.9 (20050821): o completely rewritten user interface with new theming engine (tile) o vCard avatar Coccinella-0.95.8 (20050620): o reworked the registration process Coccinella-0.95.7 (20050429): o added canvas locking mechanism Coccinella-0.95.6 (20050425): o added PLAIN sasl mechanism o updated QuickTime support which fixed an instabilty problem and an audio problem on Windows o fixed snapshot bug Coccinella-0.95.5 (20050311): o added support for kprinter on unix o status changes displayed in roster o roster remembers which dir items opened/closed o can hide offline/transports in roster o added a keepalive mechansism to guard against aggresive routers Coccinella-0.95.4 (20050126): o critical bug in one of the message catalogs Coccinella-0.95.3 (20050125): o minor bugfixes o added add server feature to disco Coccinella-0.95.2 (20041217): Short summary -- o each page, roster, disco, browser, agents, now have their own status widget o extended buddy pouncing o added automatic login option o improved smiley/url text parsing which is 20 times faster o reworked layoyt of tree widget o muc chatrooms now show users role o httpd can mount directories; using css for 404 and dir listings o the cache should now remember files between launches o bindings to Gnome Meeting on unix Coccinella-0.95.1 (20040930): Short summary -- o SASL authentication o Reworked several dialogs (new user, edit user, subscription) o Reworked how transports are displayed and handled Coccinella-0.95.0 (20040904): Short summary -- o tabbed chat dialog o auto hide scrollbars o new info menu o reworked the profile settings dialog o reorganized prefs panels o improved notebook interface for smoother refresh o added the possibility to use ssl when registering new account o now automatically login after registration o buddy pouncing as a component o reworked incoming message dialog o extra options for profiles now in tabbed notebook o Itcl interface for applets accessing whiteboard functions o Itcl runtime environment for applets o mechanism to add custom protocol o card game applet as a first example of runtime and custom protocol o slide show component o xmpp uri parser o restricted to single instance on Windows o synced playback for QuickTime o using disco as default in place of browse Coccinella-0.94.11 (20040601): Short summary -- o internal ip not always set correctly which made transfers fail Coccinella-0.94.10 (20040528): Short summary -- o STRINGPREP fixes in roster, browse, disco,... o minor fixes for XMPP (ejabberd and jabberd2) Coccinella-0.94.9 (2004????): Short summary -- o prepared for using xml/svg for all whiteboard stuff o major internal code reorganizations to separate whiteboard code from rest and be independent of protocols o reworked the groupchat dialog from scratch o major restructure of all browse code o added support for emoticon sets o added disco support o new component mechanism for plugins o removed all addons stuff, and moved to plugins o windows taskbar o added privacy/filter support Coccinella-0.94.8 (20040305): Short summary -- o fixed critical bugs in p2p startup o fixed bug when auto away o added SVG importer Coccinella-0.94.7 (20040228): Short summary -- o separating actual whiteboard code from rest. o uses resource database for everything, also images o chat dialog rewritten; new buttons, jabber:x:event support o using a hooks mechanism to handle callbacks in a more way o user profiles rewritten from scratch o alert sounds part rewritten; added a few more sound events; added possiblity to use sound sets o reworked tabbed notebook interface o added support for tkdnd (drag and drop) in the whiteboard for linux/unix and windows Coccinella-0.94.6 (2003????): Short summary -- o internal http server in its own thread if available o better redo/undo functionality o fixed stacking inconsistencies when sharing images o background image in tree widget (roster) o better handling of event sounds o new addon structure for extensions o fixed cut/copy/paste menus on macs o files transported were not always cached, now fixed o incoming files will now have there file names encoded to avoid name conflicts o added games item with chess as a first example o added (primitive) printing support for Mac OS X o sorted out how to handle 2/3-tier jids in chats and messages o reworked button tray into a mega widget Coccinella-0.94.5 (200309??): Short summary -- o jid completion entry o setup assistant with free servers info dialog o fixed really nasty bug where the ip number was not set correctly on systems with multiple network interfaces, typically when using ppp o removed smoothness option, added smooth operation of polygons o added auto update mechanism o added chat history dialog o reworked internals of the inbox, new file format o plugin control preference panel o much improved feedback with "broken image" o better handling of passive http transports o changed name of main file to Coccinella.tcl Whiteboard-0.94.4 (20030616): Short summary -- o all jabber UI elements moved from whiteboard window to roster window o get side of file transport rewritten from scratch o MUC support at client level o a plugin structure for the whiteboard Whiteboard-0.94.3 (200301??): Short summary -- o whiteboards now multiinstance for jabber; send single whiteboard messages, each chat and groupchat in separate whiteboards o uses full 3-tier jid in roster now o auto browse users to detect if coccinellas, set icon in roster o updated balloon info in roster o many rewrites o really many bugfixes... Whiteboard-0.94.2 (2002????): Short summary -- o undo/redo method of canvas o localization (language adaption) introduced via message catalogs o new directory structure for prefs and inbox o changed GUI for jabber with persistant address fields o changed canvas file format, reads old, writes new o debug console for jabber I/O o numerous rewrites and bugfixes Whiteboard-0.94.1 (2002????): Short summary -- o complete rewrite of the put side of the peer-to-peer file transfer o roster and browser (or agents) in tabbed window o use agents as fallback if no browsing o added old groupchat protocol in case o auto speech bubble from popup o smart tool button popups o new file cache database o modified image handling which makes image copy & paste incompatible with earlier versions o now saves inbox between sessions o SSL now works with jabber server o fixed really nasty bug in the xml parser o numerous rewrites and bugfixes Whiteboard-0.94 (2002????): Short summary -- o new inbox and other dialogs for message handling o printing support, expat parser, ssl, MS Speech on Windows o reorganized code so that the whiteboard toplevel is more objectified to allow multiple instances o large code rewrites for better organization o parsing smileys and http links in jabber dialogs o changed jabber xml namespace to coccinella:wb , which makes it incompatible with 0.93! o scrollbars for canvas in whiteboard, no synced window sizes o QuickTime movies streamed via http if possible Whiteboard-0.93.1 (2002????): Short summary -- o minor bugfixes and error checks o added prefs(stripJabber) option o fixed return -code in TclXML's ElementClose o fixed registration bug when resetting xml parser o restricted sending to ill formed jid's (@jabber.org) Whiteboard-0.93 (20020127): Short summary -- o adapting to the jabber XML IM server system o preferences are now collected in one window o code base more than doubled compared to 0.92... Whiteboard-0.92 (20001128): Short summary -- o new tiny http server o is now running on Windows (98) o serves streaming media to QuickTime from the TinyHttpd server o all nontransparent gifs now Mime encoded in the scripts o much of the code now as packages instead of source'ed directly o new centralized network via a reflector server o flash free window updates o handles new dashed options of canvas o new supported extensions: Img, snack, tkprint o working menu accelerators o movie controller widget with bindings to snack sound objects o many code rewrites, bug fixes, and enhancements Whiteboard-0.91 (20000517): Short summary -- o new tools, arc item and rotate o collapsable shortcut toolbar o splash screen o items menu for pre made items o put/get operations rewritten with new protocol o safety check in server o support for the xanim application on unix/linux o systematic use of mime types for handling multimedia imports o systematic handling of extensions o font import mechanism for using chinese and other multibyte fonts o many code rewrites, bug fixes, and enhancements Whiteboard-0.90 (19991201): First official release. coccinella-0.96.20/COPYING.txt000066400000000000000000001000601167435367600156540ustar00rootroot00000000000000This software is copyrighted (C) by the Coccinella Team as described in the AUTHORS.txt file, and other parties. The following terms apply to all files associated with the software unless explicitly disclaimed in individual files. The authors hereby grant permission to use, copy, modify, distribute, and license this software and its documentation for any purpose, provided that the license conditions under the GNU General Public License are fulfilled as described below. GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. 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 them 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 prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. 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. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey 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; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If 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 convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU 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 that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. 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. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 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. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. coccinella-0.96.20/Coccinella.tcl000077500000000000000000000215131167435367600165530ustar00rootroot00000000000000#!/usr/bin/env wish # Coccinella.tcl --- # # This file is the main of the jabber/whiteboard application. # It controls the startup sequence and therefore needs a number # of code files/images to be succesful. # # Copyright (c) 1999-2008 Mats Bengtsson # # See the README file for license, bugs etc. # # $Id: Coccinella.tcl,v 1.188 2008-08-19 14:06:27 matben Exp $ # Level of detail for printouts; >= 2 for my outputs; >= 6 to logfile. set debugLevel 0 # TclKit loading mechanism. package provide app-Coccinella 1.0 # We want 8.4 at least. if {[catch {package require Tk 8.5}]} { return -code error "We need Tk 8.5 or later here. Run Wish or find a tclkit!" } # The main window "." shall never be displayed. Use it for QT sounds etc. wm withdraw . tk appname coccinella # Keep 'launchStatus' around for the complete launch process to help components. set state(launchStatus) start set state(launchSecs) [clock seconds] # MacOSX adds a -psn_* switch. set argv [lsearch -all -not -inline -regexp $argv {-psn_\d*}] set argc [llength $argv] # We use a variable 'this(platform)' that is more convenient for MacOSX. switch -- $::tcl_platform(platform) { unix { if {[string equal [tk windowingsystem] "aqua"]} { set this(platform) "macosx" } else { set this(platform) $::tcl_platform(platform) } } default { set this(platform) $::tcl_platform(platform) } } # Early platform dependent stuff. switch -- $this(platform) { windows { # We should only allow a single instance of this application. # A COM interface would be better... (safer) package require dde # If any services available for coccinella then provide the argv. set services [dde services TclEval coccinella] if {$services != {}} { dde execute TclEval coccinella [concat SecondCoccinella $argv] exit } dde servername coccinella } macosx { # CoreGraphics don't align to pixel boundaries by default! #set tk::mac::useCGDrawing 0 if {[info tclversion] >= 8.5} { #set ::tk::mac::useCustomMDEF 1 proc ::tk::mac::OnHide {} {puts ::tk::mac::OnHide} proc ::tk::mac::OnShow {} {puts ::tk::mac::OnShow} proc ::tk::mac::ShowPreferences {} {puts ::tk::mac::ShowPreferences} proc ::tk::mac::Quit {} {puts ::tk::mac::Quit} } } } # Find program real pathname, resolve all links in between. Unix only. # # Contributed by Raymond Tang. Starkit fix by David Zolli. proc resolve_cmd_realpath {infile} { if {[file exists $infile]} { if {[file type $infile] == "link"} { set olddir [pwd] set dirname [file dirname $infile] set filename [file tail $infile] cd $dirname if {[file type $filename] == "link"} { set filename [file readlink $filename] if {[file pathtype $filename] == "absolute"} { set realname [resolve_cmd_realpath $filename] } else { set realname [file join [pwd] $filename] } } else { # found the destination set realname $infile } cd $olddir return [resolve_cmd_realpath $realname] } else { # found the desintation return $infile } } else { foreach name [split $::env(PATH) :] { set filename [file join $name $infile] if {[file exists $filename] && [file executable $filename]} { return [resolve_cmd_realpath $filename] } } # Kroc : for tclkit support : if {[info exists ::starkit::topdir]} { return $::starkit::topdir } else { return $infile } } } # Identify our own position in the file system. if {[string equal $this(platform) "unix"]} { set thisScript [file normalize [resolve_cmd_realpath [info script]]] } else { set thisScript [file normalize [info script]] } set thisPath [file normalize [file dirname $thisScript]] # Debug support. source [file join $thisPath lib Debug.tcl] ::Debug 2 "Installation rootdir: [file dirname $thisScript]" # Set up 'this' array which contains search paths admin stuff. source [file join $thisPath lib Init.tcl] ::Init::SetThis $thisScript ::Init::SetThisVersion ::Init::SetThisEmbedded ::Init::SetAutoPath ::Init::LoadTkPng set prefs(appName) "Coccinella" set prefs(theAppName) "Coccinella" # Read our prefs file containing the theme name and locale needed before splash. package require PrefUtils package require Theme ::PrefUtils::Init ::Theme::Init # Find our language and load message catalog. ::Init::Msgcat # Sets the window titlebar icon. Win98 bails. catch { wm iconphoto . -default \ [::Theme::FindIconSize 16 coccinella] \ [::Theme::FindIconSize 32 coccinella] \ [::Theme::FindIconSize 64 coccinella] } # Splash! Need a full update here, at least on Windows. package require Splash ::Splash::SplashScreen # TRANSLATORS: splash screen strings; shown at startup ::Splash::SetMsg [mc "Sourcing Tcl code"]... set state(launchStatus) splash update # Make sure we have the extra packages necessary and some optional. ::Splash::SetMsg [mc "Searching for our hostname"]... ::Init::SetHostname ::Init::LoadPackages set state(launchStatus) tile set prefs(tileTheme) [option get . prefs_tileTheme {}] if {[lsearch -exact [ttk::themes] $prefs(tileTheme)] >= 0} { ttk::setTheme $prefs(tileTheme) } elseif {[tk windowingsystem] eq "x11"} { # We use the 'clam' theme as a fallback (and default in resources). catch {ttk::setTheme clam} } ::Theme::ReadTileResources # The packages are divided into categories depending on their degree # of generality. ::Splash::SetMsg [mc "Loading Tcl packages"]... set state(launchStatus) packages set packages(generic) { component hooks pipes tileutils undo uri uri::urn utils } set packages(uibase) { balloonhelp Tablelist_tile ttoolbar ui::util ui::combomenu ui::dialog ui::optionmenu } set packages(application) { AMenu Component Dialogs EditDialogs FactoryDefaults Httpd HttpTrpt Media Network Preferences PrefGeneral PrefHelpers PrefNet Proxy SetupAss TheServer Types UI UserActions Utils } foreach class {generic uibase application} { foreach name $packages($class) { package require $name } } tileutils::configure -themechanged ::Theme::TileThemeChanged # Platform dependent packages. switch -- $this(platform) { macosx { package require MacintoshUtils } windows { package require WindowsUtils } } ::UI::InitDlgs # The Jabber stuff. ::Splash::SetMsg [mc "Sourcing Jabber code"]... set state(launchStatus) jabber package require Jabber # Define MIME types etc. ::Types::Init # Standard (factory) preferences are set here. # These are the hardcoded, application default, values, and can be # overridden by the ones in user default file. ::Splash::SetMsg [mc "Initializing"]... FactoryDefaults ::Jabber::FactoryDefaults ::Jabber::LoadWhiteboard # To provide code to be run before loading componenets. ::Debug 2 "--> earlyInitHook" ::hooks::run earlyInitHook # Components. ::Debug 2 "++> component::load" ::Component::Load # Set the user preferences from the preferences file. ::Splash::SetMsg [mc "Setting preferences"]... set state(launchStatus) preferences ::Preferences::SetMiscPrefs # Override any 'config's. # Must be after all sources and components loaded but before any init hooks. ::Init::Config # Components that need to add their own preferences need to be registered here. # @@@ Is this really necessary? Can't they call ::PrefUtils::Add anytime? ::Debug 2 "--> prefsInitHook" ::hooks::run prefsInitHook # Parse some command line options. # @@@ There is a conflict here if some prefs settings depend on, say protocol. ::PrefUtils::ParseCommandLineOptions $argv # Check that the mime type preference settings are consistent. ::Types::VerifyInternal # Various initializations for canvas stuff and UI. # In initHook UI before hooks BAD! ::UI::Init ::UI::InitMenuDefs ::UI::InitCommonBinds ::UI::InitVirtualEvents # All components that requires some kind of initialization should register here. # Beware, order may be important! ::Debug 2 "--> initHook" ::hooks::run initHook # Code that requires stuff done in initHook registers for this one. ::Debug 2 "--> postInitHook" ::hooks::run postInitHook # At this point we should be finished with the launch and delete the splash # screen. ::Splash::SetMsg "" after 200 {catch {destroy $::wDlgs(splash)}} # This builds the main window etc. ::Jabber::Init ::Debug 2 "--> initFinalHook" ::hooks::run initFinalHook if {$prefs(firstLaunch)} { ::hooks::run firstLaunchHook } update idletasks ::Debug 2 "--> launchFinalHook" ::hooks::run launchFinalHook unset -nocomplain state(launchStatus) set prefs(firstLaunch) 0 # This is for late init hooks that are slow to avoid locking the UI. after 200 { ::Debug 2 "--> afterFinalHook" ::hooks::run afterFinalHook ::hooks::run postAfterFinalHook } #------------------------------------------------------------------------------- coccinella-0.96.20/README.txt000066400000000000000000000046311167435367600155100ustar00rootroot00000000000000 Coccinella : Instant Messaging Program with Whiteboard ------------------------------------------------------ Website: [http://coccinella.im/] Documentation: [http://coccinella.im/documentation] Development: [http://coccinella.im/development] Communicate with Coccinella Coccinella is a free and open-source cross-platform communication tool with a built-in whiteboard for improved collaboration with other people. 1. Communicate with Whiteboard -- Sketch to explain your words. Collaborate on diagrams. Enter mathematical formulas like on paper. Draw together for fun. You decide how you visually communicate. 2. Communicate with Voice -- Handsfree communication for people who love multitasking. Discuss while working together in the whiteboard. Make a call while working on a document. It is all possible. 3. Communicate with Documents -- Exchange your documents using fast file transfer. Send files in real-time to your contacts. 4. Communicate with Multiple People -- Chat with multiple people in a virtual room. Team up in a multi-user whiteboard session. 5. Communicate with Presence -- See who is available for communication. See which communicationchannels you can use. See what your contacts are doing. See their emotions. 6. Communicate with Everybody -- Instant message with people on all legacy chat systems. Interact with people using interoperable instant messaging software based on the industry-standard XMPP protocol, including Google Talk, Apple iChat and Nokia Chat. 7. Some Other Features * Portable Coccinella on USB stick * Multi-lingual and internationalized * Plugin system * MeBeam plugin * Search people in dictionary * Avatars and emoticons * Themes * Secured connections (TLS and SASL) * GPLv3 license * QuickTime integration in whiteboard (Mac OS X and Windows) * Text-to-speech (Mac OS X and Windows) * Compression support to save bandwidth * Proxy support * Contact actions (buddy pounces) * Innovative auto-away features * Logout on laptop sleep (Mac OS X) --------------------------------------------------------------------------------coccinella-0.96.20/READMEs/000077500000000000000000000000001167435367600151265ustar00rootroot00000000000000coccinella-0.96.20/READMEs/FileTransferProtocol.txt000066400000000000000000000032501167435367600217750ustar00rootroot00000000000000 Description of various protocols used in the Whiteboard. -------------------------------------------------------------------------------- The PUT protocol: Put file from client to server. client server comments ------ ------ -------- o----------------------------->. open a socket to the server "PUT: file optList" -> <- "TCLWB/1.0 200 Ok" it is not necessary to return the 'optList' fcopy ------------------------> fcopy -------------------------------------------------------------------------------- The GET protocol: Get file from server to client. client server comments ------ ------ -------- o----------------------------->. open a socket to the server "GET: file" -> <- "TCLWB/1.0 200 Ok" <- "key: value key:value ..." it is necessary to return an 'optList' that specifies byte size and MIME type fcopy <------------------------ fcopy -------------------------------------------------------------------------------- Legend: file name of the file, only the tail optList "key: value key:value ..." which resembles the HTTP protocolcoccinella-0.96.20/READMEs/README-command-line000066400000000000000000000020601167435367600203450ustar00rootroot00000000000000 README-command-line ------------------- You may specify a command line when starting Coccinella. This is typically used to automatically login, and then you use one of two alternatives: -jid myname@somewhere.se/home -profile nameOfProfile where nameOfProfile must exist. Normally you would also add a: -password secret otherwise you will be prompted about this. Then there are a bunch of switches to control some details of your connection: -compress 0 -defaulthttpurl http://%h:5280/http-poll/ -defaultport 5222 -defaultresource "default" -defaultsslport 5223 -digest 1 -dnsprotocol udp -dnssrv 1 -dnstxthttp 1 -dnstimeout 3000 -http 0 -httpurl "" -ip "" -method ssl | tlssasl | sasl -minpollsecs 4 -noauth 0 -port "" -saslthencomp 1 -secure 0 -timeout 30000 -transport tcp | http but note that these may change. For debugging you use: -debugLevel 4 coccinella-0.96.20/READMEs/README-libraries000066400000000000000000000002141167435367600177550ustar00rootroot00000000000000 README-libraries The Coccinella is built using Tcl/Tk which is a multiplatform scripting language which only needs a runtime environment.coccinella-0.96.20/READMEs/README-sounds000066400000000000000000000022701167435367600173200ustar00rootroot00000000000000README-sounds ------------- To create a sound set. There are two ways to do this: 1) Take your folder with sound files and put inside the Coccinella-*/sounds/ directory. This requires you run from the sources, or that you are using Mac OS X and "open" the application by control clicking it. 2) As an alternative you may put a sounds folder inside the Coccinella's preference folder. Typically you'll have a path .../Coccinella/sounds/MyNoises/ The content for both alternatives are identical: In your sounds folder, create a file with name 'soundIndex.tcl' with a content that maps sound event names to your actual file names. A typical content is: set sound(online) "Alarm.aif" set sound(offline) "Clunk.aif" set sound(newmsg) "eMate StartUp.aif" set sound(newchatmsg) "Frog.aif" set sound(newchatthread) "Metallic.aif" set sound(statchange) "Extras Close.aif" set sound(connected) "Extras Open.aif" set sound(groupchatpres) "Noise.aif" This lists the presently available sound sets. Be sure to enclose your file names in quotes if they contain spaces. Do use only characters from the standard US ASCII set, and not language dependent characters. That's it! coccinella-0.96.20/READMEs/README-themes000066400000000000000000000153371167435367600173020ustar00rootroot00000000000000 README-themes ------------- There are two completely different mechanisms that control the visual appearence of this application: o The ttk (themed tk) package that draws all widgets, such as buttons etc. Ttk works with themes but in this context we usually denote these themes as skins or as ttk themes. o The application defined theme engine that controls which icons to use, and some resources that are used by the widgets. Do not confuse the application themes with tile themes. We only focus on the application themes, the second item, here. A theme consists of a sub tree in the file system and typically looks like: MyCoolTheme/avatars/32x32/ 48x48/ 64x64/ backgrounds/ elements/ icons/16x16/ 32x32/ 48x48/ 64x64/ 128x128/ others/ scalable/ iconsets/emoticons/ roster/ service/ mime/16x16/ sounds/ splash/ Most folders contain images of various sorts, but not all. Sub folders denoted 32x32, for instance, contain images of this size only. The image formats always supported are GIF and PNG, but in some cases also JPEG images can be used. avatars/ default avatars when user doesn't have any backgrounds/ typical larger size images used as roster background or as splash image chatstyles/ todo elements/ images used as user interface elements in various places icons/ the main directory where most images used for buttons etc. come from. The others/ folder is for multi resolution images like .ico and .icns. iconsets/ archives of typically small images used as emticons etc. They are jisp formats, packed or unpacked. mime/ images illustrating a given MIME type. The file name is obtained from the type by replacing "/" with "-". sounds/ sound sets, see README-sounds splash/ the splash image(s) A theme, apart from the application default, can be placed either internally in the application tree, or as a user defined theme in the preference folder. A theme is distinguished by its name, which is also the name of the folder containing the complete directory tree. Examples: coccinella/themes/Cool/ prefsFolder/themes/Green/ The file names in icons/ follow to some degree the freedesktop.org specification, where the basename contains of "-" separated smaller words which describe the context of the image in a hierarchical way. When the theme engine looks up an image or icon, it first looks in the present theme, and then in the built in default theme (Crystal). It is using the following fallback hierarchy: list-add-user-Dis -> list-add-user PNG -> GIF where it strips off the last "-" part for each image format. Many images have a resource name associated with it. If you keep the filename the same as in the original distro, the image will be automatically used. You may also pick a different name, but then you must specify a new value for the resource that is also the file name. As an example: *JMain.connectImage: imageMyConnect where the 'imageMyConnect.png' file is in the themes directory. The 'iconsets' and 'sounds' have extended search paths. As an example, the sound sets are collected from: coccinella/sounds/ coccinella/themes/MyCoolTheme/sounds/ prefsFolder/sounds/ prefsFolder/themes/MyCoolTheme/sounds/ This way it is possible to add a sound set independent of any theme. BU: ................................................................................ Images ------ Images are the most important thing determined by a theme. They are normally found in the applications images folder: coccinella/images/ but may be placed in specific places used by standalone components: coccinella/components/Phone/images/ A theme, apart from the application default, can be placed either internally in the application tree, or as a user defined theme in the preference folder. A theme is distinguished by its name, which is also the name of the folder containing the complete directory tree. Examples: coccinella/themes/Cool/ prefsFolder/themes/Green/ A theme directory tree replicates the application tree structure with the images or resources that are going to be replaced. For instance, if a "Cool" theme shall replace one or several images it can define the content in the following folders: Cool/images/ Cool/components/Phone/images/ When the application asks for an image it may define a sub path (subPath) where the image shall be searched for. This sub path defaults to "images". The search order for an image in the "Cool" theme is: coccinella/themes/Cool/subPath/ <-- if folder exists prefsPath/themes/Cool/subPath/ <-- if folder exists If not found in any of these the coccinella/subPath/ is used as a final fallback. As an example consider the search order for an image 'login' (we assume png format) in the 'Cool' theme: coccinella/themes/Cool/images/login.png <-- if folder exists prefsFolder/themes/Cool/images/login.png <-- if folder exists coccinella/images/login.png For the moment the image formats must be either GIF or PNG. Resources --------- The second part that influences the applications appearence that belong to the application theme specification is the resources. Some features of widgets and several application specific layout stuff is encoded as resources using the built in option database for resources. The default resources are found in coccinella/resources/ The default.rdb file always sets some reasonable values. After that the platform specific rdb file is read. A theme may override any resource settings by adding its own resource files in themes/themeName/resources/ using the predefined resource file names, like: themes/themeName/resources/default.rdb Most visual appearence are now set via the tile theme engine but some are still used, see specific docs for these. For the application specific resources you need to search the sources for something like: option add *Chat*mePreForeground red In the resource files they show up as: *MailBox*Tablelist.labelBackground: #dd1111 Many images have a resource name associated with it. If you keep the filename the same as in the original distro, the image will be automatically used. You may also pick a different name, but then you must specify a new value for the resource that is also the file name. Examplevise: *JMain.connectImage: imageMyConnect where the 'imageMyConnect.png' file is inside the themes image directory. That's it!coccinella-0.96.20/READMEs/README-web.html000066400000000000000000000131511167435367600175250ustar00rootroot00000000000000 XMPP URI Examples

XMPP Protocol Initiation URI Syntax.

Specifications

You can put an url in a web page to launch The Coccinella. Use a link: xmpp:matben@athlon.se This works presently only on Windows and on unix systems with the KDE environment:
  • On Windows you need to launch Coccinella at least once with administrator privilegies to make it work.
  • On KDE systems it writes a file ~/.kde/share/services/xmpp.protocol the first time Coccinella is launched, which is in turn used by KDE to communicate with The Coccinella. It seems that the desktop environment caches this info so a second login may be necessary for this to take effect. Not all web browsers seem to understand the KDE desktop but at least Konqueror does.

Note that the JID you supplu in the uri is not your own login JID but the target address for any action specified. The login uses the active profile in the application, not the JID in the uri!

The definition of the uri syntax is found in RFC 4622 from http://www.ietf.org/. If you use non US-ascii characters make sure the JID is encoded according to the reference above.

The other specifications can be found at

You can also launch The Coccinella using the switch -uri: set argv -uri xmpp:marilu@l4l.be?... from the console or terminal.

The specification does only specify the syntax used, and is considered to be generic. The syntax is: 

xmppuri   = "xmpp" ":" hierxmpp [ "?" querycomp ] [ "#" fragment ]
hierxmpp  = authpath / pathxmpp
authpath  = "//" authxmpp [ "/" pathxmpp ]
authxmpp  = nodeid "@" host
pathxmpp  = [ nodeid "@" ] host [ "/" resid ]
querycomp = querytype [ *pair ]
pair      = ";" key "=" value

Note that the form with an authpath is not recomended. The following XMPP IRI/URI signals the processing application to authenticate as "guest@example.com" and to send a message to "support@example.com": 

      xmpp://guest@example.com/support@example.com?message
By contrast, the following XMPP IRI/URI signals the processing application to authenticate as its configured default account and to send a message to "support@example.com": 
      xmpp:support@example.com?message

In addition to the standards described above, there are currently a few additions which may change later. For any querytype you may specify the following key-value pairs: 

"ssl"           0|1
"priority"      integer
"invisible"     0|1
"ip"            network domain name or number
"sasl"          0|1

For the join type the following key-value pair has been added: (note that the JID you specify here must be room/nickname): 

"xmlns"         "whiteboard"
The server must support the disco method for service discovery, and the groupchat must be of the MUC type. All modern servers comply with this.

Examples

01 Perform a Coccinella login ## xmpp:admin_user_node@example.com

Perform a Coccinella login using your current selected profile. This is not very useful since there is no query type. The JID you specify is supposed to be the target of your action, or query, but since this is missing, it just performs a standard login.

02 Prepare to send an instant message ## xmpp:contact_user_node@example.com

Prepare to send a "Hello World" message to mickey@example.com: xmpp:mickey@example.com?message;subject=Hi;body=Hello%20World.

Note that the same presumption of the current selected profile is providing the necessary authentication for this activity on the server. Valid in all cases below!

03 Prepare to start a chat session ## xmpp:contact_user_node@example.com

Prepare to start a chat session with mickey@example.com: xmpp:mickey@example.com?message;subject=Hi;body=Hello%20World;type=chat.

04 Enter a chat room ## xmpp:roomname@conference.example.com/nickname

Enter the sss chat room using nickname Terry: xmpp:sss@conference.example.com/Terry?join.

Note that the same presumption of the current selected profile is providing the necessary authentication for this activity on the server. Now, moreover, the server-side rule that the owner of a room has automatic access irrespective of password also is at play here because the 'sss' room requires a password.

05 Start a whiteboard session ## xmpp:roomname@conference.example.com/nickname

Start a whiteboard session in the sss chat room with nickname Terry: xmpp:sss@conference.example.com/Terry?join;xmlns=whiteboard.

Again, this works because Terry owns 'sss', or actually, the JID behind Terry owns the room. However, most rooms are not password protected, hence no password key is necessary. coccinella-0.96.20/READMEs/README-xmpp000066400000000000000000000073621167435367600170000ustar00rootroot00000000000000 ============= README-jabber ============= This brief text describes the jabber features supported. XMPP Core (RFC 3920) -------------------- o TLS (sect. 5) o SASL authentication with mechanisms [PLAIN], [DIGEST-MD5] (sect. 6, 14.7) o Resource binding (sect. 7) o DNS hostname resolved using SRV records (sect. 14.3) XMPP IM (RFC 3921) ------------------ 1.2. Requirements o Exchange messages with other users o Exchange presence information with other users o Manage subscriptions to and from other users o Manage items in a contact list (in XMPP this is called a "roster") o Block communications to or from specific other users (TODO) Other supported standards: o XMPP URIs (RFC 4622) o XMPP URI/IRI Querytypes from the Jabber Registrar XMPP Extension Protocols (XEPs) ------------------------------- The following XEPs are implemented, completely or in parts. Note that some of these XEPs have the form of a library or support protocol for other functions. (These were formerly known as JEPs.) XEP | Name | Implementation -------------------------------------------------------------------------- 0004 | Data Forms | complete 0008 | IQ-Based Avatars (outdated) | complete 0012 | Last Activity | complete 0022 | Message Events | partial 0025 | Jabber HTTP Polling | complete 0030 | Service Discovery | complete 0045 | Multi-User Chat | complete 0047 | In-Band Bytestreams | complete 0048 | Bookmark Storage | for conference rooms 0049 | Private XML Storage | complete 0050 | Ad-Hoc Commands | complete 0054 | vcard-temp | complete 0055 | Jabber Search | complete 0060 | Publish-Subscribe | complete 0065 | SOCKS5 Bytestreams | complete 0066 | Out of Band Data | complete 0068 | Field Standardization for ... | (+ 0077 | In-Band Registration | complete 0078 | Non-SASL Authentication | complete 0080 | User Location | complete 0082 | XMPP Date and Time Profiles | informational (see 0202) 0085 | Chat State Notifications | complete 0090 | Entity Time | complete 0091 | Delayed Delivery | complete 0092 | Software Version | complete 0095 | Stream Initiation | complete 0096 | File Transfer | complete 0100 | Gateway Interaction | complete (6.3?) 0106 | JID Escaping | complete 0107 | User Mood | complete 0108 | User Activity | complete 0115 | Entity Capabilities | complete 1.3 (1.4) (** 0128 | Service Discovery Extensions [ (+ 0137 | Publishing Stream Initiation..| complete (except pubsub) (1.0) 0138 | Stream Compression | complete 0145 | Annotations | complete (x 0147 | XMPP URI Scheme Query Comp... | almost complete 0153 | vCard-Based Avatars | complete 0156 | A DNS TXT Resource... | complete 0163 | Personal Eventing via Pubsub | complete 0166 | Jingle | complete 0170 | Recommended Order of Stream.. | complete (* 0179 | Jingle IAX Transport Method | complete 0202 | Entity Time | complete (* XEP-0138 and XEOP-0170 have different opinions on order of compression (** presence caps follow 1.4 but not activated own cache (+ disco info the full JID returns specific ip info (x only used without note timestamps in Coccinella coccinella-0.96.20/TclXML/000077500000000000000000000000001167435367600151115ustar00rootroot00000000000000coccinella-0.96.20/TclXML/CHANGES000066400000000000000000000014511167435367600161050ustar00rootroot00000000000000CHANGES ------- (2002-02-15) by Mats Bengtsson (matben@users.sourceforge.net) Fixes mainly to make the -final 0 option work. Only for *8.1* files. - Added the -statevariable to ::sgml::parseEvent call; initialization fix in parseEvent - Added the -statevariable to ::sgml::tokenise call to handle cases with chopped off xml at arbitrary places; added the 'leftover' array element to 'parse' - Now also takes the first four elements of tokenised for parsing in ::sgml::parseEvent, see comments there - Added error checking in xml::tclparser::configure - Added call to xml::tclparser::configure from xml::tclparser::parse - Added one-word error description to all -errorcommand calls, and fixed all list structures - Added return -code etc. to ElementClose similar to ElementOpencoccinella-0.96.20/TclXML/pkgIndex.tcl000066400000000000000000000022721167435367600173710ustar00rootroot00000000000000# Tcl package index file - handcrafted # # $Id: pkgIndex.tcl,v 1.7 2006-12-19 13:27:09 matben Exp $ # Handcrafted paths for the Coccinella by Mats Bengtsson # Mats: very much stripped down version to load my patched version only. # the 99.0 version number is a ugly trick to make sure it does not # interfere with any existing TclXML installation. package ifneeded xml::tcl 99.0 [list source [file join $dir xml__tcl.tcl]] package ifneeded sgmlparser 99.0 [list source [file join $dir sgmlparser.tcl]] package ifneeded xpath 1.0 [list source [file join $dir xpath.tcl]] namespace eval ::xml {} package ifneeded tclparser 99.0 { package require xml::tcl 99.0 package require xmldefs package require xml::tclparser 99.0 package provide tclparser 99.0 } package ifneeded xml 99.0 { package require xml::tcl 99.0 package require xmldefs # Only choice is tclparser package require xml::tclparser 99.0 package provide xml 99.0 } package ifneeded sgml 1.9 [list source [file join $dir sgml-8.1.tcl]] package ifneeded xmldefs 3.1 [list source [file join $dir xml-8.1.tcl]] package ifneeded xml::tclparser 99.0 [list source [file join $dir tclparser-8.1.tcl]] coccinella-0.96.20/TclXML/pkgIndexORIG.tcl000066400000000000000000000051611167435367600200520ustar00rootroot00000000000000# Tcl package index file - handcrafted # # $Id: pkgIndexORIG.tcl,v 1.2 2004-08-17 14:10:30 matben Exp $ package ifneeded xml::c 2.0 [list load [file join $dir @RELPATH@ @TCLXML_LIB_FILE@]] package ifneeded xml::tcl 2.0 [list source [file join $dir xml__tcl.tcl]] package ifneeded xml::expat 2.0 [list load [file join $dir @RELPATH@ @expat_TCL_LIB_FILE@]] package ifneeded xml::xerces 2.0 [list load [file join $dir @RELPATH@ @xerces_TCL_LIB_FILE@]] package ifneeded sgmlparser 1.0 [list source [file join $dir sgmlparser.tcl]] package ifneeded xpath 1.0 [list source [file join $dir xpath.tcl]] namespace eval ::xml {} # Requesting a specific package means we want it to be the default parser class. # This is achieved by loading it last. # expat and xerces packages must have xml::c package loaded package ifneeded expat 2.0 { package require xml::c package require xmldefs package require xml::tclparser catch {package require xml::xerces} package require xml::expat 2.0 package provide expat 2.0 } package ifneeded xerces 2.0 { package require xml::c package require xmldefs package require xml::tclparser catch {package require xml::expat} package require xml::xerces 2.0 package provide xerces 2.0 } # tclparser works with either xml::c or xml::tcl package ifneeded tclparser 2.0 { if {[catch {package require xml::c}]} { # No point in trying to load expat or xerces package require xml::tcl package require xmldefs package require xml::tclparser } else { package require xmldefs catch {package require xml::expat} catch {package require xml::xerces} package require xml::tclparser } package provide tclparser 2.0 } # Requesting the generic package leaves the choice of default parser automatic package ifneeded xml 2.0 { if {[catch {package require xml::c}]} { package require xml::tcl package require xmldefs # Only choice is tclparser package require xml::tclparser } else { package require xmldefs package require xml::tclparser catch {package require xml::expat 2.0} catch {package require xml::xerces 2.0} } package provide xml 2.0 } if {[info tclversion] <= 8.0} { package ifneeded sgml 1.8 [list source [file join $dir sgml-8.0.tcl]] package ifneeded xmldefs 2.0 [list source [file join $dir xml-8.0.tcl]] package ifneeded xml::tclparser 2.0 [list source [file join $dir tclparser-8.0.tcl]] } else { package ifneeded sgml 1.8 [list source [file join $dir sgml-8.1.tcl]] package ifneeded xmldefs 2.0 [list source [file join $dir xml-8.1.tcl]] package ifneeded xml::tclparser 2.0 [list source [file join $dir tclparser-8.1.tcl]] } coccinella-0.96.20/TclXML/sgml-8.1.tcl000066400000000000000000000147061167435367600170730ustar00rootroot00000000000000# sgml-8.1.tcl -- # # This file provides generic parsing services for SGML-based # languages, namely HTML and XML. # This file supports Tcl 8.1 characters and regular expressions. # # NB. It is a misnomer. There is no support for parsing # arbitrary SGML as such. # # Copyright (c) 1998-2003 Zveno Pty Ltd # http://www.zveno.com/ # # See the file "LICENSE" in this distribution for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # $Id: sgml-8.1.tcl,v 1.3 2006-12-19 13:27:09 matben Exp $ package require Tcl 8.1 package provide sgml 1.9 namespace eval sgml { # Convenience routine proc cl x { return "\[$x\]" } # Define various regular expressions # Character classes variable Char \t\n\r\ -\uD7FF\uE000-\uFFFD\u10000-\u10FFFF variable BaseChar \u0041-\u005A\u0061-\u007A\u00C0-\u00D6\u00D8-\u00F6\u00F8-\u00FF\u0100-\u0131\u0134-\u013E\u0141-\u0148\u014A-\u017E\u0180-\u01C3\u01CD-\u01F0\u01F4-\u01F5\u01FA-\u0217\u0250-\u02A8\u02BB-\u02C1\u0386\u0388-\u038A\u038C\u038E-\u03A1\u03A3-\u03CE\u03D0-\u03D6\u03DA\u03DC\u03DE\u03E0\u03E2-\u03F3\u0401-\u040C\u040E-\u044F\u0451-\u045C\u045E-\u0481\u0490-\u04C4\u04C7-\u04C8\u04CB-\u04CC\u04D0-\u04EB\u04EE-\u04F5\u04F8-\u04F9\u0531-\u0556\u0559\u0561-\u0586\u05D0-\u05EA\u05F0-\u05F2\u0621-\u063A\u0641-\u064A\u0671-\u06B7\u06BA-\u06BE\u06C0-\u06CE\u06D0-\u06D3\u06D5\u06E5-\u06E6\u0905-\u0939\u093D\u0958-\u0961\u0985-\u098C\u098F-\u0990\u0993-\u09A8\u09AA-\u09B0\u09B2\u09B6-\u09B9\u09DC-\u09DD\u09DF-\u09E1\u09F0-\u09F1\u0A05-\u0A0A\u0A0F-\u0A10\u0A13-\u0A28\u0A2A-\u0A30\u0A32-\u0A33\u0A35-\u0A36\u0A38-\u0A39\u0A59-\u0A5C\u0A5E\u0A72-\u0A74\u0A85-\u0A8B\u0A8D\u0A8F-\u0A91\u0A93-\u0AA8\u0AAA-\u0AB0\u0AB2-\u0AB3\u0AB5-\u0AB9\u0ABD\u0AE0\u0B05-\u0B0C\u0B0F-\u0B10\u0B13-\u0B28\u0B2A-\u0B30\u0B32-\u0B33\u0B36-\u0B39\u0B3D\u0B5C-\u0B5D\u0B5F-\u0B61\u0B85-\u0B8A\u0B8E-\u0B90\u0B92-\u0B95\u0B99-\u0B9A\u0B9C\u0B9E-\u0B9F\u0BA3-\u0BA4\u0BA8-\u0BAA\u0BAE-\u0BB5\u0BB7-\u0BB9\u0C05-\u0C0C\u0C0E-\u0C10\u0C12-\u0C28\u0C2A-\u0C33\u0C35-\u0C39\u0C60-\u0C61\u0C85-\u0C8C\u0C8E-\u0C90\u0C92-\u0CA8\u0CAA-\u0CB3\u0CB5-\u0CB9\u0CDE\u0CE0-\u0CE1\u0D05-\u0D0C\u0D0E-\u0D10\u0D12-\u0D28\u0D2A-\u0D39\u0D60-\u0D61\u0E01-\u0E2E\u0E30\u0E32-\u0E33\u0E40-\u0E45\u0E81-\u0E82\u0E84\u0E87-\u0E88\u0E8A\u0E8D\u0E94-\u0E97\u0E99-\u0E9F\u0EA1-\u0EA3\u0EA5\u0EA7\u0EAA-\u0EAB\u0EAD-\u0EAE\u0EB0\u0EB2-\u0EB3\u0EBD\u0EC0-\u0EC4\u0F40-\u0F47\u0F49-\u0F69\u10A0-\u10C5\u10D0-\u10F6\u1100\u1102-\u1103\u1105-\u1107\u1109\u110B-\u110C\u110E-\u1112\u113C\u113E\u1140\u114C\u114E\u1150\u1154-\u1155\u1159\u115F-\u1161\u1163\u1165\u1167\u1169\u116D-\u116E\u1172-\u1173\u1175\u119E\u11A8\u11AB\u11AE-\u11AF\u11B7-\u11B8\u11BA\u11BC-\u11C2\u11EB\u11F0\u11F9\u1E00-\u1E9B\u1EA0-\u1EF9\u1F00-\u1F15\u1F18-\u1F1D\u1F20-\u1F45\u1F48-\u1F4D\u1F50-\u1F57\u1F59\u1F5B\u1F5D\u1F5F-\u1F7D\u1F80-\u1FB4\u1FB6-\u1FBC\u1FBE\u1FC2-\u1FC4\u1FC6-\u1FCC\u1FD0-\u1FD3\u1FD6-\u1FDB\u1FE0-\u1FEC\u1FF2-\u1FF4\u1FF6-\u1FFC\u2126\u212A-\u212B\u212E\u2180-\u2182\u3041-\u3094\u30A1-\u30FA\u3105-\u312C\uAC00-\uD7A3 variable Ideographic \u4E00-\u9FA5\u3007\u3021-\u3029 variable CombiningChar \u0300-\u0345\u0360-\u0361\u0483-\u0486\u0591-\u05A1\u05A3-\u05B9\u05BB-\u05BD\u05BF\u05C1-\u05C2\u05C4\u064B-\u0652\u0670\u06D6-\u06DC\u06DD-\u06DF\u06E0-\u06E4\u06E7-\u06E8\u06EA-\u06ED\u0901-\u0903\u093C\u093E-\u094C\u094D\u0951-\u0954\u0962-\u0963\u0981-\u0983\u09BC\u09BE\u09BF\u09C0-\u09C4\u09C7-\u09C8\u09CB-\u09CD\u09D7\u09E2-\u09E3\u0A02\u0A3C\u0A3E\u0A3F\u0A40-\u0A42\u0A47-\u0A48\u0A4B-\u0A4D\u0A70-\u0A71\u0A81-\u0A83\u0ABC\u0ABE-\u0AC5\u0AC7-\u0AC9\u0ACB-\u0ACD\u0B01-\u0B03\u0B3C\u0B3E-\u0B43\u0B47-\u0B48\u0B4B-\u0B4D\u0B56-\u0B57\u0B82-\u0B83\u0BBE-\u0BC2\u0BC6-\u0BC8\u0BCA-\u0BCD\u0BD7\u0C01-\u0C03\u0C3E-\u0C44\u0C46-\u0C48\u0C4A-\u0C4D\u0C55-\u0C56\u0C82-\u0C83\u0CBE-\u0CC4\u0CC6-\u0CC8\u0CCA-\u0CCD\u0CD5-\u0CD6\u0D02-\u0D03\u0D3E-\u0D43\u0D46-\u0D48\u0D4A-\u0D4D\u0D57\u0E31\u0E34-\u0E3A\u0E47-\u0E4E\u0EB1\u0EB4-\u0EB9\u0EBB-\u0EBC\u0EC8-\u0ECD\u0F18-\u0F19\u0F35\u0F37\u0F39\u0F3E\u0F3F\u0F71-\u0F84\u0F86-\u0F8B\u0F90-\u0F95\u0F97\u0F99-\u0FAD\u0FB1-\u0FB7\u0FB9\u20D0-\u20DC\u20E1\u302A-\u302F\u3099\u309A variable Digit \u0030-\u0039\u0660-\u0669\u06F0-\u06F9\u0966-\u096F\u09E6-\u09EF\u0A66-\u0A6F\u0AE6-\u0AEF\u0B66-\u0B6F\u0BE7-\u0BEF\u0C66-\u0C6F\u0CE6-\u0CEF\u0D66-\u0D6F\u0E50-\u0E59\u0ED0-\u0ED9\u0F20-\u0F29 variable Extender \u00B7\u02D0\u02D1\u0387\u0640\u0E46\u0EC6\u3005\u3031-\u3035\u309D-\u309E\u30FC-\u30FE variable Letter $BaseChar|$Ideographic # white space variable Wsp " \t\r\n" variable noWsp [cl ^$Wsp] # Various XML names variable NameChar \[-$Letter$Digit._:$CombiningChar$Extender\] variable Name \[_:$BaseChar$Ideographic\]$NameChar* variable Names ${Name}(?:$Wsp$Name)* variable Nmtoken $NameChar+ variable Nmtokens ${Nmtoken}(?:$Wsp$Nmtoken)* # table of predefined entities for XML variable EntityPredef array set EntityPredef { lt < gt > amp & quot \" apos ' } } # These regular expressions are defined here once for better performance namespace eval sgml { variable Wsp # Watch out for case-sensitivity set attlist_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(#REQUIRED|#IMPLIED) set attlist_enum_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*\\(([cl ^)]*)\\)[cl $Wsp]*("([cl ^")]*)")? ;# " set attlist_fixed_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(#FIXED)[cl $Wsp]*([cl ^$Wsp]+) set param_entity_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^"$Wsp]*)[cl $Wsp]*"([cl ^"]*)" set notation_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(.*) } ### Utility procedures # sgml::noop -- # # A do-nothing proc # # Arguments: # args arguments # # Results: # Nothing. proc sgml::noop args { return 0 } # sgml::identity -- # # Identity function. # # Arguments: # a arbitrary argument # # Results: # $a proc sgml::identity a { return $a } # sgml::Error -- # # Throw an error # # Arguments: # args arguments # # Results: # Error return condition. proc sgml::Error args { uplevel return -code error [list $args] } ### Following procedures are based on html_library # sgml::zapWhite -- # # Convert multiple white space into a single space. # # Arguments: # data plain text # # Results: # As above proc sgml::zapWhite data { regsub -all "\[ \t\r\n\]+" $data { } data return $data } proc sgml::Boolean value { regsub {1|true|yes|on} $value 1 value regsub {0|false|no|off} $value 0 value return $value } coccinella-0.96.20/TclXML/sgmlparser.tcl000066400000000000000000002421521167435367600200020ustar00rootroot00000000000000# sgmlparser.tcl -- # # This file provides the generic part of a parser for SGML-based # languages, namely HTML and XML. # # NB. It is a misnomer. There is no support for parsing # arbitrary SGML as such. # # See sgml.tcl for variable definitions. # # Copyright (c) 1998-2003 Zveno Pty Ltd # http://www.zveno.com/ # # See the file "LICENSE" in this distribution for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # $Id: sgmlparser.tcl,v 1.8 2007-02-01 14:54:31 matben Exp $ package require sgml 1.9 package require uri 1.1 package provide sgmlparser 99.0 namespace eval sgml { namespace export tokenise parseEvent namespace export parseDTD # NB. Most namespace variables are defined in sgml-8.[01].tcl # to account for differences between versions of Tcl. # This especially includes the regular expressions used. variable ParseEventNum if {![info exists ParseEventNum]} { set ParseEventNum 0 } variable ParseDTDnum if {![info exists ParseDTDNum]} { set ParseDTDNum 0 } variable declExpr [cl $::sgml::Wsp]*([cl ^$::sgml::Wsp]+)[cl $::sgml::Wsp]*([cl ^>]*) variable EntityExpr [cl $::sgml::Wsp]*(%[cl $::sgml::Wsp])?[cl $::sgml::Wsp]*($::sgml::Name)[cl $::sgml::Wsp]+(.*) #variable MarkupDeclExpr <([cl ^$::sgml::Wsp>]+)[cl $::sgml::Wsp]*([cl ^$::sgml::Wsp]+)[cl $::sgml::Wsp]*([cl ^>]*)> #variable MarkupDeclSub "} {\\1} {\\2} {\\3} {" variable MarkupDeclExpr <[cl $::sgml::Wsp]*([cl ^$::sgml::Wsp>]+)[cl $::sgml::Wsp]*([cl ^>]*)> variable MarkupDeclSub "\} {\\1} {\\2} \{" variable ExternalEntityExpr ^(PUBLIC|SYSTEM)[cl $::sgml::Wsp]+("|')(.*?)\\2([cl $::sgml::Wsp]+("|')(.*?)\\2)?([cl $::sgml::Wsp]+NDATA[cl $::sgml::Wsp]+($::xml::Name))?\$ variable StdOptions array set StdOptions [list \ -elementstartcommand [namespace current]::noop \ -elementendcommand [namespace current]::noop \ -characterdatacommand [namespace current]::noop \ -processinginstructioncommand [namespace current]::noop \ -externalentitycommand {} \ -xmldeclcommand [namespace current]::noop \ -doctypecommand [namespace current]::noop \ -commentcommand [namespace current]::noop \ -entitydeclcommand [namespace current]::noop \ -unparsedentitydeclcommand [namespace current]::noop \ -parameterentitydeclcommand [namespace current]::noop \ -notationdeclcommand [namespace current]::noop \ -elementdeclcommand [namespace current]::noop \ -attlistdeclcommand [namespace current]::noop \ -paramentityparsing 1 \ -defaultexpandinternalentities 1 \ -startdoctypedeclcommand [namespace current]::noop \ -enddoctypedeclcommand [namespace current]::noop \ -entityreferencecommand {} \ -warningcommand [namespace current]::noop \ -errorcommand [namespace current]::Error \ -final 1 \ -validate 0 \ -baseuri {} \ -name {} \ -cmd {} \ -emptyelement [namespace current]::EmptyElement \ -parseattributelistcommand [namespace current]::noop \ -parseentitydeclcommand [namespace current]::noop \ -normalize 1 \ -internaldtd {} \ -reportempty 0 \ -ignorewhitespace 0 \ ] } # sgml::tokenise -- # # Transform the given HTML/XML text into a Tcl list. # # Arguments: # sgml text to tokenize # elemExpr RE to recognise tags # elemSub transform for matched tags # args options # # Valid Options: # -internaldtdvariable # -final boolean True if no more data is to be supplied # -statevariable varName Name of a variable used to store info # # Results: # Returns a Tcl list representing the document. proc sgml::tokenise {sgml elemExpr elemSub args} { array set options {-final 1} array set options $args set options(-final) [Boolean $options(-final)] # If the data is not final then there must be a variable to store # unused data. if {!$options(-final) && ![info exists options(-statevariable)]} { return -code error {option "-statevariable" required if not final} } # Pre-process stage # # Extract the internal DTD subset, if any catch {upvar #0 $options(-internaldtdvariable) dtd} if {[regexp {]*$)} [lindex $sgml end] x text rest]} { set sgml [lreplace $sgml end end $text] # Mats: unmatched stuff means that it is chopped off. Cache it for next round. set state(leftover) $rest } # Patch from bug report #596959, Marshall Rose #if {[string compare [lindex $sgml 4] ""]} { # set sgml [linsert $sgml 0 {} {} {} {} {}] #} } else { # Performance note (Tcl 8.0): # In this case, no conversion to list object is performed # Mats: This fails if not -final and $sgml is chopped off right in a tag. regsub -all $elemExpr $sgml $elemSub sgml set sgml "{} {} {} \{$sgml\}" } return $sgml } # sgml::parseEvent -- # # Produces an event stream for a XML/HTML document, # given the Tcl list format returned by tokenise. # # This procedure checks that the document is well-formed, # and throws an error if the document is found to be not # well formed. Warnings are passed via the -warningcommand script. # # The procedure only check for well-formedness, # no DTD is required. However, facilities are provided for entity expansion. # # Arguments: # sgml Instance data, as a Tcl list. # args option/value pairs # # Valid Options: # -final Indicates end of document data # -validate Boolean to enable validation # -baseuri URL for resolving relative URLs # -elementstartcommand Called when an element starts # -elementendcommand Called when an element ends # -characterdatacommand Called when character data occurs # -entityreferencecommand Called when an entity reference occurs # -processinginstructioncommand Called when a PI occurs # -externalentitycommand Called for an external entity reference # # -xmldeclcommand Called when the XML declaration occurs # -doctypecommand Called when the document type declaration occurs # -commentcommand Called when a comment occurs # -entitydeclcommand Called when a parsed entity is declared # -unparsedentitydeclcommand Called when an unparsed external entity is declared # -parameterentitydeclcommand Called when a parameter entity is declared # -notationdeclcommand Called when a notation is declared # -elementdeclcommand Called when an element is declared # -attlistdeclcommand Called when an attribute list is declared # -paramentityparsing Boolean to enable/disable parameter entity substitution # -defaultexpandinternalentities Boolean to enable/disable expansion of entities declared in internal DTD subset # # -startdoctypedeclcommand Called when the Doc Type declaration starts (see also -doctypecommand) # -enddoctypedeclcommand Called when the Doc Type declaration ends (see also -doctypecommand) # # -errorcommand Script to evaluate for a fatal error # -warningcommand Script to evaluate for a reportable warning # -statevariable global state variable # -normalize whether to normalize names # -reportempty whether to include an indication of empty elements # -ignorewhitespace whether to automatically strip whitespace # # Results: # The various callback scripts are invoked. # Returns empty string. # # BUGS: # If command options are set to empty string then they should not be invoked. proc sgml::parseEvent {sgml args} { variable Wsp variable noWsp variable Nmtoken variable Name variable ParseEventNum variable StdOptions array set options [array get StdOptions] catch {array set options $args} # Mats: # If the data is not final then there must be a variable to persistently store the parse state. if {!$options(-final) && ![info exists options(-statevariable)]} { return -code error {option "-statevariable" required if not final} } foreach {opt value} [array get options *command] { if {[string compare $opt "-externalentitycommand"] && ![string length $value]} { set options($opt) [namespace current]::noop } } if {![info exists options(-statevariable)]} { set options(-statevariable) [namespace current]::ParseEvent[incr ParseEventNum] } if {![info exists options(entities)]} { set options(entities) [namespace current]::Entities$ParseEventNum array set $options(entities) [array get [namespace current]::EntityPredef] } if {![info exists options(extentities)]} { set options(extentities) [namespace current]::ExtEntities$ParseEventNum } if {![info exists options(parameterentities)]} { set options(parameterentities) [namespace current]::ParamEntities$ParseEventNum } if {![info exists options(externalparameterentities)]} { set options(externalparameterentities) [namespace current]::ExtParamEntities$ParseEventNum } if {![info exists options(elementdecls)]} { set options(elementdecls) [namespace current]::ElementDecls$ParseEventNum } if {![info exists options(attlistdecls)]} { set options(attlistdecls) [namespace current]::AttListDecls$ParseEventNum } if {![info exists options(notationdecls)]} { set options(notationdecls) [namespace current]::NotationDecls$ParseEventNum } if {![info exists options(namespaces)]} { set options(namespaces) [namespace current]::Namespaces$ParseEventNum } # For backward-compatibility catch {set options(-baseuri) $options(-baseurl)} # Choose an external entity resolver if {![string length $options(-externalentitycommand)]} { if {$options(-validate)} { set options(-externalentitycommand) [namespace code ResolveEntity] } else { set options(-externalentitycommand) [namespace code noop] } } upvar #0 $options(-statevariable) state upvar #0 $options(entities) entities # Mats: # The problem is that the state is not maintained when -final 0 ! # I've switched back to an older version here. if {![info exists state(line)]} { # Initialise the state variable array set state { mode normal haveXMLDecl 0 haveDocElement 0 inDTD 0 context {} stack {} line 0 defaultNS {} defaultNSURI {} } } foreach {tag close param text} $sgml { # Keep track of lines in the input incr state(line) [regsub -all \n $param {} discard] incr state(line) [regsub -all \n $text {} discard] # If the current mode is cdata or comment then we must undo what the # regsub has done to reconstitute the data set empty {} switch $state(mode) { comment { # This had "[string length $param] && " as a guard - # can't remember why :-( if {[regexp ([cl ^-]*)--\$ $tag discard comm1]} { # end of comment (in tag) set tag {} set close {} set state(mode) normal DeProtect1 $options(-commentcommand) $state(commentdata)<$comm1 unset state(commentdata) } elseif {[regexp ([cl ^-]*)--\$ $param discard comm1]} { # end of comment (in attributes) DeProtect1 $options(-commentcommand) $state(commentdata)<$close$tag>$comm1 unset state(commentdata) set tag {} set param {} set close {} set state(mode) normal } elseif {[regexp ([cl ^-]*)-->(.*) $text discard comm1 text]} { # end of comment (in text) DeProtect1 $options(-commentcommand) $state(commentdata)<$close$tag$param>$comm1 unset state(commentdata) set tag {} set param {} set close {} set state(mode) normal } else { # comment continues append state(commentdata) <$close$tag$param>$text continue } } cdata { if {[string length $param] && [regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $tag discard cdata1]} { # end of CDATA (in tag) PCDATA [array get options] $state(cdata)<[subst -nocommand -novariable $close$cdata1] set text [subst -novariable -nocommand $text] set tag {} unset state(cdata) set state(mode) normal } elseif {[regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $param discard cdata1]} { # end of CDATA (in attributes) PCDATA [array get options] $state(cdata)<[subst -nocommand -novariable $close$tag$cdata1] set text [subst -novariable -nocommand $text] set tag {} set param {} unset state(cdata) set state(mode) normal } elseif {[regexp (.*)\]\][cl $Wsp]*>(.*) $text discard cdata1 text]} { # end of CDATA (in text) PCDATA [array get options] $state(cdata)<[subst -nocommand -novariable $close$tag$param>$cdata1] set text [subst -novariable -nocommand $text] set tag {} set param {} set close {} unset state(cdata) set state(mode) normal } else { # CDATA continues append state(cdata) [subst -nocommand -novariable <$close$tag$param>$text] continue } } continue { # We're skipping elements looking for the close tag switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close { 0,* { continue } *,0, { if {![string compare $tag $state(continue:tag)]} { set empty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]] if {![string length $empty]} { incr state(continue:level) } } continue } *,0,/ { if {![string compare $tag $state(continue:tag)]} { incr state(continue:level) -1 } if {!$state(continue:level)} { unset state(continue:tag) unset state(continue:level) set state(mode) {} } } default { continue } } } default { # The trailing slash on empty elements can't be automatically separated out # in the RE, so we must do it here. regexp (.*)(/)[cl $Wsp]*$ $param discard param empty } } # default: normal mode # Bug: if the attribute list has a right angle bracket then the empty # element marker will not be seen set empty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]] switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close,$empty { 0,0,, { # Ignore empty tag - dealt with non-normal mode above } *,0,, { # Start tag for an element. # Check if the internal DTD entity is in an attribute value regsub -all &xml:intdtd\; $param \[$options(-internaldtd)\] param set code [catch {ParseEvent:ElementOpen $tag $param [array get options]} msg] set state(haveDocElement) 1 switch $code { 0 {# OK} 3 { # break return {} } 4 { # continue # Remember this tag and look for its close set state(continue:tag) $tag set state(continue:level) 1 set state(mode) continue continue } default { return -code $code -errorinfo $::errorInfo $msg } } } *,0,/, { # End tag for an element. set code [catch {ParseEvent:ElementClose $tag [array get options]} msg] switch $code { 0 {# OK} 3 { # break return {} } 4 { # continue # skip sibling nodes set state(continue:tag) [lindex $state(stack) end] set state(continue:level) 1 set state(mode) continue continue } default { return -code $code -errorinfo $::errorInfo $msg } } } *,0,,/ { # Empty element # The trailing slash sneaks through into the param variable regsub -all /[cl $::sgml::Wsp]*\$ $param {} param set code [catch {ParseEvent:ElementOpen $tag $param [array get options] -empty 1} msg] set state(haveDocElement) 1 switch $code { 0 {# OK} 3 { # break return {} } 4 { # continue # Pretty useless since it closes straightaway } default { return -code $code -errorinfo $::errorInfo $msg } } set code [catch {ParseEvent:ElementClose $tag [array get options] -empty 1} msg] switch $code { 0 {# OK} 3 { # break return {} } 4 { # continue # skip sibling nodes set state(continue:tag) [lindex $state(stack) end] set state(continue:level) 1 set state(mode) continue continue } default { return -code $code -errorinfo $::errorInfo $msg } } } *,1,* { # Processing instructions or XML declaration switch -glob -- $tag { {\?xml} { # XML Declaration if {$state(haveXMLDecl)} { uplevel #0 $options(-errorcommand) [list illegalcharacter "unexpected characters \"<$tag\" around line $state(line)"] } elseif {![regexp {\?$} $param]} { uplevel #0 $options(-errorcommand) [list missingcharacters "XML Declaration missing characters \"?>\" around line $state(line)"] } else { # We can do the parsing in one step with Tcl 8.1 RE's # This has the benefit of performing better WF checking set adv_re [format {^[%s]*version[%s]*=[%s]*("|')(-+|[a-zA-Z0-9_.:]+)\1([%s]+encoding[%s]*=[%s]*("|')([A-Za-z][-A-Za-z0-9._]*)\4)?([%s]*standalone[%s]*=[%s]*("|')(yes|no)\7)?[%s]*\?$} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] if {[catch {regexp $adv_re $param discard delimiter version discard delimiter encoding discard delimiter standalone} matches]} { # Otherwise we must fallback to 8.0. # This won't detect certain well-formedness errors # Get the version number if {[regexp [format {[%s]*version[%s]*=[%s]*"(-+|[a-zA-Z0-9_.:]+)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard version] || [regexp [format {[%s]*version[%s]*=[%s]*'(-+|[a-zA-Z0-9_.:]+)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard version]} { if {[string compare $version "1.0"]} { # Should we support future versions? # At least 1.X? uplevel #0 $options(-errorcommand) [list versionincompatibility "document XML version \"$version\" is incompatible with XML version 1.0"] } } else { uplevel #0 $options(-errorcommand) [list missingversion "XML Declaration missing version information around line $state(line)"] } # Get the encoding declaration set encoding {} regexp [format {[%s]*encoding[%s]*=[%s]*"([A-Za-z]([A-Za-z0-9._]|-)*)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard encoding regexp [format {[%s]*encoding[%s]*=[%s]*'([A-Za-z]([A-Za-z0-9._]|-)*)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard encoding # Get the standalone declaration set standalone {} regexp [format {[%s]*standalone[%s]*=[%s]*"(yes|no)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard standalone regexp [format {[%s]*standalone[%s]*=[%s]*'(yes|no)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard standalone # Invoke the callback uplevel #0 $options(-xmldeclcommand) [list $version $encoding $standalone] } elseif {$matches == 0} { uplevel #0 $options(-errorcommand) [list illformeddeclaration "XML Declaration not well-formed around line $state(line)"] } else { # Invoke the callback uplevel #0 $options(-xmldeclcommand) [list $version $encoding $standalone] } } } {\?*} { # Processing instruction set tag [string range $tag 1 end] if {[regsub {\?$} $tag {} tag]} { if {[string length [string trim $param]]} { uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$param\" in processing instruction around line $state(line)"] } } elseif {![regexp ^$Name\$ $tag]} { uplevel #0 $options(-errorcommand) [list illegalcharacter "illegal character in processing instruction target \"$tag\""] # Mats: to allow for "" } elseif {0 && [regexp {[xX][mM][lL]} $tag]} { uplevel #0 $options(-errorcommand) [list illegalcharacters "characters \"xml\" not permitted in processing instruction target \"$tag\""] } elseif {![regsub {\?$} $param {} param]} { uplevel #0 $options(-errorcommand) [list missingquestion "PI: expected '?' character around line $state(line)"] } set code [catch {uplevel #0 $options(-processinginstructioncommand) [list $tag [string trimleft $param]]} msg] switch $code { 0 {# OK} 3 { # break return {} } 4 { # continue # skip sibling nodes set state(continue:tag) [lindex $state(stack) end] set state(continue:level) 1 set state(mode) continue continue } default { return -code $code -errorinfo $::errorInfo $msg } } } !DOCTYPE { # External entity reference # This should move into xml.tcl # Parse the params supplied. Looking for Name, ExternalID and MarkupDecl set matched [regexp ^[cl $Wsp]*($Name)[cl $Wsp]*(.*) $param x state(doc_name) param] set state(doc_name) [Normalize $state(doc_name) $options(-normalize)] set externalID {} set pubidlit {} set systemlit {} set externalID {} if {[regexp -nocase ^[cl $Wsp]*(SYSTEM|PUBLIC)(.*) $param x id param]} { switch [string toupper $id] { SYSTEM { if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x systemlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} { set externalID [list SYSTEM $systemlit] ;# " } else { uplevel #0 $options(-errorcommand) {syntaxerror {syntax error: SYSTEM identifier not followed by literal}} } } PUBLIC { if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x pubidlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x pubidlit param]} { if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x systemlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} { set externalID [list PUBLIC $pubidlit $systemlit] } else { uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: PUBLIC identifier not followed by system literal around line $state(line)"] } } else { uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: PUBLIC identifier not followed by literal around line $state(line)"] } } } if {[regexp -nocase ^[cl $Wsp]+NDATA[cl $Wsp]+($Name)(.*) $param x notation param]} { lappend externalID $notation } } set state(inDTD) 1 ParseEvent:DocTypeDecl [array get options] $state(doc_name) $pubidlit $systemlit $options(-internaldtd) set state(inDTD) 0 } !--* { # Start of a comment # See if it ends in the same tag, otherwise change the # parsing mode regexp {!--(.*)} $tag discard comm1 if {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $comm1 discard comm1_1]} { # processed comment (end in tag) uplevel #0 $options(-commentcommand) [list $comm1_1] } elseif {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $param discard comm2]} { # processed comment (end in attributes) uplevel #0 $options(-commentcommand) [list $comm1$comm2] } elseif {[regexp ([cl ^-]*)-->(.*) $text discard comm2 text]} { # processed comment (end in text) uplevel #0 $options(-commentcommand) [list $comm1$param$empty>$comm2] } else { # start of comment set state(mode) comment set state(commentdata) "$comm1$param$empty>$text" continue } } {!\[CDATA\[*} { regexp {!\[CDATA\[(.*)} $tag discard cdata1 if {[regexp {(.*)]]$} $cdata1 discard cdata2]} { # processed CDATA (end in tag) PCDATA [array get options] [subst -novariable -nocommand $cdata2] set text [subst -novariable -nocommand $text] } elseif {[regexp {(.*)]]$} $param discard cdata2]} { # processed CDATA (end in attribute) # Backslashes in param are quoted at this stage PCDATA [array get options] $cdata1[subst -novariable -nocommand $cdata2] set text [subst -novariable -nocommand $text] } elseif {[regexp {(.*)]]>(.*)} $text discard cdata2 text]} { # processed CDATA (end in text) # Backslashes in param and text are quoted at this stage PCDATA [array get options] $cdata1[subst -novariable -nocommand $param]$empty>[subst -novariable -nocommand $cdata2] set text [subst -novariable -nocommand $text] } else { # start CDATA set state(cdata) "$cdata1$param>$text" set state(mode) cdata continue } } !ELEMENT - !ATTLIST - !ENTITY - !NOTATION { uplevel #0 $options(-errorcommand) [list illegaldeclaration "[string range $tag 1 end] declaration not expected in document instance around line $state(line)"] } default { uplevel #0 $options(-errorcommand) [list unknowninstruction "unknown processing instruction \"<$tag>\" around line $state(line)"] } } } *,1,* - *,0,/,/ { # Syntax error uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: closed/empty tag: tag $tag param $param empty $empty close $close around line $state(line)"] } } # Mats: we could have been reset from any of the callbacks! if {![info exists state(haveDocElement)]} { return } # Process character data if {$state(haveDocElement) && [llength $state(stack)]} { # Check if the internal DTD entity is in the text regsub -all &xml:intdtd\; $text \[$options(-internaldtd)\] text # Look for entity references if {([array size entities] || \ [string length $options(-entityreferencecommand)]) && \ $options(-defaultexpandinternalentities) && \ [regexp {&[^;]+;} $text]} { # protect Tcl specials # NB. braces and backslashes may already be protected regsub -all {\\({|}|\\)} $text {\1} text regsub -all {([][$\\{}])} $text {\\\1} text # Mark entity references regsub -all {&([^;]+);} $text [format {%s; %s {\1} ; %s %s} \}\} [namespace code [list Entity [array get options] $options(-entityreferencecommand) [namespace code [list PCDATA [array get options]]] $options(entities)]] [namespace code [list DeProtect [namespace code [list PCDATA [array get options]]]]] \{\{] text set text "uplevel #0 [namespace code [list DeProtect1 [namespace code [list PCDATA [array get options]]]]] {{$text}}" eval $text } else { # Restore protected special characters regsub -all {\\([][{}\\])} $text {\1} text PCDATA [array get options] $text } } elseif {[string length [string trim $text]]} { uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$text\" in document prolog around line $state(line)"] } } # If this is the end of the document, close all open containers if {$options(-final) && [llength $state(stack)]} { eval $options(-errorcommand) [list unclosedelement "element [lindex $state(stack) end] remains unclosed around line $state(line)"] } return {} } # sgml::DeProtect -- # # Invoke given command after removing protecting backslashes # from given text. # # Arguments: # cmd Command to invoke # text Text to deprotect # # Results: # Depends on command proc sgml::DeProtect1 {cmd text} { if {[string compare {} $text]} { regsub -all {\\([]$[{}\\])} $text {\1} text uplevel #0 $cmd [list $text] } } proc sgml::DeProtect {cmd text} { set text [lindex $text 0] if {[string compare {} $text]} { regsub -all {\\([]$[{}\\])} $text {\1} text uplevel #0 $cmd [list $text] } } # sgml::ParserDelete -- # # Free all memory associated with parser # # Arguments: # var global state array # # Results: # Variables unset proc sgml::ParserDelete var { upvar #0 $var state if {![info exists state]} { return -code error "unknown parser" } catch {unset $state(entities)} catch {unset $state(parameterentities)} catch {unset $state(elementdecls)} catch {unset $state(attlistdecls)} catch {unset $state(notationdecls)} catch {unset $state(namespaces)} unset state return {} } # sgml::ParseEvent:ElementOpen -- # # Start of an element. # # Arguments: # tag Element name # attr Attribute list # opts Options # args further configuration options # # Options: # -empty boolean # indicates whether the element was an empty element # # Results: # Modify state and invoke callback proc sgml::ParseEvent:ElementOpen {tag attr opts args} { variable Name variable Wsp array set options $opts upvar #0 $options(-statevariable) state array set cfg {-empty 0} array set cfg $args set handleEmpty 0 if {$options(-normalize)} { set tag [string toupper $tag] } # Update state lappend state(stack) $tag # Parse attribute list into a key-value representation if {[string compare $options(-parseattributelistcommand) {}]} { if {[catch {uplevel #0 $options(-parseattributelistcommand) [list $opts $attr]} attr]} { if {[string compare [lindex $attr 0] "unterminated attribute value"]} { uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"] set attr {} } else { # It is most likely that a ">" character was in an attribute value. # This manifests itself by ">" appearing in the element's text. # In this case the callback should return a three element list; # the message "unterminated attribute value", the attribute list it # did manage to parse and the remainder of the attribute list. foreach {msg attlist brokenattr} $attr break upvar text elemText if {[string first > $elemText] >= 0} { # Now piece the attribute list back together regexp [cl $Wsp]*($Name)[cl $Wsp]*=[cl $Wsp]*("|')(.*) $brokenattr discard attname delimiter attvalue regexp (.*)>([cl ^>]*)\$ $elemText discard remattlist elemText regexp ([cl ^$delimiter]*)${delimiter}(.*) $remattlist discard remattvalue remattlist # Gotcha: watch out for empty element syntax if {[string match */ [string trimright $remattlist]]} { set remattlist [string range $remattlist 0 end-1] set handleEmpty 1 set cfg(-empty) 1 } append attvalue >$remattvalue lappend attlist $attname $attvalue # Complete parsing the attribute list if {[catch {uplevel #0 $options(-parseattributelistcommand) [list $options(-statevariable) $remattlist]} attr]} { uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"] set attr {} set attlist {} } else { eval lappend attlist $attr } set attr $attlist } else { uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"] set attr {} } } } } set empty {} if {$cfg(-empty) && $options(-reportempty)} { set empty {-empty 1} } # Check for namespace declarations upvar #0 $options(namespaces) namespaces set nsdecls {} if {[llength $attr]} { array set attrlist $attr foreach {attrName attrValue} [array get attrlist xmlns*] { unset attrlist($attrName) set colon [set prefix {}] if {[regexp {^xmlns(:(.+))?$} $attrName discard colon prefix]} { switch -glob -- [string length $colon],[string length $prefix] { 0,0 { # default NS declaration lappend state(defaultNSURI) $attrValue lappend state(defaultNS) [llength $state(stack)] lappend nsdecls $attrValue {} } 0,* { # Huh? } *,0 { # Error uplevel #0 $state(-warningcommand) "no prefix specified for namespace URI \"$attrValue\" in element \"$tag\"" } default { set namespaces($prefix,[llength $state(stack)]) $attrValue lappend nsdecls $attrValue $prefix } } } } if {[llength $nsdecls]} { set nsdecls [list -namespacedecls $nsdecls] } set attr [array get attrlist] } # Check whether this element has an expanded name set ns {} if {[regexp {([^:]+):(.*)$} $tag discard prefix tag]} { set nsspec [lsort -dictionary -decreasing [array names namespaces $prefix,*]] if {[llength $nsspec]} { set nsuri $namespaces([lindex $nsspec 0]) set ns [list -namespace $nsuri] } else { uplevel #0 $options(-errorcommand) [list namespaceundeclared "no namespace declared for prefix \"$prefix\" in element $tag"] } } elseif {[llength $state(defaultNSURI)]} { set ns [list -namespace [lindex $state(defaultNSURI) end]] } # Invoke callback set code [catch {uplevel #0 $options(-elementstartcommand) [list $tag $attr] $empty $ns $nsdecls} msg] # Sometimes empty elements must be handled here (see above) if {$code == 0 && $handleEmpty} { ParseEvent:ElementClose $tag $opts -empty 1 } return -code $code -errorinfo $::errorInfo $msg } # sgml::ParseEvent:ElementClose -- # # End of an element. # # Arguments: # tag Element name # opts Options # args further configuration options # # Options: # -empty boolean # indicates whether the element as an empty element # # Results: # Modify state and invoke callback proc sgml::ParseEvent:ElementClose {tag opts args} { array set options $opts upvar #0 $options(-statevariable) state array set cfg {-empty 0} array set cfg $args # WF check if {[string compare $tag [lindex $state(stack) end]]} { uplevel #0 $options(-errorcommand) [list illegalendtag "end tag \"$tag\" does not match open element \"[lindex $state(stack) end]\" around line $state(line)"] return } # Check whether this element has an expanded name upvar #0 $options(namespaces) namespaces set ns {} if {[regexp {([^:]+):(.*)$} $tag discard prefix tag]} { set nsuri $namespaces([lindex [lsort -dictionary -decreasing [array names namespaces $prefix,*]] 0]) set ns [list -namespace $nsuri] } elseif {[llength $state(defaultNSURI)]} { set ns [list -namespace [lindex $state(defaultNSURI) end]] } # Pop namespace stacks, if any if {[llength $state(defaultNS)]} { if {[llength $state(stack)] == [lindex $state(defaultNS) end]} { set state(defaultNS) [lreplace $state(defaultNS) end end] } } foreach nsspec [array names namespaces *,[llength $state(stack)]] { unset namespaces($nsspec) } # Update state set state(stack) [lreplace $state(stack) end end] set empty {} if {$cfg(-empty) && $options(-reportempty)} { set empty {-empty 1} } # Invoke callback # Mats: Shall be same as sgml::ParseEvent:ElementOpen to handle exceptions in callback. set code [catch {uplevel #0 $options(-elementendcommand) [list $tag] $empty $ns} msg] return -code $code -errorinfo $::errorInfo $msg } # sgml::PCDATA -- # # Process PCDATA before passing to application # # Arguments: # opts options # pcdata Character data to be processed # # Results: # Checks that characters are legal, # checks -ignorewhitespace setting. proc sgml::PCDATA {opts pcdata} { array set options $opts if {$options(-ignorewhitespace) && \ ![string length [string trim $pcdata]]} { return {} } if {![regexp ^[cl $::sgml::Char]*\$ $pcdata]} { upvar \#0 $options(-statevariable) state uplevel \#0 $options(-errorcommand) [list illegalcharacters "illegal, non-Unicode characters found in text \"$pcdata\" around line $state(line)"] } uplevel \#0 $options(-characterdatacommand) [list $pcdata] } # sgml::Normalize -- # # Perform name normalization if required # # Arguments: # name name to normalize # req normalization required # # Results: # Name returned as upper-case if normalization required proc sgml::Normalize {name req} { if {$req} { return [string toupper $name] } else { return $name } } # sgml::Entity -- # # Resolve XML entity references (syntax: &xxx;). # # Arguments: # opts options # entityrefcmd application callback for entity references # pcdatacmd application callback for character data # entities name of array containing entity definitions. # ref entity reference (the "xxx" bit) # # Results: # Returns substitution text for given entity. proc sgml::Entity {opts entityrefcmd pcdatacmd entities ref} { array set options $opts upvar #0 $options(-statevariable) state if {![string length $entities]} { set entities [namespace current]::EntityPredef } switch -glob -- $ref { %* { # Parameter entity - not recognised outside of a DTD } #x* { # Character entity - hex if {[catch {format %c [scan [string range $ref 2 end] %x tmp; set tmp]} char]} { return -code error "malformed character entity \"$ref\"" } uplevel #0 $pcdatacmd [list $char] return {} } #* { # Character entity - decimal if {[catch {format %c [scan [string range $ref 1 end] %d tmp; set tmp]} char]} { return -code error "malformed character entity \"$ref\"" } uplevel #0 $pcdatacmd [list $char] return {} } default { # General entity upvar #0 $entities map if {[info exists map($ref)]} { if {![regexp {<|&} $map($ref)]} { # Simple text replacement - optimise uplevel #0 $pcdatacmd [list $map($ref)] return {} } # Otherwise an additional round of parsing is required. # This only applies to XML, since HTML doesn't have general entities # Must parse the replacement text for start & end tags, etc # This text must be self-contained: balanced closing tags, and so on set tokenised [tokenise $map($ref) $::xml::tokExpr $::xml::substExpr] set options(-final) 0 eval parseEvent [list $tokenised] [array get options] return {} } elseif {[string compare $entityrefcmd "::sgml::noop"]} { set result [uplevel #0 $entityrefcmd [list $ref]] if {[string length $result]} { uplevel #0 $pcdatacmd [list $result] } return {} } else { # Reconstitute entity reference uplevel #0 $options(-errorcommand) [list illegalentity "undefined entity reference \"$ref\""] return {} } } } # If all else fails leave the entity reference untouched uplevel #0 $pcdatacmd [list &$ref\;] return {} } #################################### # # DTD parser for SGML (XML). # # This DTD actually only handles XML DTDs. Other language's # DTD's, such as HTML, must be written in terms of a XML DTD. # #################################### # sgml::ParseEvent:DocTypeDecl -- # # Entry point for DTD parsing # # Arguments: # opts configuration options # docEl document element name # pubId public identifier # sysId system identifier (a URI) # intSSet internal DTD subset proc sgml::ParseEvent:DocTypeDecl {opts docEl pubId sysId intSSet} { array set options {} array set options $opts set code [catch {uplevel #0 $options(-doctypecommand) [list $docEl $pubId $sysId $intSSet]} err] switch $code { 3 { # break return {} } 0 - 4 { # continue } default { return -code $code $err } } # Otherwise we'll parse the DTD and report it piecemeal # The internal DTD subset is processed first (XML 2.8) # During this stage, parameter entities are only allowed # between markup declarations ParseDTD:Internal [array get options] $intSSet # The external DTD subset is processed last (XML 2.8) # During this stage, parameter entities may occur anywhere # We must resolve the external identifier to obtain the # DTD data. The application may supply its own resolver. if {[string length $pubId] || [string length $sysId]} { uplevel #0 $options(-externalentitycommand) [list $options(-cmd) $options(-baseuri) $sysId $pubId] } return {} } # sgml::ParseDTD:Internal -- # # Parse the internal DTD subset. # # Parameter entities are only allowed between markup declarations. # # Arguments: # opts configuration options # dtd DTD data # # Results: # Markup declarations parsed may cause callback invocation proc sgml::ParseDTD:Internal {opts dtd} { variable MarkupDeclExpr variable MarkupDeclSub array set options {} array set options $opts upvar #0 $options(-statevariable) state upvar #0 $options(parameterentities) PEnts upvar #0 $options(externalparameterentities) ExtPEnts # Bug 583947: remove comments before further processing regsub -all {} $dtd {} dtd # Tokenize the DTD # Protect Tcl special characters regsub -all {([{}\\])} $dtd {\\\1} dtd regsub -all $MarkupDeclExpr $dtd $MarkupDeclSub dtd # Entities may have angle brackets in their replacement # text, which breaks the RE processing. So, we must # use a similar technique to processing doc instances # to rebuild the declarations from the pieces set mode {} ;# normal set delimiter {} set name {} set param {} set state(inInternalDTD) 1 # Process the tokens foreach {decl value text} [lrange "{} {} \{$dtd\}" 3 end] { # Keep track of line numbers incr state(line) [regsub -all \n $text {} discard] ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode replText text param # There may be parameter entity references between markup decls if {[regexp {%.*;} $text]} { # Protect Tcl special characters regsub -all {([{}\\])} $text {\\\1} text regsub -all %($::sgml::Name)\; $text "\} {\\1} \{" text set PElist "\{$text\}" set PElist [lreplace $PElist end end] foreach {text entref} $PElist { if {[string length [string trim $text]]} { uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text in internal DTD subset around line $state(line)"] } # Expand parameter entity and recursively parse # BUG: no checks yet for recursive entity references if {[info exists PEnts($entref)]} { set externalParser [$options(-cmd) entityparser] $externalParser parse $PEnts($entref) -dtdsubset internal } elseif {[info exists ExtPEnts($entref)]} { set externalParser [$options(-cmd) entityparser] $externalParser parse $ExtPEnts($entref) -dtdsubset external #$externalParser free } else { uplevel #0 $options(-errorcommand) [list illegalreference "reference to undeclared parameter entity \"$entref\""] } } } } return {} } # sgml::ParseDTD:EntityMode -- # # Perform special processing for various parser modes # # Arguments: # opts configuration options # modeVar pass-by-reference mode variable # replTextVar pass-by-ref # declVar pass-by-ref # valueVar pass-by-ref # textVar pass-by-ref # delimiter delimiter currently in force # name # param # # Results: # Depends on current mode proc sgml::ParseDTD:EntityMode {opts modeVar replTextVar declVar valueVar textVar delimiter name param} { upvar 1 $modeVar mode upvar 1 $replTextVar replText upvar 1 $declVar decl upvar 1 $valueVar value upvar 1 $textVar text array set options $opts switch $mode { {} { # Pass through to normal processing section } entity { # Look for closing delimiter if {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $decl discard val1 remainder]} { append replText <$val1 DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter set decl / set text $remainder\ $value>$text set value {} set mode {} } elseif {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $value discard val2 remainder]} { append replText <$decl\ $val2 DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter set decl / set text $remainder>$text set value {} set mode {} } elseif {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $text discard val3 remainder]} { append replText <$decl\ $value>$val3 DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter set decl / set text $remainder set value {} set mode {} } else { # Remain in entity mode append replText <$decl\ $value>$text return -code continue } } ignore { upvar #0 $options(-statevariable) state if {[regexp {]](.*)$} $decl discard remainder]} { set state(condSections) [lreplace $state(condSections) end end] set decl $remainder set mode {} } elseif {[regexp {]](.*)$} $value discard remainder]} { set state(condSections) [lreplace $state(condSections) end end] regexp <[cl $::sgml::Wsp]*($::sgml::Name)(.*) $remainder discard decl value set mode {} } elseif {[regexp {]]>(.*)$} $text discard remainder]} { set state(condSections) [lreplace $state(condSections) end end] set decl / set value {} set text $remainder #regexp <[cl $::sgml::Wsp]*($::sgml::Name)([cl ^>]*)>(.*) $remainder discard decl value text set mode {} } else { set decl / } } comment { # Look for closing comment delimiter upvar #0 $options(-statevariable) state if {[regexp (.*?)--(.*)\$ $decl discard data1 remainder]} { } elseif {[regexp (.*?)--(.*)\$ $value discard data1 remainder]} { } elseif {[regexp (.*?)--(.*)\$ $text discard data1 remainder]} { } else { # comment continues append state(commentdata) <$decl\ $value>$text set decl / set value {} set text {} } } } return {} } # sgml::ParseDTD:ProcessMarkupDecl -- # # Process a single markup declaration # # Arguments: # opts configuration options # declVar pass-by-ref # valueVar pass-by-ref # delimiterVar pass-by-ref for current delimiter in force # nameVar pass-by-ref # modeVar pass-by-ref for current parser mode # replTextVar pass-by-ref # textVar pass-by-ref # paramVar pass-by-ref # # Results: # Depends on markup declaration. May change parser mode proc sgml::ParseDTD:ProcessMarkupDecl {opts declVar valueVar delimiterVar nameVar modeVar replTextVar textVar paramVar} { upvar 1 $modeVar mode upvar 1 $replTextVar replText upvar 1 $textVar text upvar 1 $declVar decl upvar 1 $valueVar value upvar 1 $nameVar name upvar 1 $delimiterVar delimiter upvar 1 $paramVar param variable declExpr variable ExternalEntityExpr array set options $opts upvar #0 $options(-statevariable) state switch -glob -- $decl { / { # continuation from entity processing } !ELEMENT { # Element declaration if {[regexp $declExpr $value discard tag cmodel]} { DTD:ELEMENT [array get options] $tag $cmodel } else { uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed element declaration around line $state(line)"] } } !ATTLIST { # Attribute list declaration variable declExpr if {[regexp $declExpr $value discard tag attdefns]} { if {[catch {DTD:ATTLIST [array get options] $tag $attdefns} err]} { #puts stderr "Stack trace: $::errorInfo\n***\n" # Atttribute parsing has bugs at the moment #return -code error "$err around line $state(line)" return {} } } else { uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed attribute list declaration around line $state(line)"] } } !ENTITY { # Entity declaration variable EntityExpr if {[regexp $EntityExpr $value discard param name value]} { # Entity replacement text may have a '>' character. # In this case, the real delimiter will be in the following # text. This is complicated by the possibility of there # being several '<','>' pairs in the replacement text. # At this point, we are searching for the matching quote delimiter. if {[regexp $ExternalEntityExpr $value]} { DTD:ENTITY [array get options] $name [string trim $param] $value } elseif {[regexp ("|')(.*?)\\1(.*) $value discard delimiter replText value]} { if {[string length [string trim $value]]} { uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed entity declaration around line $state(line)"] } else { DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter } } elseif {[regexp ("|')(.*) $value discard delimiter replText]} { append replText >$text set text {} set mode entity } else { uplevel #0 $options(-errorcommand) [list illegaldeclaration "no delimiter for entity declaration around line $state(line)"] } } else { uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed entity declaration around line $state(line)"] } } !NOTATION { # Notation declaration if {[regexp $declExpr param discard tag notation]} { DTD:ENTITY [array get options] $tag $notation } else { uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed entity declaration around line $state(line)"] } } !--* { # Start of a comment if {[regexp !--(.*?)--\$ $decl discard data]} { if {[string length [string trim $value]]} { uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$value\""] } uplevel #0 $options(-commentcommand) [list $data] set decl / set value {} } elseif {[regexp -- ^(.*?)--\$ $value discard data2]} { regexp !--(.*)\$ $decl discard data1 uplevel #0 $options(-commentcommand) [list $data1\ $data2] set decl / set value {} } elseif {[regexp (.*?)-->(.*)\$ $text discard data3 remainder]} { regexp !--(.*)\$ $decl discard data1 uplevel #0 $options(-commentcommand) [list $data1\ $value>$data3] set decl / set value {} set text $remainder } else { regexp !--(.*)\$ $decl discard data1 set state(commentdata) $data1\ $value>$text set decl / set value {} set text {} set mode comment } } !*INCLUDE* - !*IGNORE* { if {$state(inInternalDTD)} { uplevel #0 $options(-errorcommand) [list illegalsection "conditional section not permitted in internal DTD subset around line $state(line)"] } if {[regexp {^!\[INCLUDE\[(.*)} $decl discard remainder]} { # Push conditional section stack, popped by ]]> sequence if {[regexp {(.*?)]]$} $remainder discard r2]} { # section closed immediately if {[string length [string trim $r2]]} { uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"] } } elseif {[regexp {(.*?)]](.*)} $value discard r2 r3]} { # section closed immediately if {[string length [string trim $r2]]} { uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"] } if {[string length [string trim $r3]]} { uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r3\" in conditional section"] } } else { lappend state(condSections) INCLUDE set parser [$options(-cmd) entityparser] $parser parse $remainder\ $value> -dtdsubset external #$parser free if {[regexp {(.*?)]]>(.*)} $text discard t1 t2]} { if {[string length [string trim $t1]]} { uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$t1\""] } if {![llength $state(condSections)]} { uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"] } set state(condSections) [lreplace $state(condSections) end end] set text $t2 } } } elseif {[regexp {^!\[IGNORE\[(.*)} $decl discard remainder]} { # Set ignore mode. Still need a stack set mode ignore if {[regexp {(.*?)]]$} $remainder discard r2]} { # section closed immediately if {[string length [string trim $r2]]} { uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"] } } elseif {[regexp {(.*?)]](.*)} $value discard r2 r3]} { # section closed immediately if {[string length [string trim $r2]]} { uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"] } if {[string length [string trim $r3]]} { uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r3\" in conditional section"] } } else { lappend state(condSections) IGNORE if {[regexp {(.*?)]]>(.*)} $text discard t1 t2]} { if {[string length [string trim $t1]]} { uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$t1\""] } if {![llength $state(condSections)]} { uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"] } set state(condSections) [lreplace $state(condSections) end end] set text $t2 } } } else { uplevel #0 $options(-errorcommand) [list illegaldeclaration "illegal markup declaration \"$decl\" around line $state(line)"] } } default { if {[regexp {^\?(.*)} $decl discard target]} { # Processing instruction } else { uplevel #0 $options(-errorcommand) [list illegaldeclaration "illegal markup declaration \"$decl\""] } } } return {} } # sgml::ParseDTD:External -- # # Parse the external DTD subset. # # Parameter entities are allowed anywhere. # # Arguments: # opts configuration options # dtd DTD data # # Results: # Markup declarations parsed may cause callback invocation proc sgml::ParseDTD:External {opts dtd} { variable MarkupDeclExpr variable MarkupDeclSub variable declExpr array set options $opts upvar #0 $options(parameterentities) PEnts upvar #0 $options(externalparameterentities) ExtPEnts upvar #0 $options(-statevariable) state # As with the internal DTD subset, watch out for # entities with angle brackets set mode {} ;# normal set delimiter {} set name {} set param {} set oldState 0 catch {set oldState $state(inInternalDTD)} set state(inInternalDTD) 0 # Initialise conditional section stack if {![info exists state(condSections)]} { set state(condSections) {} } set startCondSectionDepth [llength $state(condSections)] while {[string length $dtd]} { set progress 0 set PEref {} if {![string compare $mode "ignore"]} { set progress 1 if {[regexp {]]>(.*)} $dtd discard dtd]} { set remainder {} set mode {} ;# normal set state(condSections) [lreplace $state(condSections) end end] continue } else { uplevel #0 $options(-errorcommand) [list missingdelimiter "IGNORE conditional section closing delimiter not found"] } } elseif {[regexp ^(.*?)%($::sgml::Name)\;(.*)\$ $dtd discard data PEref remainder]} { set progress 1 } else { set data $dtd set dtd {} set remainder {} } # Tokenize the DTD (so far) # Protect Tcl special characters regsub -all {([{}\\])} $data {\\\1} dataP set n [regsub -all $MarkupDeclExpr $dataP $MarkupDeclSub dataP] if {$n} { set progress 1 # All but the last markup declaration should have no text set dataP [lrange "{} {} \{$dataP\}" 3 end] if {[llength $dataP] > 3} { foreach {decl value text} [lrange $dataP 0 [expr [llength $dataP] - 4]] { ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode repltextVar text param if {[string length [string trim $text]]} { # check for conditional section close if {[regexp {]]>(.*)$} $text discard text]} { if {[string length [string trim $text]]} { uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$text\""] } if {![llength $state(condSections)]} { uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"] } set state(condSections) [lreplace $state(condSections) end end] if {![string compare $mode "ignore"]} { set mode {} ;# normal } } else { uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$text\""] } } } } # Do the last declaration foreach {decl value text} [lrange $dataP [expr [llength $dataP] - 3] end] { ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode repltextVar text param } } # Now expand the PE reference, if any switch -glob -- $mode,[string length $PEref],$n { ignore,0,* { set dtd $text } ignore,*,* { set dtd $text$remainder } *,0,0 { set dtd $data } *,0,* { set dtd $text } *,*,0 { if {[catch {append data $PEnts($PEref)}]} { if {[info exists ExtPEnts($PEref)]} { set externalParser [$options(-cmd) entityparser] $externalParser parse $ExtPEnts($PEref) -dtdsubset external #$externalParser free } else { uplevel #0 $options(-errorcommand) [list entityundeclared "parameter entity \"$PEref\" not declared"] } } set dtd $data$remainder } default { if {[catch {append text $PEnts($PEref)}]} { if {[info exists ExtPEnts($PEref)]} { set externalParser [$options(-cmd) entityparser] $externalParser parse $ExtPEnts($PEref) -dtdsubset external #$externalParser free } else { uplevel #0 $options(-errorcommand) [list entityundeclared "parameter entity \"$PEref\" not declared"] } } set dtd $text$remainder } } # Check whether a conditional section has been terminated if {[regexp {^(.*?)]]>(.*)$} $dtd discard t1 t2]} { if {![regexp <.*> $t1]} { if {[string length [string trim $t1]]} { uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$t1\""] } if {![llength $state(condSections)]} { uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"] } set state(condSections) [lreplace $state(condSections) end end] if {![string compare $mode "ignore"]} { set mode {} ;# normal } set dtd $t2 set progress 1 } } if {!$progress} { # No parameter entity references were found and # the text does not contain a well-formed markup declaration # Avoid going into an infinite loop upvar #0 $options(-errorcommand) [list syntaxerror "external entity does not contain well-formed markup declaration"] break } } set state(inInternalDTD) $oldState # Check that conditional sections have been closed properly if {[llength $state(condSections)] > $startCondSectionDepth} { uplevel #0 $options(-errorcommand) [list syntaxerror "[lindex $state(condSections) end] conditional section not closed"] } if {[llength $state(condSections)] < $startCondSectionDepth} { uplevel #0 $options(-errorcommand) [list syntaxerror "too many conditional section closures"] } return {} } # Procedures for handling the various declarative elements in a DTD. # New elements may be added by creating a procedure of the form # parse:DTD:_element_ # For each of these procedures, the various regular expressions they use # are created outside of the proc to avoid overhead at runtime # sgml::DTD:ELEMENT -- # # defines an element. # # The content model for the element is stored in the contentmodel array, # indexed by the element name. The content model is parsed into the # following list form: # # {} Content model is EMPTY. # Indicated by an empty list. # * Content model is ANY. # Indicated by an asterix. # {ELEMENT ...} # Content model is element-only. # {MIXED {element1 element2 ...}} # Content model is mixed (PCDATA and elements). # The second element of the list contains the # elements that may occur. #PCDATA is assumed # (ie. the list is normalised). # # Arguments: # opts configuration options # name element GI # modspec unparsed content model specification proc sgml::DTD:ELEMENT {opts name modspec} { variable Wsp array set options $opts upvar #0 $options(elementdecls) elements if {$options(-validate) && [info exists elements($name)]} { eval $options(-errorcommand) [list elementdeclared "element \"$name\" already declared"] } else { switch -- $modspec { EMPTY { set elements($name) {} uplevel #0 $options(-elementdeclcommand) $name {{}} } ANY { set elements($name) * uplevel #0 $options(-elementdeclcommand) $name * } default { # Don't parse the content model for now, # just pass the model to the application if {0 && [regexp [format {^\([%s]*#PCDATA[%s]*(\|([^)]+))?[%s]*\)*[%s]*$} $Wsp $Wsp $Wsp $Wsp] discard discard mtoks]} { set cm($name) [list MIXED [split $mtoks |]] } elseif {0} { if {[catch {CModelParse $state(state) $value} result]} { eval $options(-errorcommand) [list element? $result] } else { set cm($id) [list ELEMENT $result] } } else { set elements($name) $modspec uplevel #0 $options(-elementdeclcommand) $name [list $modspec] } } } } } # sgml::CModelParse -- # # Parse an element content model (non-mixed). # A syntax tree is constructed. # A transition table is built next. # # This is going to need alot of work! # # Arguments: # state state array variable # value the content model data # # Results: # A Tcl list representing the content model. proc sgml::CModelParse {state value} { upvar #0 $state var # First build syntax tree set syntaxTree [CModelMakeSyntaxTree $state $value] # Build transition table set transitionTable [CModelMakeTransitionTable $state $syntaxTree] return [list $syntaxTree $transitionTable] } # sgml::CModelMakeSyntaxTree -- # # Construct a syntax tree for the regular expression. # # Syntax tree is represented as a Tcl list: # rep {:choice|:seq {{rep list1} {rep list2} ...}} # where: rep is repetition character, *, + or ?. {} for no repetition # listN is nested expression or Name # # Arguments: # spec Element specification # # Results: # Syntax tree for element spec as nested Tcl list. # # Examples: # (memo) # {} {:seq {{} memo}} # (front, body, back?) # {} {:seq {{} front} {{} body} {? back}} # (head, (p | list | note)*, div2*) # {} {:seq {{} head} {* {:choice {{} p} {{} list} {{} note}}} {* div2}} # (p | a | ul)+ # + {:choice {{} p} {{} a} {{} ul}} proc sgml::CModelMakeSyntaxTree {state spec} { upvar #0 $state var variable Wsp variable name # Translate the spec into a Tcl list. # None of the Tcl special characters are allowed in a content model spec. if {[regexp {\$|\[|\]|\{|\}} $spec]} { return -code error "illegal characters in specification" } regsub -all [format {(%s)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $name $Wsp $Wsp] $spec [format {%sCModelSTname %s {\1} {\2} {\3}} \n $state] spec regsub -all {\(} $spec "\nCModelSTopenParen $state " spec regsub -all [format {\)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $Wsp $Wsp] $spec [format {%sCModelSTcloseParen %s {\1} {\2}} \n $state] spec array set var {stack {} state start} eval $spec # Peel off the outer seq, its redundant return [lindex [lindex $var(stack) 1] 0] } # sgml::CModelSTname -- # # Processes a name in a content model spec. # # Arguments: # state state array variable # name name specified # rep repetition operator # cs choice or sequence delimiter # # Results: # See CModelSTcp. proc sgml::CModelSTname {state name rep cs args} { if {[llength $args]} { return -code error "syntax error in specification: \"$args\"" } CModelSTcp $state $name $rep $cs } # sgml::CModelSTcp -- # # Process a content particle. # # Arguments: # state state array variable # name name specified # rep repetition operator # cs choice or sequence delimiter # # Results: # The content particle is added to the current group. proc sgml::CModelSTcp {state cp rep cs} { upvar #0 $state var switch -glob -- [lindex $var(state) end]=$cs { start= { set var(state) [lreplace $var(state) end end end] # Add (dummy) grouping, either choice or sequence will do CModelSTcsSet $state , CModelSTcpAdd $state $cp $rep } :choice= - :seq= { set var(state) [lreplace $var(state) end end end] CModelSTcpAdd $state $cp $rep } start=| - start=, { set var(state) [lreplace $var(state) end end [expr {$cs == "," ? ":seq" : ":choice"}]] CModelSTcsSet $state $cs CModelSTcpAdd $state $cp $rep } :choice=| - :seq=, { CModelSTcpAdd $state $cp $rep } :choice=, - :seq=| { return -code error "syntax error in specification: incorrect delimiter after \"$cp\", should be \"[expr {$cs == "," ? "|" : ","}]\"" } end=* { return -code error "syntax error in specification: no delimiter before \"$cp\"" } default { return -code error "syntax error" } } } # sgml::CModelSTcsSet -- # # Start a choice or sequence on the stack. # # Arguments: # state state array # cs choice oir sequence # # Results: # state is modified: end element of state is appended. proc sgml::CModelSTcsSet {state cs} { upvar #0 $state var set cs [expr {$cs == "," ? ":seq" : ":choice"}] if {[llength $var(stack)]} { set var(stack) [lreplace $var(stack) end end $cs] } else { set var(stack) [list $cs {}] } } # sgml::CModelSTcpAdd -- # # Append a content particle to the top of the stack. # # Arguments: # state state array # cp content particle # rep repetition # # Results: # state is modified: end element of state is appended. proc sgml::CModelSTcpAdd {state cp rep} { upvar #0 $state var if {[llength $var(stack)]} { set top [lindex $var(stack) end] lappend top [list $rep $cp] set var(stack) [lreplace $var(stack) end end $top] } else { set var(stack) [list $rep $cp] } } # sgml::CModelSTopenParen -- # # Processes a '(' in a content model spec. # # Arguments: # state state array # # Results: # Pushes stack in state array. proc sgml::CModelSTopenParen {state args} { upvar #0 $state var if {[llength $args]} { return -code error "syntax error in specification: \"$args\"" } lappend var(state) start lappend var(stack) [list {} {}] } # sgml::CModelSTcloseParen -- # # Processes a ')' in a content model spec. # # Arguments: # state state array # rep repetition # cs choice or sequence delimiter # # Results: # Stack is popped, and former top of stack is appended to previous element. proc sgml::CModelSTcloseParen {state rep cs args} { upvar #0 $state var if {[llength $args]} { return -code error "syntax error in specification: \"$args\"" } set cp [lindex $var(stack) end] set var(stack) [lreplace $var(stack) end end] set var(state) [lreplace $var(state) end end] CModelSTcp $state $cp $rep $cs } # sgml::CModelMakeTransitionTable -- # # Given a content model's syntax tree, constructs # the transition table for the regular expression. # # See "Compilers, Principles, Techniques, and Tools", # Aho, Sethi and Ullman. Section 3.9, algorithm 3.5. # # Arguments: # state state array variable # st syntax tree # # Results: # The transition table is returned, as a key/value Tcl list. proc sgml::CModelMakeTransitionTable {state st} { upvar #0 $state var # Construct nullable, firstpos and lastpos functions array set var {number 0} foreach {nullable firstpos lastpos} [ \ TraverseDepth1st $state $st { # Evaluated for leaf nodes # Compute nullable(n) # Compute firstpos(n) # Compute lastpos(n) set nullable [nullable leaf $rep $name] set firstpos [list {} $var(number)] set lastpos [list {} $var(number)] set var(pos:$var(number)) $name } { # Evaluated for nonterminal nodes # Compute nullable, firstpos, lastpos set firstpos [firstpos $cs $firstpos $nullable] set lastpos [lastpos $cs $lastpos $nullable] set nullable [nullable nonterm $rep $cs $nullable] } \ ] break set accepting [incr var(number)] set var(pos:$accepting) # # var(pos:N) maps from position to symbol. # Construct reverse map for convenience. # NB. A symbol may appear in more than one position. # var is about to be reset, so use different arrays. foreach {pos symbol} [array get var pos:*] { set pos [lindex [split $pos :] 1] set pos2symbol($pos) $symbol lappend sym2pos($symbol) $pos } # Construct the followpos functions catch {unset var} followpos $state $st $firstpos $lastpos # Construct transition table # Dstates is [union $marked $unmarked] set unmarked [list [lindex $firstpos 1]] while {[llength $unmarked]} { set T [lindex $unmarked 0] lappend marked $T set unmarked [lrange $unmarked 1 end] # Find which input symbols occur in T set symbols {} foreach pos $T { if {$pos != $accepting && [lsearch $symbols $pos2symbol($pos)] < 0} { lappend symbols $pos2symbol($pos) } } foreach a $symbols { set U {} foreach pos $sym2pos($a) { if {[lsearch $T $pos] >= 0} { # add followpos($pos) if {$var($pos) == {}} { lappend U $accepting } else { eval lappend U $var($pos) } } } set U [makeSet $U] if {[llength $U] && [lsearch $marked $U] < 0 && [lsearch $unmarked $U] < 0} { lappend unmarked $U } set Dtran($T,$a) $U } } return [list [array get Dtran] [array get sym2pos] $accepting] } # sgml::followpos -- # # Compute the followpos function, using the already computed # firstpos and lastpos. # # Arguments: # state array variable to store followpos functions # st syntax tree # firstpos firstpos functions for the syntax tree # lastpos lastpos functions # # Results: # followpos functions for each leaf node, in name/value format proc sgml::followpos {state st firstpos lastpos} { upvar #0 $state var switch -- [lindex [lindex $st 1] 0] { :seq { for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} { followpos $state [lindex [lindex $st 1] $i] \ [lindex [lindex $firstpos 0] [expr $i - 1]] \ [lindex [lindex $lastpos 0] [expr $i - 1]] foreach pos [lindex [lindex [lindex $lastpos 0] [expr $i - 1]] 1] { eval lappend var($pos) [lindex [lindex [lindex $firstpos 0] $i] 1] set var($pos) [makeSet $var($pos)] } } } :choice { for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} { followpos $state [lindex [lindex $st 1] $i] \ [lindex [lindex $firstpos 0] [expr $i - 1]] \ [lindex [lindex $lastpos 0] [expr $i - 1]] } } default { # No action at leaf nodes } } switch -- [lindex $st 0] { ? { # We having nothing to do here ! Doing the same as # for * effectively converts this qualifier into the other. } * { foreach pos [lindex $lastpos 1] { eval lappend var($pos) [lindex $firstpos 1] set var($pos) [makeSet $var($pos)] } } } } # sgml::TraverseDepth1st -- # # Perform depth-first traversal of a tree. # A new tree is constructed, with each node computed by f. # # Arguments: # state state array variable # t The tree to traverse, a Tcl list # leaf Evaluated at a leaf node # nonTerm Evaluated at a nonterminal node # # Results: # A new tree is returned. proc sgml::TraverseDepth1st {state t leaf nonTerm} { upvar #0 $state var set nullable {} set firstpos {} set lastpos {} switch -- [lindex [lindex $t 1] 0] { :seq - :choice { set rep [lindex $t 0] set cs [lindex [lindex $t 1] 0] foreach child [lrange [lindex $t 1] 1 end] { foreach {childNullable childFirstpos childLastpos} \ [TraverseDepth1st $state $child $leaf $nonTerm] break lappend nullable $childNullable lappend firstpos $childFirstpos lappend lastpos $childLastpos } eval $nonTerm } default { incr var(number) set rep [lindex [lindex $t 0] 0] set name [lindex [lindex $t 1] 0] eval $leaf } } return [list $nullable $firstpos $lastpos] } # sgml::firstpos -- # # Computes the firstpos function for a nonterminal node. # # Arguments: # cs node type, choice or sequence # firstpos firstpos functions for the subtree # nullable nullable functions for the subtree # # Results: # firstpos function for this node is returned. proc sgml::firstpos {cs firstpos nullable} { switch -- $cs { :seq { set result [lindex [lindex $firstpos 0] 1] for {set i 0} {$i < [llength $nullable]} {incr i} { if {[lindex [lindex $nullable $i] 1]} { eval lappend result [lindex [lindex $firstpos [expr $i + 1]] 1] } else { break } } } :choice { foreach child $firstpos { eval lappend result $child } } } return [list $firstpos [makeSet $result]] } # sgml::lastpos -- # # Computes the lastpos function for a nonterminal node. # Same as firstpos, only logic is reversed # # Arguments: # cs node type, choice or sequence # lastpos lastpos functions for the subtree # nullable nullable functions forthe subtree # # Results: # lastpos function for this node is returned. proc sgml::lastpos {cs lastpos nullable} { switch -- $cs { :seq { set result [lindex [lindex $lastpos end] 1] for {set i [expr [llength $nullable] - 1]} {$i >= 0} {incr i -1} { if {[lindex [lindex $nullable $i] 1]} { eval lappend result [lindex [lindex $lastpos $i] 1] } else { break } } } :choice { foreach child $lastpos { eval lappend result $child } } } return [list $lastpos [makeSet $result]] } # sgml::makeSet -- # # Turn a list into a set, ie. remove duplicates. # # Arguments: # s a list # # Results: # A set is returned, which is a list with duplicates removed. proc sgml::makeSet s { foreach r $s { if {[llength $r]} { set unique($r) {} } } return [array names unique] } # sgml::nullable -- # # Compute the nullable function for a node. # # Arguments: # nodeType leaf or nonterminal # rep repetition applying to this node # name leaf node: symbol for this node, nonterm node: choice or seq node # subtree nonterm node: nullable functions for the subtree # # Results: # Returns nullable function for this branch of the tree. proc sgml::nullable {nodeType rep name {subtree {}}} { switch -glob -- $rep:$nodeType { :leaf - +:leaf { return [list {} 0] } \\*:leaf - \\?:leaf { return [list {} 1] } \\*:nonterm - \\?:nonterm { return [list $subtree 1] } :nonterm - +:nonterm { switch -- $name { :choice { set result 0 foreach child $subtree { set result [expr $result || [lindex $child 1]] } } :seq { set result 1 foreach child $subtree { set result [expr $result && [lindex $child 1]] } } } return [list $subtree $result] } } } # sgml::DTD:ATTLIST -- # # defines an attribute list. # # Arguments: # opts configuration opions # name Element GI # attspec unparsed attribute definitions # # Results: # Attribute list variables are modified. proc sgml::DTD:ATTLIST {opts name attspec} { variable attlist_exp variable attlist_enum_exp variable attlist_fixed_exp array set options $opts # Parse the attribute list. If it were regular, could just use foreach, # but some attributes may have values. regsub -all {([][$\\])} $attspec {\\\1} attspec regsub -all $attlist_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {\\3} {} \{" attspec regsub -all $attlist_enum_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {} {\\4} \{" attspec regsub -all $attlist_fixed_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {\\3} {\\4} \{" attspec eval "noop \{$attspec\}" return {} } # sgml::DTDAttribute -- # # Parse definition of a single attribute. # # Arguments: # callback attribute defn callback # name element name # var array variable # att attribute name # type type of this attribute # default default value of the attribute # value other information # text other text (should be empty) # # Results: # Attribute defn added to array, unless it already exists proc sgml::DTDAttribute args { # BUG: Some problems with parameter passing - deal with it later foreach {callback name var att type default value text} $args break upvar #0 $var atts if {[string length [string trim $text]]} { return -code error "unexpected text \"$text\" in attribute definition" } # What about overridden attribute defns? # A non-validating app may want to know about them # (eg. an editor) if {![info exists atts($name/$att)]} { set atts($name/$att) [list $type $default $value] uplevel #0 $callback [list $name $att $type $default $value] } return {} } # sgml::DTD:ENTITY -- # # declaration. # # Callbacks: # -entitydeclcommand for general entity declaration # -unparsedentitydeclcommand for unparsed external entity declaration # -parameterentitydeclcommand for parameter entity declaration # # Arguments: # opts configuration options # name name of entity being defined # param whether a parameter entity is being defined # value unparsed replacement text # # Results: # Modifies the caller's entities array variable proc sgml::DTD:ENTITY {opts name param value} { array set options $opts if {[string compare % $param]} { # Entity declaration - general or external upvar #0 $options(entities) ents upvar #0 $options(extentities) externals if {[info exists ents($name)] || [info exists externals($name)]} { eval $options(-warningcommand) entity [list "entity \"$name\" already declared"] } else { if {[catch {uplevel #0 $options(-parseentitydeclcommand) [list $value]} value]} { return -code error "unable to parse entity declaration due to \"$value\"" } switch -glob -- [lindex $value 0],[lindex $value 3] { internal, { set ents($name) [EntitySubst [array get options] [lindex $value 1]] uplevel #0 $options(-entitydeclcommand) [list $name $ents($name)] } internal,* { return -code error "unexpected NDATA declaration" } external, { set externals($name) [lrange $value 1 2] uplevel #0 $options(-entitydeclcommand) [eval list $name [lrange $value 1 2]] } external,* { set externals($name) [lrange $value 1 3] uplevel #0 $options(-unparsedentitydeclcommand) [eval list $name [lrange $value 1 3]] } default { return -code error "internal error: unexpected parser state" } } } } else { # Parameter entity declaration upvar #0 $options(parameterentities) PEnts upvar #0 $options(externalparameterentities) ExtPEnts if {[info exists PEnts($name)] || [info exists ExtPEnts($name)]} { eval $options(-warningcommand) parameterentity [list "parameter entity \"$name\" already declared"] } else { if {[catch {uplevel #0 $options(-parseentitydeclcommand) [list $value]} value]} { return -code error "unable to parse parameter entity declaration due to \"$value\"" } if {[string length [lindex $value 3]]} { return -code error "NDATA illegal in parameter entity declaration" } switch [lindex $value 0] { internal { # Substitute character references and PEs (XML: 4.5) set value [EntitySubst [array get options] [lindex $value 1]] set PEnts($name) $value uplevel #0 $options(-parameterentitydeclcommand) [list $name $value] } external - default { # Get the replacement text now. # Could wait until the first reference, but easier # to just do it now. set token [uri::geturl [uri::resolve $options(-baseuri) [lindex $value 1]]] set ExtPEnts($name) [lindex [array get $token data] 1] uplevel #0 $options(-parameterentitydeclcommand) [eval list $name [lrange $value 1 2]] } } } } } # sgml::EntitySubst -- # # Perform entity substitution on an entity replacement text. # This differs slightly from other substitution procedures, # because only parameter and character entity substitution # is performed, not general entities. # See XML Rec. section 4.5. # # Arguments: # opts configuration options # value Literal entity value # # Results: # Expanded replacement text proc sgml::EntitySubst {opts value} { array set options $opts # Protect Tcl special characters regsub -all {([{}\\])} $value {\\\1} value # Find entity references regsub -all (&#\[0-9\]+|&#x\[0-9a-fA-F\]+|%${::sgml::Name})\; $value "\[EntitySubstValue [list $options(parameterentities)] {\\1}\]" value set result [subst $value] return $result } # sgml::EntitySubstValue -- # # Handle a single character or parameter entity substitution # # Arguments: # PEvar array variable containing PE declarations # ref character or parameter entity reference # # Results: # Replacement text proc sgml::EntitySubstValue {PEvar ref} { switch -glob -- $ref { &#x* { scan [string range $ref 3 end] %x hex return [format %c $hex] } &#* { return [format %c [string range $ref 2 end]] } %* { upvar #0 $PEvar PEs set ref [string range $ref 1 end] if {[info exists PEs($ref)]} { return $PEs($ref) } else { return -code error "parameter entity \"$ref\" not declared" } } default { return -code error "internal error - unexpected entity reference" } } return {} } # sgml::DTD:NOTATION -- # # Process notation declaration # # Arguments: # opts configuration options # name notation name # value unparsed notation spec proc sgml::DTD:NOTATION {opts name value} { return {} variable notation_exp upvar opts state if {[regexp $notation_exp $value x scheme data] == 2} { } else { eval $state(-errorcommand) [list notationvalue "notation value \"$value\" incorrectly specified"] } } # sgml::ResolveEntity -- # # Default entity resolution routine # # Arguments: # cmd command of parent parser # base base URL for relative URLs # sysId system identifier # pubId public identifier proc sgml::ResolveEntity {cmd base sysId pubId} { variable ParseEventNum if {[catch {uri::resolve $base $sysId} url]} { return -code error "unable to resolve system identifier \"$sysId\"" } if {[catch {uri::geturl $url} token]} { return -code error "unable to retrieve external entity \"$url\" for system identifier \"$sysId\"" } upvar #0 $token data set parser [uplevel #0 $cmd entityparser] set body {} catch {set body $data(body)} catch {set body $data(data)} if {[string length $body]} { uplevel #0 $parser parse [list $body] -dtdsubset external } $parser free return {} } coccinella-0.96.20/TclXML/tclparser-8.1.tcl000066400000000000000000000365671167435367600201410ustar00rootroot00000000000000# tclparser-8.1.tcl -- # # This file provides a Tcl implementation of a XML parser. # This file supports Tcl 8.1. # # See xml-8.[01].tcl for definitions of character sets and # regular expressions. # # Copyright (c) 1998-2003 Zveno Pty Ltd # http://www.zveno.com/ # # See the file "LICENSE" in this distribution for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # $Id: tclparser-8.1.tcl,v 1.5 2006-12-19 13:27:09 matben Exp $ package require Tcl 8.1 package provide xml::tclparser 99.0 package require xmldefs 3.1 package require sgmlparser 99.0 namespace eval xml::tclparser { namespace export create createexternal externalentity parse configure get delete # Tokenising expressions variable tokExpr $::xml::tokExpr variable substExpr $::xml::substExpr # Register this parser class ::xml::parserclass create tcl \ -createcommand [namespace code create] \ -createentityparsercommand [namespace code createentityparser] \ -parsecommand [namespace code parse] \ -configurecommand [namespace code configure] \ -deletecommand [namespace code delete] \ -resetcommand [namespace code reset] } # xml::tclparser::create -- # # Creates XML parser object. # # Arguments: # name unique identifier for this instance # # Results: # The state variable is initialised. proc xml::tclparser::create name { # Initialise state variable upvar \#0 [namespace current]::$name parser array set parser [list -name $name \ -cmd [uplevel 3 namespace current]::$name \ -final 1 \ -validate 0 \ -statevariable [namespace current]::$name \ -baseuri {} \ internaldtd {} \ entities [namespace current]::Entities$name \ extentities [namespace current]::ExtEntities$name \ parameterentities [namespace current]::PEntities$name \ externalparameterentities [namespace current]::ExtPEntities$name \ elementdecls [namespace current]::ElDecls$name \ attlistdecls [namespace current]::AttlistDecls$name \ notationdecls [namespace current]::NotDecls$name \ depth 0 \ leftover {} \ ] # Initialise entities with predefined set array set [namespace current]::Entities$name [array get ::sgml::EntityPredef] return $parser(-cmd) } # xml::tclparser::createentityparser -- # # Creates XML parser object for an entity. # # Arguments: # name name for the new parser # parent name of parent parser # # Results: # The state variable is initialised. proc xml::tclparser::createentityparser {parent name} { upvar #0 [namespace current]::$parent p # Initialise state variable upvar \#0 [namespace current]::$name external array set external [array get p] regsub $parent $p(-cmd) {} parentns array set external [list -name $name \ -cmd $parentns$name \ -statevariable [namespace current]::$name \ internaldtd {} \ line 0 \ ] incr external(depth) return $external(-cmd) } # xml::tclparser::configure -- # # Configures a XML parser object. # # Arguments: # name unique identifier for this instance # args option name/value pairs # # Results: # May change values of config options proc xml::tclparser::configure {name args} { upvar \#0 [namespace current]::$name parser # BUG: very crude, no checks for illegal args # Mats: Should be synced with sgmlparser.tcl set options {-elementstartcommand -elementendcommand \ -characterdatacommand -processinginstructioncommand \ -externalentitycommand -xmldeclcommand \ -doctypecommand -commentcommand \ -entitydeclcommand -unparsedentitydeclcommand \ -parameterentitydeclcommand -notationdeclcommand \ -elementdeclcommand -attlistdeclcommand \ -paramentityparsing -defaultexpandinternalentities \ -startdoctypedeclcommand -enddoctypedeclcommand \ -entityreferencecommand -warningcommand \ -defaultcommand -unknownencodingcommand -notstandalonecommand \ -startcdatasectioncommand -endcdatasectioncommand \ -errorcommand -final \ -validate -baseuri -baseurl \ -name -cmd -emptyelement \ -parseattributelistcommand -parseentitydeclcommand \ -normalize -internaldtd -dtdsubset \ -reportempty -ignorewhitespace \ -reportempty \ } set usage [join $options ", "] regsub -all -- - $options {} options set pat ^-([join $options |])$ foreach {flag value} $args { if {[regexp $pat $flag]} { # Validate numbers if {[info exists parser($flag)] && \ [string is integer -strict $parser($flag)] && \ ![string is integer -strict $value]} { return -code error "Bad value for $flag ($value), must be integer" } set parser($flag) $value } else { return -code error "Unknown option $flag, can be: $usage" } } # Backward-compatibility: -baseuri is a synonym for -baseurl catch {set parser(-baseuri) $parser(-baseurl)} return {} } # xml::tclparser::parse -- # # Parses document instance data # # Arguments: # name parser object # xml data # args configuration options # # Results: # Callbacks are invoked proc xml::tclparser::parse {name xml args} { array set options $args upvar \#0 [namespace current]::$name parser variable tokExpr variable substExpr # Mats: if {[llength $args]} { eval {configure $name} $args } set parseOptions [list \ -emptyelement [namespace code ParseEmpty] \ -parseattributelistcommand [namespace code ParseAttrs] \ -parseentitydeclcommand [namespace code ParseEntity] \ -normalize 0] eval lappend parseOptions \ [array get parser -*command] \ [array get parser -reportempty] \ [array get parser -ignorewhitespace] \ [array get parser -name] \ [array get parser -cmd] \ [array get parser -baseuri] \ [array get parser -validate] \ [array get parser -final] \ [array get parser -defaultexpandinternalentities] \ [array get parser entities] \ [array get parser extentities] \ [array get parser parameterentities] \ [array get parser externalparameterentities] \ [array get parser elementdecls] \ [array get parser attlistdecls] \ [array get parser notationdecls] # Mats: # If -final 0 we also need to maintain the state with a -statevariable ! if {!$parser(-final)} { eval lappend parseOptions [array get parser -statevariable] } set dtdsubset no catch {set dtdsubset $options(-dtdsubset)} switch -- $dtdsubset { internal { # Bypass normal parsing lappend parseOptions -statevariable $parser(-statevariable) array set intOptions [array get ::sgml::StdOptions] array set intOptions $parseOptions ::sgml::ParseDTD:Internal [array get intOptions] $xml return {} } external { # Bypass normal parsing lappend parseOptions -statevariable $parser(-statevariable) array set intOptions [array get ::sgml::StdOptions] array set intOptions $parseOptions ::sgml::ParseDTD:External [array get intOptions] $xml return {} } default { # Pass through to normal processing } } lappend tokenOptions \ -internaldtdvariable [namespace current]::${name}(internaldtd) # Mats: If -final 0 we also need to maintain the state with a -statevariable ! if {!$parser(-final)} { eval lappend tokenOptions [array get parser -statevariable] \ [array get parser -final] } # Mats: # Why not the first four? Just padding? Lrange undos \n interp. # It is necessary to have the first four as well if chopped off in # middle of pcdata. set tokenised [lrange \ [eval {::sgml::tokenise $xml $tokExpr $substExpr} $tokenOptions] \ 0 end] lappend parseOptions -internaldtd [list $parser(internaldtd)] eval ::sgml::parseEvent [list $tokenised] $parseOptions return {} } # xml::tclparser::ParseEmpty -- Tcl 8.1+ version # # Used by parser to determine whether an element is empty. # This is usually dead easy in XML, but as always not quite. # Have to watch out for empty element syntax # # Arguments: # tag element name # attr attribute list (raw) # e End tag delimiter. # # Results: # Return value of e proc xml::tclparser::ParseEmpty {tag attr e} { switch -glob -- [string length $e],[regexp "/[::xml::cl $::xml::Wsp]*$" $attr] { 0,0 { return {} } 0,* { return / } default { return $e } } } # xml::tclparser::ParseAttrs -- Tcl 8.1+ version # # Parse element attributes. # # There are two forms for name-value pairs: # # name="value" # name='value' # # Arguments: # opts parser options # attrs attribute string given in a tag # # Results: # Returns a Tcl list representing the name-value pairs in the # attribute string # # A ">" occurring in the attribute list causes problems when parsing # the XML. This manifests itself by an unterminated attribute value # and a ">" appearing the element text. # In this case return a three element list; # the message "unterminated attribute value", the attribute list it # did manage to parse and the remainder of the attribute list. proc xml::tclparser::ParseAttrs {opts attrs} { set result {} while {[string length [string trim $attrs]]} { if {[regexp [::sgml::cl $::xml::Wsp]*($::xml::Name)[::sgml::cl $::xml::Wsp]*=[::sgml::cl $::xml::Wsp]*("|')([::sgml::cl ^<]*?)\\2(.*) $attrs discard attrName delimiter value attrs]} { lappend result $attrName [NormalizeAttValue $opts $value] } elseif {[regexp [::sgml::cl $::xml::Wsp]*$::xml::Name[::sgml::cl $::xml::Wsp]*=[::sgml::cl $::xml::Wsp]*("|')[::sgml::cl ^<]*\$ $attrs]} { return -code error [list {unterminated attribute value} $result $attrs] } else { return -code error "invalid attribute list" } } return $result } # xml::tclparser::NormalizeAttValue -- # # Perform attribute value normalisation. This involves: # . character references are appended to the value # . entity references are recursively processed and replacement value appended # . whitespace characters cause a space to be appended # . other characters appended as-is # # Arguments: # opts parser options # value unparsed attribute value # # Results: # Normalised value returned. proc xml::tclparser::NormalizeAttValue {opts value} { # sgmlparser already has backslashes protected # Protect Tcl specials regsub -all {([][$])} $value {\\\1} value # Deal with white space regsub -all "\[$::xml::Wsp\]" $value { } value # Find entity refs regsub -all {&([^;]+);} $value {[NormalizeAttValue:DeRef $opts {\1}]} value return [subst $value] } # xml::tclparser::NormalizeAttValue:DeRef -- # # Handler to normalize attribute values # # Arguments: # opts parser options # ref entity reference # # Results: # Returns character proc xml::tclparser::NormalizeAttValue:DeRef {opts ref} { switch -glob -- $ref { #x* { scan [string range $ref 2 end] %x value set char [format %c $value] # Check that the char is legal for XML if {[regexp [format {^[%s]$} $::xml::Char] $char]} { return $char } else { return -code error "illegal character" } } #* { scan [string range $ref 1 end] %d value set char [format %c $value] # Check that the char is legal for XML if {[regexp [format {^[%s]$} $::xml::Char] $char]} { return $char } else { return -code error "illegal character" } } lt - gt - amp - quot - apos { array set map {lt < gt > amp & quot \" apos '} return $map($ref) } default { # A general entity. Must resolve to a text value - no element structure. array set options $opts upvar #0 $options(entities) map if {[info exists map($ref)]} { if {[regexp < $map($ref)]} { return -code error "illegal character \"<\" in attribute value" } if {![regexp & $map($ref)]} { # Simple text replacement return $map($ref) } # There are entity references in the replacement text. # Can't use child entity parser since must catch element structures return [NormalizeAttValue $opts $map($ref)] } elseif {[string compare $options(-entityreferencecommand) "::sgml::noop"]} { set result [uplevel #0 $options(-entityreferencecommand) [list $ref]] return $result } else { return -code error "unable to resolve entity reference \"$ref\"" } } } } # xml::tclparser::ParseEntity -- # # Parse general entity declaration # # Arguments: # data text to parse # # Results: # Tcl list containing entity declaration proc xml::tclparser::ParseEntity data { set data [string trim $data] if {[regexp $::sgml::ExternalEntityExpr $data discard type delimiter1 id1 discard delimiter2 id2 optNDATA ndata]} { switch $type { PUBLIC { return [list external $id2 $id1 $ndata] } SYSTEM { return [list external $id1 {} $ndata] } } } elseif {[regexp {^("|')(.*?)\1$} $data discard delimiter value]} { return [list internal $value] } else { return -code error "badly formed entity declaration" } } # xml::tclparser::delete -- # # Destroy parser data # # Arguments: # name parser object # # Results: # Parser data structure destroyed proc xml::tclparser::delete name { upvar \#0 [namespace current]::$name parser catch {::sgml::ParserDelete $parser(-statevariable)} catch {unset parser} return {} } # xml::tclparser::get -- # # Retrieve additional information from the parser # # Arguments: # name parser object # method info to retrieve # args additional arguments for method # # Results: # Depends on method proc xml::tclparser::get {name method args} { upvar #0 [namespace current]::$name parser switch -- $method { elementdecl { switch [llength $args] { 0 { # Return all element declarations upvar #0 $parser(elementdecls) elements return [array get elements] } 1 { # Return specific element declaration upvar #0 $parser(elementdecls) elements if {[info exists elements([lindex $args 0])]} { return [array get elements [lindex $args 0]] } else { return -code error "element \"[lindex $args 0]\" not declared" } } default { return -code error "wrong number of arguments: should be \"elementdecl ?element?\"" } } } attlist { if {[llength $args] != 1} { return -code error "wrong number of arguments: should be \"get attlist element\"" } upvar #0 $parser(attlistdecls) return {} } entitydecl { } parameterentitydecl { } notationdecl { } default { return -code error "unknown method \"$method\"" } } return {} } # xml::tclparser::ExternalEntity -- # # Resolve and parse external entity # # Arguments: # name parser object # base base URL # sys system identifier # pub public identifier # # Results: # External entity is fetched and parsed proc xml::tclparser::ExternalEntity {name base sys pub} { } # xml::tclparser:: -- # # Reset a parser instance, ready to parse another document # # Arguments: # name parser object # # Results: # Variables unset proc xml::tclparser::reset {name} { upvar \#0 [namespace current]::$name parser # Has this parser object been properly initialised? if {![info exists parser] || \ ![info exists parser(-name)]} { return [create $name] } array set parser { -final 1 depth 0 leftover {} } foreach var {Entities ExtEntities PEntities ExtPEntities ElDecls AttlistDecls NotDecls} { catch {unset [namespace current]::${var}$name} } # Initialise entities with predefined set array set [namespace current]::Entities$name [array get ::sgml::EntityPredef] return {} } coccinella-0.96.20/TclXML/xml-8.1.tcl000066400000000000000000000056471167435367600167350ustar00rootroot00000000000000# xml.tcl -- # # This file provides generic XML services for all implementations. # This file supports Tcl 8.1 regular expressions. # # See tclparser.tcl for the Tcl implementation of a XML parser. # # Copyright (c) 1998-2004 Zveno Pty Ltd # http://www.zveno.com/ # # See the file "LICENSE" in this distribution for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # $Id: xml-8.1.tcl,v 1.4 2006-12-19 13:27:09 matben Exp $ package require Tcl 8.1 package provide xmldefs 3.1 package require sgml 1.8 namespace eval xml { namespace export qnamesplit # Convenience routine proc cl x { return "\[$x\]" } # Define various regular expressions # Characters variable Char $::sgml::Char # white space variable Wsp " \t\r\n" variable allWsp [cl $Wsp]* variable noWsp [cl ^$Wsp] # Various XML names and tokens variable NameChar $::sgml::NameChar variable Name $::sgml::Name variable Names $::sgml::Names variable Nmtoken $::sgml::Nmtoken variable Nmtokens $::sgml::Nmtokens # XML Namespaces names # NCName ::= Name - ':' variable NCName $::sgml::Name regsub -all : $NCName {} NCName variable QName (${NCName}:)?$NCName ;# (Prefix ':')? LocalPart # The definition of the Namespace URI for XML Namespaces themselves. # The prefix 'xml' is automatically bound to this URI. variable xmlnsNS http://www.w3.org/XML/1998/namespace # table of predefined entities variable EntityPredef array set EntityPredef { lt < gt > amp & quot \" apos ' } # Expressions for pulling things apart variable tokExpr <(/?)([::xml::cl ^$::xml::Wsp>/]+)([::xml::cl $::xml::Wsp]*[::xml::cl ^>]*)> variable substExpr "\}\n{\\2} {\\1} {\\3} \{" } ### ### Exported procedures ### # xml::qnamesplit -- # # Split a QName into its constituent parts: # the XML Namespace prefix and the Local-name # # Arguments: # qname XML Qualified Name (see XML Namespaces [6]) # # Results: # Returns prefix and local-name as a Tcl list. # Error condition returned if the prefix or local-name # are not valid NCNames (XML Name) proc xml::qnamesplit qname { variable NCName variable Name set prefix {} set localname $qname if {[regexp : $qname]} { if {![regexp ^($NCName)?:($NCName)\$ $qname discard prefix localname]} { return -code error "name \"$qname\" is not a valid QName" } } elseif {![regexp ^$Name\$ $qname]} { return -code error "name \"$qname\" is not a valid Name" } return [list $prefix $localname] } ### ### General utility procedures ### # xml::noop -- # # A do-nothing proc proc xml::noop args {} ### Following procedures are based on html_library # xml::zapWhite -- # # Convert multiple white space into a single space. # # Arguments: # data plain text # # Results: # As above proc xml::zapWhite data { regsub -all "\[ \t\r\n\]+" $data { } data return $data } coccinella-0.96.20/TclXML/xml__tcl.tcl000066400000000000000000000136111167435367600174200ustar00rootroot00000000000000# xml__tcl.tcl -- # # This file provides a Tcl implementation of the parser # class support found in ../tclxml.c. It is only used # when the C implementation is not installed (for some reason). # # Copyright (c) 2000-2004 Zveno Pty Ltd # http://www.zveno.com/ # # See the file "LICENSE" in this distribution for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # $Id: xml__tcl.tcl,v 1.4 2006-12-19 13:27:09 matben Exp $ package provide xml::tcl 99.0 namespace eval xml { namespace export configure parser parserclass # Parser implementation classes variable classes array set classes {} # Default parser class variable default {} # Counter for generating unique names variable counter 0 } # xml::configure -- # # Configure the xml package # # Arguments: # None # # Results: # None (not yet implemented) proc xml::configure args {} # xml::parserclass -- # # Implements the xml::parserclass command for managing # parser implementations. # # Arguments: # method subcommand # args method arguments # # Results: # Depends on method proc xml::parserclass {method args} { variable classes variable default switch -- $method { create { if {[llength $args] < 1} { return -code error "wrong number of arguments, should be xml::parserclass create name ?args?" } set name [lindex $args 0] if {[llength [lrange $args 1 end]] % 2} { return -code error "missing value for option \"[lindex $args end]\"" } array set classes [list $name [list \ -createcommand [namespace current]::noop \ -createentityparsercommand [namespace current]::noop \ -parsecommand [namespace current]::noop \ -configurecommand [namespace current]::noop \ -getcommand [namespace current]::noop \ -deletecommand [namespace current]::noop \ ]] # BUG: we're not checking that the arguments are kosher set classes($name) [lrange $args 1 end] set default $name } destroy { if {[llength $args] < 1} { return -code error "wrong number of arguments, should be xml::parserclass destroy name" } if {[info exists classes([lindex $args 0])]} { unset classes([lindex $args 0]) } else { return -code error "no such parser class \"[lindex $args 0]\"" } } info { if {[llength $args] < 1} { return -code error "wrong number of arguments, should be xml::parserclass info method" } switch -- [lindex $args 0] { names { return [array names classes] } default { return $default } } } default { return -code error "unknown method \"$method\"" } } return {} } # xml::parser -- # # Create a parser object instance # # Arguments: # args optional name, configuration options # # Results: # Returns object name. Parser instance created. proc xml::parser args { variable classes variable default if {[llength $args] < 1} { # Create unique name, no options set parserName [FindUniqueName] } else { if {[string index [lindex $args 0] 0] == "-"} { # Create unique name, have options set parserName [FindUniqueName] } else { # Given name, optional options set parserName [lindex $args 0] set args [lrange $args 1 end] } } array set options [list \ -parser $default ] array set options $args if {![info exists classes($options(-parser))]} { return -code error "no such parser class \"$options(-parser)\"" } # Now create the parser instance command and data structure # The command must be created in the caller's namespace uplevel 1 [list proc $parserName {method args} "eval [namespace current]::ParserCmd [list $parserName] \[list \$method\] \$args"] upvar #0 [namespace current]::$parserName data array set data [list class $options(-parser)] array set classinfo $classes($options(-parser)) if {[string compare $classinfo(-createcommand) ""]} { eval $classinfo(-createcommand) [list $parserName] } if {[string compare $classinfo(-configurecommand) ""] && \ [llength $args]} { eval $classinfo(-configurecommand) [list $parserName] $args } return $parserName } # xml::FindUniqueName -- # # Generate unique object name # # Arguments: # None # # Results: # Returns string. proc xml::FindUniqueName {} { variable counter return xmlparser[incr counter] } # xml::ParserCmd -- # # Implements parser object command # # Arguments: # name object reference # method subcommand # args method arguments # # Results: # Depends on method proc xml::ParserCmd {name method args} { variable classes upvar #0 [namespace current]::$name data array set classinfo $classes($data(class)) switch -- $method { configure { # BUG: We're not checking for legal options array set data $args eval $classinfo(-configurecommand) [list $name] $args return {} } cget { return $data([lindex $args 0]) } entityparser { set new [FindUniqueName] upvar #0 [namespace current]::$name parent upvar #0 [namespace current]::$new data array set data [array get parent] uplevel 1 [list proc $new {method args} "eval [namespace current]::ParserCmd [list $new] \[list \$method\] \$args"] return [eval $classinfo(-createentityparsercommand) [list $name $new] $args] } free { eval $classinfo(-deletecommand) [list $name] unset data uplevel 1 [list rename $name {}] } get { eval $classinfo(-getcommand) [list $name] $args } parse { if {[llength $args] < 1} { return -code error "wrong number of arguments, should be $name parse xml ?options?" } eval $classinfo(-parsecommand) [list $name] $args } reset { eval $classinfo(-resetcommand) [list $name] } default { return -code error "unknown method" } } return {} } # xml::noop -- # # Do nothing utility proc # # Arguments: # args whatever # # Results: # Nothing happens proc xml::noop args {} coccinella-0.96.20/TclXML/xmldep.tcl000066400000000000000000000065501167435367600171140ustar00rootroot00000000000000# xmldep.tcl -- # # Find the dependencies in an XML document. # Supports external entities and XSL include/import. # # TODO: # XInclude # # Copyright (c) 2001-2003 Zveno Pty Ltd # http://www.zveno.com/ # # See the file "LICENSE" in this distribution for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # $Id: xmldep.tcl,v 1.3 2006-12-19 13:27:09 matben Exp $ package require xml package provide xml::dep 1.0 namespace eval xml::dep { namespace export depend variable extEntities array set extEntities {} variable XSLTNS http://www.w3.org/1999/XSL/Transform } # xml::dep::depend -- # # Find the resources which an XML document # depends on. The document is parsed # sequentially, rather than using DOM, for efficiency. # # TODO: # Asynchronous parsing. # # Arguments: # xml XML document entity # args configuration options # # Results: # Returns list of resource (system) identifiers proc xml::dep::depend {xml args} { variable resources variable entities set resources {} catch {unset entities} array set entities {} set p [xml::parser \ -elementstartcommand [namespace code ElStart] \ -doctypecommand [namespace code DocTypeDecl] \ -entitydeclcommand [namespace code EntityDecl] \ -entityreferencecommand [namespace code EntityReference] \ -validate 1 \ ] if {[llength $args]} { eval [list $p] configure $args } $p parse $xml return $resources } # xml::dep::ElStart -- # # Process start element # # Arguments: # name tag name # atlist attribute list # args options # # Results: # May add to resources list proc xml::dep::ElStart {name atlist args} { variable XSLTNS variable resources array set opts { -namespace {} } array set opts $args switch -- $opts(-namespace) \ $XSLTNS { switch $name { import - include { array set attr { href {} } array set attr $atlist if {[string length $attr(href)]} { if {[lsearch $resources $attr(href)] < 0} { lappend resources $attr(href) } } } } } } # xml::dep::DocTypeDecl -- # # Process Document Type Declaration # # Arguments: # name Document element # pubid Public identifier # sysid System identifier # dtd Internal DTD Subset # # Results: # Resource added to list proc xml::dep::DocTypeDecl {name pubid sysid dtd} { variable resources puts stderr [list DocTypeDecl $name $pubid $sysid dtd] if {[string length $sysid] && \ [lsearch $resources $sysid] < 0} { lappend resources $sysid } return {} } # xml::dep::EntityDecl -- # # Process entity declaration, looking for external entity # # Arguments: # name entity name # sysid system identifier # pubid public identifier or repl. text # # Results: # Store external entity info for later reference proc xml::dep::EntityDecl {name sysid pubid} { variable extEntities puts stderr [list EntityDecl $name $sysid $pubid] set extEntities($name) $sysid } # xml::dep::EntityReference -- # # Process entity reference # # Arguments: # name entity name # # Results: # May add to resources list proc xml::dep::EntityReference name { variable extEntities variable resources puts stderr [list EntityReference $name] if {[info exists extEntities($name)] && \ [lsearch $resources $extEntities($name)] < 0} { lappend resources $extEntities($name) } } coccinella-0.96.20/TclXML/xpath.tcl000066400000000000000000000237051167435367600167500ustar00rootroot00000000000000# xpath.tcl -- # # Provides an XPath parser for Tcl, # plus various support procedures # # Copyright (c) 2000-2003 Zveno Pty Ltd # # See the file "LICENSE" in this distribution for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # $Id: xpath.tcl,v 1.3 2006-12-19 13:27:09 matben Exp $ package provide xpath 1.0 # We need the XML package for definition of Names package require xml namespace eval xpath { namespace export split join createnode variable axes { ancestor ancestor-or-self attribute child descendant descendant-or-self following following-sibling namespace parent preceding preceding-sibling self } variable nodeTypes { comment text processing-instruction node } # NB. QName has parens for prefix variable nodetestExpr ^(${::xml::QName})${::xml::allWsp}(\\(${::xml::allWsp}(("|')(.*?)\\5)?${::xml::allWsp}\\))?${::xml::allWsp}(.*) variable nodetestExpr2 ((($::xml::QName)${::xml::allWsp}(\\(${::xml::allWsp}(("|')(.*?)\\7)?${::xml::allWsp}\\))?)|${::xml::allWsp}(\\*))${::xml::allWsp}(.*) } # xpath::split -- # # Parse an XPath location path # # Arguments: # locpath location path # # Results: # A Tcl list representing the location path. # The list has the form: {{axis node-test {predicate predicate ...}} ...} # Where each list item is a location step. proc xpath::split locpath { set leftover {} set result [InnerSplit $locpath leftover] if {[string length [string trim $leftover]]} { return -code error "unexpected text \"$leftover\"" } return $result } proc xpath::InnerSplit {locpath leftoverVar} { upvar $leftoverVar leftover variable axes variable nodetestExpr variable nodetestExpr2 # First determine whether we have an absolute location path if {[regexp {^/(.*)} $locpath discard locpath]} { set path {{}} } else { set path {} } while {[string length [string trimleft $locpath]]} { if {[regexp {^\.\.(.*)} $locpath discard locpath]} { # .. abbreviation set axis parent set nodetest * } elseif {[regexp {^/(.*)} $locpath discard locpath]} { # // abbreviation set axis descendant-or-self if {[regexp ^$nodetestExpr2 [string trimleft $locpath] discard discard discard nodetest discard typetest discard discard literal wildcard locpath]} { set nodetest [ResolveWildcard $nodetest $typetest $wildcard $literal] } else { set leftover $locpath return $path } } elseif {[regexp ^\\.${::xml::allWsp}(.*) $locpath discard locpath]} { # . abbreviation set axis self set nodetest * } elseif {[regexp ^@($::xml::QName)${::xml::allWsp}=${::xml::allWsp}"(\[^"\])"(.*) $locpath discard attrName discard attrValue locpath]} { # @ abbreviation set axis attribute set nodetest $attrName } elseif {[regexp ^@($::xml::QName)${::xml::allWsp}=${::xml::allWsp}'(\[^'\])'(.*) $locpath discard attrName discard attrValue locpath]} { # @ abbreviation set axis attribute set nodetest $attrName } elseif {[regexp ^@($::xml::QName)(.*) $locpath discard attrName discard2 locpath]} { # @ abbreviation set axis attribute set nodetest $attrName } elseif {[regexp ^((${::xml::QName})${::xml::allWsp}::${::xml::allWsp})?\\*(.*) $locpath discard discard axis discard locpath]} { # wildcard specified set nodetest * if {![string length $axis]} { set axis child } } elseif {[regexp ^((${::xml::QName})${::xml::allWsp}::${::xml::allWsp})?$nodetestExpr2 $locpath discard discard axis discard discard discard nodetest discard typetest discard discard literal wildcard locpath]} { # nodetest, with or without axis if {![string length $axis]} { set axis child } set nodetest [ResolveWildcard $nodetest $typetest $wildcard $literal] } else { set leftover $locpath return $path } # ParsePredicates set predicates {} set locpath [string trimleft $locpath] while {[regexp {^\[(.*)} $locpath discard locpath]} { if {[regexp {^([0-9]+)(\].*)} [string trim $locpath] discard posn locpath]} { set predicate [list = {function position {}} [list number $posn]] } else { set leftover2 {} set predicate [ParseExpr $locpath leftover2] set locpath $leftover2 unset leftover2 } if {[regexp {^\](.*)} [string trimleft $locpath] discard locpath]} { lappend predicates $predicate } else { return -code error "unexpected text in predicate \"$locpath\"" } } set axis [string trim $axis] set nodetest [string trim $nodetest] # This step completed if {[lsearch $axes $axis] < 0} { return -code error "invalid axis \"$axis\"" } lappend path [list $axis $nodetest $predicates] # Move to next step if {[string length $locpath] && ![regexp ^/(.*) $locpath discard locpath]} { set leftover $locpath return $path } } return $path } # xpath::ParseExpr -- # # Parse one expression in a predicate # # Arguments: # locpath location path to parse # leftoverVar Name of variable in which to store remaining path # # Results: # Returns parsed expression as a Tcl list proc xpath::ParseExpr {locpath leftoverVar} { upvar $leftoverVar leftover variable nodeTypes set expr {} set mode expr set stack {} while {[string index [string trimleft $locpath] 0] != "\]"} { set locpath [string trimleft $locpath] switch $mode { expr { # We're looking for a term if {[regexp ^-(.*) $locpath discard locpath]} { # UnaryExpr lappend stack "-" } elseif {[regexp ^\\\$({$::xml::QName})(.*) $locpath discard varname discard locpath]} { # VariableReference lappend stack [list varRef $varname] set mode term } elseif {[regexp {^\((.*)} $locpath discard locpath]} { # Start grouping set leftover2 {} lappend stack [list group [ParseExpr $locpath leftover2]] set locpath $leftover2 unset leftover2 if {[regexp {^\)(.*)} [string trimleft $locpath] discard locpath]} { set mode term } else { return -code error "unexpected text \"$locpath\", expected \")\"" } } elseif {[regexp {^"([^"]*)"(.*)} $locpath discard literal locpath]} { # Literal (" delimited) lappend stack [list literal $literal] set mode term } elseif {[regexp {^'([^']*)'(.*)} $locpath discard literal locpath]} { # Literal (' delimited) lappend stack [list literal $literal] set mode term } elseif {[regexp {^([0-9]+(\.[0-9]+)?)(.*)} $locpath discard number discard locpath]} { # Number lappend stack [list number $number] set mode term } elseif {[regexp {^(\.[0-9]+)(.*)} $locpath discard number locpath]} { # Number lappend stack [list number $number] set mode term } elseif {[regexp ^(${::xml::QName})\\(${::xml::allWsp}(.*) $locpath discard functionName discard locpath]} { # Function call start or abbreviated node-type test if {[lsearch $nodeTypes $functionName] >= 0} { # Looking like a node-type test if {[regexp ^\\)${::xml::allWsp}(.*) $locpath discard locpath]} { lappend stack [list path [list child [list $functionName ()] {}]] set mode term } else { return -code error "invalid node-type test \"$functionName\"" } } else { if {[regexp ^\\)${::xml::allWsp}(.*) $locpath discard locpath]} { set parameters {} } else { set leftover2 {} set parameters [ParseExpr $locpath leftover2] set locpath $leftover2 unset leftover2 while {[regexp {^,(.*)} $locpath discard locpath]} { set leftover2 {} lappend parameters [ParseExpr $locpath leftover2] set locpath $leftover2 unset leftover2 } if {![regexp ^\\)${::xml::allWsp}(.*) [string trimleft $locpath] discard locpath]} { return -code error "unexpected text \"locpath\" - expected \")\"" } } lappend stack [list function $functionName $parameters] set mode term } } else { # LocationPath set leftover2 {} lappend stack [list path [InnerSplit $locpath leftover2]] set locpath $leftover2 unset leftover2 set mode term } } term { # We're looking for an expression operator if {[regexp ^-(.*) $locpath discard locpath]} { # UnaryExpr set stack [linsert $stack 0 expr "-"] set mode expr } elseif {[regexp ^(and|or|\\=|!\\=|<|>|<\\=|>\\=|\\||\\+|\\-|\\*|div|mod)(.*) $locpath discard exprtype locpath]} { # AndExpr, OrExpr, EqualityExpr, RelationalExpr or UnionExpr set stack [linsert $stack 0 $exprtype] set mode expr } else { return -code error "unexpected text \"$locpath\", expecting operator" } } default { # Should never be here! return -code error "internal error" } } } set leftover $locpath return $stack } # xpath::ResolveWildcard -- proc xpath::ResolveWildcard {nodetest typetest wildcard literal} { variable nodeTypes switch -glob -- [string length $nodetest],[string length $typetest],[string length $wildcard],[string length $literal] { 0,0,0,* { return -code error "bad location step (nothing parsed)" } 0,0,* { # Name wildcard specified return * } *,0,0,* { # Element type test - nothing to do return $nodetest } *,0,*,* { # Internal error? return -code error "bad location step (found both nodetest and wildcard)" } *,*,0,0 { # Node type test if {[lsearch $nodeTypes $nodetest] < 0} { return -code error "unknown node type \"$typetest\"" } return [list $nodetest $typetest] } *,*,0,* { # Node type test if {[lsearch $nodeTypes $nodetest] < 0} { return -code error "unknown node type \"$typetest\"" } return [list $nodetest $literal] } default { # Internal error? return -code error "bad location step" } } } # xpath::join -- # # Reconstitute an XPath location path from a # Tcl list representation. # # Arguments: # spath split path # # Results: # Returns an Xpath location path proc xpath::join spath { return -code error "not yet implemented" } coccinella-0.96.20/VERSION000066400000000000000000000000101167435367600150450ustar00rootroot000000000000000.96.20 coccinella-0.96.20/certificates/000077500000000000000000000000001167435367600164535ustar00rootroot00000000000000coccinella-0.96.20/certificates/cacerts.pem000066400000000000000000000345331167435367600206120ustar00rootroot00000000000000-----BEGIN CERTIFICATE----- MIIH3jCCBcagAwIBAgIBCjANBgkqhkiG9w0BAQUFADB9MQswCQYDVQQGEwJJTDEW MBQGA1UEChMNU3RhcnRDb20gTHRkLjErMCkGA1UECxMiU2VjdXJlIERpZ2l0YWwg Q2VydGlmaWNhdGUgU2lnbmluZzEpMCcGA1UEAxMgU3RhcnRDb20gQ2VydGlmaWNh dGlvbiBBdXRob3JpdHkwHhcNMDcxMDI0MjA1NDE2WhcNMTIxMDIyMjA1NDE2WjCB jDELMAkGA1UEBhMCSUwxFjAUBgNVBAoTDVN0YXJ0Q29tIEx0ZC4xKzApBgNVBAsT IlNlY3VyZSBEaWdpdGFsIENlcnRpZmljYXRlIFNpZ25pbmcxODA2BgNVBAMTL1N0 YXJ0Q29tIENsYXNzIDEgUHJpbWFyeSBJbnRlcm1lZGlhdGUgU2VydmVyIENBMIIB IjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAtonGrO8JUngHrJJj0PREGBiE gFYfka7hh/oyULTTRwbw5gdfcA4Q9x3AzhA2NIVaD5Ksg8asWFI/ujjo/OenJOJA pgh2wJJuniptTT9uYSAK21ne0n1jsz5G/vohURjXzTCm7QduO3CHtPn66+6CPAVv kvek3AowHpNz/gfK11+AnSJYUq4G2ouHI2mw5CrY6oPSvfNx23BaKA+vWjhwRRI/ ME3NO68X5Q/LoKldSKqxYVDLNM08XMML6BDAjJvwAwNi/rJsPnIO7hxDKslIDlc5 xDEhyBDBLIf+VJVSH1I8MRKbf+fAoKVZ1eKPPvDVqOHXcDGpxLPPr21TLwb0pwID AQABo4IDVzCCA1MwDAYDVR0TBAUwAwEB/zALBgNVHQ8EBAMCAa4wHQYDVR0OBBYE FOtCNNCYsKuf9BtrCPfMZC7vDixFMIGoBgNVHSMEgaAwgZ2AFE4L7xqkQFulF2mH MMo0aEPQQa7yoYGBpH8wfTELMAkGA1UEBhMCSUwxFjAUBgNVBAoTDVN0YXJ0Q29t IEx0ZC4xKzApBgNVBAsTIlNlY3VyZSBEaWdpdGFsIENlcnRpZmljYXRlIFNpZ25p bmcxKTAnBgNVBAMTIFN0YXJ0Q29tIENlcnRpZmljYXRpb24gQXV0aG9yaXR5ggEB MAkGA1UdEgQCMAAwPQYIKwYBBQUHAQEEMTAvMC0GCCsGAQUFBzAChiFodHRwOi8v d3d3LnN0YXJ0c3NsLmNvbS9zZnNjYS5jcnQwWwYDVR0fBFQwUjAnoCWgI4YhaHR0 cDovL3d3dy5zdGFydHNzbC5jb20vc2ZzY2EuY3JsMCegJaAjhiFodHRwOi8vY3Js LnN0YXJ0c3NsLmNvbS9zZnNjYS5jcmwwggFdBgNVHSAEggFUMIIBUDCCAUwGCysG AQQBgbU3AQEEMIIBOzAvBggrBgEFBQcCARYjaHR0cDovL2NlcnQuc3RhcnRjb20u b3JnL3BvbGljeS5wZGYwNQYIKwYBBQUHAgEWKWh0dHA6Ly9jZXJ0LnN0YXJ0Y29t Lm9yZy9pbnRlcm1lZGlhdGUucGRmMIHQBggrBgEFBQcCAjCBwzAnFiBTdGFydCBD b21tZXJjaWFsIChTdGFydENvbSkgTHRkLjADAgEBGoGXTGltaXRlZCBMaWFiaWxp dHksIHJlYWQgdGhlIHNlY3Rpb24gKkxlZ2FsIExpbWl0YXRpb25zKiBvZiB0aGUg U3RhcnRDb20gQ2VydGlmaWNhdGlvbiBBdXRob3JpdHkgUG9saWN5IGF2YWlsYWJs ZSBhdCBodHRwOi8vY2VydC5zdGFydGNvbS5vcmcvcG9saWN5LnBkZjARBglghkgB hvhCAQEEBAMCAAcwUQYJYIZIAYb4QgENBEQWQlN0YXJ0Q29tIENsYXNzIDEgUHJp bWFyeSBJbnRlcm1lZGlhdGUgRnJlZSBTU0wgU2VydmVyIENlcnRpZmljYXRlczAN BgkqhkiG9w0BAQUFAAOCAgEAN9nwGVuwb7kFbGiREJ/EfPnRQ/JDsIIqbfPrglDY P/q+mgx3Umd6tVrzkdnbu4GPgSJpp4b5k7qgJ/bVPJE8wgNmM/7/eDnqYEPKAFDI duxVfPCEkF70nuwe6KK5UKvsiIYrH++cu6ENb8gtWNodtpuK+WUnSRFTwLEJuVk/ WemF0Ake/JPvoDxGnV8qLo1yMQdolfcdlHikpWAGHaNLc3mPqK29qxGoLNL+PrFx mI0aNKHjuw7hl+yXFa6N25vXTtTzJDfaa8Iwf2D3YRSJC28/HH2HKdA9dNui9LFp IkYc9uAyPQB3qFwRapaBhDQOmCtFyN1iOC8dtbUKsdp7/ZW5ImcZsP+a220Fc2+W e0OQCeDenNpVorg9lKJovv5qQXnRfmBlac3HL1o6mWXI7gvlFoOlYPITAHgcvZHZ lHrs45w+X26XFVXBAHNup8C7QiAKPTtk2M6Ii/xI1yYNpht4JANykesH4Ln4fYHw 1tH60t61XZ/Kbdg/pIzh1tE+QoUFlf+CR01qfskFjXcresRrgd00KOxgfJls6HnD xoiEoL+c2vOoATe7vmvhKHv8S5pv1IBLnjJeQQqQsKY8lBYxf+b4Tl2xNddnBO28 G8P6HGtMDMHaPETF+esG9VpMNtJkq0eNiCzmEHc7MDlA6kpFIY0psK/W0aPh6hcO MAg= -----END CERTIFICATE----- -----BEGIN CERTIFICATE----- MIIFFjCCBH+gAwIBAgIBADANBgkqhkiG9w0BAQQFADCBsDELMAkGA1UEBhMCSUwx DzANBgNVBAgTBklzcmFlbDEOMAwGA1UEBxMFRWlsYXQxFjAUBgNVBAoTDVN0YXJ0 Q29tIEx0ZC4xGjAYBgNVBAsTEUNBIEF1dGhvcml0eSBEZXAuMSkwJwYDVQQDEyBG cmVlIFNTTCBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTEhMB8GCSqGSIb3DQEJARYS YWRtaW5Ac3RhcnRjb20ub3JnMB4XDTA1MDMxNzE3Mzc0OFoXDTM1MDMxMDE3Mzc0 OFowgbAxCzAJBgNVBAYTAklMMQ8wDQYDVQQIEwZJc3JhZWwxDjAMBgNVBAcTBUVp bGF0MRYwFAYDVQQKEw1TdGFydENvbSBMdGQuMRowGAYDVQQLExFDQSBBdXRob3Jp dHkgRGVwLjEpMCcGA1UEAxMgRnJlZSBTU0wgQ2VydGlmaWNhdGlvbiBBdXRob3Jp dHkxITAfBgkqhkiG9w0BCQEWEmFkbWluQHN0YXJ0Y29tLm9yZzCBnzANBgkqhkiG 9w0BAQEFAAOBjQAwgYkCgYEA7YRgACOeyEpRKSfeOqE5tWmrCbIvNP1h3D3TsM+x 18LEwrHkllbEvqoUDufMOlDIOmKdw6OsWXuO7lUaHEe+o5c5s7XvIywI6Nivcy+5 yYPo7QAPyHWlLzRMGOh2iCNJitu27Wjaw7ViKUylS7eYtAkUEKD4/mJ2IhULpNYI LzUCAwEAAaOCAjwwggI4MA8GA1UdEwEB/wQFMAMBAf8wCwYDVR0PBAQDAgHmMB0G A1UdDgQWBBQcicOWzL3+MtUNjIExtpidjShkjTCB3QYDVR0jBIHVMIHSgBQcicOW zL3+MtUNjIExtpidjShkjaGBtqSBszCBsDELMAkGA1UEBhMCSUwxDzANBgNVBAgT BklzcmFlbDEOMAwGA1UEBxMFRWlsYXQxFjAUBgNVBAoTDVN0YXJ0Q29tIEx0ZC4x GjAYBgNVBAsTEUNBIEF1dGhvcml0eSBEZXAuMSkwJwYDVQQDEyBGcmVlIFNTTCBD ZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTEhMB8GCSqGSIb3DQEJARYSYWRtaW5Ac3Rh cnRjb20ub3JnggEAMB0GA1UdEQQWMBSBEmFkbWluQHN0YXJ0Y29tLm9yZzAdBgNV HRIEFjAUgRJhZG1pbkBzdGFydGNvbS5vcmcwEQYJYIZIAYb4QgEBBAQDAgAHMC8G CWCGSAGG+EIBDQQiFiBGcmVlIFNTTCBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTAy BglghkgBhvhCAQQEJRYjaHR0cDovL2NlcnQuc3RhcnRjb20ub3JnL2NhLWNybC5j cmwwKAYJYIZIAYb4QgECBBsWGWh0dHA6Ly9jZXJ0LnN0YXJ0Y29tLm9yZy8wOQYJ YIZIAYb4QgEIBCwWKmh0dHA6Ly9jZXJ0LnN0YXJ0Y29tLm9yZy9pbmRleC5waHA/ YXBwPTExMTANBgkqhkiG9w0BAQQFAAOBgQBscSXhnjSRIe/bbL0BCFaPiNhBOlP1 ct8nV0t2hPdopP7rPwl+KLhX6h/BquL/lp9JmeaylXOWxkjHXo0Hclb4g4+fd68p 00UOpO6wNnQt8M2YI3s3S9r+UZjEHjQ8iP2ZO1CnwYszx8JSFhKVU2Ui77qLzmLb cCOxgN8aIDjnfg== -----END CERTIFICATE----- -----BEGIN CERTIFICATE----- MIIHPTCCBSWgAwIBAgIBADANBgkqhkiG9w0BAQQFADB5MRAwDgYDVQQKEwdSb290 IENBMR4wHAYDVQQLExVodHRwOi8vd3d3LmNhY2VydC5vcmcxIjAgBgNVBAMTGUNB IENlcnQgU2lnbmluZyBBdXRob3JpdHkxITAfBgkqhkiG9w0BCQEWEnN1cHBvcnRA Y2FjZXJ0Lm9yZzAeFw0wMzAzMzAxMjI5NDlaFw0zMzAzMjkxMjI5NDlaMHkxEDAO BgNVBAoTB1Jvb3QgQ0ExHjAcBgNVBAsTFWh0dHA6Ly93d3cuY2FjZXJ0Lm9yZzEi MCAGA1UEAxMZQ0EgQ2VydCBTaWduaW5nIEF1dGhvcml0eTEhMB8GCSqGSIb3DQEJ ARYSc3VwcG9ydEBjYWNlcnQub3JnMIICIjANBgkqhkiG9w0BAQEFAAOCAg8AMIIC CgKCAgEAziLA4kZ97DYoB1CW8qAzQIxL8TtmPzHlawI229Z89vGIj053NgVBlfkJ 8BLPRoZzYLdufujAWGSuzbCtRRcMY/pnCujW0r8+55jE8Ez64AO7NV1sId6eINm6 zWYyN3L69wj1x81YyY7nDl7qPv4coRQKFWyGhFtkZip6qUtTefWIonvuLwphK42y fk1WpRPs6tqSnqxEQR5YYGUFZvjARL3LlPdCfgv3ZWiYUQXw8wWRBB0bF4LsyFe7 w2t6iPGwcswlWyCR7BYCEo8y6RcYSNDHBS4CMEK4JZwFaz+qOqfrU0j36NK2B5jc G8Y0f3/JHIJ6BVgrCFvzOKKrF11myZjXnhCLotLddJr3cQxyYN/Nb5gznZY0dj4k epKwDpUeb+agRThHqtdB7Uq3EvbXG4OKDy7YCbZZ16oE/9KTfWgu3YtLq1i6L43q laegw1SJpfvbi1EinbLDvhG+LJGGi5Z4rSDTii8aP8bQUWWHIbEZAWV/RRyH9XzQ QUxPKZgh/TMfdQwEUfoZd9vUFBzugcMd9Zi3aQaRIt0AUMyBMawSB3s42mhb5ivU fslfrejrckzzAeVLIL+aplfKkQABi6F1ITe1Yw1nPkZPcCBnzsXWWdsC4PDSy826 YreQQejdIOQpvGQpQsgi3Hia/0PsmBsJUUtaWsJx8cTLc6nloQsCAwEAAaOCAc4w ggHKMB0GA1UdDgQWBBQWtTIb1Mfz4OaO873SsDrusjkY0TCBowYDVR0jBIGbMIGY gBQWtTIb1Mfz4OaO873SsDrusjkY0aF9pHsweTEQMA4GA1UEChMHUm9vdCBDQTEe MBwGA1UECxMVaHR0cDovL3d3dy5jYWNlcnQub3JnMSIwIAYDVQQDExlDQSBDZXJ0 IFNpZ25pbmcgQXV0aG9yaXR5MSEwHwYJKoZIhvcNAQkBFhJzdXBwb3J0QGNhY2Vy dC5vcmeCAQAwDwYDVR0TAQH/BAUwAwEB/zAyBgNVHR8EKzApMCegJaAjhiFodHRw czovL3d3dy5jYWNlcnQub3JnL3Jldm9rZS5jcmwwMAYJYIZIAYb4QgEEBCMWIWh0 dHBzOi8vd3d3LmNhY2VydC5vcmcvcmV2b2tlLmNybDA0BglghkgBhvhCAQgEJxYl aHR0cDovL3d3dy5jYWNlcnQub3JnL2luZGV4LnBocD9pZD0xMDBWBglghkgBhvhC AQ0ESRZHVG8gZ2V0IHlvdXIgb3duIGNlcnRpZmljYXRlIGZvciBGUkVFIGhlYWQg b3ZlciB0byBodHRwOi8vd3d3LmNhY2VydC5vcmcwDQYJKoZIhvcNAQEEBQADggIB ACjH7pyCArpcgBLKNQodgW+JapnM8mgPf6fhjViVPr3yBsOQWqy1YPaZQwGjiHCc nWKdpIevZ1gNMDY75q1I08t0AoZxPuIrA2jxNGJARjtT6ij0rPtmlVOKTV39O9lg 18p5aTuxZZKmxoGCXJzN600BiqXfEVWqFcofN8CCmHBh22p8lqOOLlQ+TyGpkO/c gr/c6EWtTZBzCDyUZbAEmXZ/4rzCahWqlwQ3JNgelE5tDlG+1sSPypZt90Pf6DBl Jzt7u0NDY8RD97LsaMzhGY4i+5jhe1o+ATc7iwiwovOVThrLm82asduycPAtStvY sONvRUgzEv/+PDIqVPfE94rwiCPCR/5kenHA0R6mY7AHfqQv0wGP3J8rtsYIqQ+T SCX8Ev2fQtzzxD72V7DX3WnRBnc0CkvSyqD/HMaMyRa+xMwyN2hzXwj7UfdJUzYF CpUCTPJ5GhD22Dp1nPMd8aINcGeGG7MW9S/lpOt5hvk9C8JzC6WZrG/8Z7jlLwum GCSNe9FINSkYQKyTYOGWhlC0elnYjyELn8+CkcY7v2vcB5G5l1YjqrZslMZIBjzk zk6q5PYvCdxTby78dOs6Y5nCpqyJvKeyRKANihDjbPIky/qbn3BHLt4Ui9SyIAmW omTxJBzcoTWcFbLUvFUufQb1nA5V9FrWk9p2rSVzTMVD -----END CERTIFICATE----- -----BEGIN CERTIFICATE----- MIIGCDCCA/CgAwIBAgIBATANBgkqhkiG9w0BAQQFADB5MRAwDgYDVQQKEwdSb290 IENBMR4wHAYDVQQLExVodHRwOi8vd3d3LmNhY2VydC5vcmcxIjAgBgNVBAMTGUNB IENlcnQgU2lnbmluZyBBdXRob3JpdHkxITAfBgkqhkiG9w0BCQEWEnN1cHBvcnRA Y2FjZXJ0Lm9yZzAeFw0wNTEwMTQwNzM2NTVaFw0zMzAzMjgwNzM2NTVaMFQxFDAS BgNVBAoTC0NBY2VydCBJbmMuMR4wHAYDVQQLExVodHRwOi8vd3d3LkNBY2VydC5v cmcxHDAaBgNVBAMTE0NBY2VydCBDbGFzcyAzIFJvb3QwggIiMA0GCSqGSIb3DQEB AQUAA4ICDwAwggIKAoICAQCrSTURSHzSJn5TlM9Dqd0o10Iqi/OHeBlYfA+e2ol9 4fvrcpANdKGWZKufoCSZc9riVXbHF3v1BKxGuMO+f2SNEGwk82GcwPKQ+lHm9WkB Y8MPVuJKQs/iRIwlKKjFeQl9RrmK8+nzNCkIReQcn8uUBByBqBSzmGXEQ+xOgo0J 0b2qW42S0OzekMV/CsLj6+YxWl50PpczWejDAz1gM7/30W9HxM3uYoNSbi4ImqTZ FRiRpoWSR7CuSOtttyHshRpocjWr//AQXcD0lKdq1TuSfkyQBX6TwSyLpI5idBVx bgtxA+qvFTia1NIFcm+M+SvrWnIl+TlG43IbPgTDZCciECqKT1inA62+tC4T7V2q SNfVfdQqe1z6RgRQ5MwOQluM7dvyz/yWk+DbETZUYjQ4jwxgmzuXVjit89Jbi6Bb 6k6WuHzX1aCGcEDTkSm3ojyt9Yy7zxqSiuQ0e8DYbF/pCsLDpyCaWt8sXVJcukfV m+8kKHA4IC/VfynAskEDaJLM4JzMl0tF7zoQCqtwOpiVcK01seqFK6QcgCExqa5g eoAmSAC4AcCTY1UikTxW56/bOiXzjzFU6iaLgVn5odFTEcV7nQP2dBHgbbEsPyyG kZlxmqZ3izRg0RS0LKydr4wQ05/EavhvE/xzWfdmQnQeiuP43NJvmJzLR5iVQAX7 6QIDAQABo4G/MIG8MA8GA1UdEwEB/wQFMAMBAf8wXQYIKwYBBQUHAQEEUTBPMCMG CCsGAQUFBzABhhdodHRwOi8vb2NzcC5DQWNlcnQub3JnLzAoBggrBgEFBQcwAoYc aHR0cDovL3d3dy5DQWNlcnQub3JnL2NhLmNydDBKBgNVHSAEQzBBMD8GCCsGAQQB gZBKMDMwMQYIKwYBBQUHAgEWJWh0dHA6Ly93d3cuQ0FjZXJ0Lm9yZy9pbmRleC5w aHA/aWQ9MTAwDQYJKoZIhvcNAQEEBQADggIBAH8IiKHaGlBJ2on7oQhy84r3HsQ6 tHlbIDCxRd7CXdNlafHCXVRUPIVfuXtCkcKZ/RtRm6tGpaEQU55tiKxzbiwzpvD0 nuB1wT6IRanhZkP+VlrRekF490DaSjrxC1uluxYG5sLnk7mFTZdPsR44Q4Dvmw2M 77inYACHV30eRBzLI++bPJmdr7UpHEV5FpZNJ23xHGzDwlVks7wU4vOkHx4y/CcV Bc/dLq4+gmF78CEQGPZE6lM5+dzQmiDgxrvgu1pPxJnIB721vaLbLmINQjRBvP+L ivVRIqqIMADisNS8vmW61QNXeZvo3MhN+FDtkaVSKKKs+zZYPumUK5FQhxvWXtaM zPcPEAxSTtAWYeXlCmy/F8dyRlecmPVsYGN6b165Ti/Iubm7aoW8mA3t+T6XhDSU rgCvoeXnkm5OvfPi2RSLXNLrAWygF6UtEOucekq9ve7O/e0iQKtwOIj1CodqwqsF YMlIBdpTwd5Ed2qz8zw87YC8pjhKKSRf/lk7myV6VmMAZLldpGJ9VzZPrYPvH5JT oI53V93lYRE9IwCQTDz6o2CTBKOvNfYOao9PSmCnhQVsRqGP9Md246FZV/dxssRu FFxtbUFm3xuTsdQAw+7Lzzw9IYCpX2Nl/N3gX6T0K/CFcUHUZyX7GrGXrtaZghNB 0m6lG5kngOcLqagA -----END CERTIFICATE----- -----BEGIN CERTIFICATE----- MIIDIDCCAomgAwIBAgIENd70zzANBgkqhkiG9w0BAQUFADBOMQswCQYDVQQGEwJV UzEQMA4GA1UEChMHRXF1aWZheDEtMCsGA1UECxMkRXF1aWZheCBTZWN1cmUgQ2Vy dGlmaWNhdGUgQXV0aG9yaXR5MB4XDTk4MDgyMjE2NDE1MVoXDTE4MDgyMjE2NDE1 MVowTjELMAkGA1UEBhMCVVMxEDAOBgNVBAoTB0VxdWlmYXgxLTArBgNVBAsTJEVx dWlmYXggU2VjdXJlIENlcnRpZmljYXRlIEF1dGhvcml0eTCBnzANBgkqhkiG9w0B AQEFAAOBjQAwgYkCgYEAwV2xWGcIYu6gmi0fCG2RFGiYCh7+2gRvE4RiIcPRfM6f BeC4AfBONOziipUEZKzxa1NfBbPLZ4C/QgKO/t0BCezhABRP/PvwDN1Dulsr4R+A cJkVV5MW8Q+XarfCaCMczE1ZMKxRHjuvK9buY0V7xdlfUNLjUA86iOe/FP3gx7kC AwEAAaOCAQkwggEFMHAGA1UdHwRpMGcwZaBjoGGkXzBdMQswCQYDVQQGEwJVUzEQ MA4GA1UEChMHRXF1aWZheDEtMCsGA1UECxMkRXF1aWZheCBTZWN1cmUgQ2VydGlm aWNhdGUgQXV0aG9yaXR5MQ0wCwYDVQQDEwRDUkwxMBoGA1UdEAQTMBGBDzIwMTgw ODIyMTY0MTUxWjALBgNVHQ8EBAMCAQYwHwYDVR0jBBgwFoAUSOZo+SvSspXXR9gj IBBPM5iQn9QwHQYDVR0OBBYEFEjmaPkr0rKV10fYIyAQTzOYkJ/UMAwGA1UdEwQF MAMBAf8wGgYJKoZIhvZ9B0EABA0wCxsFVjMuMGMDAgbAMA0GCSqGSIb3DQEBBQUA A4GBAFjOKer89961zgK5F7WF0bnj4JXMJTENAKaSbn+2kmOeUJXRmm/kEd5jhW6Y 7qj/WsjTVbJmcVfewCHrPSqnI0kBBIZCe/zuf6IWUrVnZ9NA2zsmWLIodz2uFHdh 1voqZiegDfqnc1zqcPGUIWVEX/r87yloqaKHee9570+sB3c4 -----END CERTIFICATE----- -----BEGIN CERTIFICATE----- MIIDIDCCAomgAwIBAgIENd70zzANBgkqhkiG9w0BAQUFADBOMQswCQYDVQQGEwJV UzEQMA4GA1UEChMHRXF1aWZheDEtMCsGA1UECxMkRXF1aWZheCBTZWN1cmUgQ2Vy dGlmaWNhdGUgQXV0aG9yaXR5MB4XDTk4MDgyMjE2NDE1MVoXDTE4MDgyMjE2NDE1 MVowTjELMAkGA1UEBhMCVVMxEDAOBgNVBAoTB0VxdWlmYXgxLTArBgNVBAsTJEVx dWlmYXggU2VjdXJlIENlcnRpZmljYXRlIEF1dGhvcml0eTCBnzANBgkqhkiG9w0B AQEFAAOBjQAwgYkCgYEAwV2xWGcIYu6gmi0fCG2RFGiYCh7+2gRvE4RiIcPRfM6f BeC4AfBONOziipUEZKzxa1NfBbPLZ4C/QgKO/t0BCezhABRP/PvwDN1Dulsr4R+A cJkVV5MW8Q+XarfCaCMczE1ZMKxRHjuvK9buY0V7xdlfUNLjUA86iOe/FP3gx7kC AwEAAaOCAQkwggEFMHAGA1UdHwRpMGcwZaBjoGGkXzBdMQswCQYDVQQGEwJVUzEQ MA4GA1UEChMHRXF1aWZheDEtMCsGA1UECxMkRXF1aWZheCBTZWN1cmUgQ2VydGlm aWNhdGUgQXV0aG9yaXR5MQ0wCwYDVQQDEwRDUkwxMBoGA1UdEAQTMBGBDzIwMTgw ODIyMTY0MTUxWjALBgNVHQ8EBAMCAQYwHwYDVR0jBBgwFoAUSOZo+SvSspXXR9gj IBBPM5iQn9QwHQYDVR0OBBYEFEjmaPkr0rKV10fYIyAQTzOYkJ/UMAwGA1UdEwQF MAMBAf8wGgYJKoZIhvZ9B0EABA0wCxsFVjMuMGMDAgbAMA0GCSqGSIb3DQEBBQUA A4GBAFjOKer89961zgK5F7WF0bnj4JXMJTENAKaSbn+2kmOeUJXRmm/kEd5jhW6Y 7qj/WsjTVbJmcVfewCHrPSqnI0kBBIZCe/zuf6IWUrVnZ9NA2zsmWLIodz2uFHdh 1voqZiegDfqnc1zqcPGUIWVEX/r87yloqaKHee9570+sB3c4 -----END CERTIFICATE----- -----BEGIN CERTIFICATE----- MIIEnDCCA4SgAwIBAgIQaUiiayAapCHomLHEksfFjjANBgkqhkiG9w0BAQUFADBY MQswCQYDVQQGEwJVUzEWMBQGA1UEChMNR2VvVHJ1c3QgSW5jLjExMC8GA1UEAxMo R2VvVHJ1c3QgUHJpbWFyeSBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTAeFw0wNjEx MjkwMDAwMDBaFw0xNjExMjgyMzU5NTlaMIGFMQswCQYDVQQGEwJVUzEVMBMGA1UE ChMMR2VvVHJ1c3QgSW5jMTEwLwYDVQQLEyhTZWUgd3d3Lmdlb3RydXN0LmNvbS9y ZXNvdXJjZXMvY3BzIChjKTA2MSwwKgYDVQQDEyNHZW9UcnVzdCBFeHRlbmRlZCBW YWxpZGF0aW9uIFNTTCBDQTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEB AMLv7ewLLXKKdGhzNm4QqH5If1i7eGfc7XvWfKZPPZ9dbwrQoLRl/b7Tv3e2lKWC /4GVnSgQBuzCtJCqWlFMc9lrdKg1SfSmNoDUXHWennwBx4ycgciGgxqOvQATotz/ pXiqdywhYgiXP4C992ekedt91z5uttWWuZiGTnpn4pOv2qXRJ/vxZsMqAwy2x4Id Ofs83ik2cV3hqLUWOXwb/3uG9YCSleADO6pE+/QAteWp4voY+YSaweH2Lg6BixQp NP8fVWCIpJnGb28EOTp1pKceWN+3/8maHXDbg6DTgxstbSqQW6NjkXO1/52CekHz 06ovCw2fz0TAXseha8+ulNsCAwEAAaOCATIwggEuMB0GA1UdDgQWBBQoxOuP8V95 kKMrVcNWTn1rU3IsGDA9BggrBgEFBQcBAQQxMC8wLQYIKwYBBQUHMAGGIWh0dHA6 Ly9FVlNlY3VyZS1vY3NwLmdlb3RydXN0LmNvbTASBgNVHRMBAf8ECDAGAQH/AgEA MEYGA1UdIAQ/MD0wOwYEVR0gADAzMDEGCCsGAQUFBwIBFiVodHRwOi8vd3d3Lmdl b3RydXN0LmNvbS9yZXNvdXJjZXMvY3BzMEEGA1UdHwQ6MDgwNqA0oDKGMGh0dHA6 Ly9FVlNlY3VyZS1jcmwuZ2VvdHJ1c3QuY29tL0dlb1RydXN0UENBLmNybDAOBgNV HQ8BAf8EBAMCAQYwHwYDVR0jBBgwFoAULNVQQZcVi/CPNmFbSvtr2ZnJM5IwDQYJ KoZIhvcNAQEFBQADggEBAAJgoxYSndgcGeRaN2z/Mpg3Rk+8gXyAw8qJKgD+Xj7s uowrH6uVa5GUIaBgHwIG+s8XbfiVq814IxSWwJ0fG+tQ4WVCitKzya2Aw2fPtFgb 1QTkWP40ReD7pIQii+niN0yY8Qv/pIlT0U3AaEjXWYcaO3310Pkjcspg/cMiFfCa lVhvfCST7KUSPbQbAejuae1Ba1LLmrdcFdG9BkB64AyXy2Dngl9qX95JhFZqr3yw S62MTw95oMwRPCXnRr960C+IyL/rlAtqdTN/cwC4EnAjXlV/RVseELECaNgnQM8k CeJldM6JRI17KJBorqzCOMhWDTOIKH9U/Dw8UAmTPTg= -----END CERTIFICATE----- -----BEGIN CERTIFICATE----- MIIDizCCAvSgAwIBAgIDBo4dMA0GCSqGSIb3DQEBBQUAME4xCzAJBgNVBAYTAlVT MRAwDgYDVQQKEwdFcXVpZmF4MS0wKwYDVQQLEyRFcXVpZmF4IFNlY3VyZSBDZXJ0 aWZpY2F0ZSBBdXRob3JpdHkwHhcNMDYxMTI4MTYwODMxWhcNMTgwODIxMTUwODMx WjBYMQswCQYDVQQGEwJVUzEWMBQGA1UEChMNR2VvVHJ1c3QgSW5jLjExMC8GA1UE AxMoR2VvVHJ1c3QgUHJpbWFyeSBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTCCASIw DQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAL64FXv/1Hx9Z62DZHvIQlMt3/aE CCBh1gFZapxEEa/vdv2Vfs5hMLt6g18CvQFmyu4VjW+hMJy9oYWelDrzVogAMc/Y 7mqWAtntA4z7dW3n6rhVFgUWmvTgXrGIwGSFXBVNiMe3uuB16a0FPZ3HiUjguyjI A+Ewk2ReUsBZcCI1V4iK8ZUKg9e8MXMBNO3vRnHgawKoNXJrl5tm4MsceV/YGgRo HkcC5p1g4jaXAd/ONZLfvmfHbXdZO4+d1pAVlLxCNBDBOfmxJz5+1op1xbKvltOi 3pvkmL594emBrbZv/NcO2uA0sA0ad+fjCJjvWPqchLc2r8LfrNL0EAZwcTUCAwEA AaOB6DCB5TAOBgNVHQ8BAf8EBAMCAQYwHQYDVR0OBBYEFCzVUEGXFYvwjzZhW0r7 a9mZyTOSMB8GA1UdIwQYMBaAFEjmaPkr0rKV10fYIyAQTzOYkJ/UMA8GA1UdEwEB /wQFMAMBAf8wOgYDVR0fBDMwMTAvoC2gK4YpaHR0cDovL2NybC5nZW90cnVzdC5j b20vY3Jscy9zZWN1cmVjYS5jcmwwRgYDVR0gBD8wPTA7BgRVHSAAMDMwMQYIKwYB BQUHAgEWJWh0dHA6Ly93d3cuZ2VvdHJ1c3QuY29tL3Jlc291cmNlcy9jcHMwDQYJ KoZIhvcNAQEFBQADgYEAe2AG6d2nHSkI7xH51Ts80itTyz7tvnZgZEig5svoScMa v92txUy9U0hVQdsYsU47OmgsJFpB9cipRKYyKS11+E3yUI7w4pvp4eQ7cLcyiduo OcVbaFa9BBXDtssbJEqn/MTVjbaY3QP2sbOU2j9SoKRQBspFZ07/8UGJQAA2fnk= -----END CERTIFICATE-----coccinella-0.96.20/components/000077500000000000000000000000001167435367600161735ustar00rootroot00000000000000coccinella-0.96.20/components/AppleEvents.tcl000066400000000000000000000116541167435367600211340ustar00rootroot00000000000000# AppleEvents.tcl -- # # Experimental! # Some code from Alpha. # # Copyright (c) 2007 Mats Bengtsson # # 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 3 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, see . # # $Id: AppleEvents.tcl,v 1.14 2008-05-26 09:41:58 matben Exp $ namespace eval ::AppleEvents { if {![string equal $::this(platform) "macosx"]} { return } if {[catch {package require tclAE 2.0.3}]} { return } component::define AppleEvents "Apple event handlers for Launch Services." } proc ::AppleEvents::Init {} { ::Debug 2 "::AppleEvents::Init" #tclAE::installEventHandler aevt GURL ::AppleEvents::HandleGURL tclAE::installEventHandler aevt oapp ::AppleEvents::OpenAppHandler tclAE::installEventHandler aevt rapp ::AppleEvents::OpenAppHandler tclAE::installEventHandler aevt odoc ::AppleEvents::OpenHandler tclAE::installEventHandler aevt pdoc ::AppleEvents::PrintHandler # Mac OS X have the Quit menu on the Apple menu instead. Catch it! tclAE::installEventHandler aevt quit ::AppleEvents::QuitHandler # test... tclAE::installEventHandler WWW! OURL ::AppleEvents::HandleOURL component::register AppleEvents } # AppleEvents::WhenLaunched -- # # This is a method to invoke handlers *after* we have launched. proc ::AppleEvents::WhenLaunched {cmd event reply} { global state if {[info exists state(launchStatus)]} { ::hooks::register afterFinalHook \ [list ::AppleEvents::WhenLaunched $cmd $event $reply] } else { uplevel #0 $cmd [list $event $reply] } } proc ::AppleEvents::HandleOURL {theAppleEvent theReplyAE} { ::Debug 4 "::AppleEvents::HandleOURL theAppleEvent=$theAppleEvent" } proc ::AppleEvents::OpenAppHandler {theAppleEvent theReplyAE} { WhenLaunched ::AppleEvents::OpenApp $theAppleEvent $theReplyAE } proc ::AppleEvents::OpenApp {theAppleEvent theReplyAE} { # Have no idea of what to do here... ::Debug 4 "::AppleEvents::OpenApp theAppleEvent=$theAppleEvent" return set eventClass [tclAE::getAttributeData $theAppleEvent evcl] set eventID [tclAE::getAttributeData $theAppleEvent evid] ::Debug 4 "\t eventClass=$eventClass, eventID=$eventID" } proc ::AppleEvents::OpenHandler {theAppleEvent theReplyAE} { WhenLaunched ::AppleEvents::Open $theAppleEvent $theReplyAE } proc ::AppleEvents::Open {theAppleEvent theReplyAE} { ::Debug 4 "::AppleEvents::Open theAppleEvent=$theAppleEvent" set pathDesc [tclAE::getKeyDesc $theAppleEvent ----] set paths [ExtractPaths $pathDesc wasList] tclAE::disposeDesc $pathDesc ::Debug 4 "\t paths=$paths" foreach f $paths { switch -- [file extension $f] { .can { ::WB::NewWhiteboard -file $f } } } } proc ::AppleEvents::PrintHandler {theAppleEvent theReplyAE} { WhenLaunched ::AppleEvents::Print $theAppleEvent $theReplyAE } proc ::AppleEvents::Print {theAppleEvent theReplyAE} { set pathDesc [tclAE::getKeyDesc $theAppleEvent ----] set paths [ExtractPaths $pathDesc wasList] tclAE::disposeDesc $pathDesc foreach f $paths { switch -- [file extension $f] { .can { set w [::WB::NewWhiteboard -file $f] set wcan [::WB::GetCanvasFromWtop $w] ::UserActions::DoPrintCanvas $wcan } } } } proc ::AppleEvents::HandleGURL {theAppleEvent theReplyAE} { puts "theAppleEvent=$theAppleEvent" set eventClass [tclAE::getAttributeData $theAppleEvent evcl] set eventID [tclAE::getAttributeData $theAppleEvent evid] } proc ::AppleEvents::QuitHandler {theAppleEvent theReplyAE} { ::UserActions::DoQuit } proc ::AppleEvents::ExtractPaths {files {wasList ""}} { set paths [list] upvar 1 $wasList listOfPaths switch -- [tclAE::getDescType $files] { "list" { set count [tclAE::countItems $files] for {set item 0} {$item < $count} {incr item} { set fileDesc [tclAE::getNthDesc $files $item] lappend paths [ExtractPath $fileDesc] tclAE::disposeDesc $fileDesc } set listOfPaths 1 } default { lappend paths [ExtractPath $files] set listOfPaths 1 } } return $paths } proc ::AppleEvents::ExtractPath {fileDesc} { set alisDesc [tclAE::coerceDesc $fileDesc alis] set path [tclAE::getData $alisDesc TEXT] tclAE::disposeDesc $alisDesc return $path } #------------------------------------------------------------------------------- coccinella-0.96.20/components/AutoUpdate.tcl000066400000000000000000000212461167435367600207570ustar00rootroot00000000000000# AutoUpdate.tcl --- # # This file is part of The Coccinella application. It implements # methods to query for new versions. # # Copyright (c) 2003-2007 Mats Bengtsson # # 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 3 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, see . # # $Id: AutoUpdate.tcl,v 1.30 2008-04-27 13:33:38 matben Exp $ package require tinydom package require http 2.3 namespace eval ::AutoUpdate { component::define AutoUpdate \ "Automatically checks for new version of this application." # Allow the update url to be set via the option database. set urlEN "http://coccinella.sourceforge.net/updates/update_en.xml" set urlFormat "http://coccinella.sourceforge.net/updates/update_%s.xml" # set urlEN "http://coccinella.sourceforge.net/updates/update_en_0.96.8.xml" # set urlFormat "http://coccinella.sourceforge.net/updates/update_test_%s.xml" set ::config(autoupdate,do) 1 set ::config(autoupdate,url) $urlEN set ::config(autoupdate,urlFormat) $urlFormat set ::config(autoupdate,interval) "1 day ago" variable newVersion 1.0 } proc ::AutoUpdate::Init {} { ::Debug 2 "::AutoUpdate::Init" ::hooks::register prefsInitHook ::AutoUpdate::InitPrefsHook ::hooks::register launchFinalHook ::AutoUpdate::LaunchHook # TRANSLATORS: checking for new versions of Coccinella; see Info menu set menuDef {command mUpdateCheck {[mc "&Update Check"]} {::AutoUpdate::Get -silent 0} {}} ::JUI::RegisterMenuEntry info $menuDef component::register AutoUpdate } proc ::AutoUpdate::InitPrefsHook {} { global prefs # Auto update mechanism: if lastVersion < run version => autoupdate set prefs(autoupdate,lastVersion) 0.0 set prefs(autoupdate,lastTime) [clock scan "1 year ago"] ::PrefUtils::Add [list \ [list prefs(autoupdate,lastVersion) prefs_autoupdate_lastVersion $prefs(autoupdate,lastVersion)] \ [list prefs(autoupdate,lastTime) prefs_autoupdate_lastTime $prefs(autoupdate,lastTime)] \ ] } proc ::AutoUpdate::LaunchHook {} { global prefs this config if {$config(autoupdate,do)} { # The 'notLater' gives seconds for now minus interval. set notLater [clock scan $config(autoupdate,interval)] if {$prefs(autoupdate,lastTime) < $notLater} { if {[package vcompare $this(vers,full) $prefs(autoupdate,lastVersion)] > 0} { after 10000 [namespace code Get] } } } } # AutoUpdate::Get -- # # Tries to get the update xml files, first the localized one, # and if that fails, the english one. proc ::AutoUpdate::Get {args} { global this prefs config variable opts ::Debug 2 "::AutoUpdate::Get" array set opts { -silent 1 -locale 1 } array set opts $args eval {GetURL} [array get opts] } proc ::AutoUpdate::GetURL {args} { global this prefs config variable opts array set opts $args if {$opts(-locale)} { set url [format $config(autoupdate,urlFormat) [::msgcat::mclocale]] } else { set url $config(autoupdate,url) } ::Debug 2 "\t url=$url" set tmopts [list -timeout $prefs(timeoutMillis)] if {[catch {eval { ::httpex::get $url -command [namespace code [list Command $opts(-locale)]] } $tmopts} token]} { if {!$opts(-silent)} { ::UI::MessageBox -title [mc "Error"] -icon error -type ok \ -message [mc "Cannot connect to server %s to download update details: %s" $url $token] } } } proc ::AutoUpdate::Command {locale token} { global prefs this upvar #0 $token state variable opts variable newVersion # Investigate 'state' for any exceptions. set hstate [::httpex::state $token] set status [::httpex::status $token] set ncode [::httpex::ncode $token] if {$hstate ne "final"} { return } set prefs(autoupdate,lastTime) [clock seconds] ::Debug 2 "::AutoUpdate::Command status=$status, ncode=$ncode, locale=$locale" if {($status eq "ok") && ($ncode eq "200")} { # Get and parse xml. set xml [::httpex::data $token] set token [tinydom::parse $xml] set xmllist [tinydom::documentElement $token] set releaseElem [lindex [tinydom::children $xmllist] 0] set releaseAttr [tinydom::attrlist $releaseElem] array set releaseA $releaseAttr set message "" set changesL [list] foreach elem [tinydom::children $releaseElem] { switch -- [tinydom::tagname $elem] { message { set message [tinydom::chdata $elem] } changes { foreach item [tinydom::children $elem] { lappend changesL [tinydom::chdata $item] } } } } set newVersion $releaseA(version) # Show dialog if newer version available. if {[package vcompare $this(vers,full) $releaseA(version)] == -1} { Dialog $releaseAttr $message $changesL } elseif {!$opts(-silent)} { ::UI::MessageBox -title [mc "Update Check"] -icon info -type ok \ -message [mc "You already have the latest version available (%s)." $this(vers,full)] } tinydom::cleanup $token } elseif {$locale} { # Try get the English catalog as a fallback. GetURL -locale 0 } ::httpex::cleanup $token } proc ::AutoUpdate::Dialog {releaseAttr message changesL} { global this prefs variable autocheck variable newVersion set w .aupdate if {[winfo exists $w]} { return } ::UI::Toplevel $w -macstyle documentProc -usemacmainmenu 1 \ -closecommand [namespace current]::Destroy wm title $w [mc "New Version"] # Global frame. ttk::frame $w.frall pack $w.frall -fill both -expand 1 set wbox $w.frall.f ttk::frame $wbox -padding [option get . dialogPadding {}] pack $wbox -fill both -expand 1 # Text. set wtext $wbox.text text $wtext -width 60 -height 16 -wrap word \ -borderwidth 1 -relief sunken -background white pack $wtext $wtext tag configure msgtag -lmargin1 10 -spacing1 4 -spacing3 4 \ -font CociSmallBoldFont $wtext tag configure attrtag -lmargin1 10 -spacing1 2 -spacing3 2 $wtext tag configure changestag -lmargin1 10 -spacing1 4 -spacing3 4 \ -font CociSmallBoldFont $wtext tag configure itemtag -lmargin1 20 -lmargin2 30 \ -spacing1 2 -spacing3 2 $wtext configure -tabs {100 right 110 left} $wtext mark set insert end $wtext configure -state normal $wtext insert end $message msgtag $wtext insert end "\n" foreach {name value} $releaseAttr { $wtext insert end "\t[mc [string totitle $name]]:" attrtag switch -- $name { url { $wtext insert end "\t" ::Text::ParseURI $wtext $value } date { set date [clock format [clock scan $value] \ -format "%A %d %B %Y"] $wtext insert end "\t$date" attrtag } default { $wtext insert end "\t$value" attrtag } } $wtext insert end "\n" } $wtext insert end [mc "Changes since previous release"]:\n changestag foreach item $changesL { $wtext insert end "o $item\n" itemtag } $wtext configure -state disabled set autocheck 1 if {[package vcompare $this(vers,full) $prefs(autoupdate,lastVersion)] <= 0} { set autocheck 0 } ttk::checkbutton $wbox.ch -text [mc "Automatically check for updates"] \ -variable [namespace current]::autocheck pack $wbox.ch -side top -anchor w -pady 8 # Button part. set frbot $wbox.b ttk::frame $frbot ttk::button $frbot.btok -text [mc "Close"] \ -command [list destroy $w] pack $frbot.btok -side right pack $frbot -side top -fill x # Configure text widget height to fit all. bind $wtext { set ylines [%W count -displaylines 1.0 end] set spacing [expr {2+2}] set font [%W cget -font] array set fontA [font metrics [%W cget -font]] set add [expr {int($ylines*$spacing/($fontA(-linespace) + 0.0))}] %W configure -height [expr {$ylines + $add + 1}] } wm resizable $w 0 0 } proc ::AutoUpdate::Destroy {w} { global prefs variable autocheck variable newVersion if {$autocheck} { set prefs(autoupdate,lastVersion) 0.0 } else { set prefs(autoupdate,lastVersion) $newVersion } } #------------------------------------------------------------------------------- coccinella-0.96.20/components/BuddyPounce.tcl000066400000000000000000000452061167435367600211270ustar00rootroot00000000000000# BuddyPounce.tcl -- # # Buddy pouncing... # This is just a first sketch. # TODO: all message translations. # # Copyright (c) 2007-2008 Mats Bengtsson # # 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 3 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, see . # # $Id: BuddyPounce.tcl,v 1.33 2008-07-22 07:09:49 matben Exp $ # Key phrases are: # event: something happens, presence change, incoming message etc. # target: is either a jid, a roster group, or 'any' # action: how to respond, popup, sound, reply etc. package require jlib namespace eval ::BuddyPounce { component::define BuddyPounce "Set actions for contact events" } proc ::BuddyPounce::Init {} { global this ::Debug 2 "::BuddyPounce::Init" # Add all hooks we need. ::hooks::register quitAppHook ::BuddyPounce::QuitHook ::hooks::register logoutHook ::BuddyPounce::LogoutHook ::hooks::register newMessageHook ::BuddyPounce::NewMsgHook ::hooks::register newChatMessageHook ::BuddyPounce::NewChatMsgHook ::hooks::register presenceHook ::BuddyPounce::PresenceHook ::hooks::register prefsInitHook ::BuddyPounce::InitPrefsHook # Register popmenu entry. # TRANSLATORS: actions to be execute on an event related to a contact (buddy pounces); see right-mouse click menu in the main window set menuDef { command mContactActions... {[mc "&Contact Actions"]...} {::BuddyPounce::Build $clicked $jidL $group} } set menuType { mContactActions... {group user} } set menuType { mContactActions... {} } ::Roster::RegisterPopupEntry $menuDef $menuType component::register BuddyPounce variable wdlg .budpounce # These define which the events are. variable events set events(keys) {available unavailable msg chat} set events(str) {Online Offline Message Chat} variable actionlist set actionlist(keys) {msgbox sound chat msg} # Keep prefs. jid must be mapped and with no resource! # The action keys correspond to option being on. # budprefs(jid2) {event {list-of-action-keys} event {...} ...} variable budprefs # And the same for roster groups. variable budprefsgroup # And for 'any' which is not an array. variable budprefsany {} # To save thread Id seen already, and to lookup on subsequent messages variable threadids variable alertTitle array set alertTitle { available Online unavailable Offline msg Message chat Chat } } proc ::BuddyPounce::InitPrefsHook {} { variable budprefsany ::PrefUtils::Add [list \ [list ::BuddyPounce::budprefs budprefs_array [GetJidPrefsArr]] \ [list ::BuddyPounce::budprefsgroup budprefsgroup_array [GetGroupPrefsArr]]\ [list ::BuddyPounce::budprefsany budprefsany $budprefsany] \ ] } proc ::BuddyPounce::GetJidPrefsArr {} { variable budprefs return [array get budprefs] } proc ::BuddyPounce::GetGroupPrefsArr { } { variable budprefsgroup return [array get budprefsgroup] } # BuddyPounce::Build -- # # Builds the preference dialog. # # typeselected: user, wb, group, "" proc ::BuddyPounce::Build {typeselected item groupL} { global this prefs variable wdlg variable events ::Debug 2 "::BuddyPounce::Build typeselected=$typeselected, item=$item, groupL=$groupL" # Initialize the state variable, an array, that keeps is the storage. set uid [join [split [jlib::barejid $item] "@. "] ""] set token [namespace current]::$uid variable $token upvar 0 $token state set w $wdlg$uid set state(w) $w if {[lsearch $typeselected group] >= 0} { set clicked group } elseif {[lsearch $typeselected user] >= 0} { set clicked user } else { set clicked $typeselected } switch -- $clicked { user { set jid [jlib::jidmap $item] jlib::splitjid $jid jid2 res set state(jid) $jid set state(jid2) $jid2 set state(type) jid set msg [mc "Set a specific action for events related to %s. Select events using the tabs below." $jid] set title [mc "Contact Actions"] append title ": $jid" } group { set group [lindex $groupL 0] set state(group) $group set state(type) group set msg [mc "Set a specific action for events related to any contact belonging to the group %s. Select events using the tabs below." $group] set title [mc "Contact Actions"] append title ": $group" } "" { set state(type) any set msg [mc "Set a specific action for events related to any contact in your contact list. Select events using the tabs below."] set title [mc "Contact Actions"] append title ": " append title [mc "Any"] } default { unset state return } } # Get all sounds. if {[component::exists Sounds]} { set menuDef [list] set allSounds [GetAllSounds] foreach s $allSounds { lappend menuDef [list [::Sounds::GetTextForName $s] -value $s] } set soundfileDef [lindex $allSounds 0] } else { set menuDef [list [list [mc "None"]]] set soundfileDef [mc "None"] } # Toplevel with class BuddyPounce. if ([winfo exists $w]) { raise $w focus $w return } ::UI::Toplevel $w -class BuddyPounce \ -usemacmainmenu 1 -macstyle documentProc -command ::BuddyPounce::CloseHook wm title $w $title set nwin [llength [::UI::GetPrefixedToplevels $wdlg]] if {$nwin == 1} { ::UI::SetWindowPosition $w $wdlg } # Global frame. ttk::frame $w.frall pack $w.frall -fill both -expand 1 ttk::label $w.frall.head -style Headlabel \ -text [mc "Contact Actions"] -compound left pack $w.frall.head -side top -fill both -expand 1 ttk::separator $w.frall.s -orient horizontal pack $w.frall.s -side top -fill x set wbox $w.frall.f ttk::frame $wbox -padding [option get . dialogPadding {}] pack $wbox -fill both -expand 1 ttk::label $wbox.msg -style Small.TLabel \ -padding {0 0 0 6} -wraplength 300 -justify left -text $msg pack $wbox.msg -side top -anchor w set wnb $wbox.nb ttk::notebook $wnb -padding {4} pack $wnb set i 0 foreach estr $events(str) ekey $events(keys) { $wnb add [ttk::frame $wnb.$ekey] -text [mc $estr] -sticky news # Action set wact $wnb.$ekey.f ttk::frame $wact -padding [option get . notebookPagePadding {}] pack $wact -side top -anchor [option get . dialogAnchor {}] ttk::checkbutton $wact.alrt -text [mc "Show popup"] \ -variable $token\($ekey,msgbox) ttk::checkbutton $wact.lsound -text [mc "Play sound"]: \ -variable $token\($ekey,sound) ui::combobutton $wact.msound -variable $token\($ekey,soundfile) \ -menulist $menuDef ttk::checkbutton $wact.chat -text [mc "Start chat"] \ -variable $token\($ekey,chat) set wmsg $wact.fmsg ttk::frame $wmsg ttk::frame $wmsg.f1 pack $wmsg.f1 -side top -anchor w ttk::checkbutton $wmsg.f1.c -text [mc "Send message with subject"]: \ -variable $token\($ekey,msg) ttk::entry $wmsg.f1.e -textvariable $token\($ekey,msg,subject) pack $wmsg.f1.c -side left pack $wmsg.f1.e -side top -fill x ttk::frame $wmsg.f2 -padding {0 2} pack $wmsg.f2 -side top -anchor w -fill x ttk::label $wmsg.f2.l -text [mc "Message"]: text $wmsg.f2.t -height 2 -width 24 -wrap word -bd 1 -relief sunken pack $wmsg.f2.l -side left -anchor n pack $wmsg.f2.t -side top -fill x set state($ekey,msg,wtext) $wmsg.f2.t grid $wact.alrt $wact.lsound $wact.msound -sticky w -padx 4 -pady 1 grid $wact.chat $wact.fmsg - -sticky nw -padx 4 -pady 1 set maxw [$wact.msound maxwidth] grid columnconfigure $wact 2 -minsize [expr {$maxw + 2*4}] grid $wact.msound $wact.fmsg -sticky ew if {![component::exists Sounds]} { $wact.lsound state disabled $wact.msound state disabled } # Set defaults. set state($ekey,msgbox) 0 set state($ekey,sound) 0 set state($ekey,chat) 0 set state($ekey,msg) 0 set state($ekey,soundfile) $soundfileDef } # Button part. set frbot $wbox.b ttk::frame $frbot -padding [option get . okcancelTopPadding {}] ttk::button $frbot.btok -text [mc "OK"] -default active \ -command [list [namespace current]::OK $token] ttk::button $frbot.btcancel -text [mc "Cancel"] \ -command [list [namespace current]::Cancel $token] ttk::button $frbot.btoff -text [mc "Disable All"] \ -command [list [namespace current]::AllOff $token] set padx [option get . buttonPadX {}] if {[option get . okcancelButtonOrder {}] eq "cancelok"} { pack $frbot.btok -side right pack $frbot.btcancel -side right -padx $padx pack $frbot.btoff -side right } else { pack $frbot.btoff -side right pack $frbot.btcancel -side right -padx $padx pack $frbot.btok -side right } pack $frbot -side bottom -fill x wm resizable $w 0 0 AllOff $token PrefsToState $token # Trick to resize the labels wraplength. set script [format { update idletasks %s configure -wraplength [expr {[winfo reqwidth %s] - 12}] } $wbox.msg $w] after idle $script return $token } # BuddyPounce::PrefsToState, StateToPrefs -- # # Translate to/from the budprefs array and the state array of # a particular token. proc ::BuddyPounce::PrefsToState {token} { variable $token upvar 0 $token state variable budprefs variable budprefsgroup variable budprefsany set eventActions [list] switch -- $state(type) { jid { set jid $state(jid2) if {[info exists budprefs($jid)]} { set eventActions $budprefs($jid) } } group { set group $state(group) if {[info exists budprefsgroup($group)]} { set eventActions $budprefsgroup($group) } } any { set eventActions $budprefsany } } foreach {ekey actlist} $eventActions { foreach akey $actlist { switch -glob -- $akey { soundfile:* { # The sound file is treated specially. if {[component::exists Sounds]} { set state($ekey,soundfile) \ [string map {soundfile: ""} $akey] } } subject:* { set state($ekey,msg,subject) \ [string map {subject: ""} $akey] } body:* { set body [string map {body: ""} $akey] set body [subst -nocommands -novariables $body] $state($ekey,msg,wtext) insert end $body } sound { if {[component::exists Sounds]} { set state($ekey,$akey) 1 } else { set state($ekey,$akey) 0 } } default { set state($ekey,$akey) 1 } } } } } # BuddyPounce::StateToPrefs -- # # Build the internal prefs array from the dialogs state variable. proc ::BuddyPounce::StateToPrefs {token} { variable $token upvar 0 $token state variable budprefs variable budprefsgroup variable budprefsany variable events variable actionlist set eventActions [list] # Build event-action list from state. foreach ekey $events(keys) { set actlist [list] foreach akey $actionlist(keys) { if {$state($ekey,$akey) == 1} { lappend actlist $akey switch -- $akey { sound { # If sound we also need the soundfile. if {[component::exists Sounds]} { lappend actlist soundfile:$state($ekey,soundfile) } } msg { if {$state($ekey,msg,subject) ne ""} { lappend actlist subject:$state($ekey,msg,subject) } set body [$state($ekey,msg,wtext) get 1.0 "end -1 char"] regsub -all "\n" $body {\\n} body if {$body ne ""} { lappend actlist body:$body } } } } } if {[llength $actlist]} { lappend eventActions $ekey $actlist } } if {[llength $eventActions]} { switch -- $state(type) { jid { set jid $state(jid2) set budprefs($jid) $eventActions } group { set group $state(group) set budprefsgroup($group) $eventActions } any { set budprefsany $eventActions } } } else { switch -- $state(type) { jid { set jid $state(jid2) unset -nocomplain budprefs($jid) } group { set group $state(group) unset -nocomplain budprefsgroup($group) } any { set budprefsany {} } } } } proc ::BuddyPounce::AllOff {token} { variable $token upvar 0 $token state variable events variable actionlist set actionlist(keys) {msgbox sound chat msg} foreach ekey $events(keys) { foreach mkey $actionlist(keys) { set state($ekey,$mkey) 0 } set state($ekey,msg,subject) "" $state($ekey,msg,wtext) delete 1.0 end } } proc ::BuddyPounce::OK {token} { variable $token upvar 0 $token state variable budprefs variable wdlg StateToPrefs $token ::UI::SaveWinGeom $wdlg $state(w) destroy $state(w) unset state } proc ::BuddyPounce::Cancel {token} { variable $token upvar 0 $token state variable wdlg ::UI::SaveWinGeom $wdlg $state(w) destroy $state(w) unset state } # BuddyPounce::Event -- # # Handler for any event. # # Arguments: # from 2-tier jid. # eventkey available, unavailable, chat, msg. # # Results: # none. proc ::BuddyPounce::Event {from eventkey args} { variable budprefs variable budprefsgroup variable budprefsany variable alertTitle ::Debug 4 "::BuddyPounce::Event from = $from, eventkey=$eventkey" array set argsA $args set xmldata $argsA(-xmldata) # We must check 'jid', 'group' and 'any' in that order. # A list of actions to perform if any. set actions [list] # First this specific JID. set jid [jlib::jidmap $from] if {[info exists budprefs($jid)]} { array set eventArr $budprefs($jid) if {[info exists eventArr($eventkey)]} { set actions $eventArr($eventkey) } } # Groups. if {[llength $actions] == 0} { set groups [::Jabber::RosterCmd getgroups $jid] foreach group $groups { if {[info exists budprefsgroup($group)]} { array unset eventArr array set eventArr $budprefsgroup($group) if {[info exists eventArr($eventkey)]} { set actions $eventArr($eventkey) } } } } # Any. if {[llength $actions] == 0} { array unset eventArr array set eventArr $budprefsany if {[info exists eventArr($eventkey)]} { set actions $eventArr($eventkey) } } set budpounce [dict create] dict set budpounce available [mc "%s just went online!" $from] dict set budpounce unavailable [mc "%s just went offline!" $from] dict set budpounce msg [mc "%s just sent you a message!" $from] dict set budpounce chat [mc "%s just started a chat session!" $from] foreach action $actions { switch -- $action { msgbox { ui::dialog -message [dict get $budpounce $eventkey] \ -title [mc $alertTitle($eventkey)] } sound { set soundfile [lsearch -inline -glob $actions soundfile:*] set name [string map {soundfile: ""} $soundfile] if {$name ne ""} { PlaySound $name } } chat { # If already have chat. set w [::Chat::GetWindow $jid] if {$w ne ""} { raise $w } else { ::Chat::StartThread $from } } msg { set subject [mc "Auto Reply"] set body "Insert your message!" set subjectopt [lsearch -inline -glob $actions subject:*] if {$subjectopt ne ""} { set subject [string map {subject: ""} $subjectopt] } set bodyopt [lsearch -inline -glob $actions body:*] if {$bodyopt ne ""} { set body [string map {body: ""} $bodyopt] set body [subst -nocommands -novariables $body] } set opts [list] set msgbody [wrapper::getcdata [wrapper::getfirstchildwithtag $xmldata body]] if {$msgbody ne ""} { lappend opts -quotemessage $msgbody } eval {::NewMsg::Build -to $from \ -subject $subject -message $body} $opts } } } } proc ::BuddyPounce::GetAllSounds {} { set all [list] if {[component::exists Sounds]} { set all [::Sounds::GetAllSoundsPresentSet] } if {[llength $all] == 0} { set all [msgcat::mc "None"] } return $all } proc ::BuddyPounce::PlaySound {name} { if {[component::exists Sounds]} { ::Sounds::DoPlayWhenIdle $name } } proc ::BuddyPounce::QuitHook {} { variable wdlg ::UI::SaveWinPrefixGeom $wdlg } proc ::BuddyPounce::LogoutHook {} { variable threadids array unset threadids * } proc ::BuddyPounce::CloseHook {wclose} { variable wdlg ::UI::SaveWinGeom $wdlg $wclose return "" } proc ::BuddyPounce::NewChatMsgHook {xmldata} { variable threadids set from [wrapper::getattribute $xmldata from] set jid2 [jlib::barejid $from] set msgChatState "" # only in case a body is in the chat message, produce a chat # state notificaton, otherwise it would also trigger on chat # state notifications from the other user if {[wrapper::havechildtag $xmldata body]} { # now check whether we already know this thread # since we only want to trigger an event on thread start set threadid [wrapper::getcdata [wrapper::getfirstchildwithtag $xmldata thread]] if { $threadid ne "" } { if {![info exists threadids($threadid)]} { # we haven't seen the thread yet, lets save the ID # and trigger an event set threadids($threadid) $threadid Event $jid2 chat -xmldata $xmldata } } else { Event $jid2 chat -xmldata $xmldata } } } proc ::BuddyPounce::NewMsgHook {xmldata uuid} { set from [wrapper::getattribute $xmldata from] set jid2 [jlib::barejid $from] Event $jid2 msg -xmldata $xmldata } proc ::BuddyPounce::PresenceHook {jid type args} { ::Debug 4 "::BuddyPounce::PresenceHook jid=$jid, type=$type" # The 'wasavailable' roster command returns any previous available status. switch -- $type { available { if {![::Jabber::RosterCmd wasavailable $jid]} { eval {Event $jid $type} $args } } unavailable { if {[::Jabber::RosterCmd wasavailable $jid]} { eval {Event $jid $type} $args } } } } proc ::BuddyPounce::PresenceUnavailableHook {jid type args} { Event $jid unavailable } #------------------------------------------------------------------------------- coccinella-0.96.20/components/Carbon.tcl000066400000000000000000000156051167435367600201120ustar00rootroot00000000000000# Carbon.tcl -- # # Interface for the carbon package. # # Copyright (c) 2007 Mats Bengtsson # # 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 3 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, see . # # $Id: Carbon.tcl,v 1.17 2008-06-09 09:50:59 matben Exp $ # # @@@ Move the sleep stuff to something more generic. namespace eval ::Carbon { if {[tk windowingsystem] ne "aqua"} { return } if {[catch {package require carbon}]} { return } component::define Carbon \ "Provides Mac OS X specific support such as various dock features." # Keep track of number of messages we receive while in the background. variable nHiddenMsgs 0 } proc ::Carbon::Init {} { component::register Carbon ::carbon::sleep add ::Carbon::Sleep # Add event hooks. ::hooks::register newMessageHook [namespace code NewMsgHook] ::hooks::register newChatMessageHook [namespace code NewMsgHook] ::hooks::register newChatThreadHook [namespace code NotifyHook] ::hooks::register newMessageBox [namespace code NotifyHook] ::hooks::register appInFrontHook [namespace code AppInFrontHook] ::hooks::register quitAppHook [namespace code QuitHook] ::hooks::register fileTransferReceiveHook [namespace code NotifyHook] ::hooks::register loginHook [namespace code LoginHook] # Define all hooks for preference settings. ::hooks::register prefsInitHook [namespace code InitPrefsHook] ::hooks::register prefsBuildHook [namespace code BuildPrefsHook] ::hooks::register prefsSaveHook [namespace code SavePrefsHook] ::hooks::register prefsCancelHook [namespace code CancelPrefsHook] ::hooks::register prefsUserDefaultsHook [namespace code UserDefaultsHook] variable wasSleepLoggedOut 0 } proc ::Carbon::LoginHook {} { variable wasSleepLoggedOut set wasSleepLoggedOut 0 } proc ::Carbon::NewMsgHook {xmldata args} { variable nHiddenMsgs set body [wrapper::getcdata [wrapper::getfirstchildwithtag $xmldata body]] if {($body ne {}) && ![::UI::IsAppInFront]} { incr nHiddenMsgs ::carbon::dock overlay -text $nHiddenMsgs Bounce } } proc ::Carbon::NotifyHook {args} { # Notify only if in background. if {![::UI::IsAppInFront]} { Bounce } } proc ::Carbon::Bounce {} { after idle { ::carbon::dock bounce 1 } } proc ::Carbon::AppInFrontHook {} { variable nHiddenMsgs set nHiddenMsgs 0 ::carbon::dock overlay -text "" } proc ::Carbon::QuitHook {} { ::carbon::dock overlay -text "" } proc ::Carbon::Sleep {type} { global jprefs variable wasSleepLoggedOut switch -- $type { sleep - willsleep { if {[::Jabber::IsConnected]} { set wasSleepLoggedOut 1 #::Jabber::DoCloseClientConnection ::Jabber::SetStatus unavailable -status $jprefs(sleeploutmsg) } } wakeup { if {$wasSleepLoggedOut && $jprefs(sleeplogin)} { if {![::Jabber::IsConnected]} { # We must give the system (WiFi) some time to setup the # network before loggin in. Some kind of trying multiple # times would be better... after 8000 ::Login::LoginCmd } } } } } proc ::Carbon::InitPrefsHook {} { global jprefs set jprefs(sleeplogout) 0 set jprefs(sleeplogin) 0 set jprefs(sleeploutmsg) "" ::PrefUtils::Add [list \ [list jprefs(sleeplogout) jprefs_sleeplogout $jprefs(sleeplogout)] \ [list jprefs(sleeplogin) jprefs_sleeplogin $jprefs(sleeplogin)] \ [list jprefs(sleeploutmsg) jprefs_sleeploutmsg $jprefs(sleeploutmsg)] \ ] variable allKeys {sleeplogout sleeplogin sleeploutmsg} } proc ::Carbon::BuildPrefsHook {wtree nbframe} { # TRANSLATORS: automatic logout when computer is put in sleep mode and relogin on wakeup; in preferences dialog (Mac OS X only!) ::Preferences::NewTableItem {Jabber Sleep} [mc "Sleep"] set wpage [$nbframe page Sleep] BuildPage $wpage bind $nbframe +::Carbon::DestroyPrefsHook } proc ::Carbon::BuildPage {page} { global jprefs variable tmp variable allKeys foreach key $allKeys { set tmp($key) $jprefs($key) } set wc $page.c ttk::frame $wc -padding [option get . notebookPageSmallPadding {}] pack $wc -side top -anchor [option get . dialogAnchor {}] ttk::frame $wc.head -padding {0 0 0 6} ttk::label $wc.head.l -text [mc "Sleep"] ttk::separator $wc.head.s -orient horizontal grid $wc.head.l $wc.head.s grid $wc.head.s -sticky ew grid columnconfigure $wc.head 1 -weight 1 pack $wc.head -side top -fill x set ws $wc.sleep ttk::frame $ws set varName [namespace current]::tmp(sleeplogout) ttk::checkbutton $ws.clout -text [mc "Logout on sleep"]: -variable $varName \ -command [namespace code [list SetEntryState [list $ws.emsg $ws.clin] $varName]] ttk::label $ws.lmsg -text [mc "Message"]: ttk::entry $ws.emsg -font CociSmallFont -width 32 \ -textvariable [namespace current]::tmp(sleeploutmsg) ttk::checkbutton $ws.clin -text [mc "Relogin on wakeup"] \ -variable [namespace current]::tmp(sleeplogin) SetEntryState [list $ws.emsg $ws.clin] $varName grid $ws.clout - $ws.emsg grid x $ws.clin - grid $ws.clout -sticky w grid $ws.clin -sticky w grid $ws.emsg -sticky ew grid columnconfigure $ws 0 -minsize 32 grid columnconfigure $ws 1 -weight 1 grid columnconfigure $ws 2 -weight 1 pack $ws -side top -fill x } proc ::Carbon::SetEntryState {winL varName} { upvar #0 $varName var if {$var} { foreach w $winL { $w state {!disabled} } } else { foreach w $winL { $w state {disabled} } } } proc ::Carbon::SavePrefsHook {} { global jprefs variable tmp array set jprefs [array get tmp] } proc ::Carbon::CancelPrefsHook {} { global jprefs variable tmp foreach key [array names tmp] { if {![string equal $jprefs($key) $tmp($key)]} { ::Preferences::HasChanged return } } } proc ::Carbon::UserDefaultsHook {} { global jprefs variable tmp foreach key [array names tmp] { set tmp($key) $jprefs($key) } } proc ::Carbon::DestroyPrefsHook {} { variable tmp unset -nocomplain tmp } #------------------------------------------------------------------------------- coccinella-0.96.20/components/ChatShorts.tcl000066400000000000000000000033631167435367600207660ustar00rootroot00000000000000# ChatShorts.tcl -- # # This file is part of The Coccinella application. # It implements some shortcut commands for chats. # # Copyright (c) 2007 Mats Bengtsson # # 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 3 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, see . # # $Id: ChatShorts.tcl,v 1.2 2007-11-17 07:40:52 matben Exp $ namespace eval ::ChatShorts { component::define ChatShorts \ "Implements /clean, /retain commands for chats." } proc ::ChatShorts::Init {} { component::register ChatShorts # Add event hooks. ::hooks::register sendTextChatHook [namespace code ChatTextHook] ::hooks::register sendTextGroupChatHook [namespace code TextGroupChatHook] } proc ::ChatShorts::ChatTextHook {chattoken jid str} { if {[regexp {^ */clean$} $str]} { set wtext [::Chat::GetChatTokenValue $chattoken wtext] puts "wtext=$wtext" $wtext tag configure telide -elide 1 $wtext tag add telide 1.0 end return stop } elseif {[regexp {^ */retain$} $str]} { set wtext [::Chat::GetChatTokenValue $chattoken wtext] $wtext tag delete telide return stop } return } proc ::ChatShorts::TextGroupChatHook {roomjid str} { } coccinella-0.96.20/components/ComponentExample.tcl000066400000000000000000000026011167435367600221540ustar00rootroot00000000000000# ComponentExample.tcl -- # # Demo of some of the functionality for components. # This is just a first sketch. namespace eval ::ComponentExample { component::define ComponentExample \ "This is justa dummy example of the component mechanism." } proc ::ComponentExample::Init { } { ::Debug 2 "::ComponentExample::Init" set menuspec { command {More Junk...} ::ComponentExample::Cmd {} {} } set mDef [list command "Plugin Junk" [namespace current]::Cmd] set mType {"Plugin Junk" user} ::WB::RegisterNewMenu junk "Mats Junk" $menuspec ::WB::RegisterMenuEntry file $menuspec ::JUI::RegisterMenuEntry action $menuspec ::JUI::RegisterMenuEntry file $menuspec ::Roster::RegisterPopupEntry $mDef $mType ::hooks::register jabberInitHook ::ComponentExample::JabberInitHook component::register ComponentExample } proc ::ComponentExample::JabberInitHook {jlibname} { set xmlnsj "http://jabber.org/protocol/jingle" set subtags [list [wrapper::createtag "feature" \ -attrlist [list var $xmlnsj]]] $jlibname caps register jingle $subtags $xmlnsj } proc ::ComponentExample::Cmd { } { tk_messageBox -type yesno -icon info -title "Component Example" \ -message "Hi, do you expect more fun than this?" } #------------------------------------------------------------------------------- coccinella-0.96.20/components/GMeeting.tcl000066400000000000000000000070431167435367600204020ustar00rootroot00000000000000# GMeeting.tcl -- # # Interface for launching Gnome Meeting. # # Copyright (c) 2007 Mats Bengtsson # # 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 3 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, see . # # $Id: GMeeting.tcl,v 1.17 2007-11-17 07:40:52 matben Exp $ namespace eval ::GMeeting { if {![string equal $::this(platform) "unix"]} { return } set cmd [lindex [auto_execok gnomemeeting] 0] if {$cmd == {}} { return } component::define GnomeMeeting \ "Provides a method to launch Gnome Meeting" } proc ::GMeeting::Init { } { global this ::Debug 2 "::GMeeting::Init" if {![string equal $this(platform) "unix"]} { return } set cmd [lindex [auto_execok gnomemeeting] 0] if {$cmd == {}} { return } set mDef [list command "Gnome Meeting..." {::GMeeting::RosterCmd $jid3}] set mType {"Gnome Meeting..." user} ::Roster::RegisterPopupEntry $mDef $mType ::hooks::register jabberInitHook ::GMeeting::JabberInitHook component::register GnomeMeeting } proc ::GMeeting::JabberInitHook {jlibname} { array set xmlns { h323 "http://jabber.org/protocol/voip/h323" sip "http://jabber.org/protocol/voip/sip" callto "http://jabber.org/protocol/voip/callto" } # Need to create all elements when responding to a disco info # request to the specified node. foreach uri {h323 sip callto} name {"VoIP H323" "VoIP SIP" "VoIP callto"} { set subtags($uri) [list [wrapper::createtag "identity" -attrlist \ [list category hierarchy type leaf name $name]]] lappend subtags($uri) [wrapper::createtag "feature" \ -attrlist [list var "http://jabber.org/protocol/voip/$uri"]] } $jlibname caps register voip_h323 $subtags(h323) $xmlns(h323) $jlibname caps register voip_sip $subtags(sip) $xmlns(sip) $jlibname caps register voipgm2 $subtags(callto) $xmlns(callto) } proc ::GMeeting::MenuCmd {args} { puts "::GMeeting::MenuCmd args=$args" } proc ::GMeeting::RosterCmd {jid} { ::Debug 2 "::GMeeting::RosterCmd jid=$jid" if {![HasSupport $jid]} { tk_messageBox -type ok -icon error -title Error \ -message "The user \"$jid\" has no support for H323 or SIP" return } set cmd [lindex [auto_execok gnomemeeting] 0] set ip [::Disco::GetCoccinellaIP $jid] if {$ip eq ""} { tk_messageBox -type ok -icon error -title Error \ -message "We failed to identify any ip address for \"$jid\"" return } set uri h323:${ip} if {[catch {exec $cmd -c $uri &} err]} { tk_messageBox -type ok -icon error -title Error \ -message "We failed to launch Gnome Meeting: $err" } } proc ::GMeeting::HasSupport {jid} { set ans 0 set extList [::Jabber::RosterCmd getcapsattr $jid ext] if {$extList != {}} { if {[lsearch $extList voip_h323] >= 0} { set ans 1 } elseif {[lsearch $extList voip_sip] >= 0} { set ans 1 } } return $ans } #------------------------------------------------------------------------------- coccinella-0.96.20/components/Geolocation.tcl000066400000000000000000000324071167435367600211500ustar00rootroot00000000000000# Geolocation.tcl -- # # User location using XEP recommendations over PubSub library code. # XEP-0080: User Location (formerly User Geolocation) # # Copyright (c) 2007-2008 Mats Bengtsson # # 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 3 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, see . # # $Id: Geolocation.tcl,v 1.17 2008-06-11 08:12:05 matben Exp $ package require jlib::pep namespace eval ::Geolocation { component::define Geolocation \ "Communicate information about the current geographical location" } proc ::Geolocation::Init {} { component::register Geolocation # Add event hooks. ::hooks::register jabberInitHook ::Geolocation::JabberInitHook ::hooks::register loginHook ::Geolocation::LoginHook ::hooks::register logoutHook ::Geolocation::LogoutHook ::hooks::register buildUserInfoDlgHook ::Geolocation::UserInfoHook variable xmlns set xmlns(geoloc) "http://jabber.org/protocol/geoloc" set xmlns(geoloc+notify) "http://jabber.org/protocol/geoloc+notify" set xmlns(node_config) "http://jabber.org/protocol/pubsub#node_config" variable menuDef # TRANSLATORS: geographical location of the user ( http://xmpp.org/extensions/xep-0080.html#format ); see Action menu when logged in to a server with PEP support set menuDef [list command mLocation... {[mc "Locat&ion"]...} ::Geolocation::Dlg {} {}] # These help strings are for the message catalogs. variable help set help(alt) [mc "Altitude in meters above or below sea level"] set help(area) [mc "A named area such as a campus or neighborhood"] set help(bearing) [mc "GPS bearing (direction in which the entity is heading to reach its next waypoint), measured in decimal degrees relative to true north"] set help(building) [mc "A specific building on a street or in an area"] set help(country) [mc "The nation where the user is located"] set help(datum) [mc "GPS datum"] set help(description) [mc "A natural-language name for or description of the location"] set help(error) [mc "Horizontal GPS error in arc minutes"] set help(floor) [mc "A particular floor in a building"] set help(lat) [mc "Latitude in decimal degrees North"] set help(locality) [mc "A locality within the administrative region, such as a town or city"] set help(lon) [mc "Longitude in decimal degrees East"] set help(postalcode) [mc "A code used for postal delivery"] set help(region) [mc "An administrative region of the nation, such as a state or province"] set help(room) [mc "A particular room in a building"] set help(street) [mc "A thoroughfare within the locality, or a crossing of two thoroughfares"] set help(text) [mc "A catch-all element that captures any other information about the location"] set help(timestamp) [mc "UTC timestamp specifying the moment when the reading was taken"] variable taglabel set taglabel(alt) [mc "Altitude"] set taglabel(area) [mc "Named Area"] set taglabel(bearing) [mc "GPS Bearing"] set taglabel(building) [mc "Building"] set taglabel(country) [mc "Country"] set taglabel(datum) [mc "GPS Datum"] set taglabel(description) [mc "Description"] set taglabel(error) [mc "GPS Error"] set taglabel(floor) [mc "Floor"] set taglabel(lat) [mc "Latitude"] set taglabel(locality) [mc "Locality"] set taglabel(lon) [mc "Longitude"] set taglabel(postalcode) [mc "Postal code"] set taglabel(region) [mc "Region"] set taglabel(room) [mc "Room"] set taglabel(street) [mc "Street"] set taglabel(text) [mc "Text"] set taglabel(timestamp) [mc "Timestamp"] # string is the default if not defined. variable xs array set xs { alt decimal bearing decimal error decimal lat decimal lon decimal timestamp datetime } # This is our cache for other users geoloc. variable geoloc ui::dialog button remove -text [mc "Remove"] } # Geolocation::JabberInitHook -- # # Here we announce that we have Geolocation support and is interested in # getting notifications. proc ::Geolocation::JabberInitHook {jlibname} { variable xmlns set E [list] lappend E [wrapper::createtag "identity" \ -attrlist [list category hierarchy type leaf name "Geolocation"]] lappend E [wrapper::createtag "feature" \ -attrlist [list var $xmlns(geoloc)]] lappend E [wrapper::createtag "feature" \ -attrlist [list var $xmlns(geoloc+notify)]] $jlibname caps register geoloc $E [list $xmlns(geoloc) $xmlns(geoloc+notify)] } proc ::Geolocation::LoginHook {} { variable xmlns # Disco server for pubsub/pep support. set server [::Jabber::Jlib getserver] ::Jabber::Jlib pep have $server [namespace code HavePEP] ::Jabber::Jlib pubsub register_event [namespace code Event] \ -node $xmlns(geoloc) } proc ::Geolocation::HavePEP {jlibname have} { variable menuDef if {$have} { ::JUI::RegisterMenuEntry action $menuDef } } proc ::Geolocation::LogoutHook {} { variable state ::JUI::DeRegisterMenuEntry action mLocation... unset -nocomplain state } proc ::Geolocation::Dlg {} { variable xmlns variable gearth 0 variable help variable taglabel set w [ui::dialog -message [mc "Set your location that will be shown to your contacts."] \ -detail [mc "Enter your location details below. At least you should set latitude and longitude."] -icon worldmap \ -buttons {ok cancel remove} -modal 1 \ -geovariable ::prefs(winGeom,geoloc) \ -title [mc "Location"] -command [namespace code DlgCmd]] set fr [$w clientframe] # State array variable. variable $w upvar 0 $w state set token [namespace current]::$w foreach name { alt country lat lon } { set str $taglabel($name) ttk::label $fr.l$name -text ${str}: ttk::entry $fr.e$name -textvariable $token\($name) grid $fr.l$name $fr.e$name -sticky e -pady 2 grid $fr.e$name -sticky ew set str $help($name) ::balloonhelp::balloonforwindow $fr.l$name $str ::balloonhelp::balloonforwindow $fr.e$name $str } ttk::button $fr.www -style Url -text www.mapquest.com \ -command [namespace code [list LaunchUrl $w]] grid x $fr.www -sticky w ttk::checkbutton $fr.gearth -style Small.TCheckbutton \ -variable [namespace current]::gearth \ -text [mc "Synchronize with Google Earth"] $fr.gearth state {disabled} grid $fr.gearth - -sticky w grid columnconfigure $fr 1 -weight 1 # Have some validation. foreach name [list alt lat lon] { $fr.e$name configure -validate key \ -validatecommand [namespace code [list ValidateF %d %P]] } trace add variable $token\(lat) write [namespace code [list Trace $w]] trace add variable $token\(lon) write [namespace code [list Trace $w]] set state(lat) "" set state(lon) "" # Get our own published geolocation and fill in. set myjid2 [::Jabber::Jlib myjid2] set cb [namespace code [list ItemsCB $w]] ::Jabber::Jlib pubsub items $myjid2 $xmlns(geoloc) -command $cb bind $fr.ealt { focus %W } set mbar [::JUI::GetMainMenu] ui::dialog defaultmenu $mbar ::UI::MenubarDisableBut $mbar edit $w grab ::UI::MenubarEnableAll $mbar } proc ::Geolocation::Trace {w name1 name2 op} { variable $w upvar 0 $w state set fr [$w clientframe] if {($state(lat) ne "") && ($state(lon) ne "")} { $fr.www state {!disabled} } else { $fr.www state {disabled} } } proc ::Geolocation::LaunchUrl {w} { variable $w upvar 0 $w state set lat $state(lat) set lon $state(lon) set url "http://www.mapquest.com/maps/map.adp?latlongtype=decimal&latitude=${lat}&longitude=${lon}" ::Utils::OpenURLInBrowser $url } proc ::Geolocation::ValidateF {insert P} { if {$insert} { set valid [string is double -strict $P] if {!$valid} { bell } return $valid } else { return 1 } } proc ::Geolocation::ItemsCB {w type subiq args} { variable $w upvar 0 $w state variable xmlns if {$type eq "error"} { return } # Fill in the form. if {[winfo exists $w]} { foreach itemsE [wrapper::getchildren $subiq] { set tag [wrapper::gettag $itemsE] set node [wrapper::getattribute $itemsE "node"] if {[string equal $tag "items"] && [string equal $node $xmlns(geoloc)]} { set itemE [wrapper::getfirstchildwithtag $itemsE item] set geolocE [wrapper::getfirstchildwithtag $itemE geoloc] if {![llength $geolocE]} { return } foreach E [wrapper::getchildren $geolocE] { set tag [wrapper::gettag $E] set data [wrapper::getcdata $E] if {[string length $data]} { set state($tag) $data } } } } } } proc ::Geolocation::DlgCmd {w bt} { variable $w upvar 0 $w state variable xmlns if {$bt eq "ok"} { Publish $w } elseif {$bt eq "remove"} { Retract $w } unset -nocomplain state } proc ::Geolocation::Publish {w} { variable $w upvar 0 $w state variable xmlns # Create gelocation stanza before publish. set childL [list] foreach {key value} [array get state] { if {[string length $value]} { lappend childL [wrapper::createtag $key -chdata $value] } } set geolocE [wrapper::createtag "geoloc" \ -attrlist [list xml:lang [jlib::getlang]] -subtags $childL] # NB: It is currently unclear there should be an id attribute in the item # element since PEP doesn't use it but pubsub do, and the experimental # OpenFire PEP implementation. #set itemE [wrapper::createtag item -subtags [list $geolocE]] set itemE [wrapper::createtag item \ -attrlist [list id current] -subtags [list $geolocE]] ::Jabber::Jlib pep publish $xmlns(geoloc) $itemE } proc ::Geolocation::Retract {w} { variable xmlns ::Jabber::Jlib pep retract $xmlns(geoloc) -notify 1 } # Geolocation::Event -- # # Mood event handler for incoming geoloc messages. proc ::Geolocation::Event {jlibname xmldata} { variable geoloc # The server MUST set the 'from' address on the notification to the # bare JID () of the account owner. set from [wrapper::getattribute $xmldata from] set from [jlib::jidmap $from] set geoloc($from) $xmldata ::hooks::run geolocEvent $xmldata } proc ::Geolocation::UserInfoHook {jid wnb} { variable xmlns variable geoloc variable help variable taglabel set mjid [jlib::jidmap [jlib::barejid $jid]] if {![info exists geoloc($mjid)]} { return } if ([winfo exists $wnb.geo]) { return } $wnb add [ttk::frame $wnb.geo] -text [mc "Location"] -sticky news set wpage $wnb.geo.f ttk::frame $wpage -padding [option get . notebookPagePadding {}] pack $wpage -side top -anchor [option get . dialogAnchor {}] ttk::label $wpage._lbl -text [mc "This is location data for %s" $jid] grid $wpage._lbl - -pady 2 ttk::button $wpage.mapquest -style Url -text www.mapquest.com grid $wpage.mapquest - -pady 2 $wpage.mapquest state {disabled} # Extract all geoloc data we have cached and write an entry for each. set xmldata $geoloc($mjid) set eventE [wrapper::getfirstchildwithtag $xmldata event] if {[llength $eventE]} { foreach itemsE [wrapper::getchildren $eventE] { set tag [wrapper::gettag $itemsE] set node [wrapper::getattribute $itemsE "node"] if {[string equal $tag "items"] && [string equal $node $xmlns(geoloc)]} { set itemE [wrapper::getfirstchildwithtag $itemsE item] set geolocE [wrapper::getfirstchildwithtag $itemE geoloc] if {![llength $geolocE]} { return } foreach E [wrapper::getchildren $geolocE] { set tag [wrapper::gettag $E] set data [wrapper::getcdata $E] set state($tag) $data if {[string length $data]} { set str $taglabel($tag) ttk::label $wpage.l$tag -text ${str}: ttk::label $wpage.e$tag -text $data grid $wpage.l$tag $wpage.e$tag -pady 2 grid $wpage.l$tag -sticky e grid $wpage.e$tag -sticky w set bstr $help($tag) ::balloonhelp::balloonforwindow $wpage.l$tag $bstr ::balloonhelp::balloonforwindow $wpage.e$tag $bstr } } } } } if {[info exists state(lat)] && [info exists state(lon)]} { $wpage.mapquest state {!disabled} set url "http://www.mapquest.com/maps/map.adp?latlongtype=decimal&latitude=$state(lat)&longitude=$state(lon)" $wpage.mapquest configure -command [list ::Utils::OpenURLInBrowser $url] } } coccinella-0.96.20/components/Growl.tcl000066400000000000000000000220261167435367600177730ustar00rootroot00000000000000# Growl.tcl -- # # Growl notifier bindings for MacOSX. # This is just a first sketch. # # Copyright (c) 2007 Mats Bengtsson and Antonio Camas # # 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 3 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, see . # # $Id: Growl.tcl,v 1.32 2008-06-06 13:10:10 matben Exp $ namespace eval ::Growl { if {[tk windowingsystem] ne "aqua"} { return } if {[catch {package require growl}]} { return } component::define Growl \ "Provides support for Growl notifier on Mac OS X." # TODO #option add *growlImage send widgetDefault } proc ::Growl::Init {} { global this variable cociFile component::register Growl # There are some nice 64x64 error & info icons as well. set cociFile [::Theme::FindExactIconFile icons/128x128/coccinella.png] # Use translated strings as keys, else Growls settings wont be translatable. set all {"Message" "Status" "File" "Phone" "Mood"} growl register Coccinella [lapply mc $all] $cociFile # Add event hooks. ::hooks::register newMessageHook ::Growl::MessageHook ::hooks::register newChatMessageHook ::Growl::ChatMessageHook ::hooks::register presenceNewHook ::Growl::PresenceHook ::hooks::register jivePhoneEvent ::Growl::JivePhoneEventHook ::hooks::register fileTransferReceiveHook ::Growl::FileTransferRecvHook ::hooks::register moodEvent ::Growl::MoodEventHook } proc ::Growl::MessageHook {xmldata uuid} { variable cociFile set body [wrapper::getcdata [wrapper::getfirstchildwithtag $xmldata body]] if {$body eq ""} { return } set jid [wrapper::getattribute $xmldata from] set jid2 [jlib::barejid $jid] set ujid [jlib::unescapejid $jid2] set title [mc "Message"] append title ": $ujid" set subject [wrapper::getcdata [wrapper::getfirstchildwithtag $xmldata subject]] growl post [mc "Message"] $title $subject $cociFile } proc ::Growl::ChatMessageHook {xmldata} { variable cociFile set body [wrapper::getcdata [wrapper::getfirstchildwithtag $xmldata body]] if {$body eq ""} { return } # -from is a 3-tier jid /resource included. set jid [wrapper::getattribute $xmldata from] set jid2 [jlib::barejid $jid] set ujid [jlib::unescapejid $jid2] if {[::Chat::HaveChat $jid]} { return } set title [mc "Message"] append title ": $ujid" # Not sure if only new subjects should be added. # If we've got a threadid we can always geta a handle on to # the internal chat state with: # set chattoken [::Chat::GetTokenFrom chat threadid $threadID] # parray chattoken set subject [wrapper::getcdata [wrapper::getfirstchildwithtag $xmldata subject]] if {$subject ne ""} { append title "\n$subject" } growl post [mc "Message"] $title $body $cociFile } proc ::Growl::PresenceHook {jid type args} { variable cociFile # Notify only if in background. if {![::UI::IsAppInFront]} { array set argsA $args set xmldata $argsA(-xmldata) set from [wrapper::getattribute $xmldata from] set jid $from # Skip transports since they are us. if {[::Roster::IsTransportHeuristics $jid]} { return } # Skip myself. set myjid2 [::Jabber::Jlib myjid2] if {[jlib::jidequal $myjid2 [jlib::barejid $jid]]} { return } # If we have a 'delay' this is presence sent when we login. set delay [::Jabber::RosterCmd getx $jid "jabber:x:delay"] if {$delay ne ""} { return } if {![::Jabber::Jlib roster anychange $jid {type show status}]} { return } set show $type if {[info exists argsA(-show)]} { set show $argsA(-show) } set status "" if {[info exists argsA(-status)]} { set status $argsA(-status) } # This just translates the show code into a readable text. set showMsg [::Roster::MapShowToText $show] set djid [::Roster::GetDisplayName $jid] if {[::Jabber::Jlib service isroom $jid]} { if {[info exists argsA(-from)]} { set djid $argsA(-from) } } set title $djid set msg $showMsg if {$status ne ""} { append msg "\n$status" } growl post [mc "Status"] $title $msg $cociFile } } proc ::Growl::FileTransferRecvHook {jid name size} { variable cociFile if {![::UI::IsAppInFront]} { set title [mc "Receive File"] set str "\n" append str [mc "File"] append str ": $name\n" append str [mc "Size"] append str ": [::Utils::FormatBytes $size]\n\n" set ujid [jlib::unescapejid $jid] set msg [mc "%s wants to send you this file: %s Do you want to receive this file?" $ujid $str] growl post [mc "File"] $title $msg $cociFile } } proc ::Growl::JivePhoneEventHook {type cid callID {xmldata {}}} { variable cociFile if {$type eq "RING"} { set title [mc "Ring, ring"]... set msg [mc "Phone is ringing from %s" $cid] growl post [mc "Phone"] $title $msg $cociFile } } proc ::Growl::MoodEventHook {xmldata mood text} { variable cociFile variable moodTextSmall set moodTextSmall [dict create] dict set moodTextSmall afraid [mc "afraid"] dict set moodTextSmall amazed [mc "amazed"] dict set moodTextSmall angry [mc "angry"] dict set moodTextSmall annoyed [mc "annoyed"] dict set moodTextSmall anxious [mc "anxious"] dict set moodTextSmall aroused [mc "aroused"] dict set moodTextSmall ashamed [mc "ashamed"] dict set moodTextSmall bored [mc "bored"] dict set moodTextSmall brave [mc "brave"] dict set moodTextSmall calm [mc "calm"] dict set moodTextSmall cold [mc "cold"] dict set moodTextSmall confused [mc "confused"] dict set moodTextSmall contented [mc "contented"] dict set moodTextSmall cranky [mc "cranky"] dict set moodTextSmall curious [mc "curious"] dict set moodTextSmall depressed [mc "depressed"] dict set moodTextSmall disappointed [mc "disappointed"] dict set moodTextSmall disgusted [mc "disgusted"] dict set moodTextSmall distracted [mc "distracted"] dict set moodTextSmall embarrassed [mc "embarrassed"] dict set moodTextSmall excited [mc "excited"] dict set moodTextSmall flirtatious [mc "flirtatious"] dict set moodTextSmall frustrated [mc "frustrated"] dict set moodTextSmall grumpy [mc "grumpy"] dict set moodTextSmall guilty [mc "guilty"] dict set moodTextSmall happy [mc "happy"] dict set moodTextSmall hot [mc "hot"] dict set moodTextSmall humbled [mc "humbled"] dict set moodTextSmall humiliated [mc "humiliated"] dict set moodTextSmall hungry [mc "hungry"] dict set moodTextSmall hurt [mc "hurt"] dict set moodTextSmall impressed [mc "impressed"] dict set moodTextSmall in_awe [mc "in awe"] dict set moodTextSmall in_love [mc "in love"] dict set moodTextSmall indignant [mc "indignant"] dict set moodTextSmall interested [mc "interested"] dict set moodTextSmall intoxicated [mc "intoxicated"] dict set moodTextSmall invincible [mc "invincible"] dict set moodTextSmall jealous [mc "jealous"] dict set moodTextSmall lonely [mc "lonely"] dict set moodTextSmall mean [mc "mean"] dict set moodTextSmall moody [mc "moody"] dict set moodTextSmall nervous [mc "nervous"] dict set moodTextSmall neutral [mc "neutral"] dict set moodTextSmall offended [mc "offended"] dict set moodTextSmall playful [mc "playful"] dict set moodTextSmall proud [mc "proud"] dict set moodTextSmall relieved [mc "relieved"] dict set moodTextSmall remorseful [mc "remorseful"] dict set moodTextSmall restless [mc "restless"] dict set moodTextSmall sad [mc "sad"] dict set moodTextSmall sarcastic [mc "sarcastic"] dict set moodTextSmall serious [mc "serious"] dict set moodTextSmall shocked [mc "shocked"] dict set moodTextSmall shy [mc "shy"] dict set moodTextSmall sick [mc "sick"] dict set moodTextSmall sleepy [mc "sleepy"] dict set moodTextSmall stressed [mc "stressed"] dict set moodTextSmall surprised [mc "surprised"] dict set moodTextSmall thirsty [mc "thirsty"] dict set moodTextSmall worried [mc "worried"] set title [mc "Mood change"] set from [wrapper::getattribute $xmldata from] set ujid [jlib::unescapejid $from] if {$mood ne ""} { set msg "$ujid " append msg [mc "is"] append msg " " append msg [dict get $moodTextSmall $mood] if {$text ne ""} { append msg " " [mc "because"] " " $text } } else { set msg "$ujid " [mc "retracted mood"] } growl post [mc "Mood"] $title $msg $cociFile } #------------------------------------------------------------------------------- coccinella-0.96.20/components/ICQ.tcl000066400000000000000000000061411167435367600173150ustar00rootroot00000000000000# ICQ.tcl -- # # Provides some specific ICQ handling elements. # # Copyright (c) 2007 Mats Bengtsson # # 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 3 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, see . # # $Id: ICQ.tcl,v 1.18 2007-12-20 14:01:25 matben Exp $ namespace eval ::ICQ { component::define ICQ "Use ICQ nickname in roster" } proc ::ICQ::Init { } { global this ::Debug 2 "::ICQ::Init" # Add all hooks we need. ::hooks::register discoInfoGatewayIcqHook ::ICQ::DiscoInfoHook ::hooks::register logoutHook ::ICQ::LogoutHook component::register ICQ # Cache for vCard nickname. variable vcardnick } proc ::ICQ::DiscoInfoHook {type from subiq args} { InvestigateRoster } proc ::ICQ::InvestigateRoster { } { variable vcardnick set server [::Jabber::GetServerJid] set icqHosts [::Jabber::Jlib disco getjidsforcategory "gateway/icq"] ::Debug 4 "::ICQ::InvestigateRoster icqHosts=$icqHosts" # We must loop through all roster items to search for ICQ users. foreach jid [::Jabber::RosterCmd getusers] { set mjid [jlib::jidmap $jid] jlib::splitjidex $mjid node host res # Not a user. if {$node eq ""} { continue } # Allready got it. if {[info exists vcardnick($mjid)]} { continue } # Exclude jid's that belong to our login jabber server. if {[string equal $server $host]} { continue } if {[lsearch -exact $icqHosts $host] >= 0} { set name [::Jabber::RosterCmd getname $mjid] if {$name eq ""} { # Get vCard ::Jabber::Jlib vcard send_get $jid \ [list [namespace current]::VCardGetCB $jid] } } } } proc ::ICQ::VCardGetCB {from jlibName type subiq} { variable vcardnick ::Debug 4 "::ICQ::VCardGetCB from=$from, type=$type" if {$type eq "error"} { ::Jabber::AddErrorLog $from "Failed getting vCard: [lindex $subiq 1]" } else { set name [::Jabber::RosterCmd getname $from] # Do not override any previous roster name (?) if {$name eq ""} { # Find any NICKNAME element. set nickElem [wrapper::getfirstchildwithtag $subiq "NICKNAME"] set nick [wrapper::getcdata $nickElem] set vcardnick($from) $name jlib::splitjid $from jid2 res ::Jabber::Jlib roster send_set $jid2 -name $nick } } } proc ::ICQ::RosterSetCB {args} { # puts "++++++++args='$args'" } proc ::ICQ::LogoutHook { } { variable vcardnick # Cleanup. unset -nocomplain vcardnick } #------------------------------------------------------------------------------- coccinella-0.96.20/components/IRCActions.tcl000066400000000000000000000175011167435367600206410ustar00rootroot00000000000000# IRCActions.tcl --- # # This file is part of The Coccinella application. # It implements IRC style actions for groupchats. # Nick name completion and nick alerts are also included. # # Copyright (c) 2007 Mats Bengtsson # # 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 3 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, see . # # @@@ TODO: 1) Not sure how to handle /msg # 2) Configurable nick alert # 3) Implement -command for error notice # # $Id: IRCActions.tcl,v 1.10 2008-01-30 13:15:49 matben Exp $ namespace eval ::IRCActions { component::define IRCActions \ "IRC style actions for chatrooms: /join. /topic, /invite, /nick, /me, amongst others" option add *parseMeCDataOpts {-foreground blue} widgetDefault option add *parseNickCDataOpts {-foreground blue} widgetDefault } proc ::IRCActions::Init {} { component::register IRCActions # Add event hooks. ::hooks::register sendTextGroupChatHook [namespace current]::TextGroupChatHook ::hooks::register buildGroupChatWidget [namespace current]::BuildGroupChatHook ::hooks::register textParseWordHook [namespace current]::ParseWordHook ::hooks::register displayGroupChatMessageHook [namespace current]::DisplayHook # /join #channel -> Enter into a room called channel, if it not exists # then creates a new one. #/me text -> The /me command (implemented) #/msg nick Message -> Start a private chat with nick and sending the Message #/nick newNick -> Changes our nick (for all rooms) #/topic String -> Changes the topic of the channel #/invite nick #channel -> Sends an invitation to nick for enter into channel # /kick #channel nickname -> Kicks nickname off a given channel. # /leave -> exit room # /part -> exit room variable RE set RE(join) { {^ */join ([^ ]+)} {::IRCActions::Join} } set RE(nick) { {^ */nick (.+)$} {::IRCActions::Nick} } set RE(msg) { {^ */msg (.+)$} {::IRCActions::Msg} } set RE(topic) { {^ */topic (.+)$} {::IRCActions::Topic} } set RE(subject) { {^ */subject (.+)$} {::IRCActions::Topic} } set RE(invite) { {^ */invite (.+)$} {::IRCActions::Invite} } set RE(kick) { {^ */kick (.+)$} {::IRCActions::Kick} } set RE(leave) { {^ */leave} {::IRCActions::Leave} } set RE(part) { {^ */part} {::IRCActions::Leave} } variable lastWord "" } proc ::IRCActions::TextGroupChatHook {roomjid str} { variable RE # Avoid expensive regexp's. if {[string index [string trimleft $str] 0] ne "/"} { return } set handled "" foreach {name spec} [array get RE] { lassign $spec re cmd if {[regexp $re $str - value]} { $cmd $roomjid $value set handled stop break } } return $handled } proc ::IRCActions::Join {roomjid room} { # Skip any IRC style channel name. set room [string trimleft $room "#"] jlib::splitjidex $roomjid node domain res set joinJID $room if {[string first "@" $room] < 0} { set joinJID ${room}@${domain} } set nick [::Jabber::Jlib muc mynick $roomjid] ::Enter::EnterRoom $joinJID $nick -command [namespace code ErrorJoin] } proc ::IRCActions::ErrorJoin {type args} { # TODO } proc ::IRCActions::Nick {roomjid nick} { # Do this for all rooms we participate? ::Jabber::Jlib muc setnick $roomjid $nick \ -command [namespace code ErrorNick] } proc ::IRCActions::ErrorNick {jlibname xmldata} { # TODO } proc ::IRCActions::Msg {roomjid value} { if {$value eq ""} { return } set nick [lindex $value 0] set msg [lrange $value 1 end] set jid $roomjid/$nick ::Chat::StartThread $jid -message $msg } proc ::IRCActions::Topic {roomjid subject} { ::Jabber::Jlib send_message $roomjid -type groupchat -subject $subject } proc ::IRCActions::Invite {roomjid value} { set nick [lindex $value 0] set room [lindex $value 1] jlib::splitjidex $roomjid node domain res if {[string first "@" $room] < 0} { set room ${room}@${domain} } set jid $room/$nick ::Jabber::Jlib muc invite $roomjid $jid } proc ::IRCActions::Kick {roomjid value} { set room [lindex $value 0] set nick [lindex $value 1] jlib::splitjidex $roomjid node domain res if {[string first "@" $room] < 0} { set room ${room}@${domain} } # Must be this room and no other. ::Jabber::Jlib muc setrole $roomjid $nick "none" } proc ::IRCActions::Leave {roomjid value} { ::GroupChat::ExitRoomJID $roomjid } proc ::IRCActions::BuildGroupChatHook {roomjid} { set wtextsend [::GroupChat::GetWidget $roomjid wtextsend] # need to escape the % here (used for IRC transports), because otherwise # it may be strangely interpreted by the bind command bind $wtextsend +[namespace code [list Complete [string map {% __PERCENT__} $roomjid]]] } proc ::IRCActions::Complete {roomjid} { # need to revert the % mapping done in the BuildGroupChatHook here again set roomjid [string map {__PERCENT__ %} $roomjid] set wtext [::GroupChat::GetWidget $roomjid wtextsend] set start [$wtext index "insert -1 c wordstart"] set stop [$wtext index "insert -1 c wordend"] set str [$wtext get $start $stop] set participants [::Jabber::Jlib muc participants $roomjid] set nicks [list] set matched 0 foreach jid $participants { jlib::splitjid $jid - nick if {[string match $str* $nick]} { lappend nicks $nick set matched 1 } } set len [llength $nicks] if {$len == 1} { $wtext delete $start $stop $wtext mark set insert $start $wtext insert insert $nicks return -code break } elseif {$len > 1} { bell return -code break } else { return } } proc ::IRCActions::ParseWordHook {type jid w word tagList} { variable lastWord set handled "" if {$word eq "/me"} { switch -- $type { groupchat { jlib::splitjid $jid roomjid nick } chat { set jid2 [jlib::barejid $jid] if {[::Jabber::Jlib service isroom $jid2]} { set nick $jid } else { set nick [::Roster::GetDisplayName $jid2] } } default { set nick [jlib::barejid $jid] } } set wd [string map [list "/me" "* $nick"] $word] set meopts [option get . parseMeCDataOpts {}] eval {$w tag configure tmecdata} $meopts $w insert insert $wd [concat $tagList tmecdata] set handled stop } elseif {$word eq "/msg"} { if {$type eq "groupchat"} { # Just Ignore it but lastWord id Cached. set handled stop } } if {($type eq "groupchat") && ($lastWord eq "/msg")} { set wd "*$word*" set opts [option get . parseNickCDataOpts {}] eval {$w tag configure tnickmsg} $opts $w insert insert $wd [concat $tagList tnickmsg] set handled stop } set lastWord $word return $handled } # IRCActions::DisplayHook -- # # Make some alert when my nick is displayed. proc ::IRCActions::DisplayHook {xmldata} { if {[component::exists Sounds]} { set from [wrapper::getattribute $xmldata from] set roomjid [jlib::barejid $from] set nick [::Jabber::Jlib muc mynick $roomjid] set body [wrapper::getcdata [wrapper::getfirstchildwithtag $xmldata body]] if {[string match -nocase *$nick* $body]} { ::Sounds::PlayWhenIdle newmsg } } } coccinella-0.96.20/components/ImageMagic.tcl000066400000000000000000000137341167435367600206720ustar00rootroot00000000000000# ImageMagic.tcl -- # # ImportWindowSnapShot # Depends on ImageMagic installation # Contributed by Raymond Tang, adapted as a plugin by Mats Bengtsson. # # Unix/Linux only. # # Copyright (c) 2007 Mats Bengtsson # # 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 3 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, see . # # $Id: ImageMagic.tcl,v 1.14 2007-11-17 07:40:52 matben Exp $ namespace eval ::ImageMagic { if {[string equal $::tcl_platform(platform) "unix"]} { set importcmd [lindex [auto_execok import] 0] if {[llength $importcmd]} { component::define ImageMagic \ "ImageMagic import command bindings for taking screenshots on X11" } } variable imageType gif } proc ::ImageMagic::Init {} { global tcl_platform variable imageType variable haveImageMagic variable importcmd set haveImageMagic 0 if {[string equal $tcl_platform(platform) "unix"]} { set importcmd [lindex [auto_execok import] 0] if {[llength $importcmd]} { set haveImageMagic 1 } } # Register a menu entry for this component. if {$haveImageMagic} { component::register ImageMagic # 'type' 'label' 'command' 'opts' {subspec} # where subspec defines a cascade menu recursively # TRANSLATORS: see Plugins menu in whiteboard set menuspec [list \ command mSnapshot [mc "Take &Snapshot"] {::ImageMagic::ImportWindowSnapShot $w} {} {} \ ] ::WB::RegisterNewMenu addon [mc "Plu&gins"] $menuspec } } proc ::ImageMagic::ImportWindowSnapShot {w} { global this variable imageType variable tmpfiles variable haveImageMagic variable importcmd set wcan [::WB::GetCanvasFromWtop $w] if {$haveImageMagic == 0} { ::UI::MessageBox -title [mc "Error"] -icon error -type ok -message \ "Failed to locate ImageMagic package! Can't do screen snap shot :-(" return } set ans [::ImageMagic::BuildDialog .imagic] update if {$ans eq "1"} { set tmpfile [::tfileutils::tempfile $this(tmpPath) imagemagic] append tmpfile .$imageType exec $importcmd $tmpfile set optList [list -coords [::CanvasUtils::NewImportAnchor $wcan]] set errMsg [::Import::DoImport $wcan $optList -file $tmpfile] if {$errMsg eq ""} { lappend tmpfiles $tmpfile } else { ::UI::MessageBox -title [mc "Error"] -icon error -type ok \ -message "Failed importing: $errMsg" } } } proc ::ImageMagic::BuildDialog {w} { variable imageType variable finished ::UI::Toplevel $w -usemacmainmenu 1 -macstyle documentProc \ -macclass {document closeBox} wm title $w [mc "Take Snapshot"] set finished -1 # Global frame. ttk::frame $w.frall pack $w.frall -fill both -expand 1 set wbox $w.frall.f ttk::frame $wbox -padding [option get . dialogPadding {}] pack $wbox -fill both -expand 1 ttk::label $wbox.msg -style Small.TLabel \ -padding {0 0 0 6} -wraplength 300 -justify left \ -text [mc "Click on a window or drag a rectangular area to import a snapshot into the current whiteboard."] pack $wbox.msg -side top -fill x -anchor w ttk::label $wbox.la -text {Captured image format:} -style Small.TLabel pack $wbox.la -side top -anchor w set frbt $wbox.frbt ttk::frame $frbt pack $frbt -side top -anchor w foreach type {bmp gif jpeg png tiff} { ttk::radiobutton $frbt.$type -text $type -style Small.TRadiobutton \ -variable [namespace current]::imageType -value $type grid $frbt.$type -sticky w -padx 20 -pady 1 # Verify that we've got an importer for the format. set theMime [::Types::GetMimeTypeForFileName x.$type] if {![::Media::HaveImporterForMime $theMime]} { $frbt.$type configure -state disabled } } # Button part. set frbot $wbox.b ttk::frame $frbot -padding [option get . okcancelTopPadding {}] ttk::button $frbot.btok -text [mc "OK"] -default active \ -command [list set [namespace current]::finished 1] ttk::button $frbot.btcancel -text [mc "Cancel"] \ -command [list set [namespace current]::finished 0] set padx [option get . buttonPadX {}] if {[option get . okcancelButtonOrder {}] eq "cancelok"} { pack $frbot.btok -side right pack $frbot.btcancel -side right -padx $padx } else { pack $frbot.btcancel -side right pack $frbot.btok -side right -padx $padx } pack $frbot -side bottom -fill x wm resizable $w 0 0 bind $w [list $frbot.btok invoke] # Grab and focus. focus $w catch {grab $w} # Wait here for a button press. tkwait variable [namespace current]::finished catch {grab release $w} catch {destroy $w} return $finished } # Clear Import files from in box # Argument # w # proc ::ImageMagic::ClearImportFiles {wcan} { global prefs variable tmpfiles if {$prefs(incomingFilePath) eq "" || [string match {*[*?]*} $prefs(incomingFilePath)]} { ::UI::MessageBox -message [mc "Dangerous in-box path name: %s" $prefs(incomingFilePath)] \ -icon warning return } if {![file exists $prefs(incomingFilePath)]} { file mkdir $prefs(incomingFilePath) } set all_files [glob -nocomplain [file join $prefs(incomingFilePath) -- {*}]] if {$all_files == ""} { return } set msg [mc "Click OK to remove files: %s" "\n[join $all_files \n]"] set ans [::UI::MessageBox -message $msg -type okcancel -icon warning] if {"$ans" eq "ok"} { foreach file $all_files { file delete $file } } } coccinella-0.96.20/components/JivePhone.tcl000066400000000000000000000750571167435367600206040ustar00rootroot00000000000000# JivePhone.tcl -- # # JivePhone bindings for the jive server and Asterisk. # # Contributions and testing by Antonio Cano damas # # 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 3 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, see . # # $Id: JivePhone.tcl,v 1.37 2008-06-09 09:50:59 matben Exp $ # My notes on the present "Phone Integration Proto-JEP" document from # Jive Software: # # 1) server support for this is indicated by the disco child of the server # where it should instead be a disco info feature element. # # 2) "The username must be set as the node attribute on the query" # when obtaining info if a particular user has support for this. # This seems wrong since only a specific instance of a user specified # by an additional resource can have specific features. # I could imagine a dialer as a tab page, but then we need nice buttons. # namespace eval ::JivePhone { component::define JivePhone \ "VoIP notifications from the Openfire plugin Asterisk-IM" } proc ::JivePhone::Init {} { component::register JivePhone # Add event hooks. ::hooks::register presenceHook ::JivePhone::PresenceHook ::hooks::register newMessageHook ::JivePhone::MessageHook ::hooks::register loginHook ::JivePhone::LoginHook ::hooks::register logoutHook ::JivePhone::LogoutHook ::hooks::register rosterPostCommandHook ::JivePhone::RosterPostCommandHook ::hooks::register buildChatButtonTrayHook ::JivePhone::buildChatButtonTrayHook variable xmlns set xmlns(jivephone) "http://jivesoftware.com/xmlns/phone" # Note the difference! variable feature set feature(jivephone) "http://jivesoftware.com/phone" variable statuses {AVAILABLE RING DIALED ON_PHONE HANG_UP} #--------------- Variables Uses For PopUP Menus ------------------------- variable popMenuDef variable popMenuType set popMenuDef(call) { command mJiveCall {[mc "Call"]} {::JivePhone::DialJID $jid "DIAL"} } set popMenuDef(forward) { command mJiveForward {[mc "Forward Call"]} {::JivePhone::DialJID $jid "FORWARD"} } set popMenuType(call) { mJiveCall {user available} } set popMenuType(forward) { mJiveCall {user available} } variable menuDef set menuDef \ {command mJiveCall {[mc "Call"]} {::JivePhone::DoDial "DIAL"} {}} #--------------- Variables Uses For SpeedDial Addressbook Tab ---------------- variable wtab - variable abline [list] set popMenuDef(addressbook) { mJiveCall jid {[mc "Call"]} {::JivePhone::DialExtension $jid "DIAL"} separator {} {} {} mNewAB jid {[mc "New"]} {::JivePhone::NewAddressbookDlg} mModifyAB jid {[mc "Modify"]} {::JivePhone::ModifyAddressbookDlg $jid} mRemoveAB jid {[mc "Remove"]} {::JivePhone::RemoveAddressbookDlg $jid} } InitState } proc ::JivePhone::InitState { } { variable state array set state { phoneserver 0 setui 0 win .dial wstatus - phone - abphonename - abphonenumber - } } #---------------------------------------------------------------------------- #-------------------- JEP Messages Function Handlers ------------------------ #---------------------------------------------------------------------------- proc ::JivePhone::LoginHook { } { set server [::Jabber::GetServerJid] ::Jabber::Jlib disco get_async items $server ::JivePhone::OnDiscoServer } proc ::JivePhone::OnDiscoServer {jlibname type from subiq args} { variable state Debug "::JivePhone::OnDiscoServer" # See comments above what my opinion is... if {$type eq "result"} { set childs [::Jabber::Jlib disco children $from] foreach service $childs { set name [::Jabber::Jlib disco name $service] Debug "\t service=$service, name=$name" if {$name eq "phone"} { set state(phoneserver) 1 set state(service) $service break } } } if {$state(phoneserver)} { # @@@ It is a bit unclear if we shall disco the phone service with # the username as each node. # We may not yet have obtained the roster. Sync issue! if {[::Jabber::RosterCmd haveroster]} { DiscoForUsers } else { ::hooks::register rosterExit ::JivePhone::RosterHook } } } proc ::JivePhone::RosterHook {} { Debug "::JivePhone::RosterHook" ::hooks::deregister rosterExit ::JivePhone::RosterHook DiscoForUsers } proc ::JivePhone::DiscoForUsers {} { variable state Debug "::JivePhone::DiscoForUsers" set users [::Jabber::RosterCmd getusers] # We add ourselves to this list to figure out if we've got a jive phone. lappend users [::Jabber::Jlib getthis myjid2] foreach jid $users { jlib::splitjidex $jid node domain - if {[::Jabber::GetServerJid] eq $domain} { ::Jabber::Jlib disco get_async info $state(service) \ ::JivePhone::OnDiscoUserNode -node $node } } } proc ::JivePhone::OnDiscoUserNode {jlibname type from subiq args} { variable xmlns variable state variable feature Debug "::JivePhone::OnDiscoUserNode" if {$type eq "result"} { set node [wrapper::getattribute $subiq "node"] set havePhone [::Jabber::Jlib disco hasfeature $feature(jivephone) \ $from $node] Debug "\t from=$from, node=$node, havePhone=$havePhone" if {$havePhone} { # @@@ What now? # @@@ But if we've already got phone presence? # Really stupid! It assumes user exist on login server. set server [::Jabber::Jlib getserver] set jid [jlib::joinjid $node $server ""] #puts "\t jid=$jid" # Cache this info. #set state(phone,$jid) # Since we added ourselves to the list take action if have phone. set myjid2 [::Jabber::Jlib getthis myjid2] if {[jlib::jidequal $jid $myjid2]} { WeHavePhone } else { # Attempt to set icon only if this user is unavailable since # we do not have the full jid! # This way we shouldn't interfere with phone presence. # We could use [roster isavailable $jid] instead. set item [::RosterTree::FindWithTag [list jid $jid]] if {$item ne ""} { set image [::Rosticons::ThemeGet phone/online] ::RosterTree::StyleSetItemAlternative $jid jivephone \ image $image } } } } } proc ::JivePhone::WeHavePhone { } { variable state variable popMenuDef variable popMenuType variable menuDef NewPage if {$state(setui)} { return } ::Roster::RegisterPopupEntry $popMenuDef(call) $popMenuType(call) ::JUI::RegisterMenuEntry action $menuDef set image [::Rosticons::ThemeGet [string tolower phone/online]] set win [::JUI::SetAlternativeStatusImage jivephone $image] bind $win [list ::JivePhone::DoDial "DIAL"] ::balloonhelp::balloonforwindow $win [mc "Call"] set state(wstatus) $win set state(setui) 1 } proc ::JivePhone::LogoutHook { } { variable state variable wtab variable abline ::Roster::DeRegisterPopupEntry mJiveCall ::Roster::DeRegisterPopupEntry mJiveForward ::JUI::DeRegisterMenuEntry action mJiveCall ::JUI::RemoveAlternativeStatusImage jivephone if {[winfo exists $state(wstatus)]} { destroy $state(wstatus) } unset -nocomplain state destroy $wtab set abline [list] InitState } # JivePhone::PresenceHook -- # # A user's presence is updated when on a phone call. proc ::JivePhone::PresenceHook {jid type args} { variable xmlns variable state Debug "::JivePhone::PresenceHook jid=$jid, type=$type, $args" if {$type ne "available"} { return } array set argsArr $args if {[info exists argsArr(-xmldata)]} { set xmldata $argsArr(-xmldata) set elems [wrapper::getchildswithtagandxmlns $xmldata \ phone-status $xmlns(jivephone)] if {$elems ne ""} { set from [wrapper::getattribute $xmldata from] set elem [lindex $elems 0] set status [wrapper::getattribute $elem "status"] if {$status eq ""} { set status available } # Cache this info. # @@@ How do we get unavailable status? # Must check for "normal" presence info. set state(status,$from) $status set image [::Rosticons::ThemeGet [string tolower phone/$status]] ::RosterTree::StyleSetItemAlternative $from jivephone image $image eval {::hooks::run jivePhonePresence $from $type} $args } } return } # JivePhone::MessageHook -- # # Events are sent to the user when their phone is ringing, ... # ... message packets are used to send events for the time being. proc ::JivePhone::MessageHook {xmldata uuid} { variable xmlns variable popMenuDef variable popMenuType variable state variable callID Debug "::JivePhone::MessageHook" set elem [wrapper::getfirstchildwithtag $xmldata "phone-event"] if {[llength $elem]} { set status [wrapper::getattribute $elem "status"] if {$status eq ""} { set status available } set cidElem [wrapper::getfirstchildwithtag $elem callerID] if {$cidElem != {}} { set cid [wrapper::getcdata $cidElem] } else { set cid [mc "Unknown"] } set image [::Rosticons::ThemeGet [string tolower phone/$status]] set win [::JUI::SetAlternativeStatusImage jivephone $image] set type [wrapper::getattribute $elem "type"] # @@@ What to do more? if {$type eq "RING" } { set callID [wrapper::getattribute $elem "callID"] ::Roster::RegisterPopupEntry $popMenuDef(forward) $popMenuType(forward) bind $win [list ::JivePhone::DoDial "FORWARD"] ::balloonhelp::balloonforwindow $win [mc "Forward current call to"]... ::hooks::run jivePhoneEvent $type $cid $callID $xmldata } if {$type eq "HANG_UP"} { ::Roster::DeRegisterPopupEntry mJiveForward bind $win [list ::JivePhone::DoDial "DIAL"] ::balloonhelp::balloonforwindow $win [mc "Call"] ::hooks::run jivePhoneEvent $type $cid "" $xmldata } # Provide a default notifier? # if {[hooks::info jivePhoneEvent] eq {}} { # NotifyCall::InboundCall{ $cid } # set title [mc "Ring, ring"]... # set msg [mc "Phone is ringing from %s" $cid] # ui::dialog -icon info -buttons {} -title $title \ # -message $msg -timeout 4000 # } } return } proc ::JivePhone::RosterPostCommandHook {m jidL clicked presL} { variable state set jid3 [lindex $jidL 0] jlib::splitjid $jid3 jid2 - set jid $jid2 Debug "RosterPostCommandHook $jidL $clicked $presL" if {$clicked ne "user"} { return } if {[llength $jidL] != 1} { return } if {[lsearch $presL "available"] < 0} { return } if {[info exists state(phone,$jid]} { if {[info exists state(status,$jid)]} { switch -- $state(status,$jid3) { AVAILABLE - HANG_UP { set midx [::AMenu::GetMenuIndex $m mJiveCall] if {$midx eq ""} { # Probably a submenu. return } $m entryconfigure $midx -state normal } XXXX { # @@@ ??? set midx [::AMenu::GetMenuIndex $m mJiveForward] if {$midx eq ""} { # Probably a submenu. return } $m entryconfigure $midx -state normal } } } } } #----------------------------------------------------------------------- #------------------------ JivePhone Dialer Window ---------------------- #---------------------- (Dial/Forward - Extension/Jid) ----------------- #----------------------------------------------------------------------- # JivePhone::DoDial -- # # type: FORWARD | DIAL proc ::JivePhone::DoDial {type {jid ""}} { variable state variable phoneNumber set win $state(win) if {$jid eq ""} { BuildDialer $win $type } else { jlib::splitjidex $jid node domain - if {[::Jabber::GetServerJid] eq $domain} { set phoneNumber "" OnDial $win $type $jid } else { BuildDialer $win $type } } } # JivePhone::BuildDialer -- # # A toplevel dialer. proc ::JivePhone::BuildDialer {w type} { variable state variable phoneNumber # Make sure only single instance of this dialog. if {[winfo exists $w]} { raise $w return } ::UI::Toplevel $w -class PhoneDialer \ -usemacmainmenu 1 -macstyle documentProc -macclass {document closeBox} \ -closecommand [namespace current]::CloseDialer if {$type eq "DIAL"} { wm title $w [mc "Call to"]... } else { wm title $w [mc "Forward to"]... } ::UI::SetWindowPosition $w set phoneNumber "" # Global frame. ttk::frame $w.f pack $w.f -fill x ttk::label $w.f.head -style Headlabel -text [mc "Phone"] pack $w.f.head -side top -fill both -expand 1 ttk::separator $w.f.s -orient horizontal pack $w.f.s -side top -fill x set wbox $w.f.f ttk::frame $wbox -padding [option get . dialogPadding {}] pack $wbox -fill both -expand 1 set box $wbox.b ttk::frame $box pack $box -side bottom -fill x ttk::label $box.l -text [mc "Number"]: ttk::entry $box.e -textvariable [namespace current]::phoneNumber \ -width 18 ttk::button $box.dial -text [mc "Dial"] \ -command [list [namespace current]::OnDial $w $type] grid $box.l $box.e $box.dial -padx 1 -pady 4 focus $box.e wm resizable $w 0 0 } proc ::JivePhone::CloseDialer {w} { ::UI::SaveWinGeom $w } #------------------------------------------------------------------------- #------------------- JivePhone Send IQ Actions --------------------------- #------------------------------------------------------------------------- proc ::JivePhone::OnDial {w type {jid ""}} { variable phoneNumber variable xmlns variable state variable callID Debug "::JivePhone::OnDial w=$w, type=$type, phoneNumber=$phoneNumber" if {!$state(phoneserver)} { return } if {$jid ne ""} { set dnid $jid set extensionElem [wrapper::createtag "jid" -chdata $jid] } elseif {$phoneNumber ne ""} { set extensionElem [wrapper::createtag "extension" -chdata $phoneNumber] set dnid $phoneNumber } else { Debug "\t return" return } if {$type eq "DIAL"} { set command "DIAL" set attr [list xmlns $xmlns(jivephone) type $command] } else { set command "FORWARD" set attr [list xmlns $xmlns(jivephone) id $callID type $command] } set phoneElem [wrapper::createtag "phone-action" \ -attrlist $attr -subtags [list $extensionElem]] ::Jabber::Jlib send_iq set [list $phoneElem] \ -to $state(service) -command [list ::JivePhone::DialCB $dnid] ::hooks::run jivePhoneEvent $command $dnid $callID destroy $w } proc ::JivePhone::DialJID {jid type {callID ""}} { variable state variable xmlns if {!$state(phoneserver)} { return } set extensionElem [wrapper::createtag "jid" -chdata $jid] if {$type eq "DIAL"} { set command "DIAL" set attr [list xmlns $xmlns(jivephone) type $command] } else { # @@@ Where comes callID from? set command "FORWARD" set attr [list xmlns $xmlns(jivephone) id $callID type $command] } set phoneElem [wrapper::createtag "phone-action" \ -attrlist $attr -subtags [list $extensionElem]] ::Jabber::Jlib send_iq set [list $phoneElem] \ -to $state(service) -command [list ::JivePhone::DialCB $jid] ::hooks::run jivePhoneEvent $command $jid $callID } proc ::JivePhone::DialExtension {extension type {callID ""}} { variable state variable xmlns if {!$state(phoneserver)} { return } set extensionElem [wrapper::createtag "extension" -chdata $extension] if {$type eq "DIAL"} { set command "DIAL" set attr [list xmlns $xmlns(jivephone) type $command] } else { # @@@ Where comes callID from? set command "FORWARD" set attr [list xmlns $xmlns(jivephone) id $callID type $command] } set phoneElem [wrapper::createtag "phone-action" \ -attrlist $attr -subtags [list $extensionElem]] ::Jabber::Jlib send_iq set [list $phoneElem] \ -to $state(service) -command [list ::JivePhone::DialCB $extension] ::hooks::run jivePhoneEvent $command $extension $callID } proc ::JivePhone::DialCB {dnid type subiq args} { if {$type eq "error"} { ui::dialog -title [mc "Error"] -icon error -type ok \ -message [mc "Failed calling %s" $dnid] -detail $subiq } } #--------------------------------------------------------------------------- #------------------- JivePhone Addressbook SpeedDial Tab ------------------- #--------------------------------------------------------------------------- proc ::JivePhone::NewPage {} { variable wtab set wnb [::JUI::GetNotebook] set wtab $wnb.ab if {![winfo exists $wtab]} { Build $wtab $wnb add $wtab -text [mc "Address Book"] } } # JivePhone::Build -- # # This is supposed to create a frame which is pretty object like, # and handles most stuff internally without intervention. # # Arguments: # w frame for everything # args # # Results: # w proc ::JivePhone::Build {w args} { global prefs this jprefs variable waddressbook variable wtree variable wwave upvar ::Jabber::jstate jstate upvar ::Jabber::jserver jserver variable abline ::Debug 2 "::JivePhone::Build w=$w" set jstate(wpopup,addressbook) .jpopupab set waddressbook $w set wwave $w.fs set wbox $w.box set wtree $wbox.tree set wxsc $wbox.xsc set wysc $wbox.ysc # The frame. ttk::frame $w -class AddressBook # D = -border 1 -relief sunken frame $wbox pack $wbox -side top -fill both -expand 1 ttk::scrollbar $wxsc -orient horizontal -command [list $wtree xview] ttk::scrollbar $wysc -orient vertical -command [list $wtree yview] ::ITree::New $wtree $wxsc $wysc \ -buttonpress ::JivePhone::Popup \ -buttonpopup ::JivePhone::Popup grid $wtree -row 0 -column 0 -sticky news grid $wysc -row 0 -column 1 -sticky ns grid $wxsc -row 1 -column 0 -sticky ew grid columnconfigure $wbox 0 -weight 1 grid rowconfigure $wbox 0 -weight 1 #--------- Load Entries of AddressBook into NewPage Tab --------- LoadEntries if { [llength $abline] } { foreach {name phone} $abline { set opts {-text "$name ($phone)"} if {$name ne ""} { lappend opts -text "$name ($phone)" eval {::ITree::Item $wtree $phone} $opts } } } return $w } proc ::JivePhone::LoadEntries {} { variable abline global prefs this set fileName [file join $this(prefsPath) addressbook.csv] set abline [list] if { [ file exists $fileName ] } { set hFile [open $fileName "r"] while {[eof $hFile] <= 0} { gets $hFile line set temp [split $line ":"] foreach i $temp { lappend abline $i } } close $hFile } } # JivePhone::Popup -- # # Handle popup menus in JivePhone, typically from right-clicking. # # Arguments: # w widget that issued the command: tree or text # v for the tree widget it is the item path, # for text the jidhash. # # Results: # popup menu displayed proc ::JivePhone::Popup {w v x y} { global wDlgs this variable popMenuDef upvar ::Jabber::jstate jstate ::Debug 2 "::JivePhone::Popup w=$w, v='$v', x=$x, y=$y" # The last element of $v is either a jid, (a namespace,) # a header in roster, a group, or an agents xml tag. # The variables name 'jid' is a misnomer. # Find also type of thing clicked, 'typeClicked'. set typeClicked "" set jid [lindex $v end] set jid3 $jid set childs [::ITree::Children $w $v] if {$jid ne ""} { set typeClicked jid } if {[string length $jid] == 0} { set typeClicked "" } set X [expr {[winfo rootx $w] + $x}] set Y [expr {[winfo rooty $w] + $y}] ::Debug 2 "\t jid=$jid, typeClicked=$typeClicked" # Mads Linden's workaround for menu post problem on mac: # all in menubutton commands i add "after 40 the_command" # this way i can never have to posting error. # it is important after the tk_popup f.ex to # # destroy .mb # update # # this way the .mb is destroyd before the next window comes up, thats how I # got around this. # Make the appropriate menu. set m $jstate(wpopup,addressbook) set i 0 catch {destroy $m} menu $m -tearoff 0 foreach {item type lname cmd} $popMenuDef(addressbook) { if {[string index $cmd 0] == "@"} { set mt [menu ${m}.sub${i} -tearoff 0] set locname [eval concat $lname] $m add cascade -label $locname -menu $mt -state disabled eval [string range $cmd 1 end] $mt incr i } elseif {[string equal $item "separator"]} { $m add separator continue } else { # Substitute the jid arguments. Preserve list structure! set cmd [eval list $cmd] set locname [eval concat $lname] $m add command -label $locname -command [list after 40 $cmd] \ -state disabled } # If a menu should be enabled even if not connected do it here. if {![::Jabber::IsConnected]} { continue } if {[string equal $type "any"]} { $m entryconfigure $locname -state normal continue } # State of menu entry. We use the 'type' and 'typeClicked' to sort # out which capabilities to offer for the clicked item. set state disabled if {[string equal $item "mNewAB"]} { set state normal } if {[string equal $type $typeClicked]} { set state normal } if {[string equal $state "normal"]} { $m entryconfigure $locname -state normal } } # This one is needed on the mac so the menu is built before it is posted. update idletasks # Post popup menu. tk_popup $m [expr {int($X) - 10}] [expr {int($Y) - 10}] # Mac bug... (else can't post menu while already posted if toplevel...) if {[string equal "macintosh" $this(platform)]} { catch {destroy $m} update } } proc ::JivePhone::RemoveAddressbookDlg {jid} { variable abline variable wtree set index [lsearch -exact $abline $jid] set tmp [lreplace $abline [expr {$index-1}] $index] set abline $tmp eval {::ITree::DeleteItem $wtree $jid} SaveEntries } proc ::JivePhone::NewAddressbookDlg {} { global this wDlgs variable abName variable abPhoneNumber set abName "" set abPhoneNumber "" set w ".nadbdlg" ::UI::Toplevel $w \ -macstyle documentProc -macclass {document closeBox} -usemacmainmenu 1 \ -closecommand [namespace current]::CloseCmd wm title $w [mc "New address book"] set nwin [llength [::UI::GetPrefixedToplevels $wDlgs(jmucenter)]] if {$nwin == 1} { ::UI::SetWindowPosition $w ".nadbdlg" } # Global frame. ttk::frame $w.frall pack $w.frall -fill both -expand 1 set wbox $w.frall.f ttk::frame $wbox -padding [option get . dialogPadding {}] pack $wbox -fill both -expand 1 ttk::label $wbox.msg -style Small.TLabel \ -padding {0 0 0 6} -wraplength 260 -justify left -text [mc "New address book"] pack $wbox.msg -side top -anchor w set frmid $wbox.frmid ttk::frame $frmid pack $frmid -side top -fill both -expand 1 ttk::label $frmid.lname -text [mc "Name"]: ttk::entry $frmid.ename -textvariable [namespace current]::abName ttk::label $frmid.lphone -text [mc "Phone number"]: ttk::entry $frmid.ephone -textvariable [namespace current]::abPhoneNumber grid $frmid.lname $frmid.ename - -sticky e -pady 2 grid $frmid.lphone $frmid.ephone - -sticky e -pady 2 grid $frmid.ephone $frmid.ename -sticky ew grid columnconfigure $frmid 1 -weight 1 # Button part. set frbot $wbox.b set wenter $frbot.btok ttk::frame $frbot ttk::button $wenter -text [mc "Enter"] \ -default active -command [list [namespace current]::addItemAddressBook $w] ttk::button $frbot.btcancel -text [mc "Cancel"] \ -command [list [namespace current]::CancelEnter $w] set padx [option get . buttonPadX {}] if {[option get . okcancelButtonOrder {}] eq "cancelok"} { pack $frbot.btok -side right pack $frbot.btcancel -side right -padx $padx } else { pack $frbot.btcancel -side right pack $frbot.btok -side right -padx $padx } pack $frbot -side bottom -fill x wm resizable $w 0 0 bind $w [list $wenter invoke] # Trick to resize the labels wraplength. set script [format { update idletasks %s configure -wraplength [expr {[winfo reqwidth %s] - 20}] } $wbox.msg $w] after idle $script } proc ::JivePhone::ModifyAddressbookDlg {jid} { global this wDlgs variable abName variable abPhoneNumber variable abline #Get Entry data from abline list set index [lsearch -exact $abline $jid] set abName [lindex $abline [expr {$index-1}]] set abPhoneNumber [lindex $abline [expr {$index}]] set oldPhoneNumber $abPhoneNumber set w ".madbdlg" ::UI::Toplevel $w \ -macstyle documentProc -macclass {document closeBox} -usemacmainmenu 1 \ -closecommand [namespace current]::CloseCmd wm title $w [mc "Modify address book"] set nwin [llength [::UI::GetPrefixedToplevels $wDlgs(jmucenter)]] if {$nwin == 1} { ::UI::SetWindowPosition $w ".madbdlg" } # Global frame. ttk::frame $w.frall pack $w.frall -fill both -expand 1 set wbox $w.frall.f ttk::frame $wbox -padding [option get . dialogPadding {}] pack $wbox -fill both -expand 1 ttk::label $wbox.msg -style Small.TLabel \ -padding {0 0 0 6} -wraplength 260 -justify left -text [mc "Modify address book"] pack $wbox.msg -side top -anchor w set frmid $wbox.frmid ttk::frame $frmid pack $frmid -side top -fill both -expand 1 ttk::label $frmid.lname -text [mc "Name"]: ttk::entry $frmid.ename -textvariable [namespace current]::abName ttk::label $frmid.lphone -text [mc "Phone number"]: ttk::entry $frmid.ephone -textvariable [namespace current]::abPhoneNumber grid $frmid.lname $frmid.ename - -sticky e -pady 2 grid $frmid.lphone $frmid.ephone - -sticky e -pady 2 grid $frmid.ephone $frmid.ename -sticky ew grid columnconfigure $frmid 1 -weight 1 # Button part. set frbot $wbox.b set wenter $frbot.btok ttk::frame $frbot ttk::button $wenter -text [mc "Enter"] \ -default active -command [list [namespace current]::modifyItemAddressBook $w $oldPhoneNumber] ttk::button $frbot.btcancel -text [mc "Cancel"] \ -command [list [namespace current]::CancelEnter $w] set padx [option get . buttonPadX {}] if {[option get . okcancelButtonOrder {}] eq "cancelok"} { pack $frbot.btok -side right pack $frbot.btcancel -side right -padx $padx } else { pack $frbot.btcancel -side right pack $frbot.btok -side right -padx $padx } pack $frbot -side bottom -fill x wm resizable $w 0 0 bind $w [list $wenter invoke] # Trick to resize the labels wraplength. set script [format { update idletasks %s configure -wraplength [expr {[winfo reqwidth %s] - 20}] } $wbox.msg $w] after idle $script } proc ::JivePhone::addItemAddressBook {w} { variable abName variable abPhoneNumber variable abline variable wtree if { $abName ne "" && $abPhoneNumber ne ""} { lappend abline $abName lappend abline $abPhoneNumber set opts {-text "$abName ($abPhoneNumber)"} eval {::ITree::Item $wtree $abPhoneNumber} $opts SaveEntries ::UI::SaveWinGeom $w destroy $w } } proc ::JivePhone::modifyItemAddressBook {w oldPhoneNumber} { variable abName variable abPhoneNumber variable abline variable wtree if { $abName ne "" && $abPhoneNumber ne "" } { #---------- Updates Memory Addressbook ----------------- set index [lsearch -exact $abline $oldPhoneNumber] set tmp [lreplace $abline [expr {$index-1}] $index $abName $abPhoneNumber] set abline $tmp #----- Updates GUI --------- eval {::ITree::DeleteItem $wtree $oldPhoneNumber} set opts {-text "$abName ($abPhoneNumber)"} eval {::ITree::Item $wtree $abPhoneNumber} $opts #----- Updates Database ------- SaveEntries ::UI::SaveWinGeom $w destroy $w } } proc ::JivePhone::CancelEnter {w} { ::UI::SaveWinGeom $w destroy $w } proc ::JivePhone::CloseCmd {w} { ::UI::SaveWinGeom $w } proc ::JivePhone::SaveEntries {} { variable abline global prefs this # @@@ Mats set hFile [open [file join $this(prefsPath) addressbook.csv] "w"] foreach {name phonenumber} $abline { if {$name ne ""} { puts $hFile "$name:$phonenumber" } } close $hFile } proc ::JivePhone::Debug {msg} { if {0} { puts "-------- $msg" } } proc ::JivePhone::buildChatButtonTrayHook {wtray dlgtoken args} { global this prefs wDlgs variable state if { $state(phoneserver) == 1 } { variable $dlgtoken upvar 0 $dlgtoken dlgstate set w $dlgstate(w) set iconCall [::Theme::FindIconSize 32 phone-call] set iconCallDis [::Theme::FindIconSize 32 phone-call-Dis] $wtray newbutton call \ -text [mc "Call"] -image $iconCall \ -disabledimage $iconCallDis \ -command [list [namespace current]::chatCall $dlgtoken] } } proc ::JivePhone::chatCall {dlgtoken} { set chattoken [::Chat::GetActiveChatToken $dlgtoken] variable $chattoken upvar 0 $chattoken chatstate set jid $chatstate(fromjid) DialJID $jid "DIAL" } #------------------------------------------------------------------------------- coccinella-0.96.20/components/LiveRosterImage.tcl000066400000000000000000000116001167435367600217360ustar00rootroot00000000000000# LiveRosterImage.tcl -- # # Makes a custom overlay to any roster background image. # # Copyright (c) 2007 Mats Bengtsson # # 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 3 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, see . # # $Id: LiveRosterImage.tcl,v 1.6 2008-04-26 05:47:30 matben Exp $ namespace eval ::LiveRosterImage { if {[tk windowingsystem] ne "aqua"} { return } if {[catch {package require tkpath 0.3.0}]} { return } component::define LiveRosterImage "Draw an overlay to the roster background image" } proc ::LiveRosterImage::Init {} { component::register LiveRosterImage # Add event hooks. ::hooks::register setPresenceHook [namespace code PresenceHook] if {0 && [info tclversion] >= 8.5 && [tk windowingsystem] eq "aqua"} { ::hooks::register connectInitHook [namespace code ConnectInitHook] ::hooks::register connectHook [namespace code ConnectHook] ::hooks::register disconnectHook [namespace code DisconnectHook] } } proc ::LiveRosterImage::PresenceHook {type args} { Draw } proc ::LiveRosterImage::Draw {} { set orig [::RosterTree::BackgroundImageGet] if {$orig eq ""} { return } set width [image width $orig] set height [image height $orig] if {($width < 100) || ($height < 100)} { return } set show [::Jabber::Jlib mypresence] set status [::Jabber::Jlib mypresencestatus] set showStr [::Roster::MapShowToText $show] # Find size for each line and adjust the font size. set family {Lucida Grande} set size 16 set maxSize 52 set font [list $family $size] # Scale font size to fit. set len [font measure $font $showStr] set size1 [min [expr {$size*($width - 40)/$len}] $maxSize] set font1 [list $family $size1] set linespace1 [font metrics $font1 -linespace] set descent1 [font metrics $font1 -descent] set y1 [expr {$linespace1 + 20}] set str2L [list] if {$status ne ""} { set str2L [list $status] set n [string length $status] set len [font measure $font $status] # Split status message into two lines if long. if {$len >= $width} { set idx [string first " " $status [expr {$n/2}]] if {$idx >= 0} { set str2L [list \ [string range $status 0 [expr {$idx-1}]] \ [string range $status [expr {$idx+1}] end]] set len [font measure $font [lindex $str2L 0]] } } set size2 [min [expr {$size*($width - 20)/$len}] $maxSize] set font2 [list $family $size2] set linespace2 [font metrics $font2 -linespace] set y2 [expr {$y1 + $descent1 + $linespace2}] } set S [::tkp::surface new $width $height] $S create pimage 0 0 -image $orig if {0} { set avatar [::Avatar::GetMyPhoto] if {$avatar ne ""} { $S create pimage 10 10 -image $avatar -matrix {{3 0} {0 3} {0 0}} } } # Get from resources. set opacity 0.7 set fill white set width2 [expr {$width/2}] $S create ptext $width2 $y1 -text $showStr -textanchor middle \ -fontfamily $family -fontsize $size1 -fill $fill -fillopacity $opacity foreach str $str2L { $S create ptext $width2 $y2 -text $str -textanchor middle \ -fontfamily $family -fontsize $size2 -fill $fill -fillopacity $opacity incr y2 $linespace2 } set new [$S copy [image create photo]] $S destroy image delete $orig ::RosterTree::BackgroundImageConfig $new } # Experimental! namespace eval ::LiveRosterImage { variable woverlay - } # This suffers from a BUG in tkpath! # It seems it doesn't redraw background with systemTransparent? proc ::LiveRosterImage::ConnectInitHook {} { variable woverlay set win [::JUI::GetRosterFrame] set width [winfo width $win] set height [winfo height $win] set w2 [expr {$width/2}] set h2 [expr {$height/2}] set woverlay $win.overlay tkp::canvas $woverlay -bg systemTransparent -highlightthickness 0 -bd 0 place $woverlay -x 0 -y 0 -relwidth 1 -relheight 1 $woverlay create prect 0 0 2000 2000 \ -fill gray20 -fillopacity 0.2 -stroke "" $woverlay create ptext $w2 $h2 -textanchor middle -text "Connecting..." \ -fontfamily {Lucida Grande} -fontsize 24 -fill gray50 \ -fillopacity 0.6 } proc ::LiveRosterImage::ConnectHook {} { variable woverlay destroy $woverlay } proc ::LiveRosterImage::DisconnectHook {} { variable woverlay destroy $woverlay } coccinella-0.96.20/components/MailtoURI.tcl000066400000000000000000000035751167435367600205160ustar00rootroot00000000000000# MailtoURI.tcl -- # # Parses any in-text mailto: URIs. # # Copyright (c) 2007 Mats Bengtsson # # 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 3 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, see . # # $Id: MailtoURI.tcl,v 1.9 2007-11-17 07:40:52 matben Exp $ package require uri package require uriencode namespace eval ::MailtoURI { component::define MailtoURI "Parses in-text mailto: URIs" } proc ::MailtoURI::Init {} { # Perhaps we shal simplify this to: {^mailto:.+} variable mailtoRE $::uri::mailto::url ::Text::RegisterURI $mailtoRE ::MailtoURI::TextCmd component::register MailtoURI } proc ::MailtoURI::TextCmd {uri} { global this prefs if {$prefs(mailClient) eq "gmail"} { # http://gentoo-wiki.com/HOWTO_Open_mailto:_links_in_gmail # http://www.howtogeek.com/howto/ubuntu/set-gmail-as-default-mail-client-in-ubuntu/#comment-16706 set base "https://mail.google.com/mail/?view=cm&tf=0&to=" regsub {^mailto:([^&?]+)[&?]?(.*)$} $uri {\1\&\2} guri regsub {subject=} $guri {su=} guri set gmailuri $base$guri ::Utils::OpenURLInBrowser $gmailuri } else { switch -- $this(platform) { macosx { exec open $uri } unix { # Special. set mail [::Utils::UnixGetEmailClient] catch {exec $mail $uri &} } windows { ::Windows::OpenURI $uri } } } } coccinella-0.96.20/components/MeBeam.tcl000066400000000000000000000072331167435367600200320ustar00rootroot00000000000000# MeBeam.tcl -- # # Interface for MeBeam web based video conferencing. # # Copyright (c) 2007 Mats Bengtsson # # 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 3 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, see . # # $Id: MeBeam.tcl,v 1.6 2008-03-27 15:15:26 matben Exp $ namespace eval ::MeBeam { component::define MeBeam "MeBeam web based video conferencing" # Where shall the MeBeam menu be? set ::config(mebeam,menu-action) 0 set ::config(mebeam,menu-roster) 1 } proc ::MeBeam::Init {} { global config if {$config(mebeam,menu-action)} { set menuDef [list command "Invite MeBeam" {::MeBeam::Cmd} {} {}] ::JUI::RegisterMenuEntry action $menuDef ::hooks::register menuPostCommand ::MeBeam::MainMenuPostHook ::hooks::register menuChatActionPostHook ::MeBeam::ChatMenuPostHook } if {$config(mebeam,menu-roster)} { # TRANSLATORS: check http://www.mebeam.com/ set mDef [list command "Invite MeBeam" {[mc "Invite MeBeam"]} {::MeBeam::RosterCmd $jid3}] set mType {"Invite MeBeam" {user available}} ::Roster::RegisterPopupEntry $mDef $mType } variable url "http://www.mebeam.com/coccinella.php?ccn_" component::register MeBeam } proc ::MeBeam::RosterCmd {jid} { Start $jid } proc ::MeBeam::MainMenuPostHook {type m} { if {$type eq "main-action"} { ::UI::MenuMethod $m entryconfigure "Invite MeBeam" -state disabled # If selected single online roster item. if {[::JUI::GetConnectState] eq "connectfin"} { set jidL [::RosterTree::GetSelectedJID] if {[llength $jidL] == 1} { set jid [lindex $jidL 0] if {[::Jabber::RosterCmd isavailable $jid]} { ::UI::MenuMethod $m entryconfigure "Invite MeBeam" -state normal } } } } } # Active chat dialog. This works only for Mac OS X. proc ::MeBeam::ChatMenuPostHook {m} { if {[::JUI::GetConnectState] eq "connectfin"} { ::UI::MenuMethod $m entryconfigure "Invite MeBeam" -state normal } } proc ::MeBeam::Cmd {} { if {[::JUI::GetConnectState] ne "connectfin"} { return } # Active chat dialog. This works only for Mac OS X. if {[winfo exists [focus]]} { set top [winfo toplevel [focus]] set wclass [winfo class $top] if {$wclass eq "Chat"} { set dlgtoken [::Chat::GetTokenFrom dlg w $top] set token [::Chat::GetActiveChatToken $dlgtoken] ::Chat::SendText $token [Invite] return } } # Selected roster item. set jidL [::RosterTree::GetSelectedJID] if {[llength $jidL] == 1} { set jid [lindex $jidL 0] if {[::Jabber::RosterCmd isavailable $jid]} { Start $jid } } } proc ::MeBeam::Start {jid} { set jid2 [jlib::barejid $jid] set mjid2 [jlib::jidmap $jid2] set token [::Chat::GetTokenFrom chat jid [jlib::ESC $mjid2]*] if {$token ne ""} { ::Chat::SendText $token [Invite] } else { ::Chat::StartThread $jid2 -message [Invite] } } proc ::MeBeam::Invite {} { variable url set newurl $url[uuid::uuid generate] set str [mc "Please join me for video chat on"] append str " " append str $newurl ::Utils::OpenURLInBrowser $newurl return $str } coccinella-0.96.20/components/Mood.tcl000066400000000000000000000611201167435367600175750ustar00rootroot00000000000000# Mood.tcl -- # # User Mood using PEP recommendations over PubSub library code. # # Copyright (c) 2007-2008 Mats Bengtsson # Copyright (c) 2006 Antonio Cano Damas # # 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 3 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, see . # $Id: Mood.tcl,v 1.50 2008-08-19 12:40:41 matben Exp $ package require jlib::pep namespace eval ::Mood { component::define Mood "Communicate information about user moods" # Shall we display all moods in menus or just a subset? set ::config(mood,showall) 1 set sortedLocMoods [list] } proc ::Mood::Init {} { global config component::register Mood ::Debug 2 "::Mood::Init" # Add event hooks. ::hooks::register jabberInitHook ::Mood::JabberInitHook ::hooks::register loginHook ::Mood::LoginHook ::hooks::register logoutHook ::Mood::LogoutHook variable moodNode set moodNode "http://jabber.org/protocol/mood" variable xmlns set xmlns(mood) "http://jabber.org/protocol/mood" set xmlns(mood+notify) "http://jabber.org/protocol/mood+notify" set xmlns(node_config) "http://jabber.org/protocol/pubsub#node_config" variable state variable myMoods set myMoods { angry anxious ashamed bored curious depressed excited happy in_love invincible jealous nervous sad sleepy stressed worried } variable allMoods set allMoods { afraid amazed angry annoyed anxious aroused ashamed bored brave calm cold confused contented cranky curious depressed disappointed disgusted distracted embarrassed excited flirtatious frustrated grumpy guilty happy hot humbled humiliated hungry hurt impressed in_awe in_love indignant interested intoxicated invincible jealous lonely mean moody nervous neutral offended playful proud relieved remorseful restless sad sarcastic serious shocked shy sick sleepy stressed surprised thirsty worried } # Mood text strings. variable moodText set moodText [dict create] # TRANSLATORS: Moods, more information at http://xmpp.org/extensions/xep-0107.html#moods # TRANSLATORS: Impressed with fear or apprehension; in fear; apprehensive. dict set moodText afraid [mc "Afraid"] # TRANSLATORS: Astonished; confounded with fear, surprise or wonder. dict set moodText amazed [mc "Amazed"] # TRANSLATORS: Displaying or feeling anger, i.e., a strong feeling of displeasure, hostility or antagonism towards someone or something, usually combined with an urge to harm. dict set moodText angry [mc "Angry"] # TRANSLATORS: To be disturbed or irritated, especially by continued or repeated acts. dict set moodText annoyed [mc "Annoyed"] # TRANSLATORS: Full of anxiety or disquietude; greatly concerned or solicitous, esp. respecting something future or unknown; being in painful suspense. dict set moodText anxious [mc "Anxious"] # TRANSLATORS: To be stimulated in one's feelings, especially to be sexually stimulated. dict set moodText aroused [mc "Aroused"] # TRANSLATORS: Feeling shame or guilt. dict set moodText ashamed [mc "Ashamed"] # TRANSLATORS: Suffering from boredom; uninterested, without attention. dict set moodText bored [mc "Bored"] # TRANSLATORS: Strong in the face of fear; courageous. dict set moodText brave [mc "Brave"] # TRANSLATORS: Peaceful, quiet. dict set moodText calm [mc "Calm"] # TRANSLATORS: Feeling the sensation of coldness, especially to the point of discomfort. dict set moodText cold [mc "Cold"] # TRANSLATORS: Chaotic, jumbled or muddled. dict set moodText confused [mc "Confused"] # TRANSLATORS: Pleased at the satisfaction of a want or desire; satisfied. dict set moodText contented [mc "Contented"] # TRANSLATORS: Grouchy, irritable; easily upset. dict set moodText cranky [mc "Cranky"] # TRANSLATORS: Inquisitive; tending to ask questions, investigate, or explore. dict set moodText curious [mc "Curious"] # TRANSLATORS: Severely despondent and unhappy. dict set moodText depressed [mc "Depressed"] # TRANSLATORS: Defeated of expectation or hope; let down. dict set moodText disappointed [mc "Disappointed"] # TRANSLATORS: Filled with disgust; irritated and out of patience. dict set moodText disgusted [mc "Disgusted"] # TRANSLATORS: Having one's attention diverted; preoccupied. dict set moodText distracted [mc "Distracted"] # TRANSLATORS: Having a feeling of shameful discomfort. dict set moodText embarrassed [mc "Embarrassed"] # TRANSLATORS: Having great enthusiasm. dict set moodText excited [mc "Excited"] # TRANSLATORS: In the mood for flirting. dict set moodText flirtatious [mc "Flirtatious"] # TRANSLATORS: Suffering from frustration; dissatisfied, agitated, or discontented because one is unable to perform an action or fulfill a desire. dict set moodText frustrated [mc "Frustrated"] # TRANSLATORS: Unhappy and irritable. dict set moodText grumpy [mc "Grumpy"] # TRANSLATORS: Feeling responsible for wrongdoing; feeling blameworthy. dict set moodText guilty [mc "Guilty"] # TRANSLATORS: Experiencing the effect of favourable fortune; having the feeling arising from the consciousness of well-being or of enjoyment; enjoying good of any kind, as peace, tranquillity, comfort; contented; joyous. dict set moodText happy [mc "Happy"] # TRANSLATORS: Feeling the sensation of heat, especially to the point of discomfort. dict set moodText hot [mc "Hot"] # TRANSLATORS: Having or showing a modest or low estimate of one's own importance; feeling lowered in dignity or importance. dict set moodText humbled [mc "Humbled"] # TRANSLATORS: Feeling deprived of dignity or self-respect. dict set moodText humiliated [mc "Humiliated"] # TRANSLATORS: Having a physical need for food. dict set moodText hungry [mc "Hungry"] # TRANSLATORS: Wounded, injured, or pained, whether physically or emotionally. dict set moodText hurt [mc "Hurt"] # TRANSLATORS: Favourably affected by something or someone. dict set moodText impressed [mc "Impressed"] # TRANSLATORS: Feeling amazement at something or someone; or feeling a combination of fear and reverence. dict set moodText in_awe [mc "In awe"] # TRANSLATORS: Feeling strong affection, care, liking, or attraction. dict set moodText in_love [mc "In love"] # TRANSLATORS: Showing anger or indignation, especially at something unjust or wrong. dict set moodText indignant [mc "Indignant"] # TRANSLATORS: Showing great attention to something or someone; having or showing interest. dict set moodText interested [mc "Interested"] # TRANSLATORS: Under the influence of alcohol; drunk. dict set moodText intoxicated [mc "Intoxicated"] # TRANSLATORS: Feeling as if one cannot be defeated, overcome or denied. dict set moodText invincible [mc "Invincible"] # TRANSLATORS: Fearful of being replaced in position or affection. dict set moodText jealous [mc "Jealous"] # TRANSLATORS: Feeling isolated, empty, or abandoned. dict set moodText lonely [mc "Lonely"] # TRANSLATORS: Causing or intending to cause intentional harm; bearing ill will towards another; cruel; malicious. dict set moodText mean [mc "Mean"] # TRANSLATORS: Given to sudden or frequent changes of mind or feeling; temperamental. dict set moodText moody [mc "Moody"] # TRANSLATORS: Easily agitated or alarmed; apprehensive or anxious. dict set moodText nervous [mc "Nervous"] # TRANSLATORS: Not having a strong mood or emotional state. dict set moodText neutral [mc "Neutral"] # TRANSLATORS: Feeling emotionally hurt, displeased, or insulted. dict set moodText offended [mc "Offended"] # TRANSLATORS: Interested in play; fun, recreational, unserious, lighthearted; joking, silly. dict set moodText playful [mc "Playful"] # TRANSLATORS: Feeling a sense of one's own worth or accomplishment. dict set moodText proud [mc "Proud"] # TRANSLATORS: Feeling uplifted because of the removal of stress or discomfort. dict set moodText relieved [mc "Relieved"] # TRANSLATORS: Feeling regret or sadness for doing something wrong. dict set moodText remorseful [mc "Remorseful"] # TRANSLATORS: Without rest; unable to be still or quiet; uneasy; continually moving. dict set moodText restless [mc "Restless"] # TRANSLATORS: Feeling sorrow; sorrowful, mournful. dict set moodText sad [mc "Sad"] # TRANSLATORS: Mocking and ironical. dict set moodText sarcastic [mc "Sarcastic"] # TRANSLATORS: Without humor or expression of happiness; grave in manner or disposition; earnest; thoughtful; solemn. dict set moodText serious [mc "Serious"] # TRANSLATORS: Surprised, startled, confused, or taken aback. dict set moodText shocked [mc "Shocked"] # TRANSLATORS: Feeling easily frightened or scared; timid; reserved or coy. dict set moodText shy [mc "Shy"] # TRANSLATORS: Feeling in poor health; ill. dict set moodText sick [mc "Sick"] # TRANSLATORS: Feeling the need for sleep. dict set moodText sleepy [mc "Sleepy"] # TRANSLATORS: Suffering emotional pressure. dict set moodText stressed [mc "Stressed"] # TRANSLATORS: Experiencing a feeling caused by something unexpected. dict set moodText surprised [mc "Surprised"] # TRANSLATORS: Feeling the need to drink. dict set moodText thirsty [mc "Thirsty"] # TRANSLATORS: Thinking about unpleasant things that have happened or that might happen; feeling afraid and unhappy. dict set moodText worried [mc "Worried"] variable moodTextSmall set moodTextSmall [dict create] dict set moodTextSmall afraid [mc "afraid"] dict set moodTextSmall amazed [mc "amazed"] dict set moodTextSmall angry [mc "angry"] dict set moodTextSmall annoyed [mc "annoyed"] dict set moodTextSmall anxious [mc "anxious"] dict set moodTextSmall aroused [mc "aroused"] dict set moodTextSmall ashamed [mc "ashamed"] dict set moodTextSmall bored [mc "bored"] dict set moodTextSmall brave [mc "brave"] dict set moodTextSmall calm [mc "calm"] dict set moodTextSmall cold [mc "cold"] dict set moodTextSmall confused [mc "confused"] dict set moodTextSmall contented [mc "contented"] dict set moodTextSmall cranky [mc "cranky"] dict set moodTextSmall curious [mc "curious"] dict set moodTextSmall depressed [mc "depressed"] dict set moodTextSmall disappointed [mc "disappointed"] dict set moodTextSmall disgusted [mc "disgusted"] dict set moodTextSmall distracted [mc "distracted"] dict set moodTextSmall embarrassed [mc "embarrassed"] dict set moodTextSmall excited [mc "excited"] dict set moodTextSmall flirtatious [mc "flirtatious"] dict set moodTextSmall frustrated [mc "frustrated"] dict set moodTextSmall grumpy [mc "grumpy"] dict set moodTextSmall guilty [mc "guilty"] dict set moodTextSmall happy [mc "happy"] dict set moodTextSmall hot [mc "hot"] dict set moodTextSmall humbled [mc "humbled"] dict set moodTextSmall humiliated [mc "humiliated"] dict set moodTextSmall hungry [mc "hungry"] dict set moodTextSmall hurt [mc "hurt"] dict set moodTextSmall impressed [mc "impressed"] dict set moodTextSmall in_awe [mc "in awe"] dict set moodTextSmall in_love [mc "in love"] dict set moodTextSmall indignant [mc "indignant"] dict set moodTextSmall interested [mc "interested"] dict set moodTextSmall intoxicated [mc "intoxicated"] dict set moodTextSmall invincible [mc "invincible"] dict set moodTextSmall jealous [mc "jealous"] dict set moodTextSmall lonely [mc "lonely"] dict set moodTextSmall mean [mc "mean"] dict set moodTextSmall moody [mc "moody"] dict set moodTextSmall nervous [mc "nervous"] dict set moodTextSmall neutral [mc "neutral"] dict set moodTextSmall offended [mc "offended"] dict set moodTextSmall playful [mc "playful"] dict set moodTextSmall proud [mc "proud"] dict set moodTextSmall relieved [mc "relieved"] dict set moodTextSmall remorseful [mc "remorseful"] dict set moodTextSmall restless [mc "restless"] dict set moodTextSmall sad [mc "sad"] dict set moodTextSmall sarcastic [mc "sarcastic"] dict set moodTextSmall serious [mc "serious"] dict set moodTextSmall shocked [mc "shocked"] dict set moodTextSmall shy [mc "shy"] dict set moodTextSmall sick [mc "sick"] dict set moodTextSmall sleepy [mc "sleepy"] dict set moodTextSmall stressed [mc "stressed"] dict set moodTextSmall surprised [mc "surprised"] dict set moodTextSmall thirsty [mc "thirsty"] dict set moodTextSmall worried [mc "worried"] if {$config(mood,showall)} { set moodL $allMoods } else { set moodL $myMoods } # Sort the localized list of moods. variable sortedLocMoods [list] set moodLocL [list] foreach mood $moodL { lappend moodLocL [list $mood [dict get $moodText $mood]] } set moodLocL [lsort -dictionary -index 1 $moodLocL] foreach spec $moodLocL { lappend sortedLocMoods [lindex $spec 0] } variable menuDef # bug: this should be M&ood but this does not work! set menuDef [list cascade mMood {[mc "Mood"]...} {} {} {} {}] set subMenu [list] set opts [list -variable ::Mood::menuMoodVar -value "-"] lappend subMenu [list radio None {[mc "None"]} ::Mood::MenuCmd {} $opts] lappend subMenu {separator} foreach mood $sortedLocMoods { set label [dict get $moodText $mood] set opts [list -variable ::Mood::menuMoodVar -value $mood] lappend subMenu [list radio $mood $label ::Mood::MenuCmd {} $opts] } lappend subMenu {separator} lappend subMenu [list command mCustomMood... {[mc "&Custom Mood"]...} ::Mood::CustomMoodDlg {} {}] lset menuDef 6 $subMenu variable menuMoodVar set menuMoodVar "-" } # Mood::JabberInitHook -- # # Here we announce that we have mood support and is interested in # getting notifications. proc ::Mood::JabberInitHook {jlibname} { variable xmlns set E [list] lappend E [wrapper::createtag "identity" \ -attrlist [list category hierarchy type leaf name "User Mood"]] lappend E [wrapper::createtag "feature" \ -attrlist [list var $xmlns(mood)]] lappend E [wrapper::createtag "feature" \ -attrlist [list var $xmlns(mood+notify)]] $jlibname caps register mood $E [list $xmlns(mood) $xmlns(mood+notify)] } # Setting own mood ------------------------------------------------------------- # # Disco server for PEP, disco own bare JID, create pubsub node. # # 1) Disco server for pubsub/pep support # 2) Publish mood proc ::Mood::LoginHook {} { variable xmlns # Disco server for pubsub/pep support. set server [::Jabber::Jlib getserver] ::Jabber::Jlib pep have $server [namespace code HavePEP] ::Jabber::Jlib pubsub register_event [namespace code Event] \ -node $xmlns(mood) } proc ::Mood::HavePEP {jlibname have} { variable menuDef variable xmlns if {$have} { # Get our own published mood and fill in. # NB: I thought that this should work automatically but seems not. set myjid2 [::Jabber::Jlib myjid2] ::Jabber::Jlib pubsub items $myjid2 $xmlns(mood) \ -command [namespace code ItemsCB] ::JUI::RegisterMenuEntry action $menuDef if {[MPExists]} { [MPWin] state {!disabled} } } } proc ::Mood::LogoutHook {} { variable state ::JUI::DeRegisterMenuEntry action mMood unset -nocomplain state if {[MPExists]} { [MPWin] state {disabled} } } proc ::Mood::ItemsCB {type subiq args} { variable xmlns variable menuMoodVar variable moodMessageDlg if {$type eq "error"} { return } foreach itemsE [wrapper::getchildren $subiq] { set tag [wrapper::gettag $itemsE] set node [wrapper::getattribute $itemsE "node"] if {[string equal $tag "items"] && [string equal $node $xmlns(mood)]} { set itemE [wrapper::getfirstchildwithtag $itemsE item] set moodE [wrapper::getfirstchildwithtag $itemE mood] if {![llength $moodE]} { return } set text "" set mood "" foreach E [wrapper::getchildren $moodE] { set tag [wrapper::gettag $E] switch -- $tag { text { set moodMessageDlg [wrapper::getcdata $E] } default { set menuMoodVar $tag if {[MPExists]} { MPSetMood $tag } } } } } } } proc ::Mood::MenuCmd {} { variable menuMoodVar if {$menuMoodVar eq "-"} { Retract } else { Publish $menuMoodVar } if {[MPExists]} { MPDisplayMood $menuMoodVar } } #-------------------------------------------------------------------- proc ::Mood::Publish {mood {text ""}} { variable moodNode variable xmlns # Create Mood stanza before publish set moodChildEs [list [wrapper::createtag $mood]] if {$text ne ""} { lappend moodChildEs [wrapper::createtag text -chdata $text] } set moodE [wrapper::createtag mood \ -attrlist [list xmlns $xmlns(mood)] -subtags $moodChildEs] # NB: It is currently unclear there should be an id attribute in the item # element since PEP doesn't use it but pubsub do, and the experimental # OpenFire PEP implementation. # set itemE [wrapper::createtag item -subtags [list $moodE]] set itemE [wrapper::createtag item \ -attrlist [list id current] -subtags [list $moodE]] ::Jabber::Jlib pep publish $xmlns(mood) $itemE } proc ::Mood::Retract {} { variable xmlns ::Jabber::Jlib pep retract $xmlns(mood) -notify 1 } #-------------------------------------------------------------- #----------------- UI for Custom Mood Dialog ------------------ #-------------------------------------------------------------- proc ::Mood::CustomMoodDlg {} { variable sortedLocMoods variable menuMoodVar variable moodMessageDlg variable moodStateDlg variable moodText set moodStateDlg $menuMoodVar set moodMessageDlg "" set w [ui::dialog -message [mc "Select your mood to show to your contacts."] -detail [mc "Only contacts with compatible software will see your mood."] \ -buttons {ok cancel remove} -icon info \ -modal 1 -geovariable ::prefs(winGeom,customMood) \ -title [mc "Custom Mood"] -command [namespace code CustomCmd]] set fr [$w clientframe] set mDef [list] lappend mDef [list [mc "None"] -value "-"] lappend mDef [list separator] foreach mood $sortedLocMoods { set label [dict get $moodText $mood] lappend mDef [list [mc $label] -value $mood \ -image [::Theme::FindIconSize 16 mood-$mood]] } set label "[string map {& ""} [mc Mood]]:" ttk::label $fr.lmood -text $label ui::optionmenu $fr.cmood -menulist $mDef -direction flush \ -variable [namespace current]::moodStateDlg ttk::label $fr.ltext -text [mc "Message"]: ttk::entry $fr.etext -textvariable [namespace current]::moodMessageDlg grid $fr.lmood $fr.cmood -sticky e -pady 2 grid $fr.ltext $fr.etext -sticky e -pady 2 grid $fr.cmood $fr.etext -sticky ew grid columnconfigure $fr 1 -weight 1 bind $fr.cmood { focus %W } set mbar [::JUI::GetMainMenu] ui::dialog defaultmenu $mbar ::UI::MenubarDisableBut $mbar edit $w grab ::UI::MenubarEnableAll $mbar } proc ::Mood::CustomCmd {w bt} { variable moodStateDlg variable moodMessageDlg variable menuMoodVar if {$bt eq "ok"} { if {$moodStateDlg eq "-"} { Retract } else { Publish $moodStateDlg $moodMessageDlg } set menuMoodVar $moodStateDlg if {[MPExists]} { MPSetMood $moodStateDlg } } elseif {$bt eq "remove"} { Retract set menuMoodVar - if {[MPExists]} { MPSetMood - } } } # Mood::Event -- # # Mood event handler for incoming mood messages. proc ::Mood::Event {jlibname xmldata} { variable state variable xmlns variable moodTextSmall # The server MUST set the 'from' address on the notification to the # bare JID () of the account owner. set from [wrapper::getattribute $xmldata from] set eventE [wrapper::getfirstchildwithtag $xmldata event] if {[llength $eventE]} { set itemsE [wrapper::getfirstchildwithtag $eventE items] if {[llength $itemsE]} { set node [wrapper::getattribute $itemsE node] if {$node ne $xmlns(mood)} { return } set mjid [jlib::jidmap $from] set text "" set mood "" set retractE [wrapper::getfirstchildwithtag $itemsE retract] if {[llength $retractE]} { set msg "" set state($mjid,mood) "" set state($mjid,text) "" } else { set itemE [wrapper::getfirstchildwithtag $itemsE item] set moodE [wrapper::getfirstchildwithtag $itemE mood] if {![llength $moodE]} { return } foreach E [wrapper::getchildren $moodE] { set tag [wrapper::gettag $E] switch -- $tag { text { set text [wrapper::getcdata $E] } default { set mood $tag } } } # Cache the result. set state($mjid,mood) $mood set state($mjid,text) $text if {$mood eq ""} { set msg "" } else { set mstr [string map {& ""} [mc "Mood"]] set msg "$mstr: [dict get $moodTextSmall $mood] $text" } } ::RosterTree::BalloonRegister mood $from $msg ::hooks::run moodEvent $xmldata $mood $text } } } #--- Mega Presence Hook -------------------------------------------------------- namespace eval ::Mood { set label [string map {& ""} [mc "Mood"]] ::MegaPresence::Register mood $label [namespace code MPBuild] variable imsize 16 variable mpwin "-" variable imblank set imblank [image create photo -height $imsize -width $imsize] $imblank blank } proc ::Mood::MPBuild {win} { variable imsize variable imblank variable mpwin variable mpMood variable sortedLocMoods variable moodText set mpwin $win ttk::menubutton $win -style SunkenMenubutton \ -image $imblank -compound image set m $win.m menu $m -tearoff 0 $win configure -menu $m $win state {disabled} $m add radiobutton -label [mc "None"] -value "-" \ -variable [namespace current]::mpMood \ -command [namespace code MPCmd] $m add separator foreach mood $sortedLocMoods { set label [dict get $moodText $mood] $m add radiobutton -label [mc $label] -value $mood \ -image [::Theme::FindIconSize $imsize mood-$mood] \ -variable [namespace current]::mpMood \ -command [namespace code MPCmd] -compound left } $m add separator $m add command -label [string map {& ""} [mc "&Custom Mood"]...] \ -command [namespace code CustomMoodDlg] set mpMood "-" return } proc ::Mood::MPCmd {} { variable mpMood variable menuMoodVar if {$mpMood eq "-"} { Retract } else { Publish $mpMood "" } set menuMoodVar $mpMood MPDisplayMood $mpMood } proc ::Mood::MPDisplayMood {mood} { variable imsize variable mpwin variable imblank variable moodTextSmall set mstr [string map {& ""} [mc "Mood"]] if {$mood eq "-"} { $mpwin configure -image $imblank set msg "$mstr: " append msg [mc "None"] ::balloonhelp::balloonforwindow $mpwin $msg } else { $mpwin configure -image [::Theme::FindIconSize $imsize mood-$mood] ::balloonhelp::balloonforwindow $mpwin "$mstr: [dict get $moodTextSmall $mood]" } } proc ::Mood::MPSetMood {mood} { variable mpMood set mpMood $mood MPCmd } proc ::Mood::MPExists {} { variable mpwin return [winfo exists $mpwin] } proc ::Mood::MPWin {} { variable mpwin return $mpwin } # Test if {0} { set xmlns(mood) "http://jabber.org/protocol/mood" proc cb {args} {puts "---> $args"} set jlib ::jlib::jlib1 set myjid2 [$jlib myjid2] $jlib pubsub items $myjid2 $xmlns(mood) $jlib disco send_get items $myjid2 cb $jlib pep retract $xmlns(mood) } #------------------------------------------------------------------------------- coccinella-0.96.20/components/Notifier.tcl000066400000000000000000000106611167435367600204620ustar00rootroot00000000000000# Notifier.tcl -- # # Notifies the user of certain events when application is in the # background. # This is just a first sketch. # # Copyright (c) 2007 Mats Bengtsson # # 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 3 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, see . # # $Id: Notifier.tcl,v 1.12 2008-06-09 09:50:59 matben Exp $ namespace eval ::Notifier { # Use this on windows only. if {![string equal $::this(platform) "windows"]} { return } if {[catch {package require notebox}]} { return } component::define Notifier \ "Provides a small event notifier window." } proc ::Notifier::Init {} { global this component::register Notifier # Add event hooks. ::hooks::register prefsInitHook [namespace current]::InitPrefsHook ::hooks::register newMessageHook [namespace current]::MessageHook ::hooks::register newChatThreadHook [namespace current]::ThreadHook ::hooks::register presenceNewHook [namespace current]::PresenceHook ::hooks::register fileTransferReceiveHook [namespace current]::FileTransferRecvHook set im [::Theme::FindIcon elements/close] option add *Notebox.closeButtonImage $im widgetDefault option add *Notebox.millisecs 10000 widgetDefault } proc ::Notifier::InitPrefsHook {} { global jprefs set jprefs(notifier,state) 0 ::PrefUtils::Add [list \ [list jprefs(notifier,state) jprefs_notifier_state $jprefs(notifier,state)]] } proc ::Notifier::MessageHook {xmldata uuid} { set body [wrapper::getcdata [wrapper::getfirstchildwithtag $xmldata body]] if {![string length $body]} { return } set from [wrapper::getattribute $xmldata from] set djid [::Roster::GetDisplayName $from] set str "You just received a new message from $djid" after 200 [list ::Notifier::DisplayMsg $str] } proc ::Notifier::ThreadHook {xmldata} { if {![::UI::IsAppInFront]} { set body [wrapper::getcdata [wrapper::getfirstchildwithtag $xmldata body]] if {![string length $body]} { return } set from [wrapper::getattribute $xmldata from] set djid [::Roster::GetDisplayName $from] set str "The user $djid just started a new chat thread" after 200 [list ::Notifier::DisplayMsg $str] } } proc ::Notifier::PresenceHook {jid type args} { if {![::UI::IsAppInFront]} { set delay [::Jabber::Jlib roster getx $jid "jabber:x:delay"] if {$delay ne ""} { return } if {[::Jabber::Jlib service isroom $jid]} { return } set wasavail [::Jabber::Jlib roster wasavailable $jid] set isavail [expr {$type eq "available"}] if {(!$wasavail && $isavail) || ($wasavail && !$isavail)} { array set argsA $args set show $type if {[info exists argsA(-show)]} { set show $argsA(-show) } set status "" if {[info exists argsA(-status)]} { set status $argsA(-status) } # This just translates the show code into a readable text. set showMsg [::Roster::MapShowToText $show] set djid [::Roster::GetDisplayName $jid] set msg "$djid $showMsg" if {$status ne ""} { append msg "\n$status" } after 200 [list ::Notifier::DisplayMsg $msg] } } } proc ::Notifier::FileTransferRecvHook {jid name size} { if {![::UI::IsAppInFront]} { set str "\n" append str [mc "File"] append str ": $name\n" append str [mc "Size"] append str ": [::Utils::FormatBytes $size]\n" set djid [::Roster::GetDisplayName $jid] set msg [mc "%s wants to send you this file: %s Do you want to receive this file?" $djid $str] after 200 [list ::Notifier::DisplayMsg $str] } } proc ::Notifier::DisplayMsg {str} { global jprefs # @@@ ::UI::IsAppInFront is not reliable... if {$jprefs(notifier,state) && ![::UI::IsAppInFront]} { ::notebox::addmsg $str } } #------------------------------------------------------------------------------- coccinella-0.96.20/components/NotifyCall.tcl000066400000000000000000000076711167435367600207560ustar00rootroot00000000000000#agents NotifyCall.tcl -- # # NotifyCall is an Dialog Window with Inbound calls notifications # # Copyright (c) 2007 Mats Bengtsson # # 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 3 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, see . # namespace eval ::NotifyCall { return component::define NotifyCall \ "Provides support for Incoming Calls Dialog" } proc ::NotifyCall::Init {} { return component::register NotifyCall ::hooks::register jivePhoneEvent ::NotifyCall::JivePhoneEventHook ::hooks::register IAXPhoneEvent ::NotifyCall::IAXPhoneEventHook #--------------- Variables Uses For SpeedDial Addressbook Tab ---------------- InitState } proc ::NotifyCall::InitState { } { variable state array set state { win .notify } } #----------------------------------------------------------------------- #--------------------------- Notify Call Window ------------------------ #----------------------------------------------------------------------- # NotifyCall::InboundCall -- # proc ::NotifyCall::InboundCall { {phoneNumber ""} } { variable state set win $state(win) if { $phoneNumber ne "" } { BuildDialer $win $phoneNumber } } # NotifyCall::BuildDialer -- # # A toplevel dialer. proc ::NotifyCall::BuildDialer {w phoneNumber } { variable state # Make sure only single instance of this dialog. if {[winfo exists $w]} { raise $w return } ::UI::Toplevel $w -class PhoneNotify \ -usemacmainmenu 1 -macstyle documentProc -macclass {document closeBox} \ -closecommand ::NotifyCall::CloseDialer wm title $w [mc "Notify Call"] ::UI::SetWindowPosition $w # Global frame. ttk::frame $w.f pack $w.f -fill x set msg [mc "Inbound Call"] append msg ": $phoneNumber" ttk::label $w.f.head -style Headlabel -text $msg pack $w.f.head -side top -fill both -expand 1 ttk::separator $w.f.s -orient horizontal pack $w.f.s -side top -fill x set wbox $w.f.f ttk::frame $wbox -padding [option get . dialogPadding {}] pack $wbox -fill both -expand 1 set box $wbox.b ttk::frame $box pack $box -side bottom -fill x # ttk::label $box.l -text [mc "Number"]: # ttk::entry $box.e -textvariable [namespace current]::phoneNumber \ # -width 18 ttk::button $box.hungup -text [mc "Hung Up"] \ -command [list [namespace current]::HungUp $w ] ttk::button $box.vm -text [mc "Call VM?"] \ -command [list [namespace current]::HungUp $w ] # grid $box.l $box.e $box.dial -padx 1 -pady 4 grid $box.hungup $box.vm -padx 1 -pady 4 focus $box.hungup wm resizable $w 0 0 } proc ::NotifyCall::CloseDialer {w} { # ::UI::SaveWinGeom $w } proc ::NotifyCall::HungUp {w } { eval {::JivePhone::DialExtension "666" "FORWARD"} destroy $w } proc ::NotifyCall::JivePhoneEventHook {type ext cid args} { variable cociFile variable state set win $state(win) if {$type eq "RING"} { InboundCall $cid } else { if {[winfo exists $win]} { destroy $win } } } proc ::NotifyCall::IAXPhoneEventHook {type cid args} { variable state set win $state(win) if {$type eq "RING"} { InboundCall $cid } else { if {[winfo exists $win]} { destroy $win } } } coccinella-0.96.20/components/NotifyOnline.tcl000066400000000000000000000057561167435367600213310ustar00rootroot00000000000000# NotifyOnline.tcl --- # # This file is part of The Coccinella application. # It is an experiment to set login/logout to web service. # # Copyright (c) 2006 Mats Bengtsson # # 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 3 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, see . # # $Id: NotifyOnline.tcl,v 1.5 2008-08-17 07:01:04 matben Exp $ package require http namespace eval ::NotifyOnline { return component::define NotifyOnline \ "Does http actions as a response to login/logout." # So far only logout (and quit). set url "http://www.evaal.com/index.php" set ::config(notifyonline,do) 0 set ::config(notifyonline,url) $url } proc ::NotifyOnline::Init {} { ::Debug 2 "::NotifyOnline::Init" component::register NotifyOnline # Let any custom config override component registration. ::hooks::register initHook ::NotifyOnline::InitHook } proc ::NotifyOnline::InitHook {} { global config if {$config(notifyonline,do)} { component::register NotifyOnline ::hooks::register loginHook ::NotifyOnline::LoginHook ::hooks::register logoutHook ::NotifyOnline::LogoutHook ::hooks::register preQuitAppHook ::NotifyOnline::PreQuitHook ::hooks::register setPresenceHook ::NotifyOnline::PresenceHook } } proc ::NotifyOnline::LoginHook {} { # empty return } proc ::NotifyOnline::LogoutHook {} { PostLogout return } proc ::NotifyOnline::PreQuitHook {} { if {[::Jabber::IsConnected]} { PostLogout } return } proc ::NotifyOnline::PresenceHook {type args} { array set argsArr $args if {![info exists argsArr(-to)] && ($type eq "invisible")} { PostLogout } return } proc ::NotifyOnline::PostLogout {args} { global config ::Debug 2 "::NotifyOnline::PostLogout" set url $config(notifyonline,url) set jid [::Jabber::GetMyJid] #set query [::http::formatQuery user $jid] set query [::http::formatQuery act expert] # Can't currently not fo this async during quit. catch { ::http::geturl $url -query $query #-command [namespace current]::Command } } proc ::NotifyOnline::Command {token} { upvar #0 $token state # Investigate 'state' for any exceptions. set status [::http::status $token] ::Debug 2 "::NotifyOnline::Command status=$status" ::http::cleanup $token } #------------------------------------------------------------------------------- coccinella-0.96.20/components/ParseStyledText.tcl000066400000000000000000000045551167435367600220140ustar00rootroot00000000000000# ParseStyledText.tcl --- # # This file is part of The Coccinella application. # It implements simplified text font style parsing in messages. # # Copyright (c) 2005 Mats Bengtsson # # 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 3 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, see . # # $Id: ParseStyledText.tcl,v 1.8 2007-11-17 07:40:52 matben Exp $ namespace eval ::ParseStyledText { component::define ParseStyledText \ "Simplified text font style parsing: *bold*, /italic/, and _underline_." } proc ::ParseStyledText::Init {} { component::register ParseStyledText # Add event hooks. ::hooks::register textParseWordHook [namespace code ParseWordHook] ::pipes::register htmlParseWordPipe [namespace code ParseWordPipe] variable parse set parse { {^\*(.+)\*$} -weight bold tbold {^/(.+)/$} -slant italic titalic {^_(.+)_$} -underline 1 tunderline } variable phtml set phtml { {^\*(.+)\*$} {\1} {^/(.+)/$} {\1} {^_(.+)_$} {\1} } } proc ::ParseStyledText::ParseWordPipe {type jid word} { variable phtml foreach {re sub} $phtml { if {[regsub -- $re $word $sub word]} { return $word } } return $word } proc ::ParseStyledText::ParseWordHook {type jid w word tagList} { variable parse set handled "" foreach {re name value ftag} $parse { if {[regexp $re $word m new]} { set font "" foreach tag $tagList { set font [$w tag cget $tag -font] if {$font ne ""} { break } } if {$font ne ""} { array set fopts [font actual $font] set fopts($name) $value $w tag configure $ftag -font [array get fopts] $w insert insert $new [concat $tagList $ftag] } set handled stop break } } return $handled } coccinella-0.96.20/components/ParseURI.tcl000066400000000000000000000415001167435367600203310ustar00rootroot00000000000000# ParseURI.tcl -- # # Parses and executes any -uri xmpp:jid[?query] command line option. # typically from an anchor element # in a html page. # # Reference: # RFC 4622 # Internationalized Resource Identifiers (IRIs) # and Uniform Resource Identifiers (URIs) for # the Extensible Messaging and Presence Protocol (XMPP) # # A citation: # # xmppuri = "xmpp" ":" hierxmpp [ "?" querycomp ] [ "#" fragment ] # hierxmpp = authpath / pathxmpp OR # authpath = "//" authxmpp [ "/" pathxmpp ] # authxmpp = nodeid "@" host # pathxmpp = [ nodeid "@" ] host [ "/" resid ] # ... # querycomp = querytype [ *pair ] # querytype = *( unreserved / pct-encoded ) # pair = ";" key "=" value # key = *( unreserved / pct-encoded ) # value = *( unreserved / pct-encoded ) # # Example: # # The following XMPP IRI/URI signals the processing application to # authenticate as "guest@example.com" and to send a message to # "support@example.com": # # xmpp://guest@example.com/support@example.com?message # # By contrast, the following XMPP IRI/URI signals the processing # application to authenticate as its configured default account and to # send a message to "support@example.com": # # xmpp:support@example.com?message # # Reference: # RFC 3860 # Common Profile for Instant Messaging (CPIM) # # The syntax follows the existing mailto: URI syntax specified in RFC # 2368. The ABNF is: # # IM-URI = "im:" [ to ] [ headers ] # to = mailbox # headers = "?" header *( "&" header ) # header = hname "=" hvalue # ... # # Reference: # XMPP URI/IRI Querytypes # XEP-0147: XMPP URI Scheme Query Components # # Copyright (c) 2007 Mats Bengtsson # # 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 3 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, see . # # $Id: ParseURI.tcl,v 1.50 2008-06-09 09:50:59 matben Exp $ package require uriencode namespace eval ::ParseURI { component::define ParseURI "Command line XMPP uri parsing and processing" variable uid 0 } proc ::ParseURI::Init {} { ::Debug 2 "::ParseURI::Init" ::hooks::register launchFinalHook ::ParseURI::Parse ::hooks::register relaunchHook ::ParseURI::RelaunchHook # A bit simplified xmpp URI. ::Text::RegisterURI {^xmpp:.+} ::ParseURI::TextCmd ::Text::RegisterURI {^im:.+} ::ParseURI::TextCmd component::register ParseURI } proc ::ParseURI::TextCmd {uri} { Parse -uri $uri } # ParseURI::Parse -- # # Uses any -uri in the command line and process it accordingly. proc ::ParseURI::Parse {args} { global argv jprefs variable uid if {$args eq {}} { set args $argv } set idx [lsearch $args -uri] if {$idx < 0} { return } set uri [lindex $args [incr idx]] set uri [::uri::urn::unquote $uri] ::Debug 2 "::ParseURI::Parse uri=$uri" # Actually parse the uri. set xmppRE {^xmpp:([^\?#]+)(\?([^;#]+)){0,1}(;([^#]+)){0,1}(#(.+)){0,1}$} set imRE {^im:([^\?]+)(\?(.+)){0,1}$} if {[regexp $xmppRE $uri - hierxmpp - iquerytype - querypairs - fragment]} { set type xmpp # authpath = "//" authxmpp [ "/" pathxmpp ] set RE {^//([^/]+)/(.+$)} if {![regexp $RE $hierxmpp - authxmpp pathxmpp]} { set authxmpp "" set pathxmpp $hierxmpp } set querylist [list] foreach sub [split $querypairs ";"] { foreach {key value} [split $sub =] {break} lappend querylist $key $value } } elseif {[regexp $imRE $uri - mailbox - headers]} { # Interpret this in terms of the xmpp format. set type im set authxmpp "" set pathxmpp $mailbox set iquerytype message set fragment "" set querypairs $headers set querylist [list] foreach sub [split $querypairs "&"] { foreach {key value} [split $sub =] {break} lappend querylist $key $value } } else { ::Debug 2 "\t regexp failed" return } set jid $pathxmpp jlib::splitjid $jid jid2 resource # Initialize the state variable, an array, that keeps is the storage. set token [namespace current]::[incr uid] variable $token upvar 0 $token state set state(uri) $uri set state(pathxmpp) $pathxmpp set state(jid) $jid set state(jid2) $jid2 set state(resource) $resource set state(authxmpp) $authxmpp set state(iquerytype) $iquerytype set state(querypairs) $querypairs set state(fragment) $fragment foreach {key value} $querylist { set state(query,$key) $value } if {$authxmpp eq ""} { # Use our default profile account. # Keep our own JID apart from JID in uri! set name [::Profiles::GetSelectedName] set authDomain [::Profiles::Get $name domain] set authNode [::Profiles::Get $name node] set password [::Profiles::Get $name password] set state(profname) $name set state(authNode) $authNode set state(authDomain) $authDomain } else { # We are given a bare JID. Try find matching profile if any. set name [::Profiles::FindProfileNameFromJID $authxmpp] set state(profname) $name jlib::splitjidex $authxmpp authNode authDomain - set state(authNode) $authNode set state(authDomain) $authDomain if {$name ne {}} { set password [::Profiles::Get $name password] } else { set password "" } } if {[::Jabber::IsConnected]} { # How to treat any authxmpp? ProcessURI $token } elseif {$jprefs(autoLogin)} { # Wait until logged in. ::hooks::register loginHook [list ::ParseURI::LoginHook $token] } else { set profname $state(profname) variable ans "ok" if {$password eq ""} { set w [ui::dialog -message [mc "Enter the password for your account %s" $state(jid)] \ -icon info -type okcancel -modal 1 \ -variable [namespace current]::ans] set fr [$w clientframe] ttk::entry $fr.e -show {*} \ -textvariable [namespace current]::password pack $fr.e -side top -fill x $w grab } if {$ans eq "ok"} { array set optsArr [::Profiles::Get $profname options] if {[info exists optsArr(-resource)] && ($optsArr(-resource) ne "")} { set res $optsArr(-resource) } else { set res "coccinella" } array set optsArr [::Profiles::Get $profname options] # We may override or set some of these options using specific # query key-value pairs from the uri. foreach key {sasl ssl priority invisible ip} { if {[info exists state(query,$key)]} { set optsArr(-$key) $state(query,$key) } } # Use a "high-level" login application api for this. eval {::Login::HighLogin $authDomain $authNode $res $password \ [list [namespace current]::LoginCB $token]} [array get optsArr] } else { Free $token } unset -nocomplain ans } } # Note that we have got two tokens here, the first one our own, # the second from the login. proc ::ParseURI::LoginCB {token htoken {errcode ""} {errmsg ""}} { if {$errcode eq ""} { ProcessURI $token } } proc ::ParseURI::LoginHook {token} { ::hooks::deregister loginHook ::ParseURI::LoginHook ProcessURI $token } proc ::ParseURI::RelaunchHook {args} { eval {Parse} $args } proc ::ParseURI::ProcessURI {token} { variable $token upvar 0 $token state ::Debug 2 "::ParseURI::ProcessURI iquerytype=$state(iquerytype)" switch -- $state(iquerytype) { disco - invite - join - message - probe - pubsub - recvfile - register - remove - roster - sendfile - subscribe - unregister - unsubscribe - vcard { Do[string totitle $state(iquerytype)] $token } } } proc ::ParseURI::DoDisco {token} { variable $token upvar 0 $token state set node "" set request info set type get set opts [list] foreach {key value} [array get state query,*] { switch -- $key { query,node { lappend opts -node $value } query,request { set request $value } query,type { set type $value } } } set cmd ::ParseURI::Noop if {$type eq "get"} { eval {::Jabber::Jlib disco send_get $request $cmd $state(jid)} $opts } else { # Not implemented } Free $token } proc ::ParseURI::DoInvite {token} { # Description: enables simultaneously joining a groupchat room and # inviting others. HandleJoinGroupchat $token } proc ::ParseURI::DoJoin {token} { HandleJoinGroupchat $token } # This is old code where we first disco. This stage is now skipped. proc ::ParseURI::DoJoinBU {token} { variable $token upvar 0 $token state upvar ::Jabber::jstate jstate ::Debug 2 "::ParseURI::DoJoin" # Get groupcat service from room. jlib::splitjidex $state(jid) roomname service res set state(service) $service set state(discocmd) [list ::ParseURI::DiscoInfoHook $token] # We should check if we've got info before setting up the hooks. if {[set pathA([incr i]) disco isdiscoed info $service]} { DiscoInfoHook $token result $service {} } else { # These must be one shot hooks. ::hooks::register discoInfoHook $state(discocmd) } } proc ::ParseURI::DiscoInfoHook {token type from subiq args} { variable $token upvar 0 $token state if {![jlib::jidequal $from $state(service)]} { return } HandleJoinGroupchat $token } proc ::ParseURI::HandleJoinGroupchat {token} { variable $token upvar 0 $token state ::Debug 2 "::ParseURI::HandleJoinGroupchat................" ::Debug 2 "state=[array get state]" # We require a nick name (resource part). set state(nick) $state(resource) if {$state(nick) eq ""} { variable ans set str [mc "Please enter your desired nickname for the chatroom %s" $state(jid2)] set w [ui::dialog -message $str -title [mc "Nickname"] \ -icon info -type okcancel -modal 1 \ -variable [namespace current]::ans] set fr [$w clientframe] ttk::label $fr.l -text [mc "Nickname"]: ttk::entry $fr.e -textvariable $token\(nick) pack $fr.l -side left pack $fr.e -side top -fill x $w grab if {($ans ne "ok") || ($state(nick) eq "")} { Free $token return } unset -nocomplain ans } # We brutaly assumes muc room here. set opts [list] if {[info exists state(query,password)]} { lappend opts -password $state(query,password) } eval {::Enter::EnterRoom $state(jid2) $state(nick) \ -command [list [namespace current]::EnterRoomCB $token]} $opts } proc ::ParseURI::EnterRoomCB {token type args} { variable $token upvar 0 $token state ::Debug 2 "::ParseURI::EnterRoomCB" if {![string equal $type "error"]} { if {$state(iquerytype) eq "invite"} { if {[info exists state(query,jid)]} { set tojid $state(query,jid) jlib::splitjid $state(jid) roomjid res ::Jabber::Jlib muc invite $roomjid $tojid } # Check that this is actually a whiteboard. } elseif {[info exists state(query,xmlns)] && \ [string equal $state(query,xmlns) "whiteboard"]} { if {[::Jabber::HaveWhiteboard]} { ::JWB::NewWhiteboardTo $state(jid2) -type groupchat } } } Free $token } proc ::ParseURI::DoMessage {token} { variable $token upvar 0 $token state set opts [list] set type normal foreach {key value} [array get state query,*] { switch -- $key { query,body { lappend opts -message $value } query,from { lappend opts -from $value } query,subject { lappend opts -subject $value } query,thread { lappend opts -thread $value } query,type { set type $value } } } switch -- $type { normal { eval {::NewMsg::Build -to $state(jid)} $opts } chat { eval {::Chat::StartThread $state(jid)} $opts } groupchat { # Not implemented since I don't understand it. Enter room first? } } Free $token } proc ::ParseURI::DoProbe {token} { variable $token upvar 0 $token state ::Jabber::Jlib send_presence -to $state(jid) -type "probe" Free $token } proc ::ParseURI::DoPubsub {token} { variable $token upvar 0 $token state set opts [list] set action subscribe foreach {key value} [array get state query,*] { switch -- $key { query,action { set action $value } query,node { lappend opts -node $value } } } if {![regexp {^(subscribe|unsubscribe)$} $action]} { Free $token return } set myjid [::Jabber::Jlib myjid] set myjid2 [jlib::barejid $myjid] eval {::Jabber::Jlib pubsub $action $state(jid) $myjid2} $opts Free $token } # set uri [jlib::ftrans::uri mari@jabber.se/z /Users/matben/Desktop/splash.svg image/svg] proc ::ParseURI::DoRecvfile {token} { variable $token upvar 0 $token state # xmpp:romeo@montague.net/orchard?recvfile;sid=pub234;mime-type=text%2Fplain;name=reply.txt;size=2048 array set queryA [ExtractKeyValuePairs $token] # Without a 'sid' we can't continue. if {![info exists queryA(sid)]} { Free $token return } # We do a sipub request to get the file. ::Jabber::Jlib sipub start $state(jid) $queryA(sid) \ [namespace code [list DoRecvfileCB $token]] } proc ::ParseURI::DoRecvfileCB {token type startingE} { global prefs variable $token upvar 0 $token state # Some basic error checking. if {[wrapper::gettag $startingE] ne "starting"} { Free $token return } if {$type eq "result"} { set sid [wrapper::getattribute $startingE sid] set queryA(name) "" array set queryA [ExtractKeyValuePairs $token] set userDir [::Utils::GetDirIfExist $prefs(userPath)] set fileName [tk_getSaveFile -title [mc "Save File"] \ -initialfile $queryA(name) -initialdir $userDir] if {$fileName ne ""} { set prefs(userPath) [file dirname $fileName] set fd [open $fileName w] set dlgtoken [::FTrans::ObjectReceive $state(jid) $fileName $queryA(size)] # We shall be prepared to get the si-set request. ::Jabber::Jlib sipub set_accept_handler $sid \ -channel $fd \ -progress [list ::FTrans::TProgress $dlgtoken] \ -command [list ::FTrans::TCommand $dlgtoken] } } else { ui::dialog -icon error -message "" } Free $token } proc ::ParseURI::DoRegister {token} { variable $token upvar 0 $token state ::GenRegister::NewDlg -server $state(jid) -autoget 1 Free $token } proc ::ParseURI::DoRemove {token} { variable $token upvar 0 $token state ::Jabber::Jlib roster send_remove $state(jid) Free $token } proc ::ParseURI::DoRoster {token} { variable $token upvar 0 $token state set opts [list] foreach {key value} [array get state query,*] { switch -- $key { query,group { lappend opts -groups [list $value] } query,name { lappend opts -name $value } } } eval {::Jabber::Jlib roster send_set $state(jid)} $opts Free $token } proc ::ParseURI::DoSendfile {token} { variable $token upvar 0 $token state ::FTrans::Send $state(jid) Free $token } proc ::ParseURI::DoSubscribe {token} { variable $token upvar 0 $token state ::Jabber::Jlib roster send_set $state(jid) ::Jabber::Jlib send_presence -to $state(jid) -type "subscribe" Free $token } proc ::ParseURI::DoUnregister {token} { variable $token upvar 0 $token state ::Register::Remove $state(jid) Free $token } proc ::ParseURI::DoUnsubscribe {token} { variable $token upvar 0 $token state ::Jabber::Jlib send_presence -to $state(jid) -type "unsubscribe" Free $token } proc ::ParseURI::DoVcard {token} { variable $token upvar 0 $token state ::VCard::Fetch "other" $state(jid) Free $token } proc ::ParseURI::ExtractKeyValuePairs {token} { variable $token upvar 0 $token state set keyValueL [list] foreach {key value} [array get state query,*] { set bkey [string map [list "query," ""] $key] lappend keyValueL $bkey $value } return $keyValueL } proc ::ParseURI::Noop {args} { } proc ::ParseURI::Free {token} { variable $token upvar 0 $token state unset -nocomplain state } #------------------------------------------------------------------------------- coccinella-0.96.20/components/Phone/000077500000000000000000000000001167435367600172445ustar00rootroot00000000000000coccinella-0.96.20/components/Phone/AddressBook.tcl000066400000000000000000000542441167435367600221610ustar00rootroot00000000000000# AddressBook.tcl -- # # AddressBook for phone system (Jive and Soft-Phone) # # Copyright (c) 2006 Mats Bengtsson # Copyright (c) 2006 Antonio Cano damas # # 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 3 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, see . # # $Id: AddressBook.tcl,v 1.15 2008-06-09 09:50:59 matben Exp $ namespace eval ::AddressBook { #component::define AddressBook "Address book for softphones" } proc ::AddressBook::Init {} { #component::register AddressBook # Add event hooks. ############################# Direct from Phone User Interface ############################# ::hooks::register phoneInit ::AddressBook::NewPage #--------------- Variables Uses For SpeedDial Addressbook Tab ---------------- variable wtab - variable abline variable popMenuDef # Standard widgets and standard options. option add *AddressBook.borderWidth 0 50 option add *AddressBook.relief flat 50 option add *AddressBook*box.borderWidth 1 50 option add *AddressBook*box.relief sunken 50 option add *AddressBook.padding 2 50 option add *AddressBook.addressBook16Image view-history widgetDefault option add *AddressBook.addressBook16DisImage view-history-Dis widgetDefault } #--------------------------------------------------------------------------- #------------------- Addressbook SpeedDial Tab User Interface -------------- #--------------------------------------------------------------------------- proc ::AddressBook::CloseAddressBook {} { variable wtab if {[winfo exists $wtab]} { set wnb [::JUI::GetNotebook] $wnb forget $wtab destroy $wtab } } proc ::AddressBook::NewPage {} { variable wtab variable popMenuDef set popMenuDef(addressbook,def) { mCall phone {[mc "&Call"]...} {::AddressBook::DialExtension $phone} separator {} {} {} mNewAB phone {[mc "New"]} {::AddressBook::NewAddressbookDlg} mModifyAB phone {[mc "Modify"]} {::AddressBook::ModifyAddressbookDlg $phone} mRemoveAB phone {[mc "Remove"]} {::AddressBook::RemoveAddressbookDlg $phone} } set popMenuDef(log,def) { mRedial phone {[mc "&Call"]...} {::AddressBook::DialExtension $phone} separator {} {} {} mToAB phone {[mc "Add to Address Book"]...} {::AddressBook::NewAddressbookDlg $phone} } set popMenuDef(call) { mCall phone {[mc "&Call"]...} {::AddressBook::DialExtension $phone} } set popMenuDef(redial) { mRedial phone {[mc "Redial"]} {::AddressBook::DialExtension $phone} } set popMenuDef(forward) { mForward phone {[mc "Forward Call"]} {::AddressBook::TransferExtension $phone} } set wnb [::JUI::GetNotebook] set wtab $wnb.ab if {![winfo exists $wtab]} { Build $wtab set im [::Theme::Find16Icon $wtab addressBook16Image] set imd [::Theme::Find16Icon $wtab addressBook16DisImage] set imSpec [list $im disabled $imd background $imd] $wnb add $wtab -text [mc "Address Book"] -image $imSpec -compound image } } # AddressBook::Build -- # # This is supposed to create a frame which is pretty object like, # and handles most stuff internally without intervention. # # Arguments: # w frame for everything # args # # Results: # w proc ::AddressBook::Build {w args} { global prefs this jprefs variable waddressbook variable wtree variable wwave upvar ::Jabber::jstate jstate upvar ::Jabber::jserver jserver variable abline ::Debug 2 "::AddressBook::Build w=$w" set jstate(wpopup,addressbook) .jpopupab set waddressbook $w set wbox $w.box set wtree $wbox.tree set wxsc $wbox.xsc set wysc $wbox.ysc # The frame. ttk::frame $w -class AddressBook # D = -border 1 -relief sunken frame $wbox pack $wbox -side top -fill both -expand 1 ttk::scrollbar $wxsc -orient horizontal -command [list $wtree xview] ttk::scrollbar $wysc -orient vertical -command [list $wtree yview] ::ITree::New $wtree $wxsc $wysc \ -buttonpress ::AddressBook::Popup \ -buttonpopup ::AddressBook::Popup grid $wtree -row 0 -column 0 -sticky news grid $wysc -row 0 -column 1 -sticky ns grid $wxsc -row 1 -column 0 -sticky ew grid columnconfigure $wbox 0 -weight 1 grid rowconfigure $wbox 0 -weight 1 # below two lines create exception when called, because of missing second parameter in first line #set iconImage [::Theme::Find16Icon icons/16x16/view-history] #set opts {-text AddressBook -button 1 -image $iconImage -open 1} set opts {-text AddressBook -button 1 -open 1} eval {::ITree::Item $wtree "AddressBook"} $opts #--------- Load Entries of AddressBook into NewPage Tab -------- LoadEntries if { $abline ne "" } { foreach {name phone} $abline { if {$name ne ""} { set opts {-text "$name $phone" -button 0 -open 0} set v [list "AddressBook" $phone] if { [::ITree::IsItem $wtree $v] == 0 } { eval {::ITree::Item $wtree $v} $opts } } } } #--------- Include Logs Categories --------- set iconImage [::Theme::FindIconSize 16 phone-received] set opts {-text Received -button 1 -image $iconImage -open 1} eval {::ITree::Item $wtree "Received"} $opts set iconImage [::Theme::FindIconSize 16 phone-called] set opts {-text Called -button 1 -image $iconImage -open 1} eval {::ITree::Item $wtree "Called"} $opts set iconImage [::Theme::FindIconSize 16 phone-missed] set opts {-text Missed -button 1 -image $iconImage -open 1} eval {::ITree::Item $wtree "Missed"} $opts return $w } # AddressBook::Popup -- # # Handle popup menus in AddressBook, typically from right-clicking. # # Arguments: # w widget that issued the command: tree or text # v for the tree widget it is the item path, # for text the phonehash. # # Results: # popup menu displayed proc ::AddressBook::Popup {w v x y} { global wDlgs this variable popMenuDef upvar ::Jabber::jstate jstate ::Debug 2 "::AddressBook::Popup w=$w, v='$v', x=$x, y=$y" # The last element of $v is either a phone, (a namespace,) # a header in roster, a group, or an agents xml tag. # The variables name 'phone' is a misnomer. # Find also type of thing clicked, 'typeClicked'. set typeClicked "" set phoneEntry $v set phone [lindex $phoneEntry 1] set section [lindex $phoneEntry 0] if {$phone ne ""} { set typeClicked phone } if {[string length $phone] == 0} { set typeClicked "" } set X [expr {[winfo rootx $w] + $x}] set Y [expr {[winfo rooty $w] + $y}] ::Debug 2 "\t phone=$phone, typeClicked=$typeClicked" # Mads Linden's workaround for menu post problem on mac: # all in menubutton commands i add "after 40 the_command" # this way i can never have to posting error. # it is important after the tk_popup f.ex to # # destroy .mb # update # # this way the .mb is destroyd before the next window comes up, thats how I # got around this. # Make the appropriate menu. set m $jstate(wpopup,addressbook) set i 0 catch {destroy $m} menu $m -tearoff 0 #------- Check Where the user make Popup and Select the right MenuDef ------- if { $section eq "AddressBook" } { set popMenu $popMenuDef(addressbook,def) } else { set popMenu $popMenuDef(log,def) } foreach {item type locname cmd} $popMenu { if {[string index $cmd 0] == "@"} { set mt [menu ${m}.sub${i} -tearoff 0] set locname [eval concat $locname] $m add cascade -label $locname -menu $mt -state disabled eval [string range $cmd 1 end] $mt incr i } elseif {[string equal $item "separator"]} { $m add separator continue } else { # Substitute the phone arguments. Preserve list structure! set cmd [eval list $cmd] set locname [eval concat $locname] $m add command -label $locname -command [list after 40 $cmd] \ -state disabled } # If a menu should be enabled even if not connected do it here. # if {![::Jabber::IsConnected]} { # continue # } # State of menu entry. We use the 'type' and 'typeClicked' to sort # out which capabilities to offer for the clicked item. set state disabled if {[string equal $item "mNewAB"]} { set state normal } if {[string equal $type $typeClicked]} { set state normal } if {[string equal $state "normal"]} { $m entryconfigure $locname -state normal } } # This one is needed on the mac so the menu is built before it is posted. update idletasks # Post popup menu. tk_popup $m [expr {int($X) - 10}] [expr {int($Y) - 10}] # Mac bug... (else can't post menu while already posted if toplevel...) if {[string equal "macintosh" $this(platform)]} { catch {destroy $m} update } } proc ::AddressBook::RemoveAddressbookDlg {phone} { variable abline variable wtree set removePhone [lindex [lindex $phone end] end] set index [lsearch -exact $abline $removePhone] set tmp [lreplace $abline [expr {$index-1}] $index] set abline $tmp set v [list "AddressBook" $phone] if { [::ITree::IsItem $wtree $v] >= 0 } { eval {::ITree::DeleteItem $wtree $v} } SaveEntries } proc ::AddressBook::NewAddressbookDlg {{phonenumber ""}} { global this wDlgs variable abName variable abPhoneNumber set abName "" set abPhoneNumber $phonenumber set w ".nadbdlg" ::UI::Toplevel $w \ -macstyle documentProc -macclass {document closeBox} -usemacmainmenu 1 \ -closecommand [namespace current]::CloseCmd wm title $w [mc "New address book"] set nwin [llength [::UI::GetPrefixedToplevels $wDlgs(jmucenter)]] if {$nwin == 1} { ::UI::SetWindowPosition $w ".nadbdlg" } # Global frame. ttk::frame $w.frall pack $w.frall -fill both -expand 1 set wbox $w.frall.f ttk::frame $wbox -padding [option get . dialogPadding {}] pack $wbox -fill both -expand 1 ttk::label $wbox.msg -style Small.TLabel \ -padding {0 0 0 6} -wraplength 260 -justify left -text [mc "New address book"] pack $wbox.msg -side top -anchor w set frmid $wbox.frmid ttk::frame $frmid pack $frmid -side top -fill both -expand 1 ttk::label $frmid.lname -text [mc "Name"]: ttk::entry $frmid.ename -textvariable [namespace current]::abName ttk::label $frmid.lphone -text [mc "Phone number"]: ttk::entry $frmid.ephone -textvariable [namespace current]::abPhoneNumber grid $frmid.lname $frmid.ename - -sticky e -pady 2 grid $frmid.lphone $frmid.ephone - -sticky e -pady 2 grid $frmid.ephone $frmid.ename -sticky ew grid columnconfigure $frmid 1 -weight 1 # Button part. set frbot $wbox.b set wenter $frbot.btok ttk::frame $frbot ttk::button $wenter -text [mc "Enter"] \ -default active -command [list [namespace current]::addItemAddressBook $w] ttk::button $frbot.btcancel -text [mc "Cancel"] \ -command [list [namespace current]::CancelEnter $w] set padx [option get . buttonPadX {}] if {[option get . okcancelButtonOrder {}] eq "cancelok"} { pack $frbot.btok -side right pack $frbot.btcancel -side right -padx $padx } else { pack $frbot.btcancel -side right pack $frbot.btok -side right -padx $padx } pack $frbot -side bottom -fill x wm resizable $w 0 0 bind $w [list $wenter invoke] # Trick to resize the labels wraplength. set script [format { update idletasks %s configure -wraplength [expr {[winfo reqwidth %s] - 20}] } $wbox.msg $w] after idle $script } proc ::AddressBook::ModifyAddressbookDlg {phone} { global this wDlgs variable abName variable abPhoneNumber variable abline #Get Entry data from abline list set modifyPhone $phone set index [lsearch -exact $abline $modifyPhone] set abName [lindex $abline [expr {$index-1}]] set abPhoneNumber [lindex $abline [expr {$index}]] set oldPhoneNumber $abPhoneNumber set w ".madbdlg" ::UI::Toplevel $w \ -macstyle documentProc -macclass {document closeBox} -usemacmainmenu 1 \ -closecommand [namespace current]::CloseCmd wm title $w [mc "Modify address book"] set nwin [llength [::UI::GetPrefixedToplevels $wDlgs(jmucenter)]] if {$nwin == 1} { ::UI::SetWindowPosition $w ".madbdlg" } # Global frame. ttk::frame $w.frall pack $w.frall -fill both -expand 1 set wbox $w.frall.f ttk::frame $wbox -padding [option get . dialogPadding {}] pack $wbox -fill both -expand 1 ttk::label $wbox.msg -style Small.TLabel \ -padding {0 0 0 6} -wraplength 260 -justify left -text [mc "Modify address book"] pack $wbox.msg -side top -anchor w set frmid $wbox.frmid ttk::frame $frmid pack $frmid -side top -fill both -expand 1 ttk::label $frmid.lname -text [mc "Name"]: ttk::entry $frmid.ename -textvariable [namespace current]::abName ttk::label $frmid.lphone -text [mc "Phone number"]: ttk::entry $frmid.ephone -textvariable [namespace current]::abPhoneNumber grid $frmid.lname $frmid.ename - -sticky e -pady 2 grid $frmid.lphone $frmid.ephone - -sticky e -pady 2 grid $frmid.ephone $frmid.ename -sticky ew grid columnconfigure $frmid 1 -weight 1 # Button part. set frbot $wbox.b set wenter $frbot.btok ttk::frame $frbot ttk::button $wenter -text [mc "Enter"] \ -default active -command [list [namespace current]::modifyItemAddressBook $w $phone] ttk::button $frbot.btcancel -text [mc "Cancel"] \ -command [list [namespace current]::CancelEnter $w] set padx [option get . buttonPadX {}] if {[option get . okcancelButtonOrder {}] eq "cancelok"} { pack $frbot.btok -side right pack $frbot.btcancel -side right -padx $padx } else { pack $frbot.btcancel -side right pack $frbot.btok -side right -padx $padx } pack $frbot -side bottom -fill x wm resizable $w 0 0 bind $w [list $wenter invoke] # Trick to resize the labels wraplength. set script [format { update idletasks %s configure -wraplength [expr {[winfo reqwidth %s] - 20}] } $wbox.msg $w] after idle $script } ################################################## # AddressBook Actions: # - addItemAddressBook # - modifyItemAddressBook # - CancelEnter # - CloseCmd # - SaveEntries # - LoadEntries # - DialExtension # - TransferExtension # ################################################ proc ::AddressBook::addItemAddressBook {w} { variable abName variable abPhoneNumber variable abline variable wtree if { $abName ne "" && $abPhoneNumber ne ""} { lappend abline $abName lappend abline $abPhoneNumber set text "$abPhoneNumber" set v [list "AddressBook" $text] set textUpdate "$abName $abPhoneNumber" set opts {-text $textUpdate} eval {::ITree::Item $wtree $v} $opts SaveEntries ::UI::SaveWinGeom $w destroy $w } } proc ::AddressBook::modifyItemAddressBook {w phone} { variable abName variable abPhoneNumber variable abline variable wtree #Get Entry data from abline list if { $abName ne "" && $abPhoneNumber ne "" } { #---------- Updates Memory Addressbook ----------------- set index [lsearch -exact $abline $phone] set tmp [lreplace $abline [expr {$index-1}] $index $abName $abPhoneNumber] set abline $tmp #----- Updates GUI --------- set v [list "AddressBook" $phone] if { [::ITree::IsItem $wtree $v] > 0 } { eval {::ITree::DeleteItem $wtree $v} } set text "$abName $abPhoneNumber" set opts {-text $text -button 0 -open 0} set v [list "AddressBook" $abPhoneNumber] eval {::ITree::Item $wtree $v} $opts #----- Updates Database ------- SaveEntries ::UI::SaveWinGeom $w destroy $w } } proc ::AddressBook::CancelEnter {w} { ::UI::SaveWinGeom $w destroy $w } proc ::AddressBook::CloseCmd {w} { ::UI::SaveWinGeom $w } proc ::AddressBook::SaveEntries {} { variable abline global prefs this # @@@ Mats set hFile [open [file join $this(prefsPath) addressbook.csv] "w"] foreach {name phonenumber} $abline { if {$name ne ""} { puts $hFile "$name:$phonenumber" } } close $hFile } proc ::AddressBook::LoadEntries {} { variable abline global prefs this set fileName [file join $this(prefsPath) addressbook.csv] set abline "" if { [ file exists $fileName ] } { set hFile [open $fileName "r"] while {[eof $hFile] <= 0} { gets $hFile line set temp [split $line ":"] foreach i $temp { lappend abline $i } } close $hFile } else { set abline "" } } proc ::AddressBook::DialExtension {phonenumber} { ::Phone::Dial $phonenumber } proc ::AddressBook::TransferExtension {phonenumber} { ::Phone::TransferTo [lindex $phonenumber 1] } ################################################## # AddressBook Event Hooks: # - Called # - UpdateLogs # - ReceivedCall # - FreeState # - TalkingState # ################################################ proc ::AddressBook::TalkingState {args} { variable wtab variable popMenuDef if {[winfo exists $wtab]} { # $wtab entryconfigure $popMenuDef(call) \ # -label [mc mForward] -command {::AddressBook::TransferExtension $phone} # $wtab entryconfigure $popMenuDef(redial) \ # -label [mc mForward] -command {::AddressBook::TransferExtension $phone} } } proc ::AddressBook::NormalState {args} { variable wtab variable popMenuDef if {[winfo exists $wtab]} { # $wtab entryconfigure $popMenuDef(addressbook,def) \ # -label [mc mCall] -command {::AddressBook::DialExtension $phone} # $wtab entryconfigure $popMenuDef(call) \ # -label [mc mCall] -command {::AddressBook::DialExtension $phone} # $wtab entryconfigure $popMenuDef(redial) \ # -label [mc mRedial] -command {::AddressBook::DialExtension $phone} } } proc ::AddressBook::ReceivedCall {callNo remote remote_name} { variable wtree variable wtab if {[winfo exists $wtab]} { set opts {-text "$remote_name $remote" -button 0 -open 0} set v [list "Received" $remote] if { [::ITree::IsItem $wtree $v] == 0 } { eval {::ITree::Item $wtree $v} $opts } } } proc ::AddressBook::Called {phonenumber args} { variable wtree variable wtab if {[winfo exists $wtab]} { set opts {-text $phonenumber -button 0 -open 0} set v [list "Called" $phonenumber] if { [::ITree::IsItem $wtree $v] == 0 } { eval {::ITree::Item $wtree $v} $opts } } } proc ::AddressBook::UpdateLogs {type remote remote_name initDate callLength} { variable wtree variable wtab if {[winfo exists $wtab]} { if { [clock format [clock seconds] -format %D] eq [clock format $initDate -format "%D"]} { set textDate [mc "Today"] append textDate " [clock format $initDate -format "%X"]" } else { set textDate [clock format $initDate -format "%D %X"] } set v [list $type $remote] if { $type eq "Missed" } { set textUpdate "$textDate $remote_name $remote" set opts {-text $textUpdate -button 0 -open 0} if { [::ITree::IsItem $wtree $v] == 0 } { eval {::ITree::Item $wtree $v} $opts } #Remove Missed Call from Received. set v [list "Received" $remote] if { [::ITree::IsItem $wtree $v] > 0 } { eval {::ITree::DeleteItem $wtree $v} } } else { if { [::ITree::IsItem $wtree $v] > 0 } { set textUpdate "$textDate ([clock format [expr {$callLength - 3600}] -format %X]) $remote_name $remote" set opts {-text $textUpdate} eval {::ITree::ItemConfigure $wtree $v} $opts } } } } proc ::AddressBook::Search {phonenumber} { #For searching into vCard Disco Service, take a look into Search.tcl (DoSearch, ResultCallback) and JForms.tcl (ResultPlainList) variable abline set name "" if {[info exists abline]} { set index [lsearch $abline $phonenumber] if { $index >= 0 } { set name [lindex $abline [expr {$index-1}]] } } return $name } proc ::AddressBook::Debug {msg} { if {0} { puts "-------- $msg" } } #------------------------------------------------------------------------------- #---------------- TO-DO --------------------------- # 2. Review Dial/Transfer Popup Options coccinella-0.96.20/components/Phone/IAX/000077500000000000000000000000001167435367600176655ustar00rootroot00000000000000coccinella-0.96.20/components/Phone/IAX/Iax.tcl000066400000000000000000000323571167435367600211240ustar00rootroot00000000000000# Iax.tcl -- # # Phone component for the iax client. # It must handle things on two levels: # o the iaxclient library; transport level # o the Jingle protocol; signalling level # # Initiating is started on the protocol level (jingle) and first when # that is established the transport (iaxclient) is invoked. # # Copyright (c) 2006 Mats Bengtsson # Copyright (c) 2006 Antonio Cano damas # # 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 3 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, see . # # $Id: Iax.tcl,v 1.23 2007-11-17 07:40:52 matben Exp $ namespace eval ::Iax { if {![component::exists Phone]} { return } if {[catch {package require iaxclient} err]} { ::Debug 2 "Iax.tcl unable to load/find iaxclient package: $err" return } if {[catch {package require IaxPrefs}]} { return } if {[catch {package require JingleIax}]} { return } component::define IAX "Provides the iax client softphone." variable scriptPath [file dirname [info script]] } proc ::Iax::Init { } { component::register IAX ::Phone::RegisterPhone iax "IAX Phone" \ ::Iax::InitProc ::Iax::CmdProc ::Iax::DeleteProc # Setting up Callbacks functions. #iaxclient::notify [namespace current]::NotifyState iaxclient::notify [namespace current]::NotifyRegister iaxclient::notify [namespace current]::NotifyLevels iaxclient::notify [namespace current]::NotifyNetStats iaxclient::notify [namespace current]::NotifyText # Set handler action interface. iaxclient::actionbind iaxclient::statebind add [namespace current]::NotifyIncoming # @@@ temporary ::Phone::SetPhone iax ::JingleIAX::Init # Keep track of internal iaxclient state to be able to detect changes. variable iaxstate set iaxstate(old) "free" set iaxstate(now) "free" # Register ID. set iaxstate(registerid) - # Peer address. set iaxstate(peer) "" } proc ::Iax::InitProc {} { # Empty. } # Iax::CmdProc -- # # This is our registered command procedure that gets invoked from the # Phone component. proc ::Iax::CmdProc {type args} { variable iaxstate ::Debug 4 "::Iax::CmdProc $type $args" set value [lindex $args 0] switch -- $type { answer { iaxclient::answer $value } callerid { eval CallerID $args } changeline { iaxclient::changeline $value } dial { eval Dial $args } dialjingle { eval DialJingle $args } dialjinglecandidates { eval DialJingleCandidates $args } getinputlevel { return [iaxclient::level input] } getoutputlevel { return [iaxclient::level output] } getport { return [iaxclient::getport] } hangup { iaxclient::hangup } hangupjingle { # Handle both transport and protocol levels. iaxclient::hangup ::JingleIAX::SessionTerminate } hold { #iaxclient::hold $value } inputlevel { iaxclient::level input $value } loadprefs { eval LoadPrefs $args } outputlevel { iaxclient::level output $value } playtone { iaxclient::playtone $value } register { eval Register $args } reject { iaxclient::reject $value } sendtone { iaxclient::sendtone $value } state { eval ::JingleIAX::SendJinglePresence $args } transfer { iaxclient::transfer $value } unhold { #iaxclient::unhold $value } unregister { if {[string is integer -strict $iaxstate(registerid)]} { iaxclient::unregister $iaxstate(registerid) } } } } proc ::Iax::DeleteProc {} { } proc ::Iax::Register {} { variable iaxstate # Set plain variable names. foreach {name value} [::IaxPrefs::GetAll] { set $name $value } # If Host is blank then we don't need to register into the PBX if {$host ne ""} { set iaxstate(registerid) [iaxclient::register $user $password $host] } ## This is tricky, when we got two iaxclient instances in the same box ## the second one has the port 0 # the socket is initialized with a random port one register is called ::JingleIAX::InitState } #--------------------------------------------------------------------------- #--------------------------- Protocol CallBacks Hooks ---------------------- #--------------------------------------------------------------------------- proc ::Iax::NotifyLevels {in out} { # This callbak is called every X milliseconds during the call # It is intended for level meters (todo) # We are using for counting the call duration length in the TPhone Widget and NotifyCall too # iaxclient deliver levels [-infinity 0] with -99 silence? # Scale to 0-100. set in [expr {$in + 99}] set in [expr {($in < 0) ? 0 : ($in > 100) ? 100 : $in}] set out [expr {$out + 99}] set out [expr {($out < 0) ? 0 : ($out > 100) ? 100 : $out}] ::Phone::UpdateLevels $in $out } proc ::Iax::NotifyNetStats {args} { # puts "NetStats: $args" } proc ::Iax::NotifyText { type callno textmessage args} { if { $type eq "-" && $textmessage ne ""} { ::Phone::UpdateText $callno $textmessage } } proc ::Iax::NotifyRegister {id reply msgcount} { variable iaxstate ::Debug 4 "::Iax::NotifyRegister id=$id, reply=$reply" switch -- $reply { timeout { if {$iaxstate(registerid) == $id} { ::Phone::HidePhone } } ack { ::Phone::ShowPhone ::Phone::UpdateRegister $id $reply $msgcount } } } # Iax::NotifyState -- # # Callback when the iaxclient state changes. # This controls the phone state and all state changes such as extended # presence originate from here. # The Phone component then delegates the state change to the selected # softphone component (us). proc ::Iax::NotifyState {callNo state codec remote remote_name args} { variable iaxstate ::Debug 4 "::Iax::NotifyState state=$state, old=$iaxstate(now)" # Do this to be able to do string comparisons on lists. set state [lsort $state] # Push the state change on our internal cache. set iaxstate(old) $iaxstate(now) set iaxstate(now) $state # Skip non changes which we get from changeline actions. if {$state eq $iaxstate(old)} { return } ::Phone::UpdateState $callNo $state #---------------------------------------------------------------------- #------------ Sending Outgoing/Incoming Calls actions ----------------- #---------------------------------------------------------------------- #----- Originate Outgoing Call if { $state eq [list active outgoing ringing] } { iaxclient::ringstart 0 } # Connect Peers Right (Outgoing & Incoming calls). if { [lsearch $state "complete"] >= 0 } { ::Phone::SetTalkingState $callNo iaxclient::ringstop } #----- Incoming Call Notify if { $state eq [list active ringing] } { ::Phone::IncomingCall $callNo $remote $remote_name iaxclient::ringstart 1 } #----- Connection free (incoming & outgoing) Or ChangeLine, #--------- IAXClient sometimes return free state for a changeline action if { $state eq "free" || $state eq "selected" } { ::Phone::SetNormalState $callNo set iaxstate(peer) "" iaxclient::ringstop } } # Iax::NotifyIncoming -- # # Callback when the iaxclient state changes. # This controls the phone state and all state changes such as extended # presence originate from here. # The Phone component then delegates the state change to the selected # softphone component (us). # We shall handle only incoming calls here. proc ::Iax::NotifyIncoming {action callNo state codec remote remote_name args} { variable iaxstate ::Debug 4 "::Iax::NotifyIncoming action=$action, state=$state" # Connect Peers Right (Outgoing & Incoming calls). if { [lsearch $action "complete"] >= 0 } { ::Phone::SetTalkingState $callNo iaxclient::ringstop } #----- Incoming Call Notify if { $action eq [list active ringing] } { ::Phone::IncomingCall $callNo $remote $remote_name iaxclient::ringstart 1 } #----- Connection free (incoming & outgoing) Or ChangeLine, #--------- IAXClient sometimes return free state for a changeline action if { $action eq "free" || $action eq "selected" } { ::Phone::SetNormalState $callNo set iaxstate(peer) "" iaxclient::ringstop } } #--------------------------------------------------------------------------- #------------------------------- Protocol Actions -------------------------- #--------------------------------------------------------------------------- proc ::Iax::CallerID { {_cidname ""} {_cidnum ""} } { # Set plain variable names. Note name conflicts! foreach {name value} [::IaxPrefs::GetAll] { set $name $value } if { $_cidname eq "" } { iaxclient::callerid $cidname $cidnum } else { iaxclient::callerid $_cidname $_cidnum } } proc ::Iax::DialJingle {peer {line ""} {subject ""} {user ""} {password ""}} { variable iaxstate ::Debug 4 "::Iax::DialJingle peer=$peer" if {$line eq ""} { set callNo 1 } else { set callNo $line } set callNo 1 #---- Peer String: IP[:Port]/extension #---- Dial Peer String: [user[:password]@]peer set userDef "" if {$user ne ""} { append userDef $user } if {$password ne ""} { append userDef ":$password" } if {$userDef ne ""} { append userDef "@" } #----- Dial Peer ------- ::Debug 4 "\t iaxclient::dial $userDef$peer $callNo" set iaxstate(peer) $userDef$peer iaxclient::dial ${userDef}${peer} $callNo if { $subject ne "" } { iaxclient::sendtext $subject } } proc ::Iax::DialJingleCandidates {candidates} { ::Debug 4 "::Iax::DialJingleCandidates candidates=$candidates" iaxclient::dial_candidates $candidates [namespace code DialCB] } proc ::Iax::DialCB {candidate type callNo state args} { variable iaxstate ::Debug 4 "::Iax::DialCB candidate=$candidate, type=$type" set iaxstate(peer) [lindex $candidate 0 0]:[lindex $candidate 0 1]/ ::Phone::UpdateState $callNo $type #----- Originate Outgoing Call if { $type eq [list active outgoing ringing] } { iaxclient::ringstart 0 } # Connect Peers Right (Outgoing & Incoming calls). if { [lsearch $type "complete"] >= 0 } { ::Phone::SetTalkingState $callNo iaxclient::ringstop } #----- Connection free (incoming & outgoing) Or ChangeLine, #--------- IAXClient sometimes return free state for a changeline action if { $type eq "free" || $type eq "selected" || $type eq "error" } { ::Phone::SetNormalState $callNo set iaxstate(peer) "" iaxclient::ringstop } if {$type eq "error"} { ui::dialog -message "Failed contacting ..." \ -detail "Either you have a rigorous firewall or the other user\ has one that does not allow network connections like this." } } proc ::Iax::Dial {phonenumber {line ""} {subject ""}} { ::Debug 4 "::Iax::Dial phonenumber=$phonenumber " # Set plain variable names. foreach {name value} [::IaxPrefs::GetAll] { set $name $value } if {$line eq ""} { set callNo 1 } else { set callNo $line } set callNo 1 ::Debug 4 "\t iaxclient::dial ..." set addr "${user}:${password}@${host}/${phonenumber}" set iaxstate(peer) $addr iaxclient::dial $addr $callNo if { $subject ne "" } { iaxclient::sendtext $subject } } #--------------------------------------------------------------------------- #------------------------- Protocol Preferences Actions -------------------- #--------------------------------------------------------------------------- proc ::Iax::LoadPrefs {} { global prefs ::Debug 4 "::Iax::LoadPrefs" # Set plain variable names. foreach {name value} [::IaxPrefs::GetAll] { set $name $value } set echo 0 iaxclient::applyfilters $agc $aagc $comfort $noise $echo # Pick matching device name. foreach device [iaxclient::devices output] { if { [lindex $device 0] eq $outputDevices} { iaxclient::setdevices output [lindex $device 1] break } } foreach device [iaxclient::devices input] { if { [lindex $device 0] eq $inputDevices} { iaxclient::setdevices input [lindex $device 1] break } } iaxclient::callerid $cidname $cidnum if {$codec ne ""} { iaxclient::formats $codec } iaxclient::toneinit 880 960 16000 48000 10 } proc ::Iax::Reload {} { variable iaxstate if {[string is integer -strict $iaxstate(registerid)]} { if { $iaxstate(registerid) >= 0 } { ::iaxclient::unregister $iaxstate(registerid) } } LoadPrefs Register } coccinella-0.96.20/components/Phone/IAX/IaxPrefs.tcl000066400000000000000000000250051167435367600221140ustar00rootroot00000000000000# IaxPrefs.tcl -- # # iaxClient phone UI # # Copyright (c) 2006 Antonio Cano damas # # 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 3 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, see . # # $Id: IaxPrefs.tcl,v 1.12 2007-09-16 07:39:11 matben Exp $ package provide IaxPrefs 0.1 namespace eval ::IaxPrefs { ::hooks::register prefsInitHook ::IaxPrefs::InitPrefsHook ::hooks::register prefsBuildHook ::IaxPrefs::BuildPrefsHook ::hooks::register prefsSaveHook ::IaxPrefs::SavePrefsHook ::hooks::register prefsCancelHook ::IaxPrefs::CancelPrefsHook ::hooks::register prefsUserDefaultsHook ::IaxPrefs::UserDefaultsHook } ################## Preferences Stuff ################### proc ::IaxPrefs::InitPrefsHook { } { global prefs set prefs(iaxPhone,user) "" set prefs(iaxPhone,password) "" ;# Was 0 set prefs(iaxPhone,host) "" ;# Was 0 set prefs(iaxPhone,cidnum) 0 set prefs(iaxPhone,cidname) "" set prefs(iaxPhone,codec) "SPEEX" set prefs(iaxPhone,inputDevices) "" set prefs(iaxPhone,outputDevices) "" set prefs(iaxPhone,agc) 0 set prefs(iaxPhone,aagc) 0 set prefs(iaxPhone,noise) 0 set prefs(iaxPhone,comfort) 0 # set prefs(iaxPhone,echo) 0 variable allKeys set allKeys {user password host cidnum cidname codec \ inputDevices outputDevices agc aagc noise comfort} # echo set plist {} foreach key $allKeys { set name prefs(iaxPhone,$key) set rsrc prefs_iaxPhone_$key set val [set $name] lappend plist [list $name $rsrc $val] } ::PrefUtils::Add $plist VerifySanity } proc ::IaxPrefs::VerifySanity { } { global prefs # Verify booleans. foreach key {cidnum agc aagc noise comfort} { set value $prefs(iaxPhone,$key) if {!(($value == 0) || ($value == 1))} { set prefs(iaxPhone,$key) 0 } } } # IaxPrefs::GetAll -- # # A way to get all relevant IAX prefs with simple names. proc ::IaxPrefs::GetAll { } { global prefs variable allKeys set plist {} foreach key $allKeys { lappend plist $key $prefs(iaxPhone,$key) } return $plist } proc ::IaxPrefs::BuildPrefsHook {wtree nbframe} { global prefs variable tmpPrefs if {![::Preferences::HaveTableItem {phone}]} { ::Preferences::NewTableItem {phone} [mc "Phone"] } ::Preferences::NewTableItem {phone iax} [mc "IAX Phone"] set wpage [$nbframe page {iax}] BuildPage $wpage } proc ::IaxPrefs::BuildPage {page} { global prefs variable tmpPrefs set wc $page.i ttk::frame $wc -padding [option get . notebookPageSmallPadding {}] pack $wc -side top -anchor [option get . dialogAnchor {}] set waccount $wc.ac AccountFrame $waccount set wnb $wc.nb ttk::notebook $wnb -padding {8 12 8 8} grid $waccount -sticky ew -padx 8 grid $wnb -sticky ew # Switch off devices since can create a misery for some users! $wnb add [DevicesFrame $wnb.de] -text [mc "Devices"] $wnb add [FiltersFrame $wnb.fi] -text [mc "Filters"] $wnb add [CodecsFrame $wnb.co] -text [mc "Codecs"] bind $page +[namespace current]::Free } proc ::IaxPrefs::AccountFrame {win} { global prefs variable tmpPrefs ttk::labelframe $win -text [mc "IAX Account"] \ -padding [option get . groupSmallPadding {}] pack $win -side top -anchor w foreach key {user password host cidnum cidname} { set tmpPrefs($key) $prefs(iaxPhone,$key) } ttk::label $win.luser -text [mc "Username"]: ttk::entry $win.user -textvariable [namespace current]::tmpPrefs(user) ttk::label $win.lpassword -text [mc "Password"]: ttk::entry $win.password -textvariable [namespace current]::tmpPrefs(password) \ -show {*} ttk::label $win.lhost -text [mc "Host"]: ttk::entry $win.host -textvariable [namespace current]::tmpPrefs(host) ttk::label $win.lcidnum -text [mc "Caller ID number"]: ttk::entry $win.cidnum -textvariable [namespace current]::tmpPrefs(cidnum) ttk::label $win.lcidname -text [mc "Caller ID name"]: ttk::entry $win.cidname -textvariable [namespace current]::tmpPrefs(cidname) grid $win.luser $win.user -sticky e -pady 2 grid $win.lpassword $win.password -sticky e -pady 2 grid $win.lhost $win.host -sticky e -pady 2 grid $win.lcidnum $win.cidnum -sticky e -pady 2 grid $win.lcidname $win.cidname -sticky e -pady 2 return $win } proc ::IaxPrefs::DevicesFrame {win} { global prefs variable tmpPrefs ttk::frame $win -padding [option get . groupSmallPadding {}] pack $win -side top -anchor w set listInputDevices [iaxclient::devices input] set listOutputDevices [iaxclient::devices output] # Workaround for old buggy linux build. if {[catch { set prefs(iaxPhone,inputDevices) [lindex [iaxclient::devices input -current] 0] set prefs(iaxPhone,outputDevices) [lindex [iaxclient::devices output -current] 0] }]} { set prefs(iaxPhone,inputDevices) [lindex $listInputDevices 0 0] set prefs(iaxPhone,outputDevices) [lindex $listOutputDevices 0 0] } set tmpPrefs(inputDevices) $prefs(iaxPhone,inputDevices) set tmpPrefs(outputDevices) $prefs(iaxPhone,outputDevices) foreach device $listInputDevices { lappend inputDevices [lindex $device 0] } ttk::label $win.linputDev -text [mc "Microphone"]: ttk::combobox $win.input_dev -state readonly \ -textvariable [namespace current]::tmpPrefs(inputDevices) -values $inputDevices foreach device $listOutputDevices { lappend outputDevices [lindex $device 0] } ttk::label $win.loutputDev -text [mc "Speakers"]: ttk::combobox $win.output_dev -state readonly \ -textvariable [namespace current]::tmpPrefs(outputDevices) \ -values $outputDevices grid $win.linputDev $win.input_dev -sticky e -pady 2 grid $win.loutputDev $win.output_dev -sticky e -pady 2 return $win } proc ::IaxPrefs::FiltersFrame {win} { global prefs variable tmpPrefs ttk::frame $win -padding [option get . groupSmallPadding {}] pack $win -side top -anchor w foreach key {agc aagc noise comfort} { set tmpPrefs($key) $prefs(iaxPhone,$key) } # set tmpPrefs(echo) $prefs(iaxPhone,echo) ttk::checkbutton $win.agc -text [mc "Automatic gain control (AGC)"] \ -variable [namespace current]::tmpPrefs(agc) ttk::checkbutton $win.aagc -text [mc "Analog automatic gain control (AAGC)"] \ -variable [namespace current]::tmpPrefs(aagc) ttk::checkbutton $win.noise -text [mc "Noise reduction"] \ -variable [namespace current]::tmpPrefs(noise) ttk::checkbutton $win.comfort -text [mc "Comfort noise"] \ -variable [namespace current]::tmpPrefs(comfort) # ttk::checkbutton $win.echo -text [mc "Echo"] \ # -variable [namespace current]::tmpPrefs(echo) grid $win.agc -sticky w grid $win.aagc -sticky w grid $win.noise -sticky w grid $win.comfort -sticky w # grid $win.echo -sticky w ::balloonhelp::balloonforwindow $win.agc [mc "Automatically adjust volume levels"] ::balloonhelp::balloonforwindow $win.aagc [mc "Can prevent clipping"] ::balloonhelp::balloonforwindow $win.comfort [mc "Artificial background noise to fill silence"] return $win } proc ::IaxPrefs::CodecsFrame {win} { global prefs variable tmpPrefs ttk::frame $win -padding [option get . groupSmallPadding {}] pack $win -side top -anchor w set tmpPrefs(codec) $prefs(iaxPhone,codec) ttk::label $win.lcodec -text [mc "Codec"]: ttk::radiobutton $win.codeci -text "iLBC" -variable [namespace current]::tmpPrefs(codec) -value "ILBC" ttk::radiobutton $win.codecs -text "Speex" -variable [namespace current]::tmpPrefs(codec) -value "SPEEX" ttk::radiobutton $win.codeca -text "aLaw" -variable [namespace current]::tmpPrefs(codec) -value "ALAW" ttk::radiobutton $win.codecu -text "uLaw" -variable [namespace current]::tmpPrefs(codec) -value "ULAW" ttk::radiobutton $win.codecg -text "GSM" -variable [namespace current]::tmpPrefs(codec) -value "GSM" # If you add more codecs use a new column. grid $win.lcodec $win.codeci -sticky w grid x $win.codecs -sticky w grid x $win.codeca -sticky w grid x $win.codecu -sticky w grid x $win.codecg -sticky w grid $win.lcodec -padx 4 ::balloonhelp::balloonforwindow $win.codeci [mc "iLBC (internet Low Bitrate Codec) is a free speech codec suitable for robust voice communication over IP"] ::balloonhelp::balloonforwindow $win.codecs [mc "Speex is an Open Source/Free Software patent-free audio compression format designed for speech"] ::balloonhelp::balloonforwindow $win.codeca [mc "Standard used in European digital communication systems (ITU-T)"] ::balloonhelp::balloonforwindow $win.codecu [mc "Standard used in digital communication systems in North America and Japan (ITU-T)"] ::balloonhelp::balloonforwindow $win.codecg [mc "GSM 06.10 provisional standard for full-rate speech transcoding (ETSI)"] return $win } proc ::IaxPrefs::SavePrefsHook { } { global prefs variable tmpPrefs variable allKeys foreach key $allKeys { if {[info exists tmpPrefs($key)]} { set prefs(iaxPhone,$key) $tmpPrefs($key) } } VerifySanity ::Iax::Reload } proc ::IaxPrefs::CancelPrefsHook { } { global prefs variable tmpPrefs variable allKeys foreach key $allKeys { if {[info exists tmpPrefs($key)]} { if {![string equal $prefs(iaxPhone,$key) $tmpPrefs($key)]} { ::Preferences::HasChanged break } } } } proc ::IaxPrefs::UserDefaultsHook { } { global prefs variable tmpPrefs variable allKeys foreach key $allKeys { set tmpPrefs($key) $prefs(iaxPhone,$key) } } proc ::IaxPrefs::Free { } { variable tmpPrefs unset -nocomplain tmpPrefs } coccinella-0.96.20/components/Phone/IAX/JingleIax.tcl000066400000000000000000000452401167435367600222500ustar00rootroot00000000000000# JingleIax.tcl -- # # JingleIAX package, binding for the IAX transport over Jingle # # Copyright (c) 2006 Antonio Cano damas # Copyright (c) 2006 Mats Bengtsson # # 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 3 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, see . # # $Id: JingleIax.tcl,v 1.43 2008-05-27 08:03:55 matben Exp $ if {[catch {package require stun}]} { ::Debug 2 "JingleIax.tcl: Package stun not found" return } if {[catch {package require jlib::jingle}]} { ::Debug 2 "JingleIax.tcl: Package jlib::jingle not found" return } package provide JingleIax 0.1 namespace eval ::JingleIAX:: { } proc ::JingleIAX::Init {} { option add *Chat*callImage phone-call widgetDefault option add *Chat*callDisImage phone-call-Dis widgetDefault variable xmlns set xmlns(jingle) "http://jabber.org/protocol/jingle/" set xmlns(media) "http://jabber.org/protocol/jingle/media/audio" set xmlns(transport) "http://jabber.org/protocol/jingle/transport/iax" # Add event hooks. ::hooks::register initHook ::JingleIAX::InitHook ::hooks::register jabberInitHook ::JingleIAX::JabberInitHook ::hooks::register loginHook ::JingleIAX::LoginHook ::hooks::register logoutHook ::JingleIAX::LogoutHook ::hooks::register presenceHook ::JingleIAX::PresenceHook ::hooks::register presenceHook ::JingleIAX::PresenceHangUpHook ::hooks::register rosterPostCommandHook ::JingleIAX::RosterPostCommandHook ::hooks::register buildChatButtonTrayHook ::JingleIAX::BuildChatButtonTrayHook ::hooks::register chatTabChangedHook ::JingleIAX::ChatTabChangedHook # This shall be done generically and dispatched to relevant softphone. #--------------- Variables Uses For PopUP Menus ------------------------- variable popMenuDef variable popMenuType set popMenuDef(call) { command mCall {[mc "&Call"]...} {::JingleIAX::SessionInitiate $jid3} } set popMenuType(call) { mCall {user avaliable} } #--------------- Other Variables and States ------------------ variable state array set state { public,ip 127.0.0.1 public,port 0 local,ip 127.0.0.1 local,port 0 sid "" } # Register Jingle. variable transportElem variable mediaElem set transportElem [wrapper::createtag "transport" \ -attrlist [list xmlns $xmlns(transport) version 2 secure no] ] set mediaElem [wrapper::createtag "description" \ -attrlist [list xmlns $xmlns(media)] ] jlib::jingle::register iax 50 \ [list $mediaElem] [list $transportElem] ::JingleIAX::IQHandler } proc ::JingleIAX::InitHook {} { variable popMenuDef variable popMenuType ::Roster::RegisterPopupEntry $popMenuDef(call) $popMenuType(call) } # JingleIAX::JabberInitHook -- # # Gets called for each new jlib instance. # Do jlib instance specific stuff here. proc ::JingleIAX::JabberInitHook {jlib} { variable xmlns # Caps specific iax stuff. set subtags [list [wrapper::createtag "identity" \ -attrlist [list category hierarchy type leaf name "IAX Phone"]]] lappend subtags [wrapper::createtag "feature" \ -attrlist [list var $xmlns(transport)]] $jlib caps register iax $subtags $xmlns(transport) # @@@ Subject to experimentation! # Add an: # $jlib register_presence_stanza [GetXPresence available] -type available } proc ::JingleIAX::GetXPresence {type} { variable xmlns # @@@ Perhaps 'available' should be left out as usual. return [wrapper::createtag x -attrlist [list xmlns $xmlns(media) type $type]] } #---------------------------------------------------------------------------- #----------------------- Inits and Hooks ------------------------------------ #---------------------------------------------------------------------------- proc ::JingleIAX::LoginHook { } { InitState } proc ::JingleIAX::InitState {} { global this variable state set tempPort $state(local,port) if { $tempPort == 0 } { set tempPort [::Iax::CmdProc getport] } set state(public,port) $tempPort set state(local,port) $tempPort set state(local,ip) $this(ipnum) #---- Gets Public IP ------ ::stun::request stun01.sipphone.com -command ::JingleIAX::StunCB } proc ::JingleIAX::StunCB {token status args} { variable state array set argsA $args if {$status eq "ok" && [info exists argsA(-address)]} { set state(public,ip) $argsA(-address) } } proc ::JingleIAX::LogoutHook { } { ::JUI::RemoveAlternativeStatusImage JingleIAX } # JingleIAX::RosterPostCommandHook -- # # Active/Disable the menu entry depending on JID. proc ::JingleIAX::RosterPostCommandHook {m jidL clicked presL} { variable xmlns Debug "RosterPostCommandHook jidL=$jidL, clicked=$clicked, presL=$presL" if {[llength $jidL] != 1} { return } set jid [lindex $jidL 0] set midx [::AMenu::GetMenuIndex $m mCall] if {$midx eq ""} { # Probably a submenu. return } $m entryconfigure $midx -state disabled if {$presL ne "available"} { return } # Check for the extended presence. set xelem [::Jabber::RosterCmd getx $jid "jingle/media/audio"] if {$xelem ne {}} { set status [wrapper::getattribute $xelem type] if {$status eq "available"} { $m entryconfigure $midx -state normal } } } #------------------------------------------------------------------------- #------------------- Jingle Session State Machine ------------------------ #------------------------------------------------------------------------- # Initiator..................................................................... proc ::JingleIAX::SessionInitiate {jid} { variable state variable transportElem variable mediaElem Debug "::JingleIAX::SessionInitiate $jid" set state(sid) [::Jabber::Jlib jingle initiate iax $jid \ [list $mediaElem] [list $transportElem] ::JingleIAX::SessionInitiateCB] } # JingleIAX::SessionInitiateCB -- # # This is the callback from 'SessionInitiate'. # We normally expect a single 'result' element but need to cancel # the call if an error. proc ::JingleIAX::SessionInitiateCB {type subiq args} { Debug "::JingleIAX::SessionInitiateCB" #--------- Comes an Error from Initiate -------- if { ($type eq "error") || ($type eq "cancel")} { # Cleanup! SessionTerminate ui::dialog -icon error -type ok -message [mc "Failed calling %s"] \ -detail $subiq } } # JingleIAX::SessionTerminate -- # # This is supposed to terminate a session and trigger all cleaning up. # Shall also work to call in case of any errors during a call. proc ::JingleIAX::SessionTerminate {} { variable state # @@@ Do we need to take any further action (iaxclient::hangup)? ::Jabber::Jlib jingle send_set $state(sid) "session-terminate" \ ::JingleIAX::EmptyCB set state(sid) "" } # Target (handlers)............................................................. # JingleIAX::IQHandler -- # # This is our registered jlib jingle handler. proc ::JingleIAX::IQHandler {jlib jelem args} { array set argsA $args variable state Debug "::JingleIAX::IQHandler" array set argsA $args set id $argsA(-id) set from $argsA(-from) set sid [wrapper::getattribute $jelem sid] set action [wrapper::getattribute $jelem action] switch -- $action { "session-initiate" { SessionInitiateHandler $from $jelem $sid $id } "transport-accept" { TransportAcceptHandler $from $jelem $sid $id } "session-terminate" { SessionTerminateHandler $from $jelem $sid $id } } return } # JingleIAX::SessionInitiateHandler -- # # Handler for a 'session-initiate' action. proc ::JingleIAX::SessionInitiateHandler {from jingle sid id} { variable state Debug "::JingleIAX::SessionInitiateHandler from=$from, sid=$sid, id=$id" # XEP-0166: In order to decline the session initiation request, the target # entity MUST acknowledge receipt of the session initiation request, then # terminate the session. ::Jabber::Jlib send_iq result {} -to $from -id $id # Must check that we are free to answer. if {([iaxclient::state] eq "free") && ($state(sid) eq "")} { set state(sid) $sid TransportAccept $from } else { # Need a direct call since state(sid) can be busy with another sid. ::Jabber::Jlib jingle send_set $sid "session-terminate" \ ::JingleIAX::EmptyCB } } # JingleIAX::TransportAccept -- # # This formulates our response to an incoming 'session-initiate' action. proc ::JingleIAX::TransportAccept {from} { global prefs variable state variable xmlns Debug "::JingleIAX::TransportAccept from=$from" # -------- Transports Supported ------------------- set locAttr [list name local ip $state(local,ip) port $state(local,port)] set localElem [wrapper::createtag "candidate" -attrlist $locAttr] set candidateElems [list $localElem] # Add only the public candidate if we've got a stun answer. if {$state(public,ip) ne "127.0.0.1"} { set pubAttr [list name public ip $state(public,ip) port $state(public,port)] set publicElem [wrapper::createtag "candidate" -attrlist $pubAttr] lappend candidateElems $publicElem } # Add only the hardcoded custom ip if nonempty. if {$prefs(NATip) ne ""} { set cusAttr [list name custom ip $prefs(NATip) port $state(public,port)] set customElem [wrapper::createtag "candidate" -attrlist $cusAttr] lappend candidateElems $customElem } set transportElem [wrapper::createtag "transport" \ -attrlist [list xmlns $xmlns(transport) version 2] \ -subtags $candidateElems] ::Jabber::Jlib jingle send_set $state(sid) "transport-accept" \ ::JingleIAX::EmptyCB [list $transportElem] ::Jabber::Jlib jingle send_set $state(sid) "session-accept" \ ::JingleIAX::EmptyCB } proc ::JingleIAX::EmptyCB {args} { # Empty. } # JingleIAX::TransportAcceptHandler -- # # Handles incoming 'transport-accept' actions from the jingle handler. proc ::JingleIAX::TransportAcceptHandler {from jingle sid id} { variable state variable xmlns Debug "::JingleIAX::TransportAcceptHandler" # Extract the command level XML data items. #set jingle [wrapper::gettag $args] #set calledname [wrapper::getattribute $jingle initiator] set transport [wrapper::getfirstchildwithtag $jingle "transport"] if {$transport ne {}} { # We have to test if the Transport and version are supported set transportType [wrapper::getattribute $transport xmlns] set version [wrapper::getattribute $transport version] set secure [wrapper::getattribute $transport secure] if { ($transportType ne $xmlns(transport)) && ($version ne 2) } { ::Jabber::Jlib jingle send_error $from $id unsupported-transports SessionTerminate return } set candidateList [wrapper::getchildswithtag $transport candidate] if {$candidateList eq {}} { ::Jabber::Jlib jingle send_error $from $id unsupported-media SessionTerminate return } foreach candidate $candidateList { set name [wrapper::getattribute $candidate name] if {$name ne ""} { set candidateDesc($name,ip) [wrapper::getattribute $candidate ip] set candidateDesc($name,port) [wrapper::getattribute $candidate port] } else { ::Jabber::Jlib send_iq_error $from $id 404 cancel bad-request SessionTerminate return } } # ------------- User and Password, returned by Asterisk PBX node ------- # ------- Are OPTIONAL set user "" set password "" set userElem [wrapper::getfirstchildwithtag $transport user] if {$userElem ne {}} { set user [wrapper::getcdata $userElem] } set pwdElem [wrapper::getfirstchildwithtag $transport password] if {$pwdElem ne {}} { set password [wrapper::getcdata $pwdElem] } #-------- At This moment we know how to call the Peer ------------ #------ 1/ Discover what candidate to use: custom, local or public #------------- 2/ Give control to Phone Component ---------------- # Search the candidates in priority order. foreach name {custom public local} { if {[info exists candidateDesc($name,ip)]} { set ip $candidateDesc($name,ip) set port $candidateDesc($name,port) break } } # Sort a list of {host port} candidates in priority order. set cands {} foreach name {custom public local} { if {[info exists candidateDesc($name,ip)]} { set ip $candidateDesc($name,ip) set port $candidateDesc($name,port) # If both users are on the same LAN they also have identical # public IP. Exclude this candidate. if {$ip ne $state(public,ip)} { lappend cands [list $ip $port] } } } # If both users are on the same LAN they also have identical public IP. if {$ip eq $state(public,ip)} { set ip $candidateDesc(local,ip) set port $candidateDesc(local,port) } # @@@ We should provide a list of candidates to ::Phone::DialJingle. # There should be some kind of callback from 'DialJingle' for this??? Debug "\t ::Phone::DialJingle ip=$ip, port=$port" set myjid [::Jabber::Jlib getthis myjid] if {0} { ::Phone::DialJingle $ip $port $from $myjid $user $password } else { ::Phone::DialJingleCandidates $cands $from $myjid $user $password } } } proc ::JingleIAX::SessionTerminateHandler {from jingle sid id} { variable state Debug "::JingleIAX::SessionTerminateHandler from=$from" ::Jabber::Jlib send_iq result {} -to $from -id $id set state(sid) "" # @@@ Do we need to take any further action (iaxclient::hangup)? } # JingleIAX::PresenceHangUpHook -- # # The Jingle XEP specifies that if a user we have a session with becomes # unavailable we must close down the call. proc ::JingleIAX::PresenceHangUpHook {jid type args} { variable state # Beware! jid without resource! Debug "::JingleIAX::PresenceHangUpHook jid=$jid, type=$type, $args" if {$type eq "unavailable"} { set sid $state(sid) if {[::Jabber::Jlib jingle havesession $sid]} { array set argsA $args set from $argsA(-from) set jjid [::Jabber::Jlib jingle getvalue $sid jid] if {[jlib::jidequal $jjid $from]} { ::Phone::HangupJingle } } } } #------------------------------------------------------------------------- #---------------------- (Extended Presence) ------------------------------ #------------------------------------------------------------------------- proc ::JingleIAX::PresenceHook {jid type args} { # Beware! jid without resource! Debug "::JingleIAX::PresenceHook jid=$jid, type=$type" if {$type ne "available"} { return } if {![::Jabber::RosterCmd isitem $jid]} { return } # Some transports propagate the complete prsence stanza. if {[::Roster::IsTransportHeuristics $jid]} { return } array set argsA $args set from $argsA(-from) # Set roster status icon if user has extended presence. set xelem [::Jabber::RosterCmd getx $from "jingle/media/audio"] if {[llength $xelem]} { set status [wrapper::getattribute $xelem type] set image [::Rosticons::ThemeGet [string tolower phone/$status]] ::RosterTree::StyleSetItemAlternative $from jivephone image $image } # As an alternative to extended presence we may have used the caps. if {0} { set ext [::Jabber::RosterCmd getcapsattr $from ext] if {[lsearch $ext iax] >= 0} { ::Jabber::Jlib caps disco_ext $from iax ::JingleIAX::CapsDiscoCB } } } # Note the 'from' !!!! proc ::JingleIAX::CapsDiscoCB {jlibname type from subiq args} { Debug "::JingleIAX::CapsDiscoCB" if {$type eq "result"} { } } # JingleIAX::SendJinglePresence -- # # Sends our phone presence type using x-element. proc ::JingleIAX::SendJinglePresence {type} { Debug "::JingleIAX::SendJinglePresence type=$type" # Send Info to all the contacts on the roster that Jingle Extended Presence. ::Jabber::Jlib register_presence_stanza [GetXPresence $type] \ -type available ::Jabber::SyncStatus } #------------------------------------------------------------------------- #------------------- Jingle Chat UI Call Button -------------------------- #------------------------------------------------------------------------- proc ::JingleIAX::BuildChatButtonTrayHook {wtray dlgtoken args} { # @@@ We must have a way to set state of this button when tab changes!!! set w [::Chat::GetDlgTokenValue $dlgtoken w] set iconCall [::Theme::Find32Icon $w callImage] set iconCallDis [::Theme::Find32Icon $w callDisImage] $wtray newbutton call \ -text [mc "Call"] -image $iconCall \ -disabledimage $iconCallDis \ -command [list ::JingleIAX::ChatCall $dlgtoken] set chattoken [::Chat::GetActiveChatToken $dlgtoken] SetChatButtonState $chattoken } proc ::JingleIAX::ChatCall {dlgtoken} { set chattoken [::Chat::GetActiveChatToken $dlgtoken] set jid [::Chat::GetChatTokenValue $chattoken jid3] set xelem [::Jabber::RosterCmd getx $jid "jingle/media/audio"] if {$xelem ne {}} { SessionInitiate $jid } } proc ::JingleIAX::ChatTabChangedHook {chattoken} { SetChatButtonState $chattoken } proc ::JingleIAX::SetChatButtonState {chattoken} { set dlgtoken [::Chat::GetChatTokenValue $chattoken dlgtoken] set wtray [::Chat::GetDlgTokenValue $dlgtoken wtray] set jid [::Chat::GetChatTokenValue $chattoken jid] # Must use full JID. if {[jlib::isbarejid $jid]} { set res [::Jabber::Jlib roster gethighestresource $jid] set jid3 $jid/$res } else { set jid3 $jid } set xelem [::Jabber::RosterCmd getx $jid3 "jingle/media/audio"] if {$xelem ne {}} { set state normal } else { set state disabled } $wtray buttonconfigure call -state $state } proc ::JingleIAX::Debug {msg} { if {0} { puts "-------- $msg" } } coccinella-0.96.20/components/Phone/IAX/cmpntIndex.tcl000066400000000000000000000001641167435367600225030ustar00rootroot00000000000000# See contrib/component.tcl for explanations. # component::attempt IAX [file join $dir Iax.tcl] ::Iax::Init coccinella-0.96.20/components/Phone/IAX/pkgIndex.tcl000066400000000000000000000011701167435367600221410ustar00rootroot00000000000000# Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. package ifneeded IaxPrefs 0.1 [list source [file join $dir IaxPrefs.tcl]] package ifneeded JingleIax 0.1 [list source [file join $dir JingleIax.tcl]] coccinella-0.96.20/components/Phone/NotifyCall.tcl000066400000000000000000000507361167435367600220270ustar00rootroot00000000000000# NotifyCall.tcl -- # # NotifyCall is an Dialog Window with Inbound and Outbound call # notifications. # # Copyright (c) 2006 Antonio Cano Damas # Copyright (c) 2006-2008 Mats Bengtsson # # 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 3 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, see . # # $Id: NotifyCall.tcl,v 1.31 2008-09-12 12:30:58 matben Exp $ package provide NotifyCall 0.1 namespace eval ::NotifyCall {} proc ::NotifyCall::Init {} { ::hooks::register avatarNewPhotoHook ::NotifyCall::AvatarNewPhotoHook variable wmain .notifycall # How shall the phone be dispayed: slot|dialog set ::config(phone,notify,type) dialog #set ::config(phone,notify,type) slot } # These are the interfaces that the Phone component calls....................... proc ::NotifyCall::SubjectEvent {textmessage} { # Adding the Subject from Caller } proc ::NotifyCall::IncomingEvent {callNo remote remote_name} { global config ::Debug 4 "::NotifyCall::IncomingEvent $callNo $remote $remote_name" set phoneNameInput $remote set phoneNumberInput $remote_name if {$config(phone,notify,type) eq "dialog"} { InboundCall $callNo "$phoneNameInput ($phoneNumberInput)" } elseif {$config(phone,notify,type) eq "slot"} { ::NotifyCallSlot::InboundCall $callNo "$phoneNameInput ($phoneNumberInput)" } } proc ::NotifyCall::OutgoingEvent {remote_name} { global config ::Debug 4 "::NotifyCall::OutgoingEvent" set phoneNameInput $remote_name if {$config(phone,notify,type) eq "dialog"} { OutboundCall 1 $phoneNameInput } elseif {$config(phone,notify,type) eq "slot"} { ::NotifyCallSlot::OutboundCall 1 $phoneNameInput } } proc ::NotifyCall::HangupEvent {args} { global config variable wmain if {$config(phone,notify,type) eq "dialog"} { destroy $wmain } elseif {$config(phone,notify,type) eq "slot"} { ::NotifyCallSlot::HangupEvent } } proc ::NotifyCall::TalkingEvent {args} { global config variable wmain # What to do when user is talking if {$config(phone,notify,type) eq "dialog"} { SetTalkingState [GetFrame $wmain] } elseif {$config(phone,notify,type) eq "slot"} { # ??? } } proc ::NotifyCall::LevelEvent {in out} { global config variable wmain if {$config(phone,notify,type) eq "dialog"} { if {[winfo exists $wmain]} { set win [GetFrame $wmain] variable $win upvar #0 $win state set state(inlevel) $in set state(outlevel) $out } } elseif {$config(phone,notify,type) eq "slot"} { ::NotifyCallSlot::LevelEvent $in $out } } #----------------------------------------------------------------------- #--------------------------- Notify Call Window ------------------------ #----------------------------------------------------------------------- # NotifyCall::InboundCall -- # proc ::NotifyCall::InboundCall { {line ""} {phoneNumber ""} } { variable wmain if { $phoneNumber ne "" } { Toplevel $wmain $line $phoneNumber "in" } } # NotifyCall::OutboundCall -- # proc ::NotifyCall::OutboundCall { {line ""} {phoneNumber ""} } { variable wmain if { $phoneNumber ne "" } { Toplevel $wmain $line $phoneNumber "out" } } # NotifyCall::Toplevel -- # # Build a toplevel dialog for call admin. # Dialog for incoming and outgoing calls. # # Arguments: # w # line # phoneNumber # inout 'in' or 'out' # # Results: # $w proc ::NotifyCall::Toplevel {w line phoneNumber inout} { # Make sure only single instance of this dialog. if {[winfo exists $w]} { raise $w return } ::UI::Toplevel $w -class PhoneNotify \ -usemacmainmenu 1 -macstyle documentProc -macclass {document closeBox} \ -closecommand ::NotifyCall::CloseDialer if { $inout eq "in" } { wm title $w [mc "Notify Call"] set msgHead [mc "Inbound Call"]: } else { wm title $w [mc "Make Call"] set msgHead [mc "Outbound Call"]: } # Global frame. ttk::frame $w.f pack $w.f ttk::label $w.f.head -style Headlabel -text $msgHead pack $w.f.head -side top -fill x ttk::separator $w.f.s -orient horizontal pack $w.f.s -side top -fill x Frame $w.f.call $line $phoneNumber $inout pack $w.f.call -side top -fill x $w.f.call configure -padding [option get . dialogPadding {}] wm resizable $w 0 0 ::UI::SetWindowPosition $w return $w } proc ::NotifyCall::GetFrame {w} { return $w.f.call } proc ::NotifyCall::InitState {win} { variable $win upvar #0 $win state # Variables used for the widgets. Levels only temporary. set state(cmicrophone) 1 set state(cspeaker) 1 set state(microphone) 50 set state(speaker) 50 set state(old:microphone) 50 set state(old:speaker) 50 set state(type) "pbx" } # NotifyCall::Frame -- # # Build the actual megawidget frame. Multi instance. # @@@ This can be used to put in a notebook page. # # Arguments: # win # line # phoneNumber # inout # # Results: # $win proc ::NotifyCall::Frame {win line phoneNumber inout} { # Have state array with same name as frame. variable $win upvar #0 $win state InitState $win jlib::splitjid $phoneNumber jid2 res # The vertical scales need a 100-level rescale! set state(microphone) [::Phone::GetInputLevel] set state(speaker) [::Phone::GetOutputLevel] set state(microphone-100) [expr {100 - $state(microphone)}] set state(speaker-100) [expr {100 - $state(speaker)}] set state(inlevel) 0 set state(outlevel) 0 set state(line) $line set state(inout) $inout set state(phoneNumber) $phoneNumber set state(whangup) $win.hangup set state(wanswer) $win.answer set state(jid2) $jid2 ttk::frame $win ttk::label $win.num -text $jid2 ttk::label $win.time -text "(00:00:00)" set state(wtime) $win.time ttk::frame $win.left ttk::frame $win.right if {1} { ttk::button $win.hangup -text [mc "Hung Up"] \ -command [list [namespace current]::HangUp $win] ttk::button $win.answer -text [mc "Answer"] \ -command [list [namespace current]::Answer $win] } else { # Alternative style buttons. ::TPhone::Button $win.hangup hangup \ -command [list [namespace current]::HangUp $win] ::TPhone::Button $win.answer call \ -command [list [namespace current]::Answer $win] } ttk::button $win.info -text [mc "Info"] \ -command [list [namespace current]::CallInfo $win] ttk::frame $win.ava grid $win.num - -sticky ew -padx 4 -pady 4 grid $win.time - -sticky ew -padx 4 -pady 4 grid $win.left $win.right -sticky ew -padx 4 -pady 4 grid $win.info $win.ava -sticky ew -padx 4 -pady 4 grid $win.hangup $win.answer -sticky ew -padx 4 -pady 4 grid columnconfigure $win 0 -uniform a grid columnconfigure $win 1 -uniform a # Level controls. set images(microphone) [::Theme::FindIconSize 16 audio-input-microphone] set images(speaker) [::Theme::FindIconSize 16 audio-output-speaker] # Microphone: set wmic $win.left.mic ttk::frame $wmic ttk::progressbar $wmic.p -length 60 -orient vertical \ -variable $win\(inlevel) ttk::scale $wmic.s -orient vertical -from 0 -to 100 -length 60 \ -variable $win\(microphone-100) \ -command [list ::NotifyCall::MicCmd $win] ttk::checkbutton $wmic.c -style Toolbutton \ -variable $win\(cmicrophone) -image $images(microphone) \ -onvalue 0 -offvalue 1 -padding {1} \ -command [list ::NotifyCall::Mute $win microphone] grid $wmic.p $wmic.s -sticky ns grid $wmic.c - grid $wmic.c -pady 4 pack $wmic # Speakers: set wspk $win.right.spk ttk::frame $wspk ttk::progressbar $wspk.p -length 60 -orient vertical \ -variable $win\(outlevel) ttk::scale $wspk.s -orient vertical -from 0 -to 100 -length 60 \ -variable $win\(speaker-100) \ -command [list ::NotifyCall::SpkCmd $win] ttk::checkbutton $wspk.c -style Toolbutton \ -variable $win\(cspeaker) -image $images(speaker) \ -onvalue 0 -offvalue 1 -padding {1} \ -command [list ::NotifyCall::Mute $win speaker] grid $wspk.p $wspk.s -sticky ns grid $wspk.c - grid $wspk.c -pady 4 pack $wspk # Only Incoming from Jingle (jid and res) has Avatar. # @@@ Antonio: we should have a better mechanism to separate calls # via Asterisk and Jingle p2p calls. if { $res ne "" } { set state(type) "jingle" set state(wavatar) $win.ava.avatar #---- Gets Avatar from Incoming Number ----- ttk::label $win.ava.avatar -style Sunken.TLabel -compound image ::Avatar::GetAsyncIfExists $jid2 AvatarNewPhotoHook $jid2 } # Button info is available only for Jingle Calls. if { $res eq "" } { $win.info state {disabled} } if { $inout ne "in" } { $win.answer state {disabled} } bind $win { ::NotifyCall::Free %W } return $win } proc ::NotifyCall::SetTalkingState {win} { variable $win upvar #0 $win state $state(wanswer) state {disabled} } #----------------------------------------------------------------------- #--------------------------- Notify Call Actions ----------------------- #----------------------------------------------------------------------- proc ::NotifyCall::CloseDialer {w} { set msg [mc "Do you want to hang up?"] set ans [tk_messageBox -icon question -type yesno -message $msg] if {$ans eq "no"} { return stop } else { ::UI::SaveWinGeom $w HangUp [GetFrame $w] return } } proc ::NotifyCall::Answer {win} { variable $win upvar #0 $win state $state(wanswer) state {disabled} ::Phone::Answer } proc ::NotifyCall::HangUp {win} { variable $win upvar #0 $win state ::Debug 4 "::NotifyCall::HangUp" if { $state(type) eq "pbx" } { ::Phone::Hangup $state(line) } else { ::Phone::HangupJingle $state(line) } # @@@ What to do? BAD!!! set w [winfo toplevel $win] if {[winfo class $w] eq "PhoneNotify"} { ::UI::SaveWinGeom $w destroy $w } } proc ::NotifyCall::CallInfo {win} { variable $win upvar #0 $win state ::UserInfo::Get $state(phoneNumber) } proc ::NotifyCall::MicCmd {win level} { variable $win upvar #0 $win state set level [expr {100 - $level}] set state(microphone) $level if {$level != $state(old:microphone)} { ::Phone::SetInputLevel $level } set state(old:microphone) $level } proc ::NotifyCall::SpkCmd {win level} { variable $win upvar #0 $win state set level [expr {100 - $level}] set state(speaker) $level if {$level != $state(old:speaker)} { ::Phone::SetOutputLevel $level } set state(old:speaker) $level } proc ::NotifyCall::Mute {win what} { variable $win upvar #0 $win state if { $state(c$what) } { set state($what) 0 } else { set state($what) $state(old:$what) } ::Phone::Mute $what $state(c$what) } proc ::NotifyCall::TimeUpdate {time} { variable wmain if {[winfo exists $wmain]} { set win [GetFrame $wmain] variable $win upvar #0 $win state # Make sure it is mapped grid $state(wtime) -padx 4 -pady 4 $state(wtime) configure -text "($time)" } } proc ::NotifyCall::AvatarNewPhotoHook {jid2} { variable wmain if {[winfo exists $wmain]} { set win [GetFrame $wmain] variable $win upvar #0 $win state # 'phoneNumber' first part is the JID. I don't like this! if {[jlib::jidequal [jlib::barejid $state(phoneNumber)] $jid2]} { set avatar [::Avatar::GetPhotoOfSize $jid2 64] if {$avatar eq ""} { grid forget $state(wavatar) } else { # Make sure it is mapped grid $state(wavatar) -padx 4 -pady 4 $state(wavatar) configure -image $avatar } } } } proc ::NotifyCall::Free {win} { variable $win upvar #0 $win state unset -nocomplain state } #--- Experiment using slots ---------------------------------------------------- namespace eval ::NotifyCallSlot { option add *NotifyCallSlot.padding {4 2 2 2} 50 option add *NotifyCallSlot.box.padding {4 2 8 2} 50 option add *NotifyCallSlot*TLabel.style Small.TLabel widgetDefault #::JUI::SlotRegister notifycall [namespace code BuildEmpty] -priority 90 variable images set images(microphone) [::Theme::FindIconSize 16 audio-input-microphone] set images(speaker) [::Theme::FindIconSize 16 audio-output-speaker] set images(online) [::Theme::FindIconSize 16 phone-online] set images(talk) [::Theme::FindIconSize 16 phone-talk] } # Event handlers. proc ::NotifyCallSlot::InboundCall {line number} { return [CallEvent $line $number in] } proc ::NotifyCallSlot::OutboundCall {line number} { return [CallEvent $line $number out] } proc ::NotifyCallSlot::CallEvent {line number inout} { variable slot set w $slot(wempty).slot set slot(w) $w set slot(line) $line set slot(number) $number # This builds the actual megawidget. Build $w $inout pack $w -fill x -expand 1 ::JUI::SlotDisplay ::JUI::SlotShow notifycall return $w } proc ::NotifyCallSlot::LevelEvent {in out} { variable slot set win $slot(frame) if {[winfo exists $win]} { variable $win upvar #0 $win state set state(inlevel) $in set state(outlevel) $out } } proc ::NotifyCallSlot::HangupEvent {} { variable slot # destroy ???????????? ::JUI::SlotClose notifycall destroy $slot(w) } # NotifyCallSlot::BuildEmpty -- # # This just reserves room for the slot and add menus. # The actual slot is only built when having a call. proc ::NotifyCallSlot::BuildEmpty {w args} { variable slot ttk::frame $w # Add menu. # This isn't the right way! foreach m [::JUI::SlotGetAllMenus] { $m add checkbutton -label [mc "Call Notification"] \ -variable [namespace current]::slot(show) \ -command [namespace code SlotCmd] \ -state disabled } set slot(wempty) $w set slot(show) 0 return $w } proc ::NotifyCallSlot::Build {w inout args} { variable slot ttk::frame $w -class NotifyCallSlot if {1} { set slot(collapse) 0 ttk::checkbutton $w.arrow -style Arrow.TCheckbutton \ -command [list [namespace current]::Collapse $w] \ -variable [namespace current]::slot(collapse) pack $w.arrow -side left -anchor n bind $w.arrow <> [list [namespace current]::Popup $w %x %y] set im [::Theme::FindIconSize 16 close-aqua] set ima [::Theme::FindIconSize 16 close-aqua-active] ttk::button $w.close -style Plain \ -image [list $im active $ima] -compound image \ -command [namespace code [list Close $w]] pack $w.close -side right -anchor n ::balloonhelp::balloonforwindow $w.close [mc "Close Slot"] } set box $w.box ttk::frame $box pack $box -fill x -expand 1 set win [Frame $box.f $inout] pack $win -fill x -expand 1 set slot(box) $w.box set slot(frame) $win return $w } proc ::NotifyCallSlot::Frame {win inout} { variable images # Have state array with same name as frame. variable $win upvar #0 $win state # Just make sure they exist. set state(inlevel) 0 set state(outlevel) 0 set state(old:microphone) 50 set state(old:speaker) 50 set state(cmicrophone) 1 set state(cspeaker) 1 set state(time) "(00:00:00)" # The next should be fixed? set state(caller) [mc "%s is calling" "Mats"]... # The vertical scales need a 100-level rescale! set state(microphone) [::Phone::GetInputLevel] set state(speaker) [::Phone::GetOutputLevel] ttk::frame $win -class NotifyCallSlotFrame # Caller info. set winfo $win.info #ttk::frame $win.info frame $win.info -bg red pack $win.info -side top -fill x ttk::button $winfo.answer -style Plain \ -image $images(online) \ -command [namespace code [list Answer $win]] ttk::label $winfo.name -textvariable $win\(caller) ttk::button $winfo.hangup -style Plain \ -image $images(talk) \ -command [namespace code [list HangUp $win]] grid $winfo.answer $winfo.name $winfo.hangup -padx 4 grid $winfo.name -sticky ew grid $winfo.hangup -sticky e grid columnconfigure $win 1 -weight 1 ::balloonhelp::balloonforwindow $winfo.answer [mc "Answer call"] ::balloonhelp::balloonforwindow $winfo.hangup [mc "Hangup call"] # Level controls. # These are only displayed when we have answered the call. Bad? set wctrl $win.ctrl ttk::frame $win.ctrl #pack $win.ctrl -side top -fill x # Microphone. ttk::progressbar $wctrl.pmic -orient horizontal \ -variable $win\(inlevel) ttk::scale $wctrl.smic -orient horizontal -length 60 -from 0 -to 100 \ -variable $win\(microphone) \ -command [namespace code [list MicCmd $win]] ttk::checkbutton $wctrl.cmic -style Plain \ -variable $win\(cmicrophone) -image $images(microphone) \ -onvalue 0 -offvalue 1 -padding {1} \ -command [namespace code [list Mute $win microphone]] # Speakers. ttk::progressbar $wctrl.pspk -orient horizontal \ -variable $win\(outlevel) ttk::scale $wctrl.sspk -orient horizontal -length 60 -from 0 -to 100 \ -variable $win\(speaker) \ -command [namespace code [list SpkCmd $win]] ttk::checkbutton $wctrl.cspk -style Plain \ -variable $win\(cspeaker) -image $images(speaker) \ -onvalue 0 -offvalue 1 -padding {1} \ -command [namespace code [list Mute $win speaker]] grid $wctrl.pmic $wctrl.smic $wctrl.cmic grid $wctrl.pspk $wctrl.sspk $wctrl.cspk grid $wctrl.pmic $wctrl.pspk -sticky ew grid $wctrl.smic $wctrl.sspk -padx 16 grid columnconfigure $wctrl 0 -weight 1 set state(winfo) $winfo set state(wctrl) $wctrl set state(wcall) $winfo.name set state(wanswer) $winfo.answer bind $win [namespace code [list FrameFree $win]] return $win } proc ::NotifyCallSlot::Answer {win} { variable images variable $win upvar #0 $win state pack $state(wctrl) -side top -fill x # The next should be fixed? set state(caller) [mc "%s is on the phone" "Mats"] $state(wanswer) state {disabled} ::Phone::Answer } proc ::NotifyCallSlot::HangUp {win} { variable slot variable $win upvar #0 $win state ::Phone::HangupJingle $slot(line) destroy $slot(frame) set slot(show) 0 ::JUI::SlotClose notifycall } proc ::NotifyCallSlot::MicCmd {win level} { variable $win upvar #0 $win state set state(microphone) $level if {$level != $state(old:microphone)} { ::Phone::SetInputLevel $level } set state(old:microphone) $level } proc ::NotifyCallSlot::SpkCmd {win level} { variable $win upvar #0 $win state set state(speaker) $level if {$level != $state(old:speaker)} { ::Phone::SetOutputLevel $level } set state(old:speaker) $level } proc ::NotifyCallSlot::Mute {win which} { variable $win upvar #0 $win state } proc ::NotifyCallSlot::FrameFree {win} { variable $win upvar #0 $win state unset -nocomplain state } proc ::NotifyCallSlot::SlotCmd {} { if {[::JUI::SlotShowed notifycall]} { ::JUI::SlotClose notifycall } else { ::JUI::SlotShow notifycall } } proc ::NotifyCallSlot::Collapse {w} { variable slot if {$slot(collapse)} { pack forget $slot(box) } else { pack $slot(box) -fill both -expand 1 } #event generate $w <> } proc ::NotifyCallSlot::Close {w} { variable slot set msg [mc "Do you want to hang up?"] set ans [tk_messageBox -icon question -type yesno -message $msg] if {$ans eq "yes"} { HangUp $slot(frame) } } coccinella-0.96.20/components/Phone/Phone.tcl000066400000000000000000000623421167435367600210300ustar00rootroot00000000000000# Phone.tcl --- # # This file is part of The Coccinella application. # It implements the core interface for softphone components. # # Copyright (c) 2006 Mats Bengtsson # Copyright (c) 2006 Antonio Cano Damas # # 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 3 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, see . # # $Id: Phone.tcl,v 1.27 2008-08-19 12:40:41 matben Exp $ #+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ # # A plugin system for softphones: # # softphones # # /--- Jingle/Jingle # / # / # Phone ------- IAX/iax # | \ # | \ # | \--- Jive/JivePhone # TPhone # AdBook # NotifyCall # # Each softphone registers with the Phone and gets the necessary callbacks # from the registered procedures. Hooks shall not be used for communications # from the Phone to its softphones since only one of the softphones, # the 'selected' phone, is active. # If a softphone wants something executed in Phone it shall call a procedure # directly. # # TODO: - how to handle '::hooks::run protocol*' ? # - search for @@@ to see where question marks are namespace eval ::Phone { variable phone if {[catch {package require TPhone}]} { return } if {[catch {package require NotifyCall}]} { return } component::define Phone "Protocol abstraction for softphones including an address book" set phone(selected) "" set phone(previous) "" variable scriptPath [file dirname [info script]] } proc ::Phone::Init {} { variable scriptPath component::register Phone # This seems necessary since the 'package require' only searches two # directory levels? lappend ::auto_path $scriptPath ::NotifyCall::Init variable wphone - variable phonenumber "" variable phoneNumberInput "" variable state - ::hooks::register loginHook ::Phone::LoginHook # @@@ The Phone could be registered into a PBX, # in that case it is independant of the Jabber network. # At this moment logoutHook only hide the Phone widget wich is wrong # because the reason for hide the widget is when Asterisk (Or other PBX) # says that the phone isn't registered. # ::hooks::register logoutHook ::Phone::LogoutHook ::hooks::register launchFinalHook ::Phone::LoginHook option add *Phone.phone16Image phone-symbol widgetDefault option add *Phone.phone16DisImage phone-symbol-Dis widgetDefault # Values for onhold -> no, hold, mute # Values for status -> returned by ::protocol:: library variable statePhone array set statePhone { registered 0 activeLine 0 onholdLine0 no statusLine0 free fromStateLine0 "" numberLine0 "" nameLine0 "" inputVolume0 0 outputVolume0 0 inputMuteVolume0 0 outputMuteVolume0 0 receivedDate0 -1 initDate0 -1 callLength0 0 } } # These procedures handle registration, administration, and dispatching to # softphone components. #............................................................................... proc ::Phone::RegisterPhone {name label initProc cmdProc deleteProc} { variable phone set phone($name,name) $name set phone($name,label) $label set phone($name,init) $initProc set phone($name,command) $cmdProc set phone($name,delete) $deleteProc } proc ::Phone::SetPhone {name} { variable phone # @@@ Call initProc ? set phone(previous) $phone(selected) set phone(selected) $name } proc ::Phone::GetPhone {} { variable phone return $phone(selected) } proc ::Phone::GetPreviousPhone {} { variable phone return $phone(previous) } proc ::Phone::GetAllPhones {} { variable phone set names {} foreach {key name} [array get phone *,name] { lappend names $name $phone($name,label) } return $names } proc ::Phone::InitPhone {} { variable phone set name $phone(selected) $phone($name,init) } # Phone::CommandPhone -- # # Dispatches a command to the selected softphone. proc ::Phone::CommandPhone {args} { variable phone # @@@ We could guard ourselves against no selected (""). set name $phone(selected) if {$name ne ""} { uplevel #0 $phone($name,command) $args } } proc ::Phone::DeletePhone {name} { variable phone $phone($name,delete) } #............................................................................... proc ::Phone::LoadPrefs { } { variable statePhone CommandPhone loadprefs CommandPhone register set statePhone(inputVolume0) [CommandPhone getinputlevel] set statePhone(outputVolume0) [CommandPhone getoutputlevel] SetInputLevel [expr {double($statePhone(inputVolume0))*100}] # This seems to be a bad idea since volume is set globally! # SetOutputLevel [expr {double($statePhone(outputVolume0))*100}] InitPhone ::hooks::run phoneInit } proc ::Phone::LogoutHook {} { variable statePhone variable wphone if {[GetPhone] ne ""} { CommandPhone unregister if {[winfo exists $wphone]} { set wnb [::JUI::GetNotebook] $wnb forget $wphone destroy $wphone } } } proc ::Phone::LoginHook {} { variable statePhone if {[GetPhone] ne ""} { LoadPrefs } } proc ::Phone::ShowPhone {} { if {[GetPhone] ne ""} { NewPage ::AddressBook::NewPage } } proc ::Phone::HidePhone {} { variable statePhone variable wphone if {[GetPhone] ne ""} { CommandPhone unregister if {[winfo exists $wphone]} { set wnb [::JUI::GetNotebook] $wnb forget $wphone destroy $wphone } ::AddressBook::CloseAddressBook } } ################################################## # Protocol Call Events ################################################## proc ::Phone::IncomingCall {callNo remote remote_name} { variable statePhone variable wphone variable phoneNumberInput ::Debug 4 "::Phone::IncomingCall $callNo $remote $remote_name" # For the moment the phone just have one line if { $callNo == 0 } { # Set Active Line set statePhone(activeLine) $callNo set statePhone(fromStateLine0) "Incoming" # Set State for Incoming set statePhone(numberLine0) $remote set AddressBookName [::AddressBook::Search $remote] if { $AddressBookName ne "" } { set statePhone(nameLine0) $AddressBookName } else { set statePhone(nameLine0) $remote_name } set phoneNumberInput $remote set statePhone(receivedDate0) [clock seconds] if {[winfo exists $wphone]} { ::TPhone::Number $wphone $remote } set initLength 0 if {[winfo exists $wphone]} { ::TPhone::TimeUpdate $wphone \ [clock format [expr {$initLength - 3600}] -format %X] } ::NotifyCall::TimeUpdate \ [clock format [expr {$initLength - 3600}] -format %X] ::NotifyCall::IncomingEvent $callNo $remote $statePhone(nameLine0) ::AddressBook::ReceivedCall $callNo $remote $statePhone(nameLine0) SetIncomingState ::hooks::run phoneNotifyIncomingCall $callNo $remote $statePhone(nameLine0) } else { puts "No more than one line, Reject" } } proc ::Phone::UpdateState {callNo state} { variable statePhone set statePhone(statusLine0) $state } proc ::Phone::UpdateText {callno textmessage} { variable wphone if {[winfo exists $wphone]} { ::TPhone::SetSubject $wphone $textmessage } ::NotifyCall::SubjectEvent $textmessage } proc ::Phone::UpdateLevels {in out} { variable statePhone variable wphone ::NotifyCall::LevelEvent $in $out # @@@ This is a stupid way to do it!!! # Better is to add a state handler: iaxclient::statebind # Update Call Length if { $statePhone(initDate0) >= 0 } { set tempDate [clock seconds] set statePhone(callLength0) [expr {$tempDate - $statePhone(initDate0)}] if {[winfo exists $wphone]} { ::TPhone::TimeUpdate $wphone \ [clock format [expr {$statePhone(callLength0) - 3600}] -format %X] } ::NotifyCall::TimeUpdate \ [clock format [expr {$statePhone(callLength0) - 3600}] -format %X] } } proc ::Phone::UpdateRegister {id reply msgcount} { variable statePhone variable phoneMWI variable wphone # Sets MWI set phoneMWI 0 if { $msgcount > 0} { set phoneMWI $msgcount } ::TPhone::MWIUpdate $wphone $phoneMWI # Registration Ok, start game if { $reply eq "ack"} { if {$state(registered) == 0} { SetNormalState set state(registered) 1 } } } ################################################## # Build User Interface ################################################## proc ::Phone::NewPage {} { variable statePhone variable wphone set wnb [::JUI::GetNotebook] set wphone $wnb.phone if {![winfo exists $wphone]} { ::TPhone::New $wphone ::Phone::Actions -class Phone -padding {8 4} set im [::Theme::Find16Icon $wphone phone16Image] set imd [::Theme::Find16Icon $wphone phone16DisImage] set imSpec [list $im disabled $imd background $imd] $wnb add $wphone -text [mc "Phone"] -image $imSpec -compound image \ -sticky nw } #SetUnregisterState } proc ::Phone::NewTransferDlg {} { variable state variable transferPhoneNumber set w .phonetransfer # Make sure only single instance of this dialog. if {[winfo exists $w]} { raise $w return } ::UI::Toplevel $w -class PhoneDialer \ -usemacmainmenu 1 -macstyle documentProc -macclass {document closeBox} \ -closecommand [namespace current]::CloseCmd wm title $w [mc "Forward to"]... ::UI::SetWindowPosition $w set phoneNumber "" # Global frame. ttk::frame $w.f pack $w.f -fill x ttk::label $w.f.head -style Headlabel -text [mc "Phone"] pack $w.f.head -side top -fill both -expand 1 ttk::separator $w.f.s -orient horizontal pack $w.f.s -side top -fill x set wbox $w.f.f ttk::frame $wbox -padding [option get . dialogPadding {}] pack $wbox -fill both -expand 1 set box $wbox.b ttk::frame $box pack $box -side bottom -fill x ttk::label $box.l -text [mc "Number"]: ttk::entry $box.e -textvariable [namespace current]::transferPhoneNumber \ -width 18 ttk::button $box.dial -text [mc "Dial"] \ -command [list [namespace current]::TransferTo $w] ttk::button $box.btcancel -text [mc "Cancel"] \ -command [list [namespace current]::CancelEnter $w] grid $box.l $box.e $box.dial $box.btcancel -padx 1 -pady 4 focus $box.e wm resizable $w 0 0 } proc ::Phone::CancelEnter {w} { ::UI::SaveWinGeom $w destroy $w } proc ::Phone::CloseCmd {w} { ::UI::SaveWinGeom $w } # Phone::Actions -- # # This is the callback function for the TPhone megawidget. # ################################################## # Phone Actions: # - Actions # - Touch # - Dial # - Hangup # - Hold / Unhold # - Mute / Unmute # - ChangeLine # - SetInputLevel # - SetOutputLevel # - transferTo # ################################################ proc ::Phone::Actions { type args } { switch -- $type { call { Dial } hangup { Hangup } hangupjingle { Hangup } mute { set which [lindex $args 0] set onoff [lindex $args 1] Mute $which $onoff } speaker { SetOutputLevel [lindex $args 0] } microphone { SetInputLevel [lindex $args 0] } backspace { Touch } 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 - * - \# { Touch $type } transfer { NewTransferDlg } mwi { puts "Mwi pressed" } default { Touch $type } } } proc ::Phone::UpdateDisplay {text} { variable wphone variable phoneNumberInput set phoneNumberInput $text if {[winfo exists $wphone]} { ::TPhone::Number $wphone $text } } proc ::Phone::Touch {{key ""} {alt_key ""}} { variable phoneNumberInput variable statePhone variable wphone set phonenumber $statePhone(numberLine0)$key set phoneNumberInput $phonenumber # BackSpace key pressed. if { $key eq "" && $alt_key eq "" } { set last [string length $phonenumber] if { $last > 0} { set phonenumber [string range $phonenumber 0 [expr {$last - 2}] ] set phoneNumberInput $phonenumber ::TPhone::KeyDelete $wphone } else { #@@@ This is ugly tricky. #@@@ What we can do when Display different from phoneNumberInput, #@@@ Maybe remove all the display with the first backspace. ::Phone::UpdateDisplay "" } } set statePhone(numberLine0) $phoneNumberInput if { [lsearch {0 1 2 3 4 5 6 7 8 9 C * # D} $key] >= 0 } { CommandPhone playtone $key if { $statePhone(statusLine0) ne "free" } { CommandPhone sendtone $key } } } # Phone::DialJingle -- # # Public interface for the phone components, special for Jingle/IAX. proc ::Phone::DialJingle { ipPeer portPeer calledName callerName {user ""} {password ""} } { variable statePhone variable phoneNumberInput variable wphone ::Debug 4 "::Phone::DialJingle ipPeer=$ipPeer,portPeer=$portPeer,calledName=$calledName" #---- Set Caller and Called Identification ------ ::Phone::UpdateDisplay $calledName CommandPhone callerid "Jingle" $callerName #---- Make Dial --------- if { $ipPeer ne "" } { set phoneNumberInput "$ipPeer:$portPeer/" } set activeLine 0 set statePhone(statusLine0) "outgoing" set statePhone(numberLine$activeLine) $phoneNumberInput set statePhone(onholdLine$activeLine) "no" set subject "" if {[winfo exists $wphone]} { set subject [::TPhone::GetSubject $wphone] } if {$subject eq ""} { set subject "Jingle Call" } ::NotifyCall::OutgoingEvent $calledName CommandPhone dialjingle $phoneNumberInput $statePhone(activeLine) $subject $user $password ::hooks::run phoneNotifyOutgoingCall $calledName set statePhone(fromStateLine0) "Dial" set statePhone(initDate0) [clock seconds] SetDialState } proc ::Phone::DialJingleCandidates {candidates calledName callerName {user ""} {password ""}} { variable statePhone variable phoneNumberInput variable wphone ::Debug 4 "::Phone::DialJingleCandidates" #---- Set Caller and Called Identification ------ ::Phone::UpdateDisplay $calledName CommandPhone callerid "Jingle" $callerName # @@@ ??? set phoneNumberInput "" set activeLine 0 set statePhone(statusLine0) "outgoing" set statePhone(numberLine$activeLine) $phoneNumberInput set statePhone(onholdLine$activeLine) "no" set subject "" if {[winfo exists $wphone]} { set subject [::TPhone::GetSubject $wphone] } if {$subject eq ""} { set subject "Jingle Call" } ::NotifyCall::OutgoingEvent $calledName CommandPhone dialjinglecandidates $candidates ::hooks::run phoneNotifyOutgoingCall $calledName set statePhone(fromStateLine0) "Dial" set statePhone(initDate0) [clock seconds] SetDialState } proc ::Phone::Answer {} { ::Debug 4 "::Phone::Answer" set activeLine 0 CommandPhone answer $activeLine hooks::run phoneNotifyTalkingState # IAX gets a notifier 'active complete' event which calls 'SetTalkingState'. } proc ::Phone::Dial {{phoneNumber ""}} { variable statePhone variable phoneNumberInput variable wphone #----- if Dial is called from AddressBook ------- if { $phoneNumber ne "" } { UpdateDisplay $phoneNumber set phoneNumberInput $phoneNumber } set activeLine 0 set statePhone(numberLine$activeLine) $phoneNumberInput set statePhone(onholdLine$activeLine) "no" if { [lsearch $statePhone(statusLine0) "ringing"] >= 0 } { CommandPhone answer $activeLine ::NotifyCall::TalkingEvent hooks::run phoneNotifyTalkingState } else { set subject [::TPhone::GetSubject $wphone] CommandPhone callerid CommandPhone dial $phoneNumberInput $statePhone(activeLine) $subject set statePhone(fromStateLine0) "Dial" set statePhone(initDate0) [clock seconds] ::AddressBook::Called $phoneNumberInput SetDialState } } # Phone::HangupJingle -- # # Public interface for the phone components, special for Jingle/IAX. proc ::Phone::HangupJingle {{callNo ""}} { variable statePhone ::Debug 4 "::Phone::HangupJingle" if { [lsearch $statePhone(statusLine0) "ringing"] >= 0 } { CommandPhone reject $statePhone(activeLine) } else { # @@@ Why do we change line? CommandPhone changeline $statePhone(activeLine) CommandPhone hangupjingle } # IAX gets a notifier free event which calls 'SetNormalState'. } proc ::Phone::Hangup {{callNo ""}} { variable statePhone ::Debug 4 "::Phone::Hangup" if { [lsearch $statePhone(statusLine0) "ringing"] >= 0 } { CommandPhone reject $statePhone(activeLine) } else { # @@@ Why do we change line? CommandPhone changeline $statePhone(activeLine) CommandPhone hangup } # IAX gets a notifier free event which calls 'SetNormalState'. } proc ::Phone::Mute {type onoff} { variable statePhone set line $statePhone(activeLine) set onHoldLine "onholdLine$line" switch $onoff { "1" { set statePhone($onHoldLine) "no" if {$type eq "microphone"} { SetInputLevel [expr {double($statePhone(inputMuteVolume$line))*100}] } else { SetOutputLevel [expr {double($statePhone(outputMuteVolume$line))*100}] } } "0" { set statePhone($onHoldLine) "mute" if {$type eq "microphone"} { set statePhone(inputMuteVolume$line) [CommandPhone getinputlevel] SetInputLevel 0 } else { set statePhone(outputMuteVolume$line) [CommandPhone getoutputlevel] SetOutputLevel 0 } } } } # Set/get audio levels. Note the rescaling of 100. proc ::Phone::SetInputLevel {args} { variable statePhone variable wphone set inputLevel [expr {double($args)/100.0}] CommandPhone inputlevel $inputLevel set statePhone(inputVolume0) $inputLevel if {[winfo exists $wphone]} { ::TPhone::Volume $wphone microphone $args } } proc ::Phone::SetOutputLevel {args} { variable statePhone variable wphone set outputLevel [expr {double($args)/100.0}] CommandPhone outputlevel $outputLevel set statePhone(outputVolume0) $outputLevel if {[winfo exists $wphone]} { ::TPhone::Volume $wphone speaker $args } } proc ::Phone::GetInputLevel {} { return [expr {100.0*[CommandPhone getinputlevel]}] } proc ::Phone::GetOutputLevel {} { return [expr {100.0*[CommandPhone getoutputlevel]}] } proc ::Phone::TransferTo {w} { variable transferPhoneNumber CommandPhone transfer $transferPhoneNumber destroy $w SetNormalState } #----------------------------- DialPad State ----------------------------------- # ______________________________ # | | # | v # | --> Normal-----> Dial ----> Talking ---> Normal # | | | ^ ^ # | | |______________________| | # | v | # |_____ Incoming ------------------------------+ # # Dial. State originate by Dial button # Normal. State is the Start state and it is originate by Hangup button or # Free event, too. # All the others states are originate by Events # #------------------------------------------------------------------------------- # These functions control all state changes and calls the selected softphone # component which is responsible for protocol stuff. # # Note: try to call these only from the selected softphone to avoid # duplicate presence elements. # # States: Normal, Dial, Talking, Incoming. proc ::Phone::SetUnregisterState {} { # $wpath.pad.hangup configure -text "Hangup" # $wpath.pad.dial configure -text "Dial" # # $wpath.pad.hangup state {disabled} # $wpath.pad.transfer state {disabled} # $wpath.pad.hold state {disabled} # $wpath.pad.mute state {disabled} # $wpath.pad.dial state {disabled} # $wpath.pad.c state {disabled} # set [namespace current]::phoneNumberInput "" SetNormalState } proc ::Phone::SetNormalState {{noCall ""}} { variable statePhone variable wphone ::Debug 4 "::Phone::SetNormalState" ###### Update Calls Logs (NormalState stands for Free or Hangup state too) ########### if { [info exists statePhone(fromStateLine0)] } { if { $statePhone(fromStateLine0) ne ""} { set type "" set date $statePhone(receivedDate0) switch $statePhone(fromStateLine0) { "Incoming" { set type "Received" if { $statePhone(callLength0) == 0 } { set type "Missed" } } "Dial" { set type "Called" set date $statePhone(initDate0) } } ::AddressBook::UpdateLogs $type $statePhone(numberLine0) $statePhone(nameLine0) $date $statePhone(callLength0) } } ::AddressBook::NormalState ::NotifyCall::HangupEvent ::hooks::run phoneNotifyNormalState if {[winfo exists $wphone]} { ::TPhone::SetSubject $wphone "" } ####### Initialize State Machine information ######### set statePhone(nameLine0) "" set statePhone(initDate0) -1 set statePhone(receivedDate0) -1 set statePhone(callLength0) 0 set statePhone(fromStateLine0) "" set statePhone(statusLine0) "free" set statePhone(activeLine) 0 set statePhone(onholdLine0) "no" ########## Sets Widget Buttons State ###################### if {[winfo exists $wphone]} { ::TPhone::State $wphone "call" {!disabled} ::TPhone::State $wphone "backspace" {!disabled} ::TPhone::State $wphone "hangup" {disabled} ::TPhone::State $wphone "transfer" {disabled} } ::Phone::CommandPhone state "available" ::hooks::run phoneChangeState "available" } proc ::Phone::SetDialState {} { variable wphone ::Debug 4 "::Phone::SetDialState" ########## Sets Widgets State ###################### if {[winfo exists $wphone]} { ::TPhone::State $wphone "hangup" {!disabled} ::TPhone::State $wphone "call" {disabled} ::TPhone::State $wphone "transfer" {disabled} ::TPhone::State $wphone "backspace" {disabled} } ::Phone::CommandPhone state "ring" ::hooks::run phoneChangeState "ring" } proc ::Phone::SetTalkingState {{noCall ""} } { variable statePhone variable wphone ::Debug 4 "::Phone::SetTalkingState" set statePhone(initDate0) [clock seconds] if {[winfo exists $wphone]} { ::TPhone::State $wphone "hangup" {!disabled} ::TPhone::State $wphone "transfer" {!disabled} ::TPhone::State $wphone "call" {disabled} ::TPhone::State $wphone "backspace" {disabled} } ::AddressBook::TalkingState ::Phone::CommandPhone state "on_phone" ::hooks::run phoneChangeState "on_phone" } proc ::Phone::SetIncomingState { {noCall ""}} { variable statePhone variable wphone ::Debug 4 "::Phone::SetIncomingState" if {[winfo exists $wphone]} { ::TPhone::State $wphone "hangup" {!disabled} ::TPhone::State $wphone "call" {!disabled} ::TPhone::State $wphone "transfer" {disabled} ::TPhone::State $wphone "backspace" {disabled} } ::Phone::CommandPhone state "ring" ::hooks::run phoneChangeState "ring" } ############# TO-DO ################## # Features: #---------- Advanced ---------- # 3. Call Recording # 4. Open three calls and mix channels, like an audio conference room # 5. Multi Server - Multi Protocol (Preferences) # # Known bugs and errors: # ..... A lot of Debug work coccinella-0.96.20/components/Phone/TPhone.tcl000066400000000000000000000330261167435367600211510ustar00rootroot00000000000000# TPhone.tcl --- # # This file implements a megawidget phone key pad. # # Copyright (c) 2006-2008 Mats Bengtsson # # 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 3 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, see . # # $Id: TPhone.tcl,v 1.8 2008-05-27 14:17:23 matben Exp $ #------------------------------------------------------------------------------- # USAGE: # # ::TPhone::New widgetPath tclProc ?-key value ...? # # ::TPhone::Volume widgetPath microphone|speaker ?level? # # ::TPhone::Number widgetPath ?number? # # ::TPhone::State widgetPath name ?state? # # ::TPhone::DialState widgetPath state # #------------------------------------------------------------------------------- package provide TPhone 0.1 namespace eval ::TPhone { variable inited 0 } proc ::TPhone::Init {} { global this variable inited variable images variable buttons {1 2 3 4 5 6 7 8 9 star 0 square} set names [list] foreach b $buttons { lappend names b$b b${b}Pressed } foreach b {backspace call clear hangup transfer radio1 radio2 radio3} { lappend names $b ${b}Pressed } lappend names display if {![info exists images(b0)]} { foreach name $names { set images($name) [::Theme::FindIcon elements/phone/$name] } set images(microphone) [::Theme::FindIconSize 16 audio-input-microphone] set images(speaker) [::Theme::FindIconSize 16 audio-output-speaker] } set themes [ttk::themes] foreach name $themes { ttk::style theme settings $name { ttk::style layout Phone.TButton { Phone.border -children { Phone.padding -children { Phone.label -side left } } } ttk::style configure Phone.TButton \ -padding {0} -borderwidth 0 -relief flat ttk::style layout Phone.Toolbutton { Phone.label } } } # Map from name to widget subpath. variable name2w array set name2w { display display 0 bts.0 1 bts.1 2 bts.2 3 bts.3 4 bts.4 5 bts.5 6 bts.6 7 bts.7 8 bts.8 9 bts.9 star bts.star square bts.square call bts.call hangup bts.hangup transfer bts.transfer backspace bts.backspace } set inited 1 } # TPhone::New -- # # Creates new megawidget phone pad. # # Arguments: # w # command tclProc # args options to the main ttk::frame # # Results: # $w proc ::TPhone::New {w command args} { variable inited variable images variable buttons variable $w upvar #0 $w state if {!$inited} { Init } set state(command) $command set state(microphone) 0 set state(speaker) 0 set state(old:microphone) 0 set state(old:speaker) 0 set state(cmicrophone) 1 set state(cspeaker) 1 set state(line) 1 set state(subject) "" eval {ttk::frame $w} $args # The display: set width [expr {[image width $images(display)] + 0}] set height [expr {[image height $images(display)] + 0}] set display $w.display canvas $w.display -width $width -height $height \ -highlightthickness 3 -bd 0 -highlightbackground gray87 \ -insertwidth 0 -bg gray87 $w.display create image 3 3 -anchor nw -image $images(display) $w.display create text 18 26 -anchor nw -tag number \ -font {Helvetica -16} -fill black $w.display create text 18 46 -anchor nw -tag time \ -font {Helvetica -11} -fill black $w.display create text [expr {$width - 18}] 16 -anchor nw -tag mwi \ -font {Helvetica -11} -fill black $w.display bind mwi [list ::TPhone::Invoke $w mwi] grid $w.display -pady 4 $w.display itemconfigure time -text 00:00:00 $w.display itemconfigure mwi -text 0 bind $display { focus %W %W focus number } bind $display [list ::TPhone::KeyPress $w %A %K] bind $display [list ::TPhone::KeyDeleteBind $w] bind $display [list ::TPhone::KeyDeleteBind $w] # Call Subject set subject $w.esb ttk::frame $w.esb grid $w.esb -sticky ew -pady 2 ttk::label $subject.lsubject -text [mc "Subject"]: ttk::entry $subject.esubject -textvariable $w\(subject) \ -width 18 grid $subject.lsubject $subject.esubject -padx 2 -pady 2 # Buttons: set bts $w.bts ttk::frame $w.bts grid $w.bts -sticky ew -pady 2 option add *$bts.TButton.takeFocus 0 ttk::button $bts.call -style Phone.TButton \ -image [list $images(call) pressed $images(callPressed)] \ -command [list ::TPhone::Invoke $w call] ttk::button $bts.transfer -style Phone.TButton \ -image [list $images(transfer) pressed $images(transferPressed)] \ -command [list ::TPhone::Invoke $w transfer] ttk::button $bts.hangup -style Phone.TButton \ -image [list $images(hangup) pressed $images(hangupPressed)] \ -command [list ::TPhone::Invoke $w hangup] grid $bts.call $bts.transfer $bts.hangup -padx 2 -pady 2 bind $bts.call [list ::TPhone::KeyPress $w %A %K] bind $bts.call [list ::TPhone::KeyDeleteBind $w] bind $bts.call [list ::TPhone::KeyDeleteBind $w] bind $bts.transfer [list ::TPhone::KeyPress $w %A %K] bind $bts.transfer [list ::TPhone::KeyDeleteBind $w] bind $bts.transfer [list ::TPhone::KeyDeleteBind $w] bind $bts.hangup [list ::TPhone::KeyPress $w %A %K] bind $bts.hangup [list ::TPhone::KeyDeleteBind $w] bind $bts.hangup [list ::TPhone::KeyDeleteBind $w] foreach {c0 c1 c2} $buttons { ttk::button $bts.$c0 -style Phone.TButton \ -image [list $images(b$c0) pressed $images(b${c0}Pressed)] \ -command [list ::TPhone::Invoke $w $c0] ttk::button $bts.$c1 -style Phone.TButton \ -image [list $images(b$c1) pressed $images(b${c1}Pressed)] \ -command [list ::TPhone::Invoke $w $c1] ttk::button $bts.$c2 -style Phone.TButton \ -image [list $images(b$c2) pressed $images(b${c2}Pressed)] \ -command [list ::TPhone::Invoke $w $c2] grid $bts.$c0 $bts.$c1 $bts.$c2 -padx 2 -pady 2 bind $bts.$c0 [list ::TPhone::KeyPress $w %A %K] bind $bts.$c0 [list ::TPhone::KeyDeleteBind $w] bind $bts.$c0 [list ::TPhone::KeyDeleteBind $w] bind $bts.$c1 [list ::TPhone::KeyPress $w %A %K] bind $bts.$c1 [list ::TPhone::KeyDeleteBind $w] bind $bts.$c1 [list ::TPhone::KeyDeleteBind $w] bind $bts.$c2 [list ::TPhone::KeyPress $w %A %K] bind $bts.$c2 [list ::TPhone::KeyDeleteBind $w] bind $bts.$c2 [list ::TPhone::KeyDeleteBind $w] } ttk::button $bts.backspace -style Phone.TButton \ -image [list $images(backspace) pressed $images(backspacePressed)] \ -command [list ::TPhone::Invoke $w backspace] grid $bts.backspace -column 1 bind $bts.backspace [list ::TPhone::KeyPress $w %A %K] bind $bts.backspace [list ::TPhone::KeyDeleteBind $w] bind $bts.backspace [list ::TPhone::KeyDeleteBind $w] set bot $w.bot ttk::frame $w.bot grid $w.bot -sticky ew -pady 2 bind $bot [list ::TPhone::KeyPress $w %A %K] bind $bot [list ::TPhone::KeyDeleteBind $w] bind $bot [list ::TPhone::KeyDeleteBind $w] ttk::frame $bot.mic ttk::scale $bot.mic.s -orient vertical -from 0 -to 100 \ -variable $w\(microphone) -command [list ::TPhone::MicCmd $w] -length 60 ttk::checkbutton $bot.mic.l -style Toolbutton \ -variable $w\(cmicrophone) -image $images(microphone) \ -onvalue 0 -offvalue 1 -padding {1} \ -command [list ::TPhone::Mute $w microphone] pack $bot.mic.s $bot.mic.l -side top pack $bot.mic.l -pady 4 ttk::frame $bot.spk ttk::scale $bot.spk.s -orient vertical -from 0 -to 100 \ -variable $w\(speaker) -command [list ::TPhone::SpkCmd $w] -length 60 ttk::checkbutton $bot.spk.l -style Toolbutton \ -variable $w\(cspeaker) -image $images(speaker) \ -onvalue 0 -offvalue 1 -padding {1} \ -command [list ::TPhone::Mute $w speaker] pack $bot.spk.s $bot.spk.l -side top pack $bot.spk.l -pady 4 grid $bot.mic $bot.spk -padx 4 grid $bot.mic -sticky w grid $bot.spk -sticky e grid columnconfigure $bot 1 -weight 1 bind $bot.mic.l [list ::TPhone::KeyPress $w %A %K] bind $bot.mic.l [list ::TPhone::KeyDeleteBind $w] bind $bot.mic.l [list ::TPhone::KeyDeleteBind $w] bind $bot.spk.l [list ::TPhone::KeyPress $w %A %K] bind $bot.spk.l [list ::TPhone::KeyDeleteBind $w] bind $bot.spk.l [list ::TPhone::KeyDeleteBind $w] bind $w { ::TPhone::Free %W } return $w } proc ::TPhone::KeyPress {w key alt} { variable $w upvar #0 $w state set meta {period colon minus underscore slash Shift_L Alt_L Control_L Meta_L} #We can call an URI with text characters set metaValue 0 if { ([lsearch $meta $alt]>=0) || [string is wordchar -strict $alt]} { set metaValue 1 } if { $metaValue && $key ne ""} { if {[string is integer -strict $key]} { $w.bts.$key invoke } else { set btn [string map {"*" star "#" square} $key] if { $key eq "*" || $key eq "#"} { $w.bts.$btn invoke } else { $w.display insert number end $key uplevel #0 $state(command) $key } } } } proc ::TPhone::KeyDeleteBind {w} { $w.bts.backspace invoke } proc ::TPhone::KeyDelete {w} { set len [string length [$w.display itemcget number -text]] $w.display dchars number [expr {$len - 1}] } proc ::TPhone::TimeUpdate {w time} { $w.display itemconfigure time -text $time } proc ::TPhone::GetSubject {w args} { variable $w upvar #0 $w state if {$args eq {}} { return $state(subject) } } proc ::TPhone::SetSubject {w subject} { variable $w upvar #0 $w state set state(subject) $subject } proc ::TPhone::MWIUpdate {w msgCount} { $w.display itemconfigure mwi -text $msgCount } proc ::TPhone::MicCmd {w level} { variable $w upvar #0 $w state if {$level != $state(old:microphone)} { uplevel #0 $state(command) microphone [expr {100 - $level}] } set state(old:microphone) $level } proc ::TPhone::SpkCmd {w level} { variable $w upvar #0 $w state if {$level != $state(old:speaker)} { uplevel #0 $state(command) speaker [expr {100 - $level}] } set state(old:speaker) $level } proc ::TPhone::Volume {w type args} { variable $w upvar #0 $w state if {[lsearch {microphone speaker} $type] < 0} { return -code error "unrecognized volume type \"$type\"" } if {$args == {}} { return [expr {100 - $state($type)}] } else { set state($type) [expr {100 - [lindex $args 0]}] } } proc ::TPhone::Number {w args} { variable $w upvar #0 $w state if {$args eq {}} { return [$w.display itemcget number -text] } else { set number [lindex $args 0] $w.display itemconfigure number -text $number } } proc ::TPhone::State {w name {_state ""}} { variable name2w # Map from name to widget subpath! set win $w.$name2w($name) set wclass [winfo class $win] if {$_state eq ""} { if {$wclass eq "Canvas"} { return [$win cget -state] } else { return [$win state] } } else { if {$wclass eq "Canvas"} { $win configure -state $_state } else { $win state $_state } } } proc ::TPhone::DialState {w _state} { variable name2w variable buttons if {$_state eq "disabled"} { foreach name $buttons { $w.$name2w($name) state {disabled} } $w.$name2w(display) configure -state disabled } else { foreach name $buttons { $w.$name2w($name) state {!disabled} } $w.$name2w(display) configure -state normal } } proc ::TPhone::Invoke {w b} { variable $w upvar #0 $w state set tone [string map {star "*" square "#"} $b] if {[string is integer -strict $b]} { $w.display insert number end $b } if { $b eq "star" || $b eq "square"} { $w.display insert number end $tone } uplevel #0 $state(command) $tone } proc ::TPhone::Line {w} { variable $w upvar #0 $w state uplevel #0 $state(command) line $state(line) } proc ::TPhone::Mute {w type} { variable $w upvar #0 $w state uplevel #0 $state(command) mute $type $state(c$type) } # TPhone::Button -- # # Make standalone button. proc ::TPhone::Button {w type args} { variable inited variable images if {!$inited} { Init } return [eval {ttk::button $w -style Phone.TButton \ -image [list $images($type) pressed $images(${type}Pressed)]} $args] } proc ::TPhone::Free {w} { variable $w upvar #0 $w state unset -nocomplain state } coccinella-0.96.20/components/Phone/cmpntIndex.tcl000066400000000000000000000003241167435367600220600ustar00rootroot00000000000000# See contrib/component.tcl for explanations. # component::attempt AddressBook [file join $dir AddressBook.tcl] ::AddressBook::Init component::attempt Phone [file join $dir Phone.tcl] ::Phone::Init coccinella-0.96.20/components/Phone/pkgIndex.tcl000066400000000000000000000011721167435367600215220ustar00rootroot00000000000000# Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. package ifneeded NotifyCall 0.1 [list source [file join $dir NotifyCall.tcl]] package ifneeded TPhone 0.1 [list source [file join $dir TPhone.tcl]] coccinella-0.96.20/components/SlideShow.tcl000077500000000000000000000274341167435367600206150ustar00rootroot00000000000000# SlideShow.tcl -- # # Slide show for whiteboard. This is just a first sketch. # # Copyright (c) 2004 Mats Bengtsson # # 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 3 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, see . # # $Id: SlideShow.tcl,v 1.28 2008-05-14 14:05:35 matben Exp $ package require undo namespace eval ::SlideShow { if {![::Jabber::HaveWhiteboard]} { return } component::define SlideShow "Whiteboard based slide show" } proc ::SlideShow::Load { } { variable priv if {![::Jabber::HaveWhiteboard]} { return } ::Debug 2 "::SlideShow::Load" # TRANSLATORS; whiteboard slide show menu set menuspec \ {cascade mSlideShow {[mc "Slide Show"]} {} {} {} { {command mOpenFolder... {[mc "&Open Folder"]...} {::SlideShow::PickFolder $w} {} {}} {separator} {command {Previous} {[mc "Previous"]} {::SlideShow::Previous $w} {} {}} {command {Next} {[mc "Next"]} {::SlideShow::Next $w} {} {}} {command {First} {[mc "First"]} {::SlideShow::First $w} {} {}} {command {Last} {[mc "Last"]} {::SlideShow::Last $w} {} {}} } } # Define all hooks needed here. ::hooks::register prefsInitHook ::SlideShow::InitPrefsHook ::hooks::register prefsBuildHook ::SlideShow::BuildPrefsHook ::hooks::register prefsSaveHook ::SlideShow::SavePrefsHook ::hooks::register prefsCancelHook ::SlideShow::CancelPrefsHook ::hooks::register prefsUserDefaultsHook ::SlideShow::UserDefaultsHook ::hooks::register prefsDestroyHook ::SlideShow::DestroyPrefsHook #::hooks::register initHook ::SlideShow::InitHook ::hooks::register afterFinalHook ::SlideShow::InitHook ::hooks::register whiteboardBuildButtonTrayHook ::SlideShow::BuildButtonsHook ::hooks::register whiteboardCloseHook ::SlideShow::CloseHook ::hooks::register menuPostCommand ::SlideShow::MenuPostHook ::WB::RegisterMenuEntry file $menuspec component::register SlideShow # TODO: rewrite to use ::Theme::Find32Icon function set gopreviousview [::Theme::FindIcon icons/32x32/go-previous-view] set gonextview [::Theme::FindIcon icons/32x32/go-next-view] set gopreviousviewDis [::Theme::FindIcon icons/32x32/go-previous-view-Dis] set gonextviewDis [::Theme::FindIcon icons/32x32/go-next-view-Dis] set priv(btdefs) [list \ [list previous $gopreviousview $gopreviousviewDis {::SlideShow::Previous $w}] \ [list next $gonextview $gonextviewDis {::SlideShow::Next $w}] ] } proc ::SlideShow::InitHook { } { global prefs variable priv set mimes {image/gif image/png image/jpeg} set priv(mimes) {} foreach mime $mimes { if {[::Media::HaveImporterForMime $mime]} { lappend priv(mimes) $mime } } set priv(suffixes) {.can} foreach mime $priv(mimes) { set priv(suffixes) [concat $priv(suffixes) \ [::Types::GetSuffixListForMime $mime]] } if {$prefs(slideShow,buttons)} { ::WB::RegisterShortcutButtons $priv(btdefs) } } proc ::SlideShow::InitPrefsHook { } { global prefs set prefs(slideShow,dir) "" set prefs(slideShow,buttons) 0 set prefs(slideShow,autosize) 0 ::PrefUtils::Add [list \ [list prefs(slideShow,buttons) prefs_slideShow_buttons $prefs(slideShow,buttons)] \ [list prefs(slideShow,autosize) prefs_slideShow_autosize $prefs(slideShow,autosize)] \ [list prefs(slideShow,dir) prefs_slideShow_dir $prefs(slideShow,dir)]] } proc ::SlideShow::BuildPrefsHook {wtree nbframe} { global prefs variable tmpPrefs if {![::Preferences::HaveTableItem Whiteboard]} { ::Preferences::NewTableItem {Whiteboard} [mc "Whiteboard"] } ::Preferences::NewTableItem {Whiteboard {SlideShow}} [mc "Slide Show"] set wpage [$nbframe page {SlideShow}] set wc $wpage.c ttk::frame $wc -padding [option get . notebookPageSmallPadding {}] pack $wc -side top -anchor [option get . dialogAnchor {}] set lfr $wc.fr ttk::frame $lfr pack $lfr -side top -anchor w set tmpPrefs(slideShow,buttons) $prefs(slideShow,buttons) set tmpPrefs(slideShow,autosize) $prefs(slideShow,autosize) ttk::checkbutton $lfr.ss -text [mc "Show navigation buttons"] \ -variable [namespace current]::tmpPrefs(slideShow,buttons) ttk::checkbutton $lfr.size -text [mc "Resize window to fit slides"] \ -variable [namespace current]::tmpPrefs(slideShow,autosize) grid $lfr.ss -sticky w grid $lfr.size -sticky w } proc ::SlideShow::SavePrefsHook { } { global prefs variable tmpPrefs variable priv set prefs(slideShow,buttons) $tmpPrefs(slideShow,buttons) set prefs(slideShow,autosize) $tmpPrefs(slideShow,autosize) if {$prefs(slideShow,buttons)} { ::WB::RegisterShortcutButtons $priv(btdefs) } else { ::WB::DeregisterShortcutButton previous ::WB::DeregisterShortcutButton next } } proc ::SlideShow::CancelPrefsHook { } { global prefs variable tmpPrefs set key slideShow,buttons if {![string equal $prefs($key) $tmpPrefs($key)]} { ::Preferences::HasChanged } } proc ::SlideShow::UserDefaultsHook { } { global prefs variable tmpPrefs set tmpPrefs(slideShow,buttons) $prefs(slideShow,buttons) } proc ::SlideShow::DestroyPrefsHook { } { variable tmpPrefs unset -nocomplain tmpPrefs } proc ::SlideShow::BuildButtonsHook {wtray} { global prefs variable priv set w [winfo toplevel $wtray] set priv($w,wtray) $wtray if {$prefs(slideShow,buttons)} { foreach btdef $priv(btdefs) { $wtray buttonconfigure [lindex $btdef 0] -state disabled } } } proc ::SlideShow::PickFolder {w} { global prefs variable priv set opts {} if {[file isdirectory $prefs(slideShow,dir)]} { lappend opts -initialdir $prefs(slideShow,dir) } set ans [eval { tk_chooseDirectory -mustexist 1 -title [mc "Open Folder"]} $opts] if {$ans ne ""} { # Check first if any useful content? set priv($w,dir) $ans LoadFolder $w } } proc ::SlideShow::LoadFolder {w} { variable priv set dir $priv($w,dir) set files {} foreach suff $priv(suffixes) { set flist [glob -nocomplain -directory $dir -types f -tails -- *$suff] set files [concat $files $flist] } set pages {} foreach page $files { lappend pages [file rootname $page] } set pages [lsort -unique -dictionary $pages] set priv(pages) $pages # Pick first one. OpenPage $w [lindex $pages 0] SetButtonState $w } proc ::SlideShow::GetFile {w page} { variable priv set rootpath [file join $priv($w,dir) $page] set path "" foreach suff $priv(suffixes) { if {[file exists ${rootpath}${suff}]} { set path ${rootpath}${suff} break } } return $path } proc ::SlideShow::OpenPage {w page} { variable priv set fileName [GetFile $w $page] OpenFile $w $fileName set priv($w,current) $page } proc ::SlideShow::OpenFile {w fileName} { global prefs variable priv set wcan [::WB::GetCanvasFromWtop $w] switch -- [file extension $fileName] { .can { ::CanvasFile::OpenCanvas $wcan $fileName } default { ::CanvasCmd::DoEraseAll $wcan ::undo::reset [::WB::GetUndoToken $wcan] ::Import::DoImport $wcan {-coords {0 0}} -file $fileName } } # Auto resize. if {$prefs(slideShow,autosize)} { foreach {cwidth cheight} [::WB::GetCanvasSize $w] {break} set bbox [$wcan bbox all] if {[llength $bbox]} { foreach {bx by bw bh} $bbox {break} if {($cwidth < $bw) && ($cheight < $bh)} { ::WB::SetCanvasSize $w $bw $bh } elseif {$cwidth < $bw} { ::WB::SetCanvasSize $w $bw $cheight } elseif {$cheight < $bh} { ::WB::SetCanvasSize $w $cwidth $bh } } } } proc ::SlideShow::Previous {w} { variable priv SaveCurrentCanvas $w set ind [lsearch -exact $priv(pages) $priv($w,current)] OpenPage $w [lindex $priv(pages) [expr {$ind - 1}]] SetButtonState $w } proc ::SlideShow::Next {w} { variable priv SaveCurrentCanvas $w set ind [lsearch -exact $priv(pages) $priv($w,current)] OpenPage $w [lindex $priv(pages) [expr {$ind + 1}]] SetButtonState $w } proc ::SlideShow::First {w} { variable priv SaveCurrentCanvas $w OpenPage $w [lindex $priv(pages) 0] SetButtonState $w } proc ::SlideShow::Last {w} { variable priv SaveCurrentCanvas $w OpenPage $w [lindex $priv(pages) end] SetButtonState $w } proc ::SlideShow::SetButtonState {w} { variable priv set wtray $priv($w,wtray) if {[llength $priv(pages)]} { if {[$wtray exists next]} { $wtray buttonconfigure next -state normal $wtray buttonconfigure previous -state normal } } if {[string equal $priv($w,current) [lindex $priv(pages) 0]]} { if {[$wtray exists previous]} { $wtray buttonconfigure previous -state disabled } } elseif {[string equal $priv($w,current) [lindex $priv(pages) end]]} { if {[$wtray exists next]} { $wtray buttonconfigure next -state disabled } } } proc ::SlideShow::SetMenuState {w} { global prefs variable priv set wmenu [::UI::GetMenu $w mSlideShow] if {[info exists priv($w,dir)] && [file isdirectory $priv($w,dir)]} { ::UI::MenuMethod $wmenu entryconfigure First -state normal -label [mc "First"] ::UI::MenuMethod $wmenu entryconfigure Last -state normal -label [mc "Last"] if {[llength $priv(pages)]} { ::UI::MenuMethod $wmenu entryconfigure Previous -state normal -label [mc "Previous"] ::UI::MenuMethod $wmenu entryconfigure Next -state normal -label [mc "Next"] } if {[string equal $priv($w,current) [lindex $priv(pages) 0]]} { ::UI::MenuMethod $wmenu entryconfigure Previous -state disabled -label [mc "Previous"] } elseif {[string equal $priv($w,current) [lindex $priv(pages) end]]} { ::UI::MenuMethod $wmenu entryconfigure Next -state disabled -label [mc "Next"] } } else { ::UI::MenuMethod $wmenu entryconfigure First -state disabled -label [mc "First"] ::UI::MenuMethod $wmenu entryconfigure Last -state disabled -label [mc "Last"] ::UI::MenuMethod $wmenu entryconfigure Previous -state disabled -label [mc "Previous"] ::UI::MenuMethod $wmenu entryconfigure Next -state disabled -label [mc "Next"] } } proc ::SlideShow::SaveCurrentCanvas {w} { variable priv set wcan [::WB::GetCanvasFromWtop $w] set fileName [file join $priv($w,dir) $priv($w,current)].can ::CanvasFile::SaveCanvas $wcan $fileName } proc ::SlideShow::MenuPostHook {type wmenu} { variable priv if {$type eq "whiteboard-file"} { if {[winfo exists [focus]]} { set wtop [winfo toplevel [focus]] # Sander reports a bug related to this. if {[winfo class $wtop] eq "TopWhiteboard"} { SetMenuState $wtop } } } } proc ::SlideShow::CloseHook {w} { variable priv # Be sure to save the current page. Need to know that we have slide show? # SaveCurrentCanvas $w array unset priv $w,* } #------------------------------------------------------------------------------- coccinella-0.96.20/components/Sounds.tcl000066400000000000000000000461601167435367600201610ustar00rootroot00000000000000# Sounds.tcl --- # # This file is part of The Coccinella application. # It implements alert sounds. # # Copyright (c) 2002-2008 Mats Bengtsson # # 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 3 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, see . # # $Id: Sounds.tcl,v 1.48 2008-05-30 07:25:04 matben Exp $ namespace eval ::Sounds { # We undefine ourselves if we have no audio support. component::define Sounds \ "Provides alert sounds through QuickTime or the Snack audio package." } proc ::Sounds::Init {} { # We are doing all inits late since loading audio can be slow. ::hooks::register afterFinalHook ::Sounds::AfterFinalHook } # Sounds::AfterFinalHook -- # # Tries to load the sounds component. proc ::Sounds::AfterFinalHook {} { variable priv ::Debug 2 "::Sounds::AfterFinalHook" set priv(canPlay) 0 set priv(inited) 0 set priv(QuickTimeTcl) [expr {![catch {package require QuickTimeTcl}]}] set priv(snack) [expr {![catch {package require snack}]}] # Skip if both 0. if {!$priv(QuickTimeTcl) && !$priv(snack)} { component::undefine Sounds return } set priv(canPlay) 1 Mappings # This one is needed since we have missed it during the launch process. InitPrefsHook # We should register ourselves. component::register Sounds # Make sure we get called when certain events happen. InitEventHooks InitHook } proc ::Sounds::Mappings {} { ::Debug 2 "::Sounds::Mappings" variable nameToText set nameToText [dict create] # TRANSLATORS; Sound settings in preferences dict set nameToText online [mc "Contact is online"] dict set nameToText offline [mc "Contact is offline"] dict set nameToText newmsg [mc "Incoming message"] dict set nameToText newchatmsg [mc "Incoming chat"] dict set nameToText newchatthread [mc "New chat thread"] dict set nameToText statchange [mc "Contact presence change"] dict set nameToText connected [mc "Logged in"] dict set nameToText groupchatpres [mc "Chatroom presence change"] # Map between sound name and file name for default sound set. variable soundIndex array set soundIndex { online online.wav offline offline.wav newmsg newmsg.wav newchatmsg newchatmsg.wav newchatthread newchatthread.wav statchange statchange.wav connected connected.wav groupchatpres clicked.wav } variable wqtframe .quicktime::audio variable allSounds set allSounds [array names soundIndex] } proc ::Sounds::GetTextForName {name} { variable nameToText return [dict get $nameToText $name] } proc ::Sounds::InitPrefsHook {} { global prefs variable sprefs variable allSounds variable priv set names [::Theme::GetAllWithFilter sound] if {$prefs(rootTheme) in $names} { set defaultSet $prefs(rootTheme) } else { set defaultSet [lindex $names 0] } set priv(defaultSet) $defaultSet set sprefs(soundSet) $defaultSet set sprefs(volume) 100 set sprefs(midiCmd) "" set sprefs(outputDevice) "" ::PrefUtils::Add [list \ [list ::Sounds::sprefs(soundSet) sound_set $sprefs(soundSet)] \ [list ::Sounds::sprefs(volume) sound_volume $sprefs(volume)] \ [list ::Sounds::sprefs(midiCmd) sound_midiCmd $sprefs(midiCmd)] \ [list ::Sounds::sprefs(outputDevice) sound_outputDevice $sprefs(outputDevice)] \ ] set optL [list] foreach name $allSounds { set sprefs($name) 1 lappend optL [list ::Sounds::sprefs($name) sound_${name} $sprefs($name)] } ::PrefUtils::Add $optL if {$priv(snack)} { # Volume seems to be set globally on snack. set sprefs(volume) [snack::audio play_gain] # initialize snack audio device if {![string equal $sprefs(outputDevice) ""]} { snack::audio selectOutput $sprefs(outputDevice) } } } proc ::Sounds::InitEventHooks {} { # Add all event hooks. ::hooks::register quitAppHook ::Sounds::Free 80 ::hooks::register newMessageHook [list ::Sounds::Msg normal newmsg] ::hooks::register newChatMessageHook [list ::Sounds::Msg chat newchatmsg] ::hooks::register newGroupChatMessageHook [list ::Sounds::Msg groupchat newchatmsg] ::hooks::register newChatThreadHook [list ::Sounds::Event newchatthread] ::hooks::register loginHook [list ::Sounds::Event connected] ::hooks::register presenceNewHook ::Sounds::Presence # Define all hooks for preference settings. ::hooks::register prefsBuildHook ::Sounds::BuildPrefsHook ::hooks::register prefsSaveHook ::Sounds::SavePrefsHook ::hooks::register prefsCancelHook ::Sounds::CancelPrefsHook ::hooks::register prefsUserDefaultsHook ::Sounds::UserDefaultsHook } # Sounds::InitHook -- # # Make all the necessary initializations, create audio objects. # # Arguments: # # Results: # none. proc ::Sounds::InitHook {} { global this variable allSounds variable priv variable sprefs ::Debug 2 "::Sounds::InitHook" if {$priv(inited)} { return } # Create all sounds from current sound set (which is "" as default). if {$priv(canPlay)} { # Verify that sound set exists. if {$sprefs(soundSet) in [GetAllSets]} { set sprefs(soundSet) $priv(defaultSet) } LoadSoundSet $sprefs(soundSet) } set priv(inited) 1 } proc ::Sounds::GetAllSets {} { set names [list] foreach path [GetAllSoundSetPaths] { lappend names [lindex [file split $path] end-1] } return $names } proc ::Sounds::GetAllSoundSetPaths {} { set soundPaths [list] set paths [::Theme::GetAllPathsWithFilter sound] foreach path $paths { foreach dir [glob -nocomplain -types d -directory $path -- *] { set indFile [file join $dir soundIndex.tcl] if {[file exists $indFile]} { lappend soundPaths $dir } } } return $soundPaths } proc ::Sounds::GetAllSoundsPresentSet {} { variable allSounds return $allSounds } proc ::Sounds::LoadSoundSet {soundSet} { global this variable allSounds variable soundIndex variable priv variable wqtframe ::Debug 2 "::Sounds::LoadSoundSet: soundSet=$soundSet" Free unset -nocomplain nameToPath array set sound [array get soundIndex] if {$soundSet ni [GetAllSets]} { return } if {$priv(QuickTimeTcl)} { frame $wqtframe } set dir [GetPathForSet $soundSet] foreach s $allSounds { Create $s [file join $dir $sound($s)] } } proc ::Sounds::GetPathForSet {soundSet} { global this return [file join [::Theme::GetPath $soundSet] $this(sounds)] } proc ::Sounds::Create {name path} { global this variable priv variable nameToPath variable wqtframe # QuickTime doesn't understand vfs; need to copy out to tmp dir. if {$priv(QuickTimeTcl)} { if {[info exists ::starkit::topdir]} { set path [CopyToTemp $path] } if {[catch { movie $wqtframe.$name -file $path -controller 0 }]} { # ? } } elseif {[file extension $path] eq ".mid"} { if {[info exists ::starkit::topdir]} { set path [CopyToTemp $path] } } elseif {$priv(snack)} { # Snack seems not to complain about midi files; just no sound. if {[catch { snack::sound $name -load $path }]} { # ? } } set nameToPath($name) $path return $path } proc ::Sounds::Play {snd} { variable sprefs variable priv variable afterid if {!$priv(inited)} { Init } # Check the jabber prefs if sound should be played. if {[info exists sprefs($snd)] && !$sprefs($snd)} { return } unset -nocomplain afterid($snd) DoPlay $snd } proc ::Sounds::DoPlay {snd} { variable priv variable wqtframe variable nameToPath if {$priv(QuickTimeTcl)} { if {[catch {$wqtframe.$snd play}]} { # ? } } elseif {[file extension $nameToPath($snd)] eq ".mid"} { PlayMIDI $nameToPath($snd) } elseif {$priv(snack)} { if {[catch {$snd play}]} { # ? } } } proc ::Sounds::PlayWhenIdle {snd} { variable afterid variable sprefs if {![info exists sprefs($snd)] || !$sprefs($snd)} { return } if {![info exists afterid($snd)]} { set afterid($snd) 1 after idle [list ::Sounds::Play $snd] } } proc ::Sounds::DoPlayWhenIdle {snd} { variable afterid if {![info exists afterid($snd)]} { set afterid($snd) 1 after idle [list ::Sounds::Play $snd] } } proc ::Sounds::PlaySoundTmp {path} { global this variable priv variable wqtframe if {$priv(QuickTimeTcl)} { if {[info exists ::starkit::topdir]} { set path [CopyToTemp $path] } destroy $wqtframe._tmp catch { movie $wqtframe._tmp -file $path -controller 0 $wqtframe._tmp play } } elseif {[file extension $path] eq ".mid"} { if {[info exists ::starkit::topdir]} { set path [CopyToTemp $path] } PlayMIDI $path } elseif {$priv(snack)} { catch {_tmp destroy} catch {snack::sound _tmp -load $path} catch {_tmp play} } } proc ::Sounds::CopyToTemp {path} { global this set tmp [::tfileutils::tempfile $this(tmpPath) sound] append tmp [file extension $path] file copy -force $path $tmp return $tmp } proc ::Sounds::PlayMIDI {fileName} { variable sprefs # This is unix only. set cmd [lindex $sprefs(midiCmd) 0] set opts [lrange $sprefs(midiCmd) 1 end] set mcmd [auto_execok $cmd] if {$mcmd ne ""} { catch {exec $mcmd $opts $fileName &} } } proc ::Sounds::Msg {type snd xmldata {uuid ""}} { set body [wrapper::getcdata [wrapper::getfirstchildwithtag $xmldata body]] # We sometimes get non text stuff messages, like jabber:x:event etc. if {![string length $body]} { return } set from [wrapper::getattribute $xmldata from] # We shouldn't make noise for our own messages. switch -- $type { normal { } chat { set myjid [::Jabber::GetMyJid] set jid2 [jlib::barejid $myjid] if {[string match ${jid2}* $from]} { return } } groupchat { set roomjid [jlib::barejid $from] set myjid [::Jabber::GetMyJid $roomjid] if {[jlib::jidequal $myjid $from]} { return } } } PlayWhenIdle $snd return } proc ::Sounds::Event {snd args} { PlayWhenIdle $snd } # Sounds::Presence -- # # Makes an alert sound corresponding to the jid's presence status. # # Arguments: # jid bare JID # presence "available", "unavailable", or "unsubscribed" # args list of '-key value' pairs of presence attributes. # # Results: # roster tree updated. proc ::Sounds::Presence {jid presence args} { array set argsA $args set xmldata $argsA(-xmldata) set from [wrapper::getattribute $xmldata from] set jid2 [jlib::barejid $from] set wasAvail [::Jabber::Jlib roster wasavailable $jid] # Alert sounds. if {[::Jabber::Jlib service isroom $jid2]} { PlayWhenIdle groupchatpres } elseif {[string equal $presence "unavailable"]} { PlayWhenIdle offline } elseif {$wasAvail} { # Pling only when also show changed. set show "" if {[info exists argsA(-show)]} { set show $argsA(-show) } set oldShow "" array set oldPresA [::Jabber::Jlib roster getoldpresence $from] if {[info exists oldPresA(-show)]} { set oldShow $oldPresA(-show) } if {$show ne $oldShow} { PlayWhenIdle statchange } } elseif {[string equal $presence "available"]} { PlayWhenIdle online } } proc ::Sounds::Free {} { variable priv variable allSounds variable wqtframe if {$priv(QuickTimeTcl)} { catch {destroy $wqtframe} } elseif {$priv(snack)} { foreach name $allSounds { catch {$name destroy} } } } # Preference page -------------------------------------------------------------- proc ::Sounds::BuildPrefsHook {wtree nbframe} { variable priv if {$priv(canPlay)} { ::Preferences::NewTableItem {General Sounds} [mc "Sounds"] set wpage [$nbframe page {Sounds}] BuildPrefsPage $wpage } } proc ::Sounds::BuildPrefsPage {wpage} { variable nameToText variable sprefs variable tmpPrefs variable allSounds variable priv # System gain can have been changed. if {$priv(snack)} { set sprefs(volume) [snack::audio play_gain] set outputDevices [snack::audio outputDevices] } foreach name $allSounds { set tmpPrefs($name) $sprefs($name) } set tmpPrefs(soundSet) $sprefs(soundSet) set tmpPrefs(volume) $sprefs(volume) set tmpPrefs(midiCmd) $sprefs(midiCmd) set tmpPrefs(outputDevice) $sprefs(outputDevice) set soundSets [GetAllSets] set wc $wpage.c ttk::frame $wc -padding [option get . notebookPageSmallPadding {}] pack $wc -side top -anchor [option get . dialogAnchor {}] ttk::frame $wc.alrt -padding {0 0 0 6} ttk::label $wc.alrt.l -text [mc "Alert sounds"] ttk::separator $wc.alrt.s -orient horizontal grid $wc.alrt.l $wc.alrt.s -sticky w grid $wc.alrt.s -sticky ew grid columnconfigure $wc.alrt 1 -weight 1 pack $wc.alrt -side top -anchor w -fill x set fss $wc.fss ttk::frame $fss ttk::label $fss.l -text [mc "Sound set"]: ui::combobutton $fss.p -variable [namespace current]::tmpPrefs(soundSet) \ -menulist [ui::optionmenu::menuList $soundSets] grid $fss.l $fss.p -sticky w -padx 2 grid $fss.p -sticky ew grid columnconfigure $fss 1 -minsize [$fss.p maxwidth] ttk::label $wc.lbl -text [mc "Enable or disable sounds below"]: set wmid $wc.m ttk::frame $wmid pack $wc.fss -side top -anchor w pack $wc.lbl -side top -anchor w -pady 8 pack $wc.m -side top foreach name $allSounds { ttk::checkbutton $wmid.c$name -text [dict get $nameToText $name] \ -variable [namespace current]::tmpPrefs($name) ttk::button $wmid.b$name -text [mc "Play"] \ -command [list [namespace current]::PlayTmpPrefSound $name] grid $wmid.c$name $wmid.b$name -sticky w -padx 4 -pady 1 grid $wmid.b$name -sticky ew } set fvol $wc.fvol ttk::frame $fvol ttk::label $fvol.l -text [mc "Volume"]: ttk::scale $fvol.v -orient horizontal -from 0 -to 100 \ -variable [namespace current]::tmpPrefs(volume) -value $tmpPrefs(volume) pack $fvol.l -side left -padx 4 pack $fvol.v -side left -padx 4 pack $fvol -side top -pady 4 -anchor [option get . dialogAnchor {}] if {$priv(snack)} { set odev $wc.odev ttk::frame $odev ttk::label $odev.l -text [mc "Sound device"]: ui::combobutton $odev.p -variable [namespace current]::tmpPrefs(outputDevice) \ -menulist [ui::optionmenu::menuList $outputDevices] grid $odev.l $odev.p -sticky w -padx 2 grid $odev.p -sticky ew grid columnconfigure $odev 1 -minsize [$odev.p maxwidth] pack $wc.odev -side top -anchor w } ttk::button $wc.midi -text [mc "MIDI Player"] -command ::Sounds::MidiPlayer pack $wc.midi -pady 2 bind $wpage {+::Sounds::PrefsFree} } proc ::Sounds::MidiPlayer {} { variable tmpPrefs set title [mc "External Midi Player"] set ans [ui::megaentry -title $title -message [mc "Set command to use for playing MIDI sounds. This option is only relevant if you use a sound set with MIDI files."] \ -label [mc "MIDI command"]: -value $tmpPrefs(midiCmd)] if {$ans ne ""} { set tmpPrefs(midiCmd) [ui::megaentrytext $ans] } } proc ::Sounds::PlayTmpPrefSound {name} { global this variable priv variable soundIndex variable tmpPrefs variable wqtframe array set sound [array get soundIndex] set path [GetPathForSet $tmpPrefs(soundSet)] source [file join $path soundIndex.tcl] set f [file join $path $sound($name)] if {$priv(QuickTimeTcl)} { if {[info exists ::starkit::topdir]} { set tmp [::tfileutils::tempfile $this(tmpPath) sound] append tmp [file extension $f] file copy -force $f $tmp set f $tmp } destroy $wqtframe._tmp catch { movie $wqtframe._tmp -file $f -controller 0 \ -volume [expr {int($tmpPrefs(volume) * 2.55)}] $wqtframe._tmp play } } elseif {$priv(snack)} { catch {_tmp destroy} catch {snack::sound _tmp -load $f} catch {_tmp play} } } proc ::Sounds::SavePrefsHook {} { variable sprefs variable tmpPrefs variable allSounds variable priv variable wqtframe if {!$priv(canPlay)} { return } if {[string equal $tmpPrefs(soundSet) [mc "Default"]]} { set tmpPrefs(soundSet) "" } if {![string equal $tmpPrefs(soundSet) $sprefs(soundSet)]} { LoadSoundSet $tmpPrefs(soundSet) } set sprefs(soundSet) $tmpPrefs(soundSet) set sprefs(volume) $tmpPrefs(volume) set sprefs(outputDevice) $tmpPrefs(outputDevice) foreach name $allSounds { set sprefs($name) $tmpPrefs($name) } if {$priv(QuickTimeTcl)} { foreach wmovie [winfo children $wqtframe] { if {[winfo class $wmovie] eq "Movie"} { $wmovie configure -volume [expr {int($sprefs(volume) * 2.55)}] } } } # The snack play_gain seems to be set globally on the machine which is BAD! if {$priv(snack)} { snack::audio play_gain [expr {int($sprefs(volume))}] snack::audio selectOutput $sprefs(outputDevice) } set sprefs(midiCmd) $tmpPrefs(midiCmd) } proc ::Sounds::CancelPrefsHook {} { variable sprefs variable tmpPrefs variable allSounds variable priv if {!$priv(canPlay)} { return } foreach name $allSounds { if {$sprefs($name) ne $tmpPrefs($name)} { ::Preferences::HasChanged } } if {[string equal $tmpPrefs(soundSet) [mc "Default"]]} { set tmpPrefs(soundSet) "" } if {![string equal $sprefs(soundSet) $tmpPrefs(soundSet)]} { ::Preferences::HasChanged } if {![string equal $sprefs(volume) $tmpPrefs(volume)]} { ::Preferences::HasChanged } if {![string equal $sprefs(midiCmd) $tmpPrefs(midiCmd)]} { ::Preferences::HasChanged } if {![string equal $sprefs(outputDevice) $tmpPrefs(outputDevice)]} { ::Preferences::HasChanged } } proc ::Sounds::UserDefaultsHook {} { variable sprefs variable tmpPrefs variable allSounds foreach name $allSounds { set tmpPrefs($name) $sprefs($name) } if {[string equal $sprefs(soundSet) ""]} { set tmpPrefs(soundSet) [mc "Default"] } else { set tmpPrefs(soundSet) $sprefs(soundSet) } } proc ::Sounds::PrefsFree {} { variable tmpPrefs unset -nocomplain tmpPrefs } #------------------------------------------------------------------------------- coccinella-0.96.20/components/Speech.tcl000066400000000000000000000246731167435367600201220ustar00rootroot00000000000000# Speech.tcl --- # # Implements platform independent synthetic speech. # # Copyright (c) 2003-2007 Mats Bengtsson # # 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 3 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, see . # # $Id: Speech.tcl,v 1.19 2008-03-30 10:00:41 matben Exp $ namespace eval ::Speech { variable sprefs set sprefs(package) "" set sprefs(haveSpeech) 0 switch -- $::this(platform) { macosx { if {[catch {package require TclSpeech}]} { return } set sprefs(haveSpeech) 1 set sprefs(package) TclSpeech } windows { if {[catch {package require MSSpeech}]} { return } set sprefs(haveSpeech) 1 set sprefs(package) MSSpeech } default { return } } component::define Speech \ "Text-to-speech on Macs using TclSpeech and on Windows using MSSpeech" } # Speech::Load -- # # Tries to load the speech component. proc ::Speech::Load {} { ::Debug 2 "::Speech::Load" # Set up all hooks. Init # We should register ourselves. component::register Speech } proc ::Speech::Init {} { ::Debug 2 "::Speech::Init" # Hooks to run when message displayed to user. ::hooks::register displayMessageHook [list ::Speech::SpeakMessage normal] ::hooks::register displayChatMessageHook ::Speech::SpeakMessage2 ::hooks::register displayGroupChatMessageHook ::Speech::SpeakMessage2 ::hooks::register whiteboardTextInsertHook ::Speech::SpeakWBText # Define all hooks for preference settings. ::hooks::register prefsInitHook ::Speech::InitPrefsHook ::hooks::register prefsBuildHook ::Speech::BuildPrefsHook ::hooks::register prefsSaveHook ::Speech::SavePrefsHook ::hooks::register prefsCancelHook ::Speech::CancelPrefsHook ::hooks::register prefsUserDefaultsHook ::Speech::UserDefaultsPrefsHook } # Speech::Verify -- # # Verifies that we actually have a speech package. # Also checks voices available. proc ::Speech::Verify {} { global this variable sprefs set plat $this(platform) set voices [SpeakGetVoices] # Voices consistency check. if {([lsearch $voices $sprefs(voiceUs-$plat)] < 0) || \ ($sprefs(voiceUs-$plat) eq "")} { set sprefs(voiceUs-$plat) [lindex $voices 0] } if {([lsearch $voices $sprefs(voiceOther-$plat)] < 0) || \ ($sprefs(voiceOther-$plat) eq "")} { set sprefs(voiceOther-$plat) [lindex $voices 1] } # Always keep shortcut names. set sprefs(voiceUs) $sprefs(voiceUs-$plat) set sprefs(voiceOther) $sprefs(voiceOther-$plat) } proc ::Speech::SpeakMessage2 {xmldata} { variable sprefs set from [wrapper::getattribute $xmldata from] set type [wrapper::getattribute $xmldata type] set subject [wrapper::getcdata [wrapper::getfirstchildwithtag $xmldata subject]] set body [wrapper::getcdata [wrapper::getfirstchildwithtag $xmldata body]] switch -- $type { chat { if {$sprefs(speakChat)} { set myjid [::Jabber::GetMyJid] set jid2 [jlib::barejid $myjid] if {[string match ${jid2}* $from]} { set voice $sprefs(voiceUs) set txt "I say, " } else { set voice $sprefs(voiceOther) set txt " , " } append txt $body Speak $txt $voice } } groupchat { if {$sprefs(speakChat)} { jlib::splitjid $from roomjid res set myjid [::Jabber::GetMyJid $roomjid] if {[string equal $myjid $from]} { Speak $body $sprefs(voiceUs) } else { Speak $body $sprefs(voiceOther) } } } } return } proc ::Speech::SpeakMessage {type body args} { variable sprefs array set argsArr $args set from "" if {[info exists argsArr(-from)]} { set from $argsArr(-from) } switch -- $type { normal { if {$sprefs(speakMsg)} { set txt " " if {[info exists argsArr(-subject)] && \ ($argsArr(-subject) ne "")} { append txt "Subject is $argsArr(-subject). " } append txt $body Speak $txt $sprefs(voiceOther) } } chat { if {$sprefs(speakChat)} { set myjid [::Jabber::GetMyJid] jlib::splitjid $myjid jid2 res if {[string match ${jid2}* $from]} { set voice $sprefs(voiceUs) set txt "I say, " } else { set voice $sprefs(voiceOther) set txt " , " } append txt $body Speak $txt $voice } } groupchat { if {$sprefs(speakChat)} { jlib::splitjid $from roomjid res set myjid [::Jabber::GetMyJid $roomjid] if {[string equal $myjid $from]} { Speak $body $sprefs(voiceUs) } else { Speak $body $sprefs(voiceOther) } } } } } proc ::Speech::SpeakWBText {who str} { variable sprefs set punct {[.,;?!]} if {$sprefs(speakWBText) && [string match *${punct}* $str] && ($str ne "")} { set key [string map {me Us other Other} $who] set voice $sprefs(voice$key) Speak $str $voice } } proc ::Speech::Speak {msg {voice {}}} { global this switch -- $this(platform) { macosx { ::Mac::Speech::Speak $msg $voice } windows { ::MSSpeech::Speak $msg $voice } unix { # empty. } } } proc ::Speech::SpeakGetVoices {} { global this switch -- $this(platform) { macosx { return [speech::speakers] } windows { return [::MSSpeech::GetVoices] } unix { return } } } # Preference page -------------------------------------------------------------- proc ::Speech::InitPrefsHook {} { variable sprefs ::Debug 2 "::Speech::InitPrefsHook sprefs(haveSpeech)=$sprefs(haveSpeech)" # Default in/out voices. set sprefs(voiceUs-macosx) "" set sprefs(voiceOther-macosx) "" set sprefs(voiceUs-windows) "" set sprefs(voiceOther-windows) "" set sprefs(speakMsg) 0 set sprefs(speakChat) 0 set sprefs(speakWBText) 0 ::PrefUtils::Add [list \ [list ::Speech::sprefs(speakMsg) speakMsg $sprefs(speakMsg)] \ [list ::Speech::sprefs(speakChat) speakChat $sprefs(speakChat)] \ [list ::Speech::sprefs(speakWBText) speakWBText $sprefs(speakWBText)] \ [list ::Speech::sprefs(voiceUs-macosx) speakVoiceUs-macosx $sprefs(voiceUs-macosx)] \ [list ::Speech::sprefs(voiceOther-macosx) speakVoiceOther-macosx $sprefs(voiceOther-macosx)] \ [list ::Speech::sprefs(voiceUs-windows) speakVoiceUs-windows $sprefs(voiceUs-windows)] \ [list ::Speech::sprefs(voiceOther-windows) speakVoiceOther-windows $sprefs(voiceOther-windows)] \ ] # Verify } proc ::Speech::BuildPrefsHook {wtree nbframe} { variable sprefs if {$sprefs(haveSpeech)} { # TRANSLATORS; Only on Mac OS X and Windows in preferences. ::Preferences::NewTableItem {General {Speech}} [mc "Text-to-Speech"] set wpage [$nbframe page {Speech}] BuildPrefsPage $wpage } } proc ::Speech::SavePrefsHook {} { variable sprefs variable tmpPrefs if {$sprefs(haveSpeech)} { array set sprefs [array get tmpPrefs] foreach {key value} [array get tmpPrefs] { set sprefs($key) $tmpPrefs($key) } Verify } } proc ::Speech::CancelPrefsHook {} { variable sprefs variable tmpPrefs if {$sprefs(haveSpeech)} { # Detect any changes. foreach {key value} [array get tmpPrefs] { if {![string equal $sprefs($key) $tmpPrefs($key)]} { ::Preferences::HasChanged return } } } } proc ::Speech::UserDefaultsPrefsHook {} { variable sprefs variable tmpPrefs array set tmpPrefs [array get sprefs] } proc ::Speech::BuildPrefsPage {page} { global this variable sprefs variable tmpPrefs array set tmpPrefs [array get sprefs] set plat $this(platform) set wc $page.c ttk::frame $wc -padding [option get . notebookPageSmallPadding {}] pack $wc -side top -anchor [option get . dialogAnchor {}] ttk::frame $wc.head -padding {0 0 0 6} ttk::label $wc.head.l -text [mc "Text-to-Speech"] ttk::separator $wc.head.s -orient horizontal grid $wc.head.l $wc.head.s grid $wc.head.s -sticky ew grid columnconfigure $wc.head 1 -weight 1 pack $wc.head -side top -fill x set wfr $wc.f ttk::frame $wfr pack $wfr -side top ttk::checkbutton $wfr.speak -text [mc "Text-to-speech for whiteboard text"] \ -variable [namespace current]::tmpPrefs(speakWBText) ttk::checkbutton $wfr.speakmsg -text [mc "Text-to-speech for messages"] \ -variable [namespace current]::tmpPrefs(speakMsg) ttk::checkbutton $wfr.speakchat -text [mc "Text-to-speech for chat"] \ -variable [namespace current]::tmpPrefs(speakChat) grid $wfr.speak -sticky w grid $wfr.speakmsg -sticky w grid $wfr.speakchat -sticky w if {$sprefs(haveSpeech)} { # Get a list of voices set voicelist [concat None [SpeakGetVoices]] } else { set voicelist {None} $wfr.speak state {disabled} $wfr.speakmsg state {disabled} $wfr.speakchat state {disabled} set tmpPrefs(SpeechOn) 0 } set wfvo $wfr.fvo ttk::frame $wfvo grid $wfvo -pady 4 ttk::label $wfvo.in -text [mc "Select voice for incoming text"]: ttk::label $wfvo.out -text [mc "Select voice for outgoing write"]: ui::combobutton $wfvo.pin \ -variable [namespace current]::tmpPrefs(voiceOther-$plat) \ -menulist [ui::optionmenu::menuList $voicelist] ui::combobutton $wfvo.pout \ -variable [namespace current]::tmpPrefs(voiceUs-$plat) \ -menulist [ui::optionmenu::menuList $voicelist] grid $wfvo.in $wfvo.pin -sticky e -padx 2 -pady 1 grid $wfvo.out $wfvo.pout -sticky e -padx 2 -pady 1 grid $wfvo.pin $wfvo.pout -sticky ew if {!$sprefs(haveSpeech)} { $wfvo.pin state {disabled} $wfvo.pout state {disabled} } bind $page +::Speech::Free } proc ::Speech::Free {} { variable tmpPrefs unset -nocomplain tmpPrefs } #------------------------------------------------------------------------------- coccinella-0.96.20/components/Spell.tcl000066400000000000000000000130231167435367600177550ustar00rootroot00000000000000# Spell.tcl -- # # This file is part of The Coccinella application. # It provides an application interface to the 'spell' package. # # Copyright (c) 2007 Mats Bengtsson # # 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 3 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, see . # # $Id: Spell.tcl,v 1.10 2007-12-21 13:50:14 matben Exp $ package require spell namespace eval ::Spell { if {$::tcl_platform(platform) eq "windows"} { set programs {C:\Program} if {[info exists ::env(ProgramFiles)]} { set programs $::env(ProgramFiles) } spell::addautopath [file join $programs Aspell bin] } if {$::tcl_platform(os) eq "Darwin"} { # Seems not always in PATH variable. spell::addautopath /sw/bin/ } if {![spell::have]} { return } component::define Spell \ "Provides an interface to the aspell and ispell spellers." } proc ::Spell::Init {} { if {![spell::have]} { return } set speller [spell::speller] component::register Spell set menuDef {checkbutton mCheckSpell {[mc "Check Spelling"]} {::Spell::OnMenu} {} \ {-variable ::Spell::state(on)}} ::JUI::RegisterMenuEntry info $menuDef if {$speller eq "aspell"} { set menuDef {cascade mDictionaries {[mc "Dictionaries"]} {} {} } ::JUI::RegisterMenuEntry info $menuDef } # Add event hooks. ::hooks::register prefsInitHook [namespace code InitPrefsHook] ::hooks::register textSpellableNewHook [namespace code TextHook] ::hooks::register menuPostCommand [namespace code MenuPost] variable wall [list] } proc ::Spell::InitPrefsHook {} { variable state set state(on) 0 set state(dict) en ::PrefUtils::Add [list \ [list ::Spell::state(on) spell_state_on $state(on)] \ [list ::Spell::state(dict) spell_state_dict $state(dict)] \ ] spell::setdict $state(dict) } proc ::Spell::OnMenu {} { variable state variable wall if {$state(on)} { foreach w $wall { spell::new $w # @@@ We must have a kind of plugin architecture here so it is # possible to add multiple popup menu entries. # Generic text binding <> that just does ::hooks::run # Interested parties that have registered for the hook then make # a call and add their menu entries if any. Then the generic # code is able to display menu or not. bind $w <> [namespace code [list Popup %W %x %y]] } } else { Clear } } proc ::Spell::MenuPost {which wmenu} { if {$which eq "main-info"} { set m [::UI::MenuMethod $wmenu entrycget mDictionaries -menu] # ispell doesn't put the dict menu there. if {$m eq ""} { return } $m delete 0 end set dicts [spell::alldicts] foreach dict $dicts { $m add radiobutton -label $dict -value $dict \ -variable [namespace current]::state(dict) \ -command [namespace code [list SetDict $dict]] } update idletasks } } proc ::Spell::Clear {} { variable wall foreach w $wall { spell::clear $w bind $w <> {} } } proc ::Spell::SetDict {name} { spell::reset Clear spell::setdict $name spell::init OnMenu } proc ::Spell::Popup {w x y} { variable pop set word [spell::GetWord $w current] set isword [string is wordchar -strict $word] if {$isword} { lassign [spell::wordserial $word] correct suggest if {!$correct && [llength $suggest]} { lassign [spell::GetWordIndices $w current] idx1 idx2 set pop(idx1) $idx1 set pop(idx2) $idx2 set pop(word) $word set menu $w.menuspell catch {destroy $menu} menu $menu -tearoff 0 foreach s $suggest { $menu add command -label $s \ -command [namespace code [list Cmd $w $s]] } $menu add separator $menu add command -label [mc "Add to Dictionary"] \ -command [namespace code [list AddWord $w]] set X [expr {[winfo rootx $w] + $x}] set Y [expr {[winfo rooty $w] + $y}] tk_popup $menu [expr {int($X) - 10}] [expr {int($Y) - 10}] update bind $menu {after idle {catch {destroy %W}}} } } } proc ::Spell::Cmd {w new} { variable pop # Try to preserver cases to some extent. if {[string is lower $pop(word)]} { set str [string tolower $new] } elseif {[string is upper $pop(word)]} { set str [string toupper $new] } elseif {[string is upper [string index $pop(word) 0]]} { set str [string toupper [string index $new 0]][string range $new 1 end] } else { set str $new } $w delete $pop(idx1) $pop(idx2) $w insert $pop(idx1) $str unset -nocomplain pop } proc ::Spell::AddWord {w} { variable pop spell::addword $pop(word) } proc ::Spell::TextHook {w} { variable wall variable state if {$state(on)} { spell::new $w bind $w <> [namespace code [list Popup %W %x %y]] } bind $w {+Spell::OnDestroy %W} lappend wall $w } proc Spell::OnDestroy {w} { variable wall lprune wall $w } coccinella-0.96.20/components/SpotLight.tcl000066400000000000000000000110131167435367600206100ustar00rootroot00000000000000# SpotLight.tcl --- # # Integrated spotlight bindings for MacOSX. # # Copyright (c) 2006 Antonio Cano Damas # # 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 3 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, see . # # $Id: SpotLight.tcl,v 1.9 2007-11-17 07:40:52 matben Exp $ namespace eval ::SpotLight:: { # I switch off this since buggy! return if {[::SpotLight::Have]} { component::define SpotLight "Launch SpotLight with incoming messages." } } proc ::SpotLight::Init {} { global this global tcl_platform # Add event hooks. ::hooks::register newChatMessageHook ::SpotLight::ChatMessageHook 1 component::register SpotLight } proc ::SpotLight::Have {} { global this global tcl_platform #---- Check support of Indexer into our Operating System ------- if {![string equal $this(platform) "macosx"]} { if {![string equal $this(platform) "windows"]} { #@@@ Support for Beagle in Linux coming... return 0 } else { # Get Google Desktop Registry Entry if {[catch {package require registry}]} { return 0 } else { variable gDesktopURL # If Google Desktop is Not installed return if {[catch { set gDesktopURL [registry get "HKEY_CURRENT_USER\\Software\\Google\\Google Desktop\\API" "search_url"] }]} { return 0 } if {$gDesktopURL eq ""} { return 0 } } } } else { # Check that we are running over a Tiger or greater version of OSX set darwinVersion [string index $tcl_platform(osVersion) 0] if { $darwinVersion < 8 } { return 0 } else { # Load AppleScript support needed for launching SpotLight if {[catch {package require Tclapplescript}]} { return 0 } } } return 1 } proc ::SpotLight::ChatMessageHook {xmldata} { global this set body [wrapper::getcdata [wrapper::getfirstchildwithtag $xmldata body]] if {$body eq ""} { return } # -from is a 3-tier jid /resource included. set jid [wrapper::getattribute $xmldata from] set jid2 [jlib::barejid $jid] if {[::Chat::HaveChat $jid]} { return } set search_string "$jid2" set subject [wrapper::getcdata [wrapper::getfirstchildwithtag $xmldata subject]] if {$subject ne ""} { append search_string " $subject" } if {[string equal $this(platform) "macosx"]} { LaunchSL $search_string } else { LaunchGD $search_string } } #------------------------------------------- # Query Launchers #------------------------------------------- #-- Google Desktop for Windows proc ::SpotLight::LaunchGD {search_string} { variable gDesktopURL set launchURL "$gDesktopURL$search_string" ::Utils::OpenURLInBrowser $launchURL } #-- SpotLight for Mac OSX Tiger proc ::SpotLight::LaunchSL {search_string} { global this if {$this(package,Tclapplescript)} { set script { --Search spotlight key shortcuts set pList to (path to preferences folder as string) & "com.apple.universalaccess.plist" tell application "System Events" set pList to property list file pList set pListItems to property list items of property list item "UserAssignableHotKeys" of contents of pList set theItem to 1st item of pListItems whose value of property list item 4 is 65 -- index of spotlight shortcut (or 64 for spotlight window) set {theKey, keyEnabled, ModifierKeys, idx} to value of property list items of theItem if (keyEnabled = 1) or (keyEnabled = true) then set ModifierKeys to ModifierKeys / 131072 as integer -- strip bits 0 - 16 --Press shortcuts if ModifierKeys div 8 mod 2 = 1 then key down command if ModifierKeys div 4 mod 2 = 1 then key down option if ModifierKeys div 2 mod 2 = 1 then key down control if ModifierKeys mod 2 = 1 then key down shift key code theKey key up {command, option, control, shift} --Send to spotlight query text delay 1 keystroke "%s" end if end tell } AppleScript execute [format $script $search_string] } } coccinella-0.96.20/components/Totd.tcl000066400000000000000000000154621167435367600176210ustar00rootroot00000000000000# Totd.tcl # # Tip of the day. namespace eval ::Totd { component::define Totd "Tip of the Day" option add *Totd.icon coccinella widgetDefault option add *Totd*Text.font CociDefaultFont 50 } proc ::Totd::Init {} { variable tips global prefs # Register menu entry. set menuDef [list command mTotd... {[mc "Tip of the Day"]...} {::Totd::Build} {} {}] ::JUI::RegisterMenuEntry info $menuDef # Set system key for commands if {$::this(platform) eq "macosx"} { set ctrl "Cmd" } else { set ctrl "Ctrl" } # All tips should be listed below. set tips [dict create] dict set tips 0 [mc "If the desired chat system is not available when you\ want to add a contact, this indicates no server support had\ been detected. Luckily, for most chat systems you can use\ another server without the need to register a new account.\ \n\n\ Instructions:\n\ 1. Login to your account in %s.\n\ 2. Select the Discover Server option in the Actions menu.\n\ 3. Find a server with support for the desired chat system\ at http://coccinella.im/servers/servers.html (you can\ sort the columns).\n\ 4. Enter the name of the desired server and proceed.\n\ 5. The chat system will become available in the list!" $prefs(appName)] dict set tips 1 [mc "Typing the /clean command during a chat conversation\ will empty your chat window, whilst the /retain command will\ restore its content. Your contacts do not see these commands."] dict set tips 2 [mc "You might be interested in the hidden XML console if\ you are a developer. You can open it with the command\ %s+Shift+D" $ctrl] dict set tips 3 [mc "You can initiate a whiteboard session with multiple\ participants by clicking the whiteboard icon in a\ chatroom. All participants using %s will be invited." $prefs(appName)] dict set tips 4 [mc "Documentation is available at http://coccinella.im/documentation"] dict set tips 5 [mc "To override the automatic creation of the XMPP resource you can add\ /resourcename to your Contact ID."] dict set tips 6 [mc "Nicknames in chatrooms can be automatically completed using the TAB key.\ Enter the first letter(s) of the nickname and then use the TAB key to complete."] dict set tips 7 [mc "You can carry %s with you on an USB stick and use the same configuration\ on different computers. You can create such a cross-platform portable %s USB\ stick this way:\n\n\ 1. Create a folder on the USB stick.\n\ 2. Put in this folder the Coccinella binaries (for Windows, Linux and Mac OS X).\ Of course you do not necessarily need all binaries, for instance in case\ you do not want to use the USB stick on Windows computers.\n\ 3. Then open on each platform (Windows, Linux and Mac OS X) the binary for that platform.\n\ 4. Go each time to Preferences and enable the checkbox option\ 'Store preferences in same folder as program' (on the General page).\n\ 5. Preferences will now be saved on the USB stick in the same folder as the binary." $prefs(appName) $prefs(appName)] dict set tips 8 [mc "%s is free software. This means you have the freedom to improve %s for\ internal use without breaking copyright laws. Feel free to contribute\ improvements back to the project so that others can build upon your contribution.\ Check out http://coccinella.im/development to learn how you can help." $prefs(appName) $prefs(appName)] ::hooks::register launchFinalHook ::Totd::LaunchHook ::hooks::register prefsInitHook ::Totd::InitPrefsHook component::register Totd } proc ::Totd::InitPrefsHook {} { variable opts set opts(show) 1 ::PrefUtils::Add [list [list ::Totd::opts(show) totd_show $opts(show)]] } proc ::Totd::LaunchHook {} { variable opts if {$opts(show)} { Build } } proc ::Totd::Build {} { variable tips variable opts variable current variable wtext global prefs set w .cmpnt_totd if {[winfo exists $w]} { raise $w return } ::UI::Toplevel $w -class Totd \ -usemacmainmenu 1 -macstyle documentProc -macclass {document closeBox} \ -closecommand ::Totd::Close wm title $w [mc "Tip of the Day"] ::UI::SetWindowPosition $w set icon [::Theme::Find128Icon $w icon] ttk::frame $w.frtips pack $w.frtips -fill x set wbox $w.frtips.f ttk::frame $wbox -padding [option get . dialogPadding {}] pack $wbox -fill both -expand 1 set frbot $wbox.b ttk::frame $frbot -padding [option get . okcancelTopPadding {}] ttk::checkbutton $frbot.c -style Small.TCheckbutton \ -text [mc "Show tips on %s startup" $prefs(appName)] \ -variable [namespace current]::opts(show) ttk::button $frbot.btok -text [mc "OK"] -default active \ -command [list destroy $w] ttk::button $frbot.next -text [mc "Next"] \ -command [namespace code [list Navigate 1]] ttk::button $frbot.prev -text [mc "Previous"] \ -command [namespace code [list Navigate -1]] pack $frbot.btok $frbot.next $frbot.prev -side right -padx 4 pack $frbot.c -side left pack $frbot -side bottom -fill x set wpage $wbox.f ttk::frame $wpage -padding [option get . notebookPagePadding {}] pack $wpage -side right -fill x -anchor [option get . dialogAnchor {}] set wtext $wpage.t set wysc $wpage.s ttk::scrollbar $wysc -orient vertical -command [list $wtext yview] text $wpage.t -width 52 -height 12 -wrap word \ -yscrollcommand [list ::UI::ScrollSet $wysc [list pack $wysc -side right -fill y]] pack $wpage.t -side left -fill both -expand 1 pack $wysc -side right -fill y ttk::label $wbox.icon -compound image -image $icon -padding {0 0 6 0} pack $wbox.icon -side top # Pick random message. set len [dict size $tips] set idx [expr {int($len*rand())}] ::Text::Parse $wtext [dict get $tips $idx] "" set current $idx return $w } proc ::Totd::Navigate {dir} { variable tips variable current variable wtext $wtext delete 1.0 end set len [dict size $tips] set idx [expr {$current + $dir}] if {$idx < 0} { incr idx $len } elseif {$idx >= $len} { incr idx -$len } set current $idx ::Text::Parse $wtext [dict get $tips $idx] "" } proc ::Totd::Close {w} { ::UI::SaveWinGeom $w } coccinella-0.96.20/components/TtkDialog.tcl000066400000000000000000000044621167435367600205670ustar00rootroot00000000000000# TtkDialog.tcl -- # # Use fsdialog on unix to replace the standard ugly ones. # # Copyright (c) 2007 Mats Bengtsson # # 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 3 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, see . # # $Id: TtkDialog.tcl,v 1.10 2008-04-27 06:50:15 matben Exp $ namespace eval ::TtkDialog { # X11 only! if {[tk windowingsystem] ne "x11"} { return } if {[catch {package require ui::dialog}]} { return } variable scriptDir [file dirname [info script]] set fsdialog [file join $scriptDir fsdialog.tcl] if {![file exists $fsdialog]} { return } component::define TtkDialog "User friendly file selection dialogs" } proc ::TtkDialog::Init {} { variable scriptDir set fsdialog [file join $scriptDir fsdialog.tcl] if {![file exists $fsdialog]} { return } uplevel #0 [list source $fsdialog] component::register TtkDialog interp alias {} tk_getOpenFile {} ttk::getOpenFile interp alias {} tk_getSaveFile {} ttk::getSaveFile interp alias {} tk_chooseDirectory {} ttk::chooseDirectory interp alias {} tk_messageBox {} ::TtkDialog::MessageBox # Message catalog. set msgdir [file join $::this(msgcatCompPath) TtkDialog] if {[file isdirectory $msgdir]} { uplevel #0 [list ::msgcat::mcload $msgdir] } } proc ::TtkDialog::MessageBox {args} { variable button # @@@ Some of this should probably be in ui::dialog set argsA(-parent) . array set argsA $args set argsA(-variable) [namespace current]::button set argsA(-modal) 1 set w [eval {ui::dialog} [array get argsA]] ::tk::PlaceWindow $w widget $argsA(-parent) catch {grab $w} vwait [namespace current]::button grab release $w return $button } coccinella-0.96.20/components/URIRegisterKDE.tcl000066400000000000000000000064231167435367600213740ustar00rootroot00000000000000# URIRegisterKDE.tcl -- # # At least Konqurer on my SUSE box understands this. # There is a dependency on ParseURI. # # Copyright (c) 2007 Mats Bengtsson # # 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 3 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, see . # # $Id: URIRegisterKDE.tcl,v 1.5 2007-11-17 07:40:52 matben Exp $ namespace eval URIRegisterKDE { if {![string equal $::this(platform) "unix"]} { return } # Try to see if we've got KDE. set dir ~/.kde/share/services/ if {![file isdirectory $dir]} { return } component::define URIRegisterKDE "Adds XMPP uri parsing support in KDE" } proc URIRegisterKDE::Init {} { Register component::register URIRegisterKDE } # ParseURI::RegisterKDE -- # # At least Konqurer on my SUSE box understands this. proc ::URIRegisterKDE::Register {} { global this set prefsPath [file nativename ~/.coccinella] set scriptFile [file join $prefsPath scripts handle_uri.tcl] # Not sure how any spaces should be handled; uri parsed? set protocolSpec {\ [Protocol] exec=@T %u protocol=xmpp input=none output=none helper=true listing=false reading=false writing=false makedir=false deleting=false Icon="" } set protocolSpec [string map [list @T $scriptFile] $protocolSpec] # Write protocol file only if dir exists. set dst ~/.kde/share/services/xmpp.protocol if {[file isdirectory [file dirname $dst]]} { set fd [open $dst w] puts $fd $protocolSpec close $fd } # This is a script that either sends off a command to open the uri or # launches the app with -uri. # --- Begin script --- set script {#!/bin/sh # the next line restarts using wish @B exec wish "$0" -visual best "$@" wm withdraw . set prefsPath [file nativename ~/.coccinella] set pidFile [file join $prefsPath coccinella.pid] set execFile [file join $prefsPath launchCmd] set runs 0 if {[file exists $pidFile]} { set fd [open $pidFile r] set pid [read $fd] close $fd # BSD style: # set pids [exec ps -xa -o pid] # On unix BSD switches must not have dashes. set pids [exec ps xa o pid] set runs [expr {[lsearch $pids $pid] >= 0 ? 1 : 0}] } set uri [lindex $argv 0] if {$runs} { send -async coccinella [list ::ParseURI::TextCmd $uri] } else { set fd [open $execFile r] set exe [read $fd] close $fd eval exec $exe [list -uri $uri] & } exit } # --- End script --- # Trick to get the ending \ in place. set script [string map {@B \\} $script] # Write the launch script to our prefs dir. if {![file exists $scriptFile]} { set fd [open $scriptFile w] puts $fd $script close $fd file attributes $scriptFile -permissions "u+x" } } coccinella-0.96.20/components/URIRegistry.tcl000066400000000000000000000043111167435367600210660ustar00rootroot00000000000000# URIRegistry.tcl -- # # # # See: http://msdn.microsoft.com/workshop/networking/pluggable/overview/appendix_a.asp # # Copyright (c) 2007 Mats Bengtsson # # 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 3 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, see . # # $Id: URIRegistry.tcl,v 1.10 2007-11-17 07:40:52 matben Exp $ namespace eval ::URIRegistry { if {![string equal $::tcl_platform(platform) "windows"]} { return } if {[catch {package require registry}]} { return } component::define URIRegistry \ {Automatically adds an registry entry so that this program is\ launched when clicking an uri .} } proc ::URIRegistry::Init {} { global tcl_platform this ::Debug 2 "::URIRegistry::Init" # Find the exe we are running. Starkits? if {[info exists ::starkit::topdir]} { set exe [file nativename [info nameofexecutable]] set cmd "\"$exe\" -uri \"%1\"" } else { set exe [file nativename [info nameofexecutable]] set app [file nativename $this(script)] set cmd "\"$exe\" \"$app\" -uri \"%1\"" } foreach name {xmpp im} { if {[catch {SetProtocol $name $cmd}]} { return } } component::register URIRegistry } proc ::URIRegistry::SetProtocol {name cmd} { registry set HKEY_CLASSES_ROOT\\$name {} "URL:$name Protocol" registry set HKEY_CLASSES_ROOT\\$name "URL Protocol" {} registry set HKEY_CLASSES_ROOT\\$name\\Shell registry set HKEY_CLASSES_ROOT\\$name\\Shell\\open registry set HKEY_CLASSES_ROOT\\$name\\Shell\\open\\command {} $cmd } #------------------------------------------------------------------------------- coccinella-0.96.20/components/UserActivity.tcl000066400000000000000000000506041167435367600213370ustar00rootroot00000000000000# UserActivity.tcl -- # # User Activity using PEP recommendations over PubSub library code. # Implements XEP-0108: User Activity # # Copyright (c) 2007-2008 Mats Bengtsson # # 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 3 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, see . # # $Id: UserActivity.tcl,v 1.22 2008-08-18 12:34:22 matben Exp $ package require jlib::pep package require ui::optionmenu namespace eval ::UserActivity { component::define UserActivity \ "Communicate information about user activities" set allActivities [list] } proc ::UserActivity::Init {} { component::register UserActivity ::Debug 2 "::UserActivity::Init" # Add event hooks. ::hooks::register jabberInitHook ::UserActivity::JabberInitHook ::hooks::register loginHook ::UserActivity::LoginHook ::hooks::register logoutHook ::UserActivity::LogoutHook variable moodNode set moodNode "http://jabber.org/protocol/activity " variable xmlns set xmlns(activity) "http://jabber.org/protocol/activity" set xmlns(activity+notify) "http://jabber.org/protocol/activity+notify" set xmlns(node_config) "http://jabber.org/protocol/pubsub#node_config" variable menuDef # TRANSLATORS; user activity settings; see Action menu when logged in to a server with PEP support set menuDef [list command mActivity... {[mc "Acti&vity"]...} ::UserActivity::Dlg {} {}] variable subActivities set subActivities(doing_chores) { buying_groceries cleaning cooking doing_maintenance doing_the_dishes doing_the_laundry gardening running_an_errand walking_the_dog } set subActivities(drinking) { having_a_beer having_coffee having_tea } set subActivities(eating) { having_a_snack having_breakfast having_dinner having_lunch } set subActivities(exercising) { cycling hiking jogging playing_sports running skiing swimming working_out } set subActivities(grooming) { at_the_spa brushing_teeth getting_a_haircut shaving taking_a_bath taking_a_shower } set subActivities(having_appointment) {} set subActivities(inactive) { day_off hanging_out on_vacation scheduled_holiday sleeping } set subActivities(relaxing) { gaming going_out partying reading rehearsing shopping socializing sunbathing watching_tv watching_a_movie } set subActivities(talking) { in_real_life on_the_phone on_video_phone } set subActivities(traveling) { commuting cycling driving in_a_car on_a_bus on_a_plane on_a_train on_a_trip walking } set subActivities(working) { coding in_a_meeting studying writing } variable allActivities set allActivities [lsort [array names subActivities]] variable allSpecific set allSpecific [list] foreach {key value} [array get subActivities] { set allSpecific [concat $allSpecific $value] } set allSpecific [lsort -unique $allSpecific] } # UserActivity::JabberInitHook -- # # Here we announce that we have user activity support and is interested in # getting notifications. proc ::UserActivity::JabberInitHook {jlibname} { variable xmlns set E [list] lappend E [wrapper::createtag "identity" \ -attrlist [list category hierarchy type leaf name "User Activity"]] lappend E [wrapper::createtag "feature" \ -attrlist [list var $xmlns(activity)]] lappend E [wrapper::createtag "feature" \ -attrlist [list var $xmlns(activity+notify)]] $jlibname caps register activity $E [list $xmlns(activity) $xmlns(activity+notify)] } # Setting own activity --------------------------------------------------------- # # Disco server for PEP, disco own bare JID, create pubsub node. # # 1) Disco server for pubsub/pep support # 2) Publish activity proc ::UserActivity::LoginHook {} { variable xmlns # Disco server for pubsub/pep support. set server [::Jabber::Jlib getserver] ::Jabber::Jlib pep have $server [namespace code HavePEP] ::Jabber::Jlib pubsub register_event [namespace code Event] \ -node $xmlns(activity) } proc ::UserActivity::HavePEP {jlibname have} { variable menuDef variable xmlns if {$have} { # Get our own published activity and fill in. # NB: I thought that this should work automatically but seems not. set myjid2 [::Jabber::Jlib myjid2] ::Jabber::Jlib pubsub items $myjid2 $xmlns(activity) \ -command [namespace code ItemsCB] ::JUI::RegisterMenuEntry action $menuDef if {[MPExists]} { [MPWin] state {!disabled} } } } proc ::UserActivity::LogoutHook {} { ::JUI::DeRegisterMenuEntry action mActivity... if {[MPExists]} { [MPWin] state {disabled} } } namespace eval ::UserActivity { variable dialogL [list] } proc ::UserActivity::Dlg {} { variable allActivities variable subActivities variable xmlns variable dialogL set w [ui::dialog -message [mc "Set your activity that will be shown to your contacts."] \ -detail [mc "Select from the first button your general activity, and optionally, your specific actvity from the second button. You may also add a descriptive text."] -icon info \ -buttons {ok cancel remove} \ -geovariable ::prefs(winGeom,activity) \ -title [mc "User Activity"] -command [namespace code DlgCmd]] set fr [$w clientframe] # State array variable. variable $w upvar 0 $w state set token [namespace current]::$w set state(activity) [lindex $allActivities 0] set state(specific) - set state(text) "" set state(all) 0 lappend dialogL $w set mDef [list] lappend mDef [list [mc "None"] -value "-"] lappend mDef {separator} foreach name $allActivities { set dname [string totitle [string map {_ " "} $name]] lappend mDef [list [mc $dname] -value $name \ -image [::Theme::FindIconSize 16 activity-$name]] } ttk::label $fr.la -text [mc "General"]: ui::optionmenu $fr.activity -menulist $mDef -direction flush \ -variable $token\(activity) ttk::label $fr.ls -text [mc "Specific"]: ui::optionmenu $fr.specific -direction flush \ -variable $token\(specific) ttk::label $fr.lt -text [mc "Message"]: ttk::entry $fr.text -textvariable $token\(text) ttk::checkbutton $fr.all -text [mc "Show all specific activities"] \ -variable $token\(all) -command [namespace code [list DlgAll $w]] set maxw [$fr.activity maxwidth] grid $fr.la $fr.activity -sticky e -pady 1 grid $fr.ls $fr.specific -sticky e -pady 1 grid $fr.lt $fr.text -sticky e -pady 1 grid x $fr.all -sticky e -pady 1 grid $fr.activity $fr.specific $fr.text -sticky ew grid columnconfigure $fr 1 -minsize $maxw trace add variable $token\(activity) write [namespace code [list Trace $w]] ConfigSpecificMenu $w $state(activity) bind $fr.activity { focus %W } # Get our own published activity and fill in. set myjid2 [::Jabber::Jlib myjid2] ::Jabber::Jlib pubsub items $myjid2 $xmlns(activity) \ -command [namespace code ItemsCB] } proc ::UserActivity::Trace {w name1 name2 op} { variable $w upvar 0 $w state upvar $name1 var if {0} { # Never managed to figure out this :-( if {$name2 eq ""} { set val $var } else { set val $var($name2) } ConfigSpecificMenu $w $val } ConfigSpecificMenu $w $state(activity) } proc ::UserActivity::DlgAll {w} { variable $w upvar 0 $w state ConfigSpecificMenu $w $state(activity) } proc ::UserActivity::ConfigSpecificMenu {w activity} { variable $w upvar 0 $w state variable subActivities variable allSpecific set fr [$w clientframe] # User Activity strings. set activityText [dict create] dict set activityText doing_chores [mc "Doing chores"] dict set activityText buying_groceries [mc "Buying groceries"] dict set activityText cleaning [mc "Cleaning"] dict set activityText cooking [mc "Cooking"] dict set activityText doing_maintenance [mc "Doing maintenance"] dict set activityText doing_the_dishes [mc "Doing the dishes"] dict set activityText doing_the_laundry [mc "Doing the laundry"] dict set activityText gardening [mc "Gardening"] dict set activityText running_an_errand [mc "Running an errand"] dict set activityText walking_the_dog [mc "Walking the dog"] dict set activityText drinking [mc "Drinking"] dict set activityText having_a_beer [mc "Having a beer"] dict set activityText having_coffee [mc "Having coffee"] dict set activityText having_tea [mc "Having tea"] dict set activityText eating [mc "Eating"] dict set activityText having_a_snack [mc "Having a snack"] dict set activityText having_breakfast [mc "Having breakfast"] dict set activityText having_dinner [mc "Having dinner"] dict set activityText having_lunch [mc "Having lunch"] dict set activityText exercising [mc "Exercising"] dict set activityText hiking [mc "Hiking"] dict set activityText jogging [mc "Jogging"] dict set activityText playing_sports [mc "Playing sports"] dict set activityText running [mc "Running"] dict set activityText skiing [mc "Skiing"] dict set activityText swimming [mc "Swimming"] dict set activityText working_out [mc "Working out"] dict set activityText grooming [mc "Grooming"] dict set activityText at_the_spa [mc "At the spa"] dict set activityText brushing_teeth [mc "Brushing teeth"] dict set activityText getting_a_haircut [mc "Getting a haircut"] dict set activityText shaving [mc "Shaving"] dict set activityText taking_a_bath [mc "Taking a bath"] dict set activityText taking_a_shower [mc "Taking a shower"] dict set activityText having_appointment [mc "Having appointment"] dict set activityText inactive [mc "Inactive"] dict set activityText day_off [mc "Day off"] dict set activityText hanging_out [mc "Hanging out"] dict set activityText on_vacation [mc "On vacation"] dict set activityText scheduled_holiday [mc "Scheduled holiday"] dict set activityText sleeping [mc "Sleeping"] dict set activityText relaxing [mc "Relaxing"] dict set activityText gaming [mc "Gaming"] dict set activityText going_out [mc "Going out"] dict set activityText partying [mc "Partying"] dict set activityText reading [mc "Reading"] dict set activityText rehearsing [mc "Rehearsing"] dict set activityText shopping [mc "Shopping"] dict set activityText socializing [mc "Socializing"] dict set activityText sunbathing [mc "Sunbathing"] dict set activityText watching_tv [mc "Watching tv"] dict set activityText watching_a_movie [mc "Watching a movie"] dict set activityText talking [mc "Talking"] dict set activityText in_real_life [mc "In real life"] dict set activityText on_the_phone [mc "On the phone"] dict set activityText on_video_phone [mc "On video phone"] dict set activityText traveling [mc "Traveling"] dict set activityText commuting [mc "Commuting"] dict set activityText cycling [mc "Cycling"] dict set activityText driving [mc "Driving"] dict set activityText in_a_car [mc "In a car"] dict set activityText on_a_bus [mc "On a bus"] dict set activityText on_a_plane [mc "On a plane"] dict set activityText on_a_train [mc "On a train"] dict set activityText on_a_trip [mc "On a trip"] dict set activityText walking [mc "Walking"] dict set activityText working [mc "Working"] dict set activityText coding [mc "Coding"] dict set activityText in_a_meeting [mc "In a meeting"] dict set activityText studying [mc "Studying"] dict set activityText writing [mc "Writing"] set mDef [list] lappend mDef [list [mc "None"] -value "-"] if {$activity ne "-"} { lappend mDef [list separator] if {$state(all)} { foreach name $allSpecific { set dname [dict get $activityText $name] lappend mDef [list $dname -value $name \ -image [::Theme::FindIconSize 16 activity-$name]] } } else { foreach name $subActivities($activity) { set dname [dict get $activityText $name] lappend mDef [list [mc $dname] -value $name \ -image [::Theme::FindIconSize 16 activity-$name]] } } } $fr.specific configure -menulist $mDef } proc ::UserActivity::DlgCmd {w bt} { variable $w upvar 0 $w state variable xmlns variable dialogL if {$bt eq "ok"} { if {$state(activity) eq "-"} { Retract } else { Publish $state(activity) $state(specific) $state(text) } if {[MPExists]} { MPDisplayActivity $state(activity) } } elseif {$bt eq "remove"} { Retract if {[MPExists]} { MPDisplayActivity - } } unset -nocomplain state set dialogL [lsearch -inline -all -not $dialogL $w] } proc ::UserActivity::ItemsCB {type subiq args} { variable xmlns variable subActivities variable dialogL if {$type eq "error"} { return } set activity - set specific - set activityText "" foreach itemsE [wrapper::getchildren $subiq] { set tag [wrapper::gettag $itemsE] set node [wrapper::getattribute $itemsE "node"] if {[string equal $tag "items"] && [string equal $node $xmlns(activity)]} { set itemE [wrapper::getfirstchildwithtag $itemsE item] set activityE [wrapper::getfirstchildwithtag $itemE activity] if {![llength $activityE]} { continue } foreach E [wrapper::getchildren $activityE] { set tag [wrapper::gettag $E] switch -- $tag { text { set activityText [wrapper::getcdata $E] } default { if {![info exists subActivities($tag)]} { return } set activity $tag set specificE [lindex [wrapper::getchildren $E] 0] if {[llength $specificE]} { set specific [wrapper::gettag $specificE] if {[lsearch $subActivities($activity) $specific] < 0} { set state(specific) - } } else { set state(specific) - } } } } } } if {[MPExists]} { MPDisplayActivity $activity } foreach w $dialogL { if {[winfo exists $w]} { SetDlg $w $activity $specific $activityText } } } proc ::UserActivity::SetDlg {w activity specific text} { variable $w upvar 0 $w state set state(activity) $activity set state(specific) $specific set state(text) $text } proc ::UserActivity::Publish {activity specific text} { variable xmlns set specificE [list] if {($specific ne "-") && ($specific ne "")} { set specificE [list [wrapper::createtag $specific]] } set childL [list [wrapper::createtag $activity -subtags $specificE]] if {[string trim $text] ne ""} { lappend childL [wrapper::createtag "text" \ -attrlist [list xml:lang [jlib::getlang]] -chdata $text] } set activityE [wrapper::createtag "activity" -subtags $childL] # NB: It is currently unclear there should be an id attribute in the item # element since PEP doesn't use it but pubsub do, and the experimental # OpenFire PEP implementation. #set itemE [wrapper::createtag item -subtags [list $activityE]] set itemE [wrapper::createtag item \ -attrlist [list id current] -subtags [list $activityE]] ::Jabber::Jlib pep publish $xmlns(activity) $itemE } proc ::UserActivity::Retract {} { variable xmlns ::Jabber::Jlib pep retract $xmlns(activity) -notify 1 } # UserActivity::Event -- # # User activity event handler for incoming activity messages. proc ::UserActivity::Event {jlibname xmldata} { variable state variable xmlns # The server MUST set the 'from' address on the notification to the # bare JID () of the account owner. set from [wrapper::getattribute $xmldata from] set eventE [wrapper::getfirstchildwithtag $xmldata event] if {[llength $eventE]} { set itemsE [wrapper::getfirstchildwithtag $eventE items] if {[llength $itemsE]} { set node [wrapper::getattribute $itemsE node] if {$node ne $xmlns(activity)} { return } set mjid [jlib::jidmap $from] set activity "" set specific "" set text "" set retractE [wrapper::getfirstchildwithtag $itemsE retract] if {[llength $retractE]} { set msg "" set state($mjid,mood) "" set state($mjid,text) "" } else { set itemE [wrapper::getfirstchildwithtag $itemsE item] set activityE [wrapper::getfirstchildwithtag $itemE activity] if {![llength $activityE]} { return } foreach E [wrapper::getchildren $activityE] { set tag [wrapper::gettag $E] switch -- $tag { text { set text [wrapper::getcdata $E] } default { set activity $tag set specificE [lindex [wrapper::getchildren $E] 0] if {[llength $specificE]} { set specific [wrapper::gettag $specificE] } } } } # Cache the result. set state($mjid,activity) $activity set state($mjid,specific) $specific set state($mjid,text) $text if {$activity eq ""} { set msg "" } else { set dname [string totitle [string map {_ " "} $activity]] set msg [mc "Activity"] append msg ": [mc $dname]" if {$specific ne ""} { set dname [string totitle [string map {_ " "} $specific]] append msg " - [mc $dname]" } if {$text ne ""} { append msg " - $text" } } } ::RosterTree::BalloonRegister activity $from $msg ::hooks::run activityEvent $xmldata $activity $specific $text } } } #--- Mega Presence Hook -------------------------------------------------------- namespace eval ::UserActivity { ::MegaPresence::Register activity [mc "Activity"] [namespace code MPBuild] variable imsize 16 variable mpwin "-" variable imblank set imblank [image create photo -height $imsize -width $imsize] $imblank blank } proc ::UserActivity::MPBuild {win} { variable imsize variable imblank variable mpwin variable allActivities variable mpActivity set mpwin $win ttk::menubutton $win -style SunkenMenubutton \ -image $imblank -compound image set m $win.m menu $m -tearoff 0 $win configure -menu $m $win state {disabled} $m add radiobutton -label [mc "None"] -value "-" \ -variable [namespace current]::mpActivity \ -command [namespace code MPCmd] $m add separator foreach activity $allActivities { set dname [string totitle [string map {_ " "} $activity]] $m add radiobutton -label [mc $dname] -value $activity \ -image [::Theme::FindIconSize $imsize activity-$activity] \ -variable [namespace current]::mpActivity \ -command [namespace code MPCmd] -compound left } $m add separator $m add command -label [mc "Custom Activity"]... -command [namespace code Dlg] set mpActivity "-" return } proc ::UserActivity::MPCmd {} { variable mpwin variable mpActivity variable imblank if {$mpActivity eq "-"} { Retract } else { Publish $mpActivity "" "" } MPDisplayActivity $mpActivity } proc ::UserActivity::MPDisplayActivity {activity} { variable imsize variable mpwin variable mpActivity variable imblank set mpActivity $activity if {$activity eq "-"} { $mpwin configure -image $imblank set msg [mc "Activity"] append msg ": " append msg [mc "None"] ::balloonhelp::balloonforwindow $mpwin $msg } else { set dname [string totitle [string map {_ " "} $activity]] $mpwin configure -image [::Theme::FindIconSize $imsize activity-$activity] set msg [mc "Activity"] append msg ": [mc $dname]" ::balloonhelp::balloonforwindow $mpwin $msg } } proc ::UserActivity::MPSetActivity {activity} { variable mpActivity set mpActivity $activity MPCmd } proc ::UserActivity::MPExists {} { variable mpwin return [winfo exists $mpwin] } proc ::UserActivity::MPWin {} { variable mpwin return $mpwin } coccinella-0.96.20/components/WhiteboardMK.tcl000066400000000000000000000051601167435367600212210ustar00rootroot00000000000000# WhiteboardMK.tcl -- # # Registers a metakit file format for whiteboards. # # Copyright (c) 2007 Mats Bengtsson # # 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 3 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, see . # # $Id: WhiteboardMK.tcl,v 1.5 2007-11-17 07:40:52 matben Exp $ namespace eval ::WhiteboardMK { if {![::Jabber::HaveWhiteboard]} { return } if {[catch { package require vfs package require vfs::mk4 }]} { return } component::define WhiteboardMK \ "Provides a metakit database to save complete whiteboards in a single file." } proc ::WhiteboardMK::Init { } { component::register WhiteboardMK ::CanvasFile::RegisterSaveFormat WhiteboardMK Metakit .cmk \ ::WhiteboardMK::Save ::CanvasFile::RegisterOpenFormat WhiteboardMK Metakit .cmk \ ::WhiteboardMK::Open } proc ::WhiteboardMK::Save {wcan fileName} { global this # Work on a temporary file. set tmpCan [::tfileutils::tempfile $this(tmpPath) ""] append tmpCan .can set tmpfd [open $tmpCan {CREAT WRONLY}] fconfigure $tmpfd -encoding utf-8 ::CanvasFile::CanvasToChannel $wcan $tmpfd $tmpCan -pathtype absolute close $tmpfd # Make a VFS. 'fileName' will be a dir in VFS sense. # Creating a file using 'open' and then writing wont work! set compress $mk4vfs::compress set mk4vfs::compress 0 vfs::mk4::Mount $fileName $fileName ::CanvasFile::FlattenToDir $tmpCan $fileName # Must rename the tmp file to tail of 'fileName'. set vfstmpCan [file join $fileName [file tail $tmpCan]] set canTail [file rootname [file tail $fileName]].can set newCan [file join $fileName $canTail] file rename -force $vfstmpCan $newCan vfs::unmount $fileName set mk4vfs::compress $compress } proc ::WhiteboardMK::Open {wcan fileName} { # Pick the ordinary canvas file inside vfs. vfs::mk4::Mount $fileName $fileName set can [file rootname [file tail $fileName]].can ::CanvasFile::OpenCanvas $wcan [file join $fileName $can] vfs::unmount $fileName } coccinella-0.96.20/components/XMLConsole.tcl000066400000000000000000000207601167435367600206670ustar00rootroot00000000000000# XMLConsole.tcl -- # # A simple XML console. # This is just a first sketch. # # Copyright (c) 2007 Mats Bengtsson and Antonio Camas # # 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 3 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, see . # # $Id: XMLConsole.tcl,v 1.8 2008-03-07 10:40:05 matben Exp $ namespace eval ::XMLConsole { component::define XMLConsole "Simple XML console <$this(modkey)-Shift-D>" # TODO option add *XMLConsole*Text.tabsX 4 widgetDefault option add *XMLConsole*Text.trecvBackground gray90 widgetDefault option add *XMLConsole*Text.trecvForeground blue widgetDefault option add *XMLConsole*Text.tsendBackground gray80 widgetDefault option add *XMLConsole*Text.tsendForeground red widgetDefault } proc ::XMLConsole::Init {} { global this component::register XMLConsole ::hooks::register prefsInitHook [namespace code InitPrefsHook] ::hooks::register loginHook [namespace code LoginHook] ::hooks::register logoutHook [namespace code LogoutHook] bind all <$this(modkey)-Shift-Key-D> [namespace code OnCmd] } proc ::XMLConsole::OnCmd {} { Build } proc ::XMLConsole::InitPrefsHook {} { variable opts set opts(pretty) 1 ::PrefUtils::Add [list [list ::XMLConsole::opts(pretty) xmlconsole_pretty $opts(pretty)]] } proc ::XMLConsole::LoginHook {} { foreach w [ui::findalltoplevelwithclass XMLConsole] { variable $w upvar 0 $w state $state(send) configure -state normal } } proc ::XMLConsole::LogoutHook {} { foreach w [ui::findalltoplevelwithclass XMLConsole] { variable $w upvar 0 $w state $state(send) delete 1.0 end $state(send) configure -state disabled } } proc ::XMLConsole::Build {} { global config variable opts set w .cmpnt_xml if {[winfo exists $w]} { raise $w return } set token [namespace current]::$w variable $w upvar 0 $w state ::UI::Toplevel $w -class XMLConsole \ -usemacmainmenu 1 -macstyle documentProc \ -macclass {document {closeBox resizable}} \ -closecommand [namespace code Close] # TRANSLATORS; hidden XML console: Control + Shift + D (or Command + Shift + D on Mac OS X) wm title $w [mc "XML Console"] ttk::frame $w.frall pack $w.frall -fill both -expand 1 set wbox $w.frall.f ttk::frame $wbox -padding [option get . dialogPadding {}] pack $wbox -fill both -expand 1 set frbot $wbox.b ttk::frame $frbot -padding [option get . okcancelTopPadding {}] ttk::checkbutton $frbot.c -style Small.TCheckbutton \ -text [mc "Pretty format"] -variable $token\(pretty) ttk::button $frbot.btok -text [mc "OK"] -default active \ -command [list destroy $w] ttk::button $frbot.clear -text [mc "Clear"] \ -command [namespace code [list Clear $w]] set padx [option get . buttonPadX {}] pack $frbot.btok -side right pack $frbot.clear -side right -padx $padx pack $frbot.c -side left pack $frbot -side bottom -fill x # Frame to serve as container for the pane geometry manager. frame $wbox.m pack $wbox.m -side top -fill both -expand 1 set width 60 # Pane geometry manager. set wpane $wbox.m.p ttk::paned $wpane -orient vertical pack $wpane -side top -fill both -expand 1 # Log pane. set wlog $wpane.l set wtext $wlog.t set wysc $wlog.y if {$config(ui,aqua-text)} { frame $wlog set wcont [::UI::Text $wtext -height 16 -width $width -cursor {} -wrap word \ -yscrollcommand [list ::UI::ScrollSet $wysc \ [list grid $wysc -column 1 -row 0 -sticky ns]]] } else { frame $wlog -bd 1 -relief sunken text $wtext -height 16 -width $width -bd 0 -state disabled -cursor {} -wrap word \ -yscrollcommand [list ::UI::ScrollSet $wysc \ [list grid $wysc -column 1 -row 0 -sticky ns]] set wcont $wtext } ttk::scrollbar $wysc -orient vertical -command [list $wtext yview] # @@@ This suddenly stopped working??? bindtags $wtext [linsert [bindtags $wtext] 0 ReadOnlyText] grid $wcont -column 0 -row 0 -sticky news grid $wysc -column 1 -row 0 -sticky ns grid columnconfigure $wlog 0 -weight 1 grid rowconfigure $wlog 0 -weight 1 set font [$wtext cget -font] set tabsx [option get $wtext tabsX {}] set tab [font measure $font [string repeat x $tabsx]] $wtext configure -tabs [list $tab left] $wtext tag configure trecv $wtext tag configure tsend ::Text::ConfigureTags $wtext set state(text) $wtext # Send pane. set wsend $wpane.s set wtext $wsend.t set wysc $wsend.y if {$config(ui,aqua-text)} { frame $wsend set wcont [::UI::Text $wtext -height 1 -width $width -wrap word \ -yscrollcommand [list ::UI::ScrollSet $wysc \ [list grid $wysc -column 1 -row 0 -sticky ns]]] } else { frame $wsend -bd 1 -relief sunken text $wtext -height 1 -width $width -bd 0 -wrap word \ -yscrollcommand [list ::UI::ScrollSet $wysc \ [list grid $wysc -column 1 -row 0 -sticky ns]] set wcont $wtext } ttk::scrollbar $wysc -orient vertical -command [list $wtext yview] grid $wcont -column 0 -row 0 -sticky news grid $wysc -column 1 -row 0 -sticky ns grid columnconfigure $wsend 0 -weight 1 grid rowconfigure $wsend 0 -weight 1 if {![::Jabber::IsConnected]} { $wtext configure -state disabled } $wpane add $wlog -weight 1 $wpane add $wsend -weight 0 set state(send) $wtext set state(pretty) $opts(pretty) bind $wtext [namespace code [list DoSend $w]] bind $w \ +[subst { if {"%W" eq "$w"} { [namespace code [list Free %W]] } }] ::UI::SetWindowGeometry $w ::Jabber::Jlib tee_recv add [namespace code [list Recv $w]] ::Jabber::Jlib tee_send add [namespace code [list Send $w]] return $w } proc ::XMLConsole::DoSend {w} { variable $w upvar 0 $w state set wstext $state(send) set xml [string trim [$wstext get 1.0 end]] ::Jabber::Jlib sendraw $xml $wstext delete 1.0 end set wtext $state(text) $wtext configure -state normal $wtext insert end $xml tsend $wtext insert end "\n" tsend $wtext configure -state disabled $wtext see end return -code break } proc ::XMLConsole::Recv {w jlibname xmllist} { variable $w upvar 0 $w state set wtext $state(text) if {$state(pretty)} { set xml [wrapper::formatxml $xmllist] } else { set xml [wrapper::createxml $xmllist] } $wtext configure -state normal $wtext insert end $xml trecv $wtext insert end "\n" trecv $wtext configure -state disabled $wtext see end } proc ::XMLConsole::Send {w jlibname xmllist} { variable $w upvar 0 $w state set wtext $state(text) if {$state(pretty)} { set xml [wrapper::formatxml $xmllist] } else { set xml [wrapper::createxml $xmllist] } $wtext configure -state normal $wtext insert end $xml tsend $wtext insert end "\n" tsend $wtext configure -state disabled $wtext see end } proc ::XMLConsole::Clear {w} { variable $w upvar 0 $w state set wtext $state(text) $wtext configure -state normal $wtext delete 1.0 end $wtext configure -state disabled } proc ::XMLConsole::Close {w} { ::UI::SaveWinGeom $w } proc ::XMLConsole::Free {w} { variable opts variable $w upvar 0 $w state set opts(pretty) $state(pretty) ::Jabber::Jlib tee_recv remove [namespace code [list Recv $w]] ::Jabber::Jlib tee_send remove [namespace code [list Send $w]] unset -nocomplain $w } coccinella-0.96.20/components/cmpntIndex.tcl000066400000000000000000000061071167435367600210140ustar00rootroot00000000000000# See contrib/component.tcl for explanations. # component::attempt AppleEvents [file join $dir AppleEvents.tcl] ::AppleEvents::Init component::attempt AutoUpdate [file join $dir AutoUpdate.tcl] ::AutoUpdate::Init component::attempt BuddyPounce [file join $dir BuddyPounce.tcl] ::BuddyPounce::Init component::attempt ChatShorts [file join $dir ChatShorts.tcl] ::ChatShorts::Init component::attempt Geolocation [file join $dir Geolocation.tcl] ::Geolocation::Init component::attempt GnomeMeeting [file join $dir GMeeting.tcl] ::GMeeting::Init component::attempt ICQ [file join $dir ICQ.tcl] ::ICQ::Init component::attempt IRCActions [file join $dir IRCActions.tcl] ::IRCActions::Init component::attempt ImageMagic [file join $dir ImageMagic.tcl] ::ImageMagic::Init component::attempt JivePhone [file join $dir JivePhone.tcl] ::JivePhone::Init component::attempt MailtoURI [file join $dir MailtoURI.tcl] ::MailtoURI::Init component::attempt LiveRosterImage [file join $dir LiveRosterImage.tcl] ::LiveRosterImage::Init component::attempt MeBeam [file join $dir MeBeam.tcl] ::MeBeam::Init component::attempt Mood [file join $dir Mood.tcl] ::Mood::Init component::attempt Notifier [file join $dir Notifier.tcl] ::Notifier::Init component::attempt NotifyOnline [file join $dir NotifyOnline.tcl] ::NotifyOnline::Init component::attempt ParseStyledText [file join $dir ParseStyledText.tcl] ::ParseStyledText::Init component::attempt ParseURI [file join $dir ParseURI.tcl] ::ParseURI::Init component::attempt SlideShow [file join $dir SlideShow.tcl] ::SlideShow::Load component::attempt Sounds [file join $dir Sounds.tcl] ::Sounds::Init component::attempt Spell [file join $dir Spell.tcl] ::Spell::Init component::attempt Speech [file join $dir Speech.tcl] ::Speech::Load component::attempt SpotLight [file join $dir SpotLight.tcl] ::SpotLight::Init component::attempt Totd [file join $dir Totd.tcl] ::Totd::Init component::attempt TtkDialog [file join $dir TtkDialog.tcl] ::TtkDialog::Init component::attempt URIRegistry [file join $dir URIRegistry.tcl] ::URIRegistry::Init component::attempt URIRegisterKDE [file join $dir URIRegisterKDE.tcl] ::URIRegisterKDE::Init component::attempt UserActivity [file join $dir UserActivity.tcl] ::UserActivity::Init component::attempt WhiteboardMK [file join $dir WhiteboardMK.tcl] ::WhiteboardMK::Init component::attempt XMLConsole [file join $dir XMLConsole.tcl] ::XMLConsole::Init if {[tk windowingsystem] eq "aqua"} { component::attempt Carbon [file join $dir Carbon.tcl] ::Carbon::Init component::attempt Growl [file join $dir Growl.tcl] ::Growl::Init } # This is just an example plugin. Uncomment to test. # component::attempt ComponentExample [file join $dir ComponentExample.tcl] ::ComponentExample::Init coccinella-0.96.20/components/fsdialog.tcl000066400000000000000000001725561167435367600205070ustar00rootroot00000000000000# Copyright (C) Schelte Bron. Freely redistributable. # Mats fix: proc ttk::messageBox {args} { return [eval ui::dialog::modal $args] } interp alias {} ttk_messageBox {} ::ttk::messageBox namespace eval ::ttk::dialog {} namespace eval ::ttk::dialog::file { variable sort name hidden 1 sepfolders 1 foldersfirst 1 variable details 0 reverse 0 filetype none variable dirlist "" filelist "" } namespace eval ::ttk::dialog::image {} # Images for the configuration menu image create photo ::ttk::dialog::image::blank16 -height 16 -width 16 image create photo ::ttk::dialog::image::tick16 -data { R0lGODlhEAAQAMIAAExOTFRSVPz+/AQCBP///////////////yH5BAEKAAQALAAAAAAQABAA AAM4CAHcvkEAQqu18uqat+4eFoTEwE3eYFLCWK2lelqyChMtbd84+sqX3IXH8pFwrmNPyRI4 n9CoIAEAOw==} image create photo ::ttk::dialog::image::radio16 -data { R0lGODlhEAAQAMIAAJyZi////83OxQAAAP///////////////yH5BAEKAAEALAAAAAAQABAA AAMtGLrc/jCAOaNsAGYn3A5DuHTMFp4KuZjnkGJK6waq8qEvzGlNzQlAn2VILC4SADs=} # Images for ttk::getOpenFile, ttk::getSaveFile, ttk::getAppendFile image create photo ::ttk::dialog::image::next -data { R0lGODlhFgAWAMYAADt1BDpzBFiJKb7ZpGaVOTx2A8HcqbfVm3ShSjt0BDp1BDx3Bb/apYe7 V7DSkIOtWzt0A8Dbpr/apL7ao7zZoXu0RXy0R6bMgo23Zz12CbzZoH+2Sn61SX21R3qzRHiy QnaxPnOvOnCuNpjFb5e/cUV8ELnXnHiyQXaxP3WwPXCtNm2sMmqqLWaoKIm8WJ3FeEuBGLXV l2+tNGGlIWanJ2urLWutLmqtK2irJ2SpIl+lHJ/GeFaKIjt1A6jNhU+aB06aBk+cBlKhCFWl CViqDF6uEmCvFWGtFl2qE3e2Op3HdVWLIjt2BKPLflSjCFipClyvDF6zDWC2Dl+0DYTER5zK cEqDFjt3A1eoClywDGG3DmW9EGfBEWnCE5XTWZjJZ0R9D6TLfqbPf6nUgazYgq/cg2nDEXPM GqPfaY7DWj53CTlzBD13Ba7bg3HGH6fecn+0SqbWdmufOjhwBKTPelqNKTNmAk6DHi9dAzdu A////////////////////////yH5BAEKAH8ALAAAAAAWABYAAAfGgH+Cg4SFhoeIiYgAio0B Ao2JAQMEBZGGAQYHCAmNCgGgoAsMDQ4PEIoBEasREhMUFRYXGBmSGhsbHB0eHyAhIiMkJYgB JifHKCkhKissLS4vMIcBMTItMzM0NTY3ODk6Jzs9mD4/QEBBQkNERUZHSElKTJhN50FOT1BR UlJTVFVXptUDIgRLFi1buHTx8gUMsSZNwogZQ6aMmTNo0qhJtCYUKDZt3LyB0+mSoABk4siZ Y3JQADp17LR0eQfPzEF5burcKSgQADs=} image create photo ::ttk::dialog::image::nextbw -data { R0lGODlhFgAWAOcAAAAAAAEBAQICAgMDAwQEBAUFBQYGBgcHBwgICAkJCQoKCgsLCwwMDA0N DQ4ODg8PDxAQEBERERISEhMTExQUFBUVFRYWFhcXFxgYGBkZGRoaGhsbGxwcHB0dHR4eHh8f HyAgICEhISIiIiMjIyQkJCUlJSYmJicnJygoKCkpKSoqKisrKywsLC0tLS4uLi8vLzAwMDEx MTIyMjMzMzQ0NDU1NTY2Njc3Nzg4ODk5OTo6Ojs7Ozw8PD09PT4+Pj8/P0BAQEFBQUJCQkND Q0REREVFRUZGRkdHR0hISElJSUpKSktLS0xMTE1NTU5OTk9PT1BQUFFRUVJSUlNTU1RUVFVV VVZWVldXV1hYWFlZWVpaWltbW1xcXF1dXV5eXl9fX2BgYGFhYWJiYmNjY2RkZGVlZWZmZmdn Z2hoaGlpaWpqamtra2xsbG1tbW5ubm9vb3BwcHFxcXJycnNzc3R0dHV1dXZ2dnd3d3h4eHl5 eXp6ent7e3x8fH19fX5+fn9/f4CAgIGBgYKCgoODg4SEhIWFhYaGhoeHh4iIiImJiYqKiouL i4yMjI2NjY6Ojo+Pj5CQkJGRkZKSkpOTk5SUlJWVlZaWlpeXl5iYmJmZmZqampubm5ycnJ2d nZ6enp+fn6CgoKGhoaKioqOjo6SkpKWlpaampqenp6ioqKmpqaqqqqurq6ysrK2tra6urq+v r7CwsLGxsbKysrOzs7S0tLW1tba2tre3t7i4uLm5ubq6uru7u7y8vL29vb6+vr+/v8DAwMHB wcLCwsPDw8TExMXFxcbGxsfHx8jIyMnJycrKysvLy8zMzM3Nzc7Ozs/Pz9DQ0NHR0dLS0tPT 09TU1NXV1dbW1tfX19jY2NnZ2dra2tvb29zc3N3d3d7e3t/f3+Dg4OHh4eLi4uPj4+Tk5OXl 5ebm5ufn5+jo6Onp6erq6uvr6+zs7O3t7e7u7u/v7/Dw8PHx8fLy8vPz8/T09PX19fb29vf3 9/j4+Pn5+fr6+vv7+/z8/P39/f7+/v///yH5BAEKAP8ALAAAAAAWABYAAAjUAP8JHEiwoMGD CBMivKKwYZU3DRNWWcaHYcSCVZwVS2SloZUqIEFiYQYK2KWOEpupbLZsmTJLl3CFwiJRWaZM mDBVoiQJkiNXqr4grHKMklFJkSA1WpTIUChYZQ5WIdbIkCBBhRItUoSoECBKsSwSrJJrjhw5 dPDsAUTIUCFBlcIarGLrLB09fwgdSpQI0ShZNOfWlYPHDyFFjyRRkvVKqFRbkHP1CkaMUidg p7JIDAkyyzBNwTChvPivSrBehKaQHlgFl5wlq1mfKRJ7YJTauHMLDAgAOw==} image create photo ::ttk::dialog::image::previous -data { R0lGODlhFgAWAOcAADp0BFSIJTx1Bzp0A2KSNLrWnz93Czt1BHGeRbXUmL/apTx0BH6qVa/R joS5UrzZoEF7CzpzBD13CIu2Y6TLf3iyQniyQbnXnbzZob7ao7/apMDbpj92CkR7D5S8bJbD a22sMW+tNHKvOXaxPnqzRH21R361SX+2SrvYn0mAFprDdIe6VWOmI2aoKGqqLW2sMnCtNnOv OnWwPXaxP7jWmj52CTt1A1SIIJvEdHWxPlqhF16jHGGlIWSnJWmrK2uvLGqwKGevI2uvKXKy NrTVlT11CDt3A1SKIJrEcVOdDVWeEFSeD1ekD1enC1mrCluuC1ywDFqqC6rThEmCFZXAbE6a BlKgB1enCV+0DWK4DmS7D2O7D1+zDajUfkJ5DYy5YYa7U1elDFqsC2jBEWvGEmrFEmfBEWO6 D6rXfzx1CDx2B4GwU5TGY2GxFGC2Dq7dgLLhhLXmhrTlha/dg63Zgjx2CDpyA3WmRZ3Ob2m5 HK3bgEF9CTtzBDduA2aYNqHQdazYgTNlAleLJaPOeS1ZA0yBGzx0Bv////////////////// //////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////// /////////////////////////////////yH5BAEKAP8ALAAAAAAWABYAAAjgAP8JHEiwoMGD CBMq/AdgYcIAAhwaHECggAGJBA8gSKDgIsZ/Cxg0cPAAQoSTJw8klDCBQgULFzBk0LChJgeE HTx8ABFCxIgKJEqYOIHipsEUKlawaOHiBYwYMmZYsECjhkEbOHLo2MGjh48fQIIEETKESBGD RpDASKJkCZMmTp5AgfIkipSzBgFQIVHFypUnWLJo2ZKFSxe8Br18ARNGDBYtY8iUMXMGTZqE atawaePmDZw4cuDMoVNHoZ07ePLo2YPyJJ+Fffz8AVT6o8BAggbVtv2PUCFDvAn2CU7cdkAA Ow==} image create photo ::ttk::dialog::image::previousbw -data { R0lGODlhFgAWAOcAAAAAAAEBAQICAgMDAwQEBAUFBQYGBgcHBwgICAkJCQoKCgsLCwwMDA0N DQ4ODg8PDxAQEBERERISEhMTExQUFBUVFRYWFhcXFxgYGBkZGRoaGhsbGxwcHB0dHR4eHh8f HyAgICEhISIiIiMjIyQkJCUlJSYmJicnJygoKCkpKSoqKisrKywsLC0tLS4uLi8vLzAwMDEx MTIyMjMzMzQ0NDU1NTY2Njc3Nzg4ODk5OTo6Ojs7Ozw8PD09PT4+Pj8/P0BAQEFBQUJCQkND Q0REREVFRUZGRkdHR0hISElJSUpKSktLS0xMTE1NTU5OTk9PT1BQUFFRUVJSUlNTU1RUVFVV VVZWVldXV1hYWFlZWVpaWltbW1xcXF1dXV5eXl9fX2BgYGFhYWJiYmNjY2RkZGVlZWZmZmdn Z2hoaGlpaWpqamtra2xsbG1tbW5ubm9vb3BwcHFxcXJycnNzc3R0dHV1dXZ2dnd3d3h4eHl5 eXp6ent7e3x8fH19fX5+fn9/f4CAgIGBgYKCgoODg4SEhIWFhYaGhoeHh4iIiImJiYqKiouL i4yMjI2NjY6Ojo+Pj5CQkJGRkZKSkpOTk5SUlJWVlZaWlpeXl5iYmJmZmZqampubm5ycnJ2d nZ6enp+fn6CgoKGhoaKioqOjo6SkpKWlpaampqenp6ioqKmpqaqqqqurq6ysrK2tra6urq+v r7CwsLGxsbKysrOzs7S0tLW1tba2tre3t7i4uLm5ubq6uru7u7y8vL29vb6+vr+/v8DAwMHB wcLCwsPDw8TExMXFxcbGxsfHx8jIyMnJycrKysvLy8zMzM3Nzc7Ozs/Pz9DQ0NHR0dLS0tPT 09TU1NXV1dbW1tfX19jY2NnZ2dra2tvb29zc3N3d3d7e3t/f3+Dg4OHh4eLi4uPj4+Tk5OXl 5ebm5ufn5+jo6Onp6erq6uvr6+zs7O3t7e7u7u/v7/Dw8PHx8fLy8vPz8/T09PX19fb29vf3 9/j4+Pn5+fr6+vv7+/z8/P39/f7+/v///yH5BAEKAP8ALAAAAAAWABYAAAjXAP8JHEiwoMGD CBMq/GdlYcI2VxwatJLnmBaJBK8YIsbsIkaGk351UtalikmTERFm+WSLEqVjypYta0YzC0Iv p1YtavRIEqVKmDBlSmbT4BhXnwYZSrQTUiSflIwVzehKEp8/ggglYsRIkaJFkYhhMYjFVSM7 ePDw6QNoECFCgwD5GjsxVSU5d/oMQrSz0aJDvega5BLqE59AiBpJsmRJUqNfKQ9iucTqUCJi yJgtQ1ZMmOCDVBjRejTMy8mTC6P4uRXsM8YlcG65xiikTOSPA6Pg3s1bYEAAOw==} image create photo ::ttk::dialog::image::up -data { R0lGODlhFgAWAOcAADx2Azx2BFWLIlWNIjx1A0uBGJzFdZrFckuDF0V8EJzDdnKvOm+tNZbB bUR7Dz52CZa/cIW5UlqhGFaeEXmzQ467ZD14CIy2ZZTCaWOmI16jHFmgFlSdDoO4UIKyVTt1 Azp2BIKsWaLKfWysMWaoKGGlIVyiGlSeD0+bCI2+X3anSDt2BHShSa3RjXexQG+tNGusLWir J2GoHFOhCVGgB1ahDpXDamiaOWSUN7XVmIS4UXm1QXe1O3O0NG6zLFyqEVeoClenCVamCV6o F5zIcluOKViKKLvXoL/bpb7bo73coH27QXm8OmWzGVywDFyvDKrVganTgKjRgKDLeU+FHzt1 BDpzBD14BcDeooLBRXK7KmC2DmG4DmK4DmG3DqzZgj55BcLhpYfHSma6FGW9EGe/EGfAEWa/ EK/cg8TjpnzDOGnDEWvHEmzIE2vGErDfhMbkqXTBKW/MFHHQFW3KE7HghGy9Hma+EGrEEm3J E27LFGzHE7HfhMXjqa/aha7bg7Deg6/dg/////////////////////////////////////// //////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////// /////////////////////////////////yH5BAEKAP8ALAAAAAAWABYAAAjWAP8JHEiwoMGD CBMqXMiw4UEAARwWLGDgAAGJAhMoWMCggQOJDyBEkDCBQgULDQFcwJBBwwYOHTx8WAgihIgR JEqYOIEihYoVCQGwaOHiBYwYMmbQqGHjxsWDOHLo2MGjh48fQIIIGUKkyEEjR5AkUbKESRMn Tp5AiSJlCpWCVazIvYIli5YtXLp4+QJGrhUQCK2EETOGTBkzZ9BYYWgljRoya9i0cfNm8UIr cOKccSNnDp06lhVitnMHTx49e/iETmilj58/gPjU4RNodWC/uOVi3L07IAA7} image create photo ::ttk::dialog::image::upbw -data { R0lGODlhFgAWAOcAAAAAAAEBAQICAgMDAwQEBAUFBQYGBgcHBwgICAkJCQoKCgsLCwwMDA0N DQ4ODg8PDxAQEBERERISEhMTExQUFBUVFRYWFhcXFxgYGBkZGRoaGhsbGxwcHB0dHR4eHh8f HyAgICEhISIiIiMjIyQkJCUlJSYmJicnJygoKCkpKSoqKisrKywsLC0tLS4uLi8vLzAwMDEx MTIyMjMzMzQ0NDU1NTY2Njc3Nzg4ODk5OTo6Ojs7Ozw8PD09PT4+Pj8/P0BAQEFBQUJCQkND Q0REREVFRUZGRkdHR0hISElJSUpKSktLS0xMTE1NTU5OTk9PT1BQUFFRUVJSUlNTU1RUVFVV VVZWVldXV1hYWFlZWVpaWltbW1xcXF1dXV5eXl9fX2BgYGFhYWJiYmNjY2RkZGVlZWZmZmdn Z2hoaGlpaWpqamtra2xsbG1tbW5ubm9vb3BwcHFxcXJycnNzc3R0dHV1dXZ2dnd3d3h4eHl5 eXp6ent7e3x8fH19fX5+fn9/f4CAgIGBgYKCgoODg4SEhIWFhYaGhoeHh4iIiImJiYqKiouL i4yMjI2NjY6Ojo+Pj5CQkJGRkZKSkpOTk5SUlJWVlZaWlpeXl5iYmJmZmZqampubm5ycnJ2d nZ6enp+fn6CgoKGhoaKioqOjo6SkpKWlpaampqenp6ioqKmpqaqqqqurq6ysrK2tra6urq+v r7CwsLGxsbKysrOzs7S0tLW1tba2tre3t7i4uLm5ubq6uru7u7y8vL29vb6+vr+/v8DAwMHB wcLCwsPDw8TExMXFxcbGxsfHx8jIyMnJycrKysvLy8zMzM3Nzc7Ozs/Pz9DQ0NHR0dLS0tPT 09TU1NXV1dbW1tfX19jY2NnZ2dra2tvb29zc3N3d3d7e3t/f3+Dg4OHh4eLi4uPj4+Tk5OXl 5ebm5ufn5+jo6Onp6erq6uvr6+zs7O3t7e7u7u/v7/Dw8PHx8fLy8vPz8/T09PX19fb29vf3 9/j4+Pn5+fr6+vv7+/z8/P39/f7+/v///yH5BAEKAP8ALAAAAAAWABYAAAjPAP8JHEiwoMGD CBMqXMiw4cErWBwWLPPK1RWJAr+4etRIlReJWVR54oOn0qgsDa+AUjXoz547nDJdVHjFUq1F hgT5wUOHVKOZDxP5mtRIEaJBeO7oWQUIaME9xDpZoiTpUSA/ffgEijXnIBxkzMJqyqSIkFlf vXbVSlPwSpW3WZyBqpRo0SJFwbS8reKUYJVophw9iiQpErEqDKtI8/SI0iVMlowhXliFWqZI ljZ5ynRsssLKkyBVyqTpUufE04YNM3asdTHPCffK3ouxdu2AADs=} image create photo ::ttk::dialog::image::gohome -data { R0lGODlhFgAWAMYAAKQAAPR1deU5OeInJ+xGRvFMTPBRUfJVVeAmJvNbW/JeXntMSohaWN4m JvNkZJldW4SFgpubmsCKitwmJvRsbPRmZp11c4+Qjbi5uMLCwbq6ucShodwlJfNjY6ONi5+g nr+/vt7e3d3d3dfX18m1tZwICKefnaOjotra2urq6unp6efn59zQ0IQiIaGgnqKjodjY2Obm 5uTk5OPj4+Le3tvc21VXU3d4enZ5fXV1dXV2dvPz8+7u7n6Ae3+BfICCfeXl5XZ5fHmZw3eY wnV4fPLy8u3t7YSGgYWHguLi4nV4e1+Gt0p2rnJ1evHx8ezs7IaIg4qIZYmIcODg4HF4gTRl pG52gfDw8Ovr64eJhIiJfvn5+bGztri8wbq7vLm9waSkpO/v74iKhd7e3qKioqOjo2VnY5eZ lJiZlpmalpmal/j4+P////////////////////////////////////////////////////// /////////////////////////yH5BAEKAH8ALAAAAAAWABYAAAf+gH+Cg4QAAISIiYUBAYeK j38AjIyOkIsCjAONloOSBAWZmpWPkgYHjZIIopCSCQqNCwySDauJkg4OjQ8QERKSE7WdARQV jRYXGBkaG5IcwZEBHY0eHyAhISIjJCUBHJvCjSYnKCnlKiorLNzfgpItLi8wMSv0MTIyMzTc o5E1Nv//0N3AkQOHjh38/tjgYaOHjx8/YgAJIiTHECJFbCSyYcTGkY9IZCRRsiQHkyZONCKy 8cQGFChRpCSZQqVKjipWrqgkZAOLjSxZtPiYsoVLFy9fwITZOchGChtioooZs4VMmatlRDAV ZOOKmTNo0qjZwaOs2TVbFQJcyxYgp7cEcDkFAgA7} image create photo ::ttk::dialog::image::gohomebw -data { R0lGODlhFgAWAOcAAAAAAAEBAQICAgMDAwQEBAUFBQYGBgcHBwgICAkJCQoKCgsLCwwMDA0N DQ4ODg8PDxAQEBERERISEhMTExQUFBUVFRYWFhcXFxgYGBkZGRoaGhsbGxwcHB0dHR4eHh8f HyAgICEhISIiIiMjIyQkJCUlJSYmJicnJygoKCkpKSoqKisrKywsLC0tLS4uLi8vLzAwMDEx MTIyMjMzMzQ0NDU1NTY2Njc3Nzg4ODk5OTo6Ojs7Ozw8PD09PT4+Pj8/P0BAQEFBQUJCQkND Q0REREVFRUZGRkdHR0hISElJSUpKSktLS0xMTE1NTU5OTk9PT1BQUFFRUVJSUlNTU1RUVFVV VVZWVldXV1hYWFlZWVpaWltbW1xcXF1dXV5eXl9fX2BgYGFhYWJiYmNjY2RkZGVlZWZmZmdn Z2hoaGlpaWpqamtra2xsbG1tbW5ubm9vb3BwcHFxcXJycnNzc3R0dHV1dXZ2dnd3d3h4eHl5 eXp6ent7e3x8fH19fX5+fn9/f4CAgIGBgYKCgoODg4SEhIWFhYaGhoeHh4iIiImJiYqKiouL i4yMjI2NjY6Ojo+Pj5CQkJGRkZKSkpOTk5SUlJWVlZaWlpeXl5iYmJmZmZqampubm5ycnJ2d nZ6enp+fn6CgoKGhoaKioqOjo6SkpKWlpaampqenp6ioqKmpqaqqqqurq6ysrK2tra6urq+v r7CwsLGxsbKysrOzs7S0tLW1tba2tre3t7i4uLm5ubq6uru7u7y8vL29vb6+vr+/v8DAwMHB wcLCwsPDw8TExMXFxcbGxsfHx8jIyMnJycrKysvLy8zMzM3Nzc7Ozs/Pz9DQ0NHR0dLS0tPT 09TU1NXV1dbW1tfX19jY2NnZ2dra2tvb29zc3N3d3d7e3t/f3+Dg4OHh4eLi4uPj4+Tk5OXl 5ebm5ufn5+jo6Onp6erq6uvr6+zs7O3t7e7u7u/v7/Dw8PHx8fLy8vPz8/T09PX19fb29vf3 9/j4+Pn5+fr6+vv7+/z8/P39/f7+/v///yH5BAEKAP8ALAAAAAAWABYAAAj+AP8JHEgwRgyC CBMW3LTpoMKH/2IwZOgQ4kI2DL80tDhQ4p0+GTVWfCgREKGGEruIhCgRkaKGWc6kXJlQoiNH Dd0Q0qRJIheaHTdRgtQQ0CNcwXKtkrgFaMRNOGNM+uSrm9Vru2hs2rIxaMNQorSpG5su3blp WrsKlPgDlChs5s7JNUeO3LhvWkdG3Falb1+zd/DUETxP778q7qr4+QMIkLlyeCjVkXRHXpWE VdpVIcS5EDlxd/7UcUMn3mWEVdhVMWSIUCFx4Ox0qdOFDrzTBKusq3Ko9x9w+WTt0sWL1Dvc A6uoq4KoOSJv+USNmj6qG3KBVeCVuYQpU6Z57sIPi8d3/bDf8+j9clzPnmNAADs=} image create photo ::ttk::dialog::image::reload -data { R0lGODlhFgAWAOcAADtqqDtrqDdnpTVmpThopjpqpzdopjpqqHeaxaC726zG4q7I46jC3p25 2X6hyk16sDZnpTdnpjRlpFqDt7fN5bDI4qC82q3G4bfN5rrP5rvR57vQ57vR6K/H4W+VwThp pnOYxUZ0rkVyrJ+52Ux4sDlppjdmpU56sYWmzbbN5bXM5abC4LHK5KO/3X+iy8PW6kNxrDtq p1N+sz5tq0BvqzZnpDpppzprqH+kzLHJ45a325G02bTM5cja7EBuqjtrpzVlpE56tGKNw0x4 r6fA3a/J43Sfz83d7j1sqD9uq2yWyjpqqT5tqbTJ4pS22nKfz9Xi8DdopabA3cna7M3d7dTi 8Nzn8zZnpjRlpTlppzhopzZmpTVlpdrl8eDp8+Dp9OHq9Nnk8FV+szVmpOLr9aC+3qG+3dvm 8n+gx0FwrOPs9Zu63L3S6Nzm8lB8smWOxEd2sDxsqDRmpOTs9crb7K7I4sHV6oKjyzdopz5u qz1sqUd0ruXt9sDS5tjj8dHf7qrG4sDU6bjN5YSkzGqQv1B7sj1rqEBuqVeBtZOy1sXV6Dlo pjtppoelysjY6bDJ5LPK5KrE4Zq42j9vqURxqjxpo2qOvJSx07LJ4rbN5qK+3XKXwy9ZjzNl pDFbkTZlojZno0FuqDdnpDZmpDRfl/////////////////////////////////////////// //////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////// /////////////////////////////////yH5BAEKAP8ALAAAAAAWABYAAAj+AP8JHEiwoMGD CBMWBBBAwAACBQwYHGCwwAEECRQsYNDAwQMIAyNIKFhgAoUKFi5gyKBhA4cOHj5EABGioIgR JCKUMAHhBIoUKlawaOHiBQyCMWTEmEGjxkAbN3Dk0LGDRw8fBH8ACSLEhsEPQ4gUMXIECUEb SZT8W3KQSRMnT6B4HShAYRQpU6hUsXJFIUEsEm5k0WLgChaCA7YoXszF78ABXbx8ARNGjMIx BIGQKWPmDBqJBW8ITAMAsZo1bNq4yWLQwBs4EuIQlDOHTh07Vu7gASlwQB49MPYUlMOnj58/ gAIJGkSokKFDiFwkIlAQgqJFjBo5osBDxSMWkBYmRJI0yeAYSgMrWbqEiU2mHJo2leBksJNB T59AhRI1ipTj/wD6FRAAOw==} image create photo ::ttk::dialog::image::folder_new -data { R0lGODlhEAAQAMYAAG1va2dpZc7OzsrEuW1pXvyxPsDAv5aXlZuYkOOrVb6cZODCkfvSkNyy bMuYSfywPsnJyaamptm5hv3nw/765/740f3urPzJZvuyQGF6mjRlpDtnoFJwlNvFnv766P77 5P32u/3xkfzkddSsW2R4jMbY677S6MjMy+64Y/zTk/740/32vP3zo/zue/zoYPq+SNCgVK7H 44yx2I+w05yxwebFif3vrv3xkvzufPzrYfzfUe2+YV9hXdCyfvzLavzld/zoYfzgUfvDRNu6 gVVXU5OwzeGwYs2yf+a7Zvq9SeW6YNCxeem1ZT5onpWwy5Gw0J2xwOOxX7PF2ERrm4+x0p6x vomu1qbC4Dlnoq3H44uw14qv14iu1oWr1YCo03qk0nOgz26dzpi53Fh2m5u73XCeznCdz26c zm2czmybzmubzWqazmmZzWiZzZS226mrqYmv12uazWqazWiYzWaYzGWYzWWXzGSWzGOVzJq6 3lNxlkVdeT5giT9ghv///////yH5BAEKAH8ALAAAAAAQABAAAAfNgH8Ag4MBAX+IiYgAAo2O AwSIBYoABgeXlwgJCgsMDQ4PghARpKUSExQVFhcYfwEGGRqyGxwdHh8gISIjJAEQGiUmJico KSorLC0uLzCvGjEyMjM0NTY3ODk6Oxw8v9DRMj0+P0BBQkMaRAbP4EVGR0hJSktMTUTe4E5P MlBRNDJSpqhjBy4alSozrFxJBwFLFi0ytGzh0sXLFzBhxKQzMIZMGTNhzqBJo2YNmzZu0r2B oyaOHDZz6NSxcwdPHj17+MjayZNnH0VAgyIKBAA7} image create photo ::ttk::dialog::image::configure -data { R0lGODlhFgAWAMYAAH9/f+rp6Pn5+NjY1/j39vPy8YKXsjRlpOzq6P///050pHx8fLu7u+3r 6szMzK+vr2WErOjn5Orq6q2trePj4vr6+Xl4dNzc3JmZmejn5vLx7+3r6evp5/r6+oeHh8/N yvj49/n59/n49/7+/p6enrW1tfb29Z+fnvj4+Ofm5LvByEVxqfT09J2wyt/f31l9q6enpiBK h1R8rqSttvv7+3WQrqS60JCmvqexvcHBwePi4dPf6qKuvJ22zmN7lYScttfi7Y2YpZ240mB3 kZmtw9/n8IGTqVhthFtxiYaGhqG0yO7z9mB2j+Tj4V9fXpGmvvD095eltgAAALDG2+3y9oGK lWyFocDR4v////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////// /////////////////////////yH5BAEKAH8ALAAAAAAWABYAAAfygH+CggAAg4eIiX8AAQID hoqRhAQFj5EGB5EACAKQiAcJCpl/C4WCDA2diaAODxCEERIAExQIFRarFw+jfxgZGhsIHMOq gwcdB7yCHh8gAiECwyKQByPKhySFACUCwiYnByjXkgACKSorLOOSiy0HLi8w7Icx9QcsMjM0 npIxNTY3YhzAkUPHCH6J/O3g0cNHDAAjhh2MFOMHkCA+hAyJsWiEsImIYhApYuSIkBpIOHaU mISekiVGmJxMeQhiEycgYzyBEkUmSpWCpAgdKvRPjClUqswEGpToUKNWhFx5QjORUymDYlix 4lAS0ZD15hUVFAgAOw==} image create photo ::ttk::dialog::image::folder -data { R0lGODlhEAAQAKUAAG1va2dpZc7OzsbGxWNlYcDAv5aXlVVXU8nJyaampqenp6ioqGF6mjRl pEZtnMbY677S6K7H44yx2F9hXYmu1qbC4Dlnoq3H44uw14qv14iu1oWr1YCo03qk0nOgz26d zpi53Fh2m5u73XCeznCdz26czm2czmybzmubzWqazmmZzWiZzZS226mrqYmv12uazWqazWiY zWaYzGWYzWWXzGSWzGOVzJq63lNxlkVdeT5giT9ghv///////////////yH5BAEKAD8ALAAA AAAQABAAAAaGwB9gOAwEfsgkEiBoOgcEZRJQMFivhoNWu0QkvmCwYnFABgqMhnrNVjsCiMYD Qq/bH41zIyLp+/8RDRNxfH+GgQcFe4aHDQeEjICOioWRFBWOCBYXGBIYGRobHB0eHyCTISIj JB8lJicoKSorLI4tLigvMCoxMjM0NTY3ODk6bcdqO1LLy0EAOw==} image create photo ::ttk::dialog::image::file -data { R0lGODlhEAAQAIQAAJmZmYGBgf///+zs7Orq6uvr6+3t7fDw8MTExMXFxcbGxsfHx+7u7u3t 5e3t5u/v78jIyPHx8fLy8pWVlf////////////////////////////////////////////// /yH5BAEKAB8ALAAAAAAQABAAAAVuIBCMZDl+aCCsbLsGqTAQRGEPg3EI8KcSiERCQVQsdr3f DWcwMJCxwrBIPPKiBaahMXhefYIClcFweJOynJPxaEPBg+JiAam/VTmyO8L/qgxGdHV8En4C TWwPBwcREoVoLpE9EyaVARMomZqbmiEAOw==} # Images for ttk::chooseDirectory image create photo ::ttk::dialog::image::dirclose -data { R0lGODlhCQAJAKUAAFRWUlVXU1pcWP///1lbV2BiXt/i3Obo5O3u6/P08vj4911fW2NlYeHk 3+bp5Ovt6u/x7vDx72ZoZAAAAGNmYWpsZ93g2t7h2+Di3WdpZG1vatjb1dfb1Njb1Nfb09XZ 0WpsaHBybW1wa3N1cP////////////////////////////////////////////////////// /////////////////////////////////////////////////////////yH5BAEKAD8ALAAA AAAJAAkAAAY4QEBgSBwKBsjkgFAYGA6IhGKwYAwajgckMihIBpNweECpDCwXDOYyyGgGG07H 8xmAQsqkaMTv94MAOw==} image create photo ::ttk::dialog::image::diropen -data { R0lGODlhCQAJAKUAAFRWUlVXU1pcWP///1lbV2BiXt/i3Obo5AAAAPP08vj4911fW2NlYeHk 3+bp5O/x7vDx72ZoZGNmYWpsZ93g2t7h2+Di3WdpZG1vatjb1dfb1Nfb09XZ0WpsaHBybW1w a3N1cP////////////////////////////////////////////////////////////////// /////////////////////////////////////////////////////////yH5BAEKAD8ALAAA AAAJAAkAAAY4QEBgSBwKBsjkgFAYGA6IhGKwYAwaDsQDMihEBohweCCZDCgVhKUyuGAGGQ1i wxl0PMrkB8Tv94MAOw==} ### ttk::getOpenFile, ttk::getSaveFile, ttk::getAppendFile proc ttk::getOpenFile {args} { return [::ttk::dialog::file::tkFDialog open $args] } proc ttk::getSaveFile {args} { return [::ttk::dialog::file::tkFDialog save $args] } proc ttk::getAppendFile {args} { return [::ttk::dialog::file::tkFDialog append $args] } proc ::ttk::dialog::file::Create {win class} { toplevel $win -class $class wm withdraw $win set dataName [winfo name $win] upvar ::ttk::dialog::file::$dataName data # Additional frame to make sure the toplevel has the correct # background color for the theme # set w [ttk::frame $win.f] pack $w -fill both -expand 1 # f1: the toolbar # set f1 [ttk::frame $w.f1 -class Toolbar] set data(bgLabel) [ttk::label $f1.bg -style Toolbutton] set data(upBtn) [ttk::button $f1.up -style Toolbutton] $data(upBtn) configure -image {::ttk::dialog::image::up disabled ::ttk::dialog::image::upbw} \ -command [list ::ttk::dialog::file::UpDirCmd $win] set data(prevBtn) [ttk::button $f1.prev -style Toolbutton] $data(prevBtn) configure -image {::ttk::dialog::image::previous disabled ::ttk::dialog::image::previousbw} \ -command [list ::ttk::dialog::file::PrevDirCmd $win] set data(nextBtn) [ttk::button $f1.next -style Toolbutton] $data(nextBtn) configure -image {::ttk::dialog::image::next disabled ::ttk::dialog::image::nextbw} \ -command [list ::ttk::dialog::file::NextDirCmd $win] set data(homeBtn) [ttk::button $f1.home -style Toolbutton] $data(homeBtn) configure -image {::ttk::dialog::image::gohome \ disabled ::ttk::dialog::image::gohomebw} \ -command [list ::ttk::dialog::file::HomeDirCmd $win] set data(reloadBtn) [ttk::button $f1.reload -style Toolbutton] $data(reloadBtn) configure -image ::ttk::dialog::image::reload \ -command [list ::ttk::dialog::file::Update $win] set data(newBtn) [ttk::button $f1.new -style Toolbutton] $data(newBtn) configure -image ::ttk::dialog::image::folder_new \ -command [list ::ttk::dialog::file::NewDirCmd $win] set data(cfgBtn) [ttk::menubutton $f1.cfg -style Toolbutton] set data(cfgMenu) [menu $data(cfgBtn).menu -tearoff 0] $data(cfgBtn) configure -image ::ttk::dialog::image::configure \ -menu $data(cfgMenu) set data(dirMenuBtn) [ttk::combobox $f1.menu] $data(dirMenuBtn) configure \ -textvariable ::ttk::dialog::file::${dataName}(selectPath) set data(sortMenu) [menu $data(cfgMenu).sort -tearoff 0] set image [option get $data(cfgMenu) image Image] set selimage [option get $data(cfgMenu) selectImage Image] set msg " " # TRANSLATORS: strings of open file dialog; e.g. click "Whiteboard..." and then "Open File..." append msg [::msgcat::mc "Sorting"] $data(cfgMenu) add cascade -label $msg \ -menu $data(sortMenu) -image $image -compound left $data(cfgMenu) add separator $data(cfgMenu) add radiobutton -label [::msgcat::mc "Short View"] \ -compound left \ -image $image -selectimage ::ttk::dialog::image::radio16 \ -variable ::ttk::dialog::file::details -value 0 -indicatoron 0 \ -command [list ::ttk::dialog::file::setopt $win \ -details ::ttk::dialog::file::details] $data(cfgMenu) add radiobutton -label [::msgcat::mc "Detailed View"] \ -compound left \ -image $image -selectimage ::ttk::dialog::image::radio16 \ -variable ::ttk::dialog::file::details -value 1 -indicatoron 0 \ -command [list ::ttk::dialog::file::setopt $win \ -details ::ttk::dialog::file::details] $data(cfgMenu) add separator $data(cfgMenu) add checkbutton -label [::msgcat::mc "Show Hidden Files"] \ -image $image -selectimage $selimage -compound left \ -variable ::ttk::dialog::file::hidden -indicatoron 0 \ -command [list ::ttk::dialog::file::setopt $win \ -hidden ::ttk::dialog::file::hidden] $data(cfgMenu) add checkbutton -label [::msgcat::mc "Separate Folders"] \ -image $image -selectimage $selimage -compound left \ -variable ::ttk::dialog::file::sepfolders -indicatoron 0 \ -command [list ::ttk::dialog::file::setopt $win \ -sepfolders ::ttk::dialog::file::sepfolders] $data(sortMenu) add radiobutton -label [::msgcat::mc "By Name"] \ -compound left \ -image $image -selectimage ::ttk::dialog::image::radio16 \ -variable ::ttk::dialog::file::sort -value name -indicatoron 0 \ -command [list ::ttk::dialog::file::setopt $win \ -sort ::ttk::dialog::file::sort] $data(sortMenu) add radiobutton -label [::msgcat::mc "By Date"] \ -compound left \ -image $image -selectimage ::ttk::dialog::image::radio16 \ -variable ::ttk::dialog::file::sort -value date -indicatoron 0 \ -command [list ::ttk::dialog::file::setopt $win \ -sort ::ttk::dialog::file::sort] $data(sortMenu) add radiobutton -label [::msgcat::mc "By Size"] \ -compound left \ -image $image -selectimage ::ttk::dialog::image::radio16 \ -variable ::ttk::dialog::file::sort -value size -indicatoron 0 \ -command [list ::ttk::dialog::file::setopt $win \ -sort ::ttk::dialog::file::sort] $data(sortMenu) add separator $data(sortMenu) add checkbutton -label [::msgcat::mc "Reverse"] \ -image $image -selectimage $selimage -compound left \ -variable ::ttk::dialog::file::reverse -indicatoron 0 \ -command [list ::ttk::dialog::file::setopt $win \ -reverse ::ttk::dialog::file::reverse] $data(sortMenu) add checkbutton -label [::msgcat::mc "Folders First"] \ -image $image -selectimage $selimage -compound left \ -variable ::ttk::dialog::file::foldersfirst -indicatoron 0 \ -command [list ::ttk::dialog::file::setopt $win \ -foldersfirst ::ttk::dialog::file::foldersfirst] $data(prevBtn) state disabled $data(nextBtn) state disabled if {![info exists ::env(HOME)]} { $data(homeBtn) state disabled } place $data(bgLabel) -relheight 1 -relwidth 1 pack $data(upBtn) -side left -fill y pack $data(prevBtn) -side left -fill y pack $data(nextBtn) -side left -fill y pack $data(homeBtn) -side left -fill y pack $data(reloadBtn) -side left -fill y pack $data(newBtn) -side left -fill y pack $data(cfgBtn) -side left -fill y pack $data(dirMenuBtn) -side left -fill x -expand 1 -padx 8 # f2: the frame with the OK button, cancel button, "file name" field, # and file types field. # set f2 [ttk::frame $w.f2] ttk::label $f2.lab1 -text [::msgcat::mc "Location"]: -anchor w set data(location) [ttk::combobox $f2.loc] $data(location) configure \ -textvariable ::ttk::dialog::file::${dataName}(selectFile) set data(typeMenuLab) [ttk::label $f2.lab2 -text [::msgcat::mc "Filter"]: -anchor w] set data(typeMenuBtn) [ttk::combobox $f2.filter] set data(okBtn) [ttk::button $f2.ok -text [::msgcat::mc "OK"] \ -default active -width -8 \ -command [list ::ttk::dialog::file::Done $win]] set data(cancelBtn) [ttk::button $f2.cancel -text [::msgcat::mc "Cancel"] \ -width -8 \ -command [list ::ttk::dialog::file::Cancel $win]] grid $f2.lab1 $f2.loc $data(okBtn) -padx 4 -pady 5 -sticky ew grid $f2.lab2 $f2.filter $data(cancelBtn) -padx 4 -pady 5 -sticky ew grid columnconfigure $f2 1 -weight 1 # f3: The file and directory lists # set f3 [ttk::paned $w.f3 -orient horizontal] array set fontinfo [font actual [[label $f3.dummy] cget -font]] set font [list $fontinfo(-family) -14] destroy $f3.dummy $f3 add [ttk::frame $f3.dir] -weight 0 ttk::label $f3.dir.bg -relief sunken set data(dirArea) [text $f3.dir.t -bg white -width 20 -height 16 \ -font $font -bd 0 -highlightthickness 0 -cursor "" \ -wrap none -spacing1 1 -spacing3 1 -exportselection 0 \ -state disabled -yscrollcommand [list $f3.dir.y set] \ -xscrollcommand [list $f3.dir.x set]] ttk::scrollbar $f3.dir.y -command [list $f3.dir.t yview] ttk::scrollbar $f3.dir.x -command [list $f3.dir.t xview] \ -orient horizontal grid $f3.dir.t $f3.dir.y -sticky ns grid $f3.dir.x -sticky we grid $f3.dir.bg -row 0 -column 0 -rowspan 2 -columnspan 2 -sticky news grid $f3.dir.t -sticky news -padx {2 0} -pady {2 0} grid columnconfigure $f3.dir 0 -weight 1 grid rowconfigure $f3.dir 0 -weight 1 $f3 add [ttk::frame $f3.file] -weight 1 # The short view version # set data(short) [ttk::frame $f3.file.short] ttk::label $data(short).bg -relief sunken set data(fileArea) [text $data(short).t -width 42 -height 16 \ -bg white -font $font -bd 0 -highlightthickness 0 \ -cursor "" -wrap none -spacing1 1 -spacing3 1 \ -exportselection 0 -state disabled \ -xscrollcommand [list ::ttk::dialog::file::scrollset $win]] set data(xScroll) [ttk::scrollbar $data(short).x -orient horizontal \ -command [list ::ttk::dialog::file::xview $win]] grid $data(short).t -sticky news -padx 2 -pady {2 0} grid $data(short).x -sticky ew grid $data(short).bg -row 0 -column 0 \ -rowspan 2 -columnspan 2 -sticky news grid columnconfigure $data(short) 0 -weight 1 grid rowconfigure $data(short) 0 -weight 1 # The detailed view version # set data(long) [ttk::frame $f3.file.long] ttk::label $data(long).bg -relief sunken ttk::frame $data(long).f set data(fileHdr) [frame $data(long).f.f] ttk::label $data(fileHdr).l0 -style Toolbutton -anchor w \ -text [::msgcat::mc "Name"] ttk::label $data(fileHdr).l1 -style Toolbutton -anchor w \ -text [::msgcat::mc "Size"] ttk::label $data(fileHdr).l2 -style Toolbutton -anchor w \ -text [::msgcat::mc "Date"] ttk::label $data(fileHdr).l3 -style Toolbutton -anchor w \ -text [::msgcat::mc "Permissions"] ttk::label $data(fileHdr).l4 -style Toolbutton -anchor w \ -text [::msgcat::mc "Owner"] ttk::label $data(fileHdr).l5 -style Toolbutton -anchor w \ -text [::msgcat::mc "Group"] ttk::separator $data(fileHdr).s1 -orient vertical ttk::separator $data(fileHdr).s2 -orient vertical ttk::separator $data(fileHdr).s3 -orient vertical ttk::separator $data(fileHdr).s4 -orient vertical ttk::separator $data(fileHdr).s5 -orient vertical set height [winfo reqheight $data(fileHdr).l1] $data(long).f configure -height [expr {$height + 1}] $data(fileHdr) configure -height $height place $data(fileHdr) -x 1 -relwidth 1 place $data(fileHdr).l0 -x -1 -relwidth 1 -relheight 1 place $data(fileHdr).s1 -rely .1 -relheight .8 -anchor n place $data(fileHdr).s2 -rely .1 -relheight .8 -anchor n place $data(fileHdr).s3 -rely .1 -relheight .8 -anchor n place $data(fileHdr).s4 -rely .1 -relheight .8 -anchor n place $data(fileHdr).s5 -rely .1 -relheight .8 -anchor n set data(fileList) [text $data(long).t -width 42 -height 12 \ -bg white -font $font -bd 0 -highlightthickness 0 \ -cursor "" -wrap none -spacing1 1 -spacing3 1 \ -exportselection 0 -state disabled \ -yscrollcommand [list $data(long).y set] \ -xscrollcommand [list ::ttk::dialog::file::scrollhdr $win]] ttk::scrollbar $data(long).y -command [list $data(long).t yview] ttk::scrollbar $data(long).x -orient horizontal \ -command [list $data(long).t xview] grid $data(long).f $data(long).y -sticky ew -padx {2 0} -pady {2 0} grid $data(long).t ^ -sticky news -padx {2 0} grid $data(long).x -sticky ew grid $data(long).y -sticky ns -padx 0 -pady 0 grid $data(long).bg -row 0 -column 0 \ -rowspan 3 -columnspan 2 -sticky news grid columnconfigure $data(long) 0 -weight 1 grid rowconfigure $data(long) 1 -weight 1 grid $data(long) $data(short) -row 0 -column 0 -sticky news grid columnconfigure $f3.file 0 -weight 1 grid rowconfigure $f3.file 0 -weight 1 # Get rid of the default Text bindings bindtags $data(dirArea) [list $data(dirArea) FileDialogDir $win all] bindtags $data(fileArea) [list $data(fileArea) FileDialogFile $win all] bindtags $data(fileList) [list $data(fileList) FileDialogList $win all] $data(fileArea) tag bind file <1> \ {set ::ttk::dialog::file::filetype file} $data(fileArea) tag bind characterSpecial <1> \ {set ::ttk::dialog::file::filetype file} $data(fileArea) tag bind blockSpecial <1> \ {set ::ttk::dialog::file::filetype file} $data(fileArea) tag bind fifo <1> \ {set ::ttk::dialog::file::filetype file} $data(fileArea) tag bind link <1> \ {set ::ttk::dialog::file::filetype link} $data(fileArea) tag bind directory <1> \ {set ::ttk::dialog::file::filetype directory} $data(fileList) tag bind file <1> \ {set ::ttk::dialog::file::filetype file} $data(fileList) tag bind characterSpecial <1> \ {set ::ttk::dialog::file::filetype file} $data(fileList) tag bind blockSpecial <1> \ {set ::ttk::dialog::file::filetype file} $data(fileList) tag bind fifo <1> \ {set ::ttk::dialog::file::filetype file} $data(fileList) tag bind link <1> \ {set ::ttk::dialog::file::filetype link} $data(fileList) tag bind directory <1> \ {set ::ttk::dialog::file::filetype directory} set data(paneWin) $f3 pack $f1 -side top -fill x pack $f2 -side bottom -fill x -padx 8 -pady {0 5} pack $f3 -side bottom -fill both -expand 1 -padx 8 -pady {6 0} set data(columns) 0 set data(history) "" set data(histpos) -1 update idletasks pack propagate $w 0 wm protocol $win WM_DELETE_WINDOW [list $data(cancelBtn) invoke] bind $data(fileArea) \ [list ::ttk::dialog::file::configure $win] bind $data(dirMenuBtn) [list ::ttk::dialog::file::chdir $win] bind $data(dirMenuBtn) <> \ [list ::ttk::dialog::file::chdir $win] bind $data(location) [list ::ttk::dialog::file::Done $win] bind $data(typeMenuBtn) \ [list ::ttk::dialog::file::SetFilter $win] bind $data(typeMenuBtn) <> \ [list ::ttk::dialog::file::SelectFilter $win] } proc ::ttk::dialog::file::ChangeDir {w dir} { set dataName [winfo name $w] upvar ::ttk::dialog::file::$dataName data set data(history) [lrange $data(history) 0 $data(histpos)] set cwd [lindex $data(history) $data(histpos)] set data(selectPath) [file normalize [file join $cwd $dir]] lappend data(history) $data(selectPath) if {[incr data(histpos)]} { $data(prevBtn) state !disabled set data(selectFile) "" } $data(nextBtn) state disabled UpdateWhenIdle $w } proc ::ttk::dialog::file::UpdateWhenIdle {w} { upvar ::ttk::dialog::file::[winfo name $w] data if {[info exists data(updateId)]} { return } elseif {[winfo ismapped $w]} { set after idle } else { set after 1 } set data(updateId) [after $after [list ::ttk::dialog::file::Update $w]] } proc ::ttk::dialog::file::Update {w} { # This proc may be called within an idle handler. Make sure that the # window has not been destroyed before this proc is called if {![winfo exists $w]} { return } set dataName [winfo name $w] upvar ::ttk::dialog::file::$dataName data unset -nocomplain data(updateId) if {$data(-details)} { grid $data(long) grid remove $data(short) } else { grid $data(short) grid remove $data(long) } if {$data(-sepfolders)} { if {![llength [winfo manager $data(paneWin).dir]]} { $data(paneWin) insert 0 $data(paneWin).dir } } else { if {[llength [winfo manager $data(paneWin).dir]]} { $data(paneWin) forget 0 } } $w configure -cursor watch update set dir ::ttk::dialog::image::folder set file ::ttk::dialog::image::file set cwd [lindex $data(history) $data(histpos)] if {$data(-hidden)} { set pattern "* .*" } else { set pattern "*" } # Make the directory list set dlist "" foreach f [eval glob -nocomplain -tails \ -directory $cwd -type d -- $pattern] { if {[string equal $f .]} continue if {[string equal $f ..]} continue lappend dlist [list $f dir] } # Make the file list set flist "" set filter $data(filter) if {[string equal $filter *]} { set filter $pattern } foreach f [eval [linsert $filter 0 glob -nocomplain -tails \ -directory $cwd -type {f l c b p}]] { # Links can still be directories. Skip those. if {[file isdirectory [file join $cwd $f]]} continue lappend flist [list $f file] } # Combine the two lists, if necessary if {$data(-sepfolders)} { set dlist [sort $w $dlist] set flist [sort $w $flist] } elseif {$data(-foldersfirst)} { set flist [concat [sort $w $dlist] [sort $w $flist]] set dlist "" } else { set flist [sort $w [concat $flist $dlist]] set dlist "" } set t $data(dirArea) $t configure -state normal $t delete 1.0 end foreach f $dlist { $t image create end -image $dir $t insert end " [lindex $f 0]\n" } $t delete end-1c end $t configure -state disabled if {$data(-details)} { set t $data(fileList) $t configure -state normal $t delete 1.0 end set size "" set date "" set mode "" set uid "" set gid "" set maxsize 50 set font [$t cget -font] foreach f $flist { lassign $f name type size date mode uid gid if {![info exists users($uid)] || \ ![info exists groups($gid)]} { set fname [file join $cwd $name] # May fail for dead links if {![catch {array set attr \ [file attributes $fname]}]} { if {[info exists attr(-owner)]} { set users($uid) $attr(-owner) } else { set users($uid) "" } if {[info exists attr(-group)]} { set groups($gid) $attr(-group) } else { set groups($gid) "" } } } catch {set uid $users($uid)} catch {set gid $groups($gid)} set image [expr {$type eq "directory" ? $dir : $file}] set img [$t image create end -image $image] $t tag add name $img $t tag add $type $img $t insert end " $name" [list name $type] $t insert end "\t$size\t" $type $t insert end "[datefmt $date]\t" $type $t insert end "[modefmt $type $mode]\t" $type $t insert end "$uid\t$gid\t\n" $type set size [font measure $font " $name"] if {$size > $maxsize} { set maxsize $size } } $t delete end-1c end $t configure -state disabled set today [datefmt [clock seconds]] set maxu [winfo reqwidth $data(fileHdr).l4] foreach n [array names users] { set size [font measure $font $users($n)] if {$size > $maxu} {set maxu $size} } set maxg [winfo reqwidth $data(fileHdr).l5] foreach n [array names groups] { set size [font measure $font $groups($n)] if {$size > $maxg} {set maxg $size} } set tabs [list [set x [incr maxsize 22]]] lappend tabs [incr x [font measure $font 1000000000]] \ [incr x [font measure $font " $today "]] \ [incr x [font measure $font [modefmt w 0777]]] \ [incr x [incr maxu 8]] [incr x [incr maxg 8]] $t configure -tabs $tabs set i 1 foreach n $tabs { place $data(fileHdr).l$i -x $n place $data(fileHdr).s$i -x $n if {[incr i] > 5} break } } else { set t $data(fileArea) $t configure -state normal $t delete 1.0 end set lines [expr {[winfo height $t] / 18}] set row 1 set col 0 set maxsize 50 set list "" set font [$t cget -font] foreach f $flist { set idx "$row.end" lassign $f name type set image [expr {$type eq "directory" ? $dir : $file}] set img [$t image create $idx -image $image] $t tag add $type $img $t tag add name $img $t insert $idx " $name" [list name $type] "\t" $type lappend list $name $type set size [font measure $font " $name"] if {$size > $maxsize} { set maxsize $size } if {[incr row] > $lines} { incr col set row 1 } elseif {$col == 0} { $t insert $idx "\n" } } # Make sure maxsize is a multiple of an average size character set dx [font measure $font 0] set maxsize [expr {($maxsize + 20 + $dx) / $dx * $dx}] $t insert 1.end "\t" $t configure -state disabled $t configure -tabs $maxsize set data(columns) [expr {$row > 1 ? $col + 1 : $col}] set data(rows) $lines set data(colwidth) $maxsize set data(list) $list } if {[string equal $cwd "/"]} { $data(upBtn) state disabled } else { $data(upBtn) state !disabled } $w configure -cursor "" } proc ::ttk::dialog::file::sort {w list} { set dataName [winfo name $w] upvar ::ttk::dialog::file::$dataName data set cwd [lindex $data(history) $data(histpos)] set order [expr {$data(-reverse) ? "-decreasing" : "-increasing"}] set newlist "" foreach f $list { set file [lindex $f 0] # Use lstat in case the destination doesn't exists file lstat [file join $cwd $file] stat if {[string equal $stat(type) link]} { # This may fail if the link points to nothing if {![catch {file stat [file join $cwd $file] dest}]} { array set stat [array get dest] if {[string equal $stat(type) file]} { set stat(type) link } } } lappend newlist [list $file $stat(type) $stat(size) \ $stat(mtime) $stat(mode) $stat(uid) $stat(gid)] } switch -- $data(-sort) { size { set mode -integer set idx 2 } date { set mode -integer set idx 3 } default { set mode -dictionary set idx 0 } } lsort $order $mode -index $idx $newlist } proc ::ttk::dialog::file::datefmt {str} { clock format $str -format {%d-%m-%Y %H:%M} } proc ::ttk::dialog::file::modefmt {type mode} { switch $type { file {set rc -} default {set rc [string index $type 0]} } binary scan [binary format I $mode] B* bits foreach b [split [string range $bits end-8 end] ""] \ c {r w x r w x r w x} { if {$b} {append rc $c} else {append rc -} } set rc } proc ::ttk::dialog::file::xview {w cmd number {units ""}} { set dataName [winfo name $w] upvar ::ttk::dialog::file::$dataName data set width [winfo width $data(fileArea)] lassign [$data(fileArea) xview] pos1 pos2 set cols $data(columns) set page [expr {int($width / $data(colwidth))}] if {!$page} {set page 1} switch $cmd { scroll { set col [expr {round($pos1 * ($cols + 1))}] if {[string match p* $units]} { incr col [expr {$number * $page}] } else { incr col $number } } moveto { set col [expr {round($number * $cols)}] } } set max [expr {$cols - $page}] if {$col > $max} {set col $max} if {$col < 0} {set col 0} set pos [expr {double($col) / ($cols + 1)}] $data(fileArea) xview moveto $pos } proc ::ttk::dialog::file::scrollset {w first last} { set dataName [winfo name $w] upvar ::ttk::dialog::file::$dataName data if {$data(columns)} { if {$last >= 0.999} { xview $w scroll -1 units return } set w $data(colwidth) set cols $data(columns) set width [winfo width $data(fileArea)] set vwidth [expr {$width % $w + $cols * $w}] set total [expr {$width / ($last - $first)}] set first [expr {$first * $total / $vwidth}] set last [expr {$last * $total / $vwidth}] } $data(xScroll) set $first $last } proc ::ttk::dialog::file::scrollhdr {w first last} { set dataName [winfo name $w] upvar ::ttk::dialog::file::$dataName data lassign [$data(fileList) dlineinfo @0,0] x y width height base place $data(fileHdr) -x $x -width $width $data(long).x set $first $last } proc ::ttk::dialog::file::configure {w} { set dataName [winfo name $w] upvar ::ttk::dialog::file::$dataName data if {$data(columns) == 0} return set dir ::ttk::dialog::image::folder set file ::ttk::dialog::image::file set h [winfo height $data(fileArea)] set rows [expr {$h / 18}] if {$rows == $data(rows)} return set t $data(fileArea) set lines $rows set row 1 set col 0 $t configure -state normal $t delete 1.0 end foreach {name type} $data(list) { set idx $row.end set image [expr {$type eq "directory" ? $dir : $file}] $t tag add file [$t image create $idx -image $image] $t insert $idx " $name" file "\t" if {[incr row] > $lines} { incr col set row 1 } elseif {$col == 0} { $t insert $idx "\n" } } $t insert 1.end "\t" $t configure -state disabled set data(columns) [expr {$row > 1 ? $col + 1 : $col}] set data(rows) $lines } proc ::ttk::dialog::file::setopt {w option var} { set dataName [winfo name $w] upvar ::ttk::dialog::file::$dataName data upvar #0 $var value set data($option) $value UpdateWhenIdle $w } proc ::ttk::dialog::file::UpDirCmd {w} { set dataName [winfo name $w] upvar ::ttk::dialog::file::$dataName data ChangeDir $w [file dirname [lindex $data(history) $data(histpos)]] } proc ::ttk::dialog::file::PrevDirCmd {w} { set dataName [winfo name $w] upvar ::ttk::dialog::file::$dataName data set data(selectFile) "" incr data(histpos) -1 set data(selectPath) [lindex $data(history) $data(histpos)] $data(nextBtn) state !disabled if {!$data(histpos)} { $data(prevBtn) state disabled } Update $w } proc ::ttk::dialog::file::NextDirCmd {w} { set dataName [winfo name $w] upvar ::ttk::dialog::file::$dataName data set data(selectFile) "" incr data(histpos) set data(selectPath) [lindex $data(history) $data(histpos)] $data(prevBtn) state !disabled if {$data(histpos) >= [llength $data(history)] - 1} { $data(nextBtn) state disabled } Update $w } proc ::ttk::dialog::file::HomeDirCmd {w} { ChangeDir $w ~ } proc ::ttk::dialog::file::NewDirCmd {win} { set dataName [winfo name $win] upvar ::ttk::dialog::file::$dataName data set dir [lindex $data(history) $data(histpos)] toplevel $win.new wm title $win.new [::msgcat::mc "New Folder"] set w [ttk::frame $win.new.f] pack $w -expand 1 -fill both ttk::label $w.prompt -anchor w -justify left \ -text [::msgcat::mc "Create new folder in"]:\n$dir ttk::entry $w.box -width 36 -validate all \ -validatecommand [list ::ttk::dialog::file::NewDirVCmd $w %P] ttk::separator $w.sep set f [ttk::frame $w.buttons] ttk::button $f.clear -text [::msgcat::mc "Clear"] -takefocus 0 \ -command [list $w.box delete 0 end] ttk::button $f.ok -text [::msgcat::mc "OK"] -default active \ -command [list ::ttk::dialog::file::NewDirExit $win 1] ttk::button $f.cancel -text [::msgcat::mc "Cancel"] \ -command [list ::ttk::dialog::file::NewDirExit $win] grid $f.clear $f.ok $f.cancel -padx 4 -pady {0 10} -sticky we grid columnconfigure $f {0 1 2} -uniform 1 pack $w.prompt $w.box $w.sep $f \ -side top -padx 12 -pady 3 -anchor w -fill x pack $w.prompt -pady {12 0} pack $f -anchor e -fill none -padx 8 wm transient $win.new $win wm resizable $win.new 0 0 wm protocol $win.new WM_DELETE_WINDOW [list $f.cancel invoke] bind $w.box [list $f.ok invoke] ::tk::PlaceWindow $win.new widget $win ::tk::SetFocusGrab $win.new $w.box } proc ::ttk::dialog::file::NewDirVCmd {w str} { if {[string length $str]} { $w.buttons.ok state !disabled $w.buttons.clear state !disabled } else { $w.buttons.ok state disabled $w.buttons.clear state disabled } return 1 } proc ::ttk::dialog::file::NewDirExit {w {save 0}} { upvar ::ttk::dialog::file::[winfo name $w] data if {$save} { set dir [lindex $data(history) $data(histpos)] set newdir [file join $dir [$w.new.f.box get]] if {[catch {file mkdir $newdir} err]} { ttk::messageBox -type ok -parent $w.new -icon error \ -message "$err" return } else { ChangeDir $w $newdir } } destroy $w.new ::tk::RestoreFocusGrab $w.new $w.new.f.box } proc ::ttk::dialog::file::Cancel {w} { variable selectFilePath "" } proc ::ttk::dialog::file::Done {w} { variable selectFilePath variable filelist set dataName [winfo name $w] upvar ::ttk::dialog::file::$dataName data if {![string length $data(selectFile)] || \ [string equal $data(selectFile) .]} { return -code break } set cwd [lindex $data(history) $data(histpos)] set path [file join $cwd $data(selectFile)] if {[file isdirectory $path]} { ChangeDir $w $path return -code break } if {![string length [file extension $path]]} { append path $data(-defaultextension) } if {[file exists $path]} { if {[string equal $data(type) save]} { set reply [ttk::messageBox -icon warning -type yesno \ -parent $w -message [::msgcat::mc "File %s already exists. Do you want to overwrite it?" $path]] if {[string equal $reply "no"]} {return} } } else { if {[string equal $data(type) open]} { set str {} ttk::messageBox -icon warning -type ok -parent $w \ -message [::msgcat::mc "File %s does not exist." $path] return } } set idx [lsearch -exact $filelist $path] set filelist [linsert [lreplace $filelist $idx $idx] 0 $path] set selectFilePath $path return -code break } proc ::ttk::dialog::file::chdir {w} { upvar ::ttk::dialog::file::[winfo name $w] data set dir $data(selectPath) if {[file isdirectory $dir]} { ChangeDir $w $dir } else { ttk::messageBox -type ok -parent $w \ -message [::msgcat::mc "Cannot change to the directory %s. Permission denied." $data(selectPath)] -icon warning } return -code break } proc ::ttk::dialog::file::SelectFilter {w} { upvar ::ttk::dialog::file::[winfo name $w] data set data(filter) [lindex $data(-filetypes) \ [$data(typeMenuBtn) current] 1] ::ttk::dialog::file::UpdateWhenIdle $w } proc ::ttk::dialog::file::SetFilter {w} { upvar ::ttk::dialog::file::[winfo name $w] data set data(filter) [$data(typeMenuBtn) get] ::ttk::dialog::file::UpdateWhenIdle $w return -code break } proc ::ttk::dialog::file::DirButton1 {w x y} { scan [$w index @$x,$y] %d.%d line char $w tag remove sel 1.0 end $w tag add sel $line.2 $line.end } proc ::ttk::dialog::file::DirRelease1 {w x y} { set top [winfo toplevel $w] $top configure -cursor "" } proc ::ttk::dialog::file::DirDouble1 {w x y} { set dir [$w get sel.first sel.last] ChangeDir [winfo toplevel $w] $dir } proc ::ttk::dialog::file::DirMotion1 {w x y} { [winfo toplevel $w] configure -cursor "X_cursor #C00 #000" } proc ::ttk::dialog::file::FileButton1 {w x y} { set dataName [winfo name [winfo toplevel $w]] upvar ::ttk::dialog::file::$dataName data variable filetype if {[string equal $filetype none]} return set range [$w tag prevrange name @$x,$y+1c "@$x,$y linestart"] if {[llength $range]} { lassign $range index1 index2 $w tag remove sel 1.0 end $w tag add sel $index1+2c $index2 if {$filetype eq "file" || $filetype eq "link"} { set data(selectFile) [$w get sel.first sel.last] } } } proc ::ttk::dialog::file::FileRelease1 {w x y} { set dataName [winfo name [winfo toplevel $w]] upvar ::ttk::dialog::file::$dataName data variable filetype set top [winfo toplevel $w] if {[llength [$top cget -cursor]]} { # The mouse has been moved, don't perform the action $top configure -cursor "" } elseif {![string equal $filetype directory]} { # A file was selected } elseif {[llength [$w tag ranges sel]]} { set dir [$w get sel.first sel.last] ChangeDir [winfo toplevel $w] $dir } [winfo toplevel $w] configure -cursor "" set filetype none } proc ::ttk::dialog::file::FileMotion1 {w x y} { [winfo toplevel $w] configure -cursor "X_cursor #C00 #000" } proc ::ttk::dialog::file::tkFDialog {type arglist} { global env variable selectFilePath variable filelist set dataName __ttk_filedialog upvar ::ttk::dialog::file::$dataName data ::ttk::dialog::file::Config $dataName $type $arglist if {[string equal $data(-parent) .]} { set w .$dataName } else { set w $data(-parent).$dataName } if {![winfo exists $w]} { ::ttk::dialog::file::Create $w TkFDialog } elseif {![string equal [winfo class $w] TkFDialog]} { destroy $w ::ttk::dialog::file::Create $w TkFDialog } else { $data(fileArea) configure -state normal $data(fileArea) delete 1.0 end $data(fileArea) configure -state disabled $data(dirArea) configure -state normal $data(dirArea) delete 1.0 end $data(dirArea) configure -state disabled $data(prevBtn) state disabled $data(nextBtn) state disabled $data(upBtn) state disabled set data(history) "" set data(histpos) -1 } wm transient $w $data(-parent) if {[llength $data(-filetypes)]} { set titles "" foreach type $data(-filetypes) { lassign $type title filter lappend titles $title } $data(typeMenuBtn) configure -values $titles $data(typeMenuLab) state !disabled $data(typeMenuBtn) state !disabled $data(typeMenuBtn) current 0 ::ttk::dialog::file::SelectFilter $w } else { set data(filter) "*" $data(typeMenuBtn) configure -takefocus 0 $data(typeMenuBtn) state disabled $data(typeMenuLab) state disabled } set dirlist "/" if {[info exists env(HOME)] && ![string equal $env(HOME) /]} { lappend dirlist $env(HOME) } if {[lsearch -exact $dirlist $data(selectPath)] < 0} { lappend dirlist $data(selectPath) } foreach n $filelist { set dir [file dirname $n] if {[lsearch -exact $dirlist $dir] < 0} { lappend dirlist $dir } } $data(dirMenuBtn) configure -values $dirlist $data(location) configure -values $filelist ::ttk::dialog::file::ChangeDir $w $data(selectPath) ::tk::PlaceWindow $w widget $data(-parent) wm title $w $data(-title) ::tk::SetFocusGrab $w $data(location) tkwait variable ::ttk::dialog::file::selectFilePath ::tk::RestoreFocusGrab $w $data(location) withdraw return $selectFilePath } proc ::ttk::dialog::file::Config {dataName type argList} { upvar ::ttk::dialog::file::$dataName data set data(type) $type # 1: the configuration specs # set specs { {-defaultextension "" "" ""} {-filetypes "" "" ""} {-initialdir "" "" ""} {-initialfile "" "" ""} {-parent "" "" "."} {-title "" "" ""} {-sepfolders "" "" 1} {-foldersfirst "" "" 1} {-sort "" "" "name"} {-reverse "" "" 0} {-details "" "" 0} {-hidden "" "" 0} } # 2: default values depending on the type of the dialog # if {![info exists data(selectPath)]} { # first time the dialog has been popped up set data(selectPath) [pwd] set data(selectFile) "" } # 3: parse the arguments # tclParseConfigSpec ::ttk::dialog::file::$dataName $specs "" $argList if {$data(-title) == ""} { if {[string equal $type "save"]} { set data(-title) [::msgcat::mc "Save As"] } else { set data(-title) [::msgcat::mc "Open"] } } # 4: set the default directory and selection according to the -initial # settings # # Ensure that initialdir is an absolute path name. if {[string length $data(-initialdir)]} { set dir [file normalize [file join [pwd] $data(-initialdir)]] if {[string equal [file type $dir] "link"]} { set dir [file normalize [file join $dir [file link $dir]]] } if {[file isdirectory $dir]} { set data(selectPath) $dir } else { set data(selectPath) [pwd] } } set data(selectFile) $data(-initialfile) # 5. Parse the -filetypes option # set data(-filetypes) [::tk::FDGetFileTypes $data(-filetypes)] if {![winfo exists $data(-parent)]} { error "bad window path name \"$data(-parent)\"" } variable sepfolders $data(-sepfolders) variable foldersfirst $data(-foldersfirst) variable sort $data(-sort) variable reverse $data(-reverse) variable details $data(-details) variable hidden $data(-hidden) } ### ttk::chooseDirectory proc ::ttk::dialog::file::treeCreate {w} { destroy $w toplevel $w -class TkChooseDir wm iconname $w Dialog set dataName [winfo name $w] upvar ::ttk::dialog::file::$dataName data if {[winfo viewable [winfo toplevel $data(-parent)]] } { wm transient $w $data(-parent) } set f1 [ttk::frame $w.f1] set data(dirMenuBtn) [ttk::combobox $f1.dir \ -textvariable ::ttk::dialog::file::${dataName}(selectPath)] pack $f1.dir -fill x -expand 1 -padx 8 -pady 5 set f2 [ttk::frame $w.f2] ttk::frame $f2.f ttk::label $f2.f.bg -relief sunken array set fontinfo [font actual [[label $f2.f.dummy] cget -font]] set font [list $fontinfo(-family) -14] destroy $f2.f.dummy ttk::label $f2.f.title -anchor w -style Toolbutton \ -text [::msgcat::mc "Folder"] set data(text) [text $f2.f.text -width 48 -height 16 -font $font \ -tabs 20 -wrap none -highlightthickness 0 -bd 0 -cursor "" \ -spacing1 1 -spacing3 1 -exportselection 0 \ -yscrollcommand [list $f2.f.scroll set]] $data(text) mark set subdir end $data(text) mark gravity subdir left ttk::scrollbar $f2.f.scroll -command [list $data(text) yview] grid $f2.f.title $f2.f.scroll -sticky ns grid $f2.f.text ^ -sticky news -padx {2 0} -pady {0 2} grid $f2.f.title -padx {2 0} -pady {2 1} -sticky ew grid $f2.f.bg -column 0 -row 0 -columnspan 2 -rowspan 2 -sticky news grid columnconfigure $f2.f 0 -weight 1 grid rowconfigure $f2.f 1 -weight 1 pack $f2.f -fill both -expand 1 -padx 8 -pady 4 set f3 [ttk::frame $w.f3] ttk::button $f3.ok -text [::msgcat::mc "OK"] -default active \ -command [list ::ttk::dialog::file::TreeDone $w] ttk::button $f3.cancel -text [::msgcat::mc "Cancel"] \ -command [list ::ttk::dialog::file::Cancel $w] grid x $f3.ok $f3.cancel -sticky ew -padx {4 8} -pady 8 grid columnconfigure $f3 {1 2} -uniform buttons -minsize 80 grid columnconfigure $f3 0 -weight 1 pack $f1 -side top -fill x pack $f3 -side bottom -fill x pack $f2 -side top -fill both -expand 1 $data(text) image create end -padx 1 \ -image ::ttk::dialog::image::folder $data(text) insert end " /" name $data(text) configure -state disabled # Get rid of the default Text bindings bindtags $data(text) [list $data(text) DirDialog $w all] bind $data(dirMenuBtn) \ [list ::ttk::dialog::file::TreeReturn $w] wm protocol $w WM_DELETE_WINDOW [list $f3.cancel invoke] } proc ::ttk::dialog::file::treeUpdate {w dir} { upvar ::ttk::dialog::file::[winfo name $w](text) txt set dir [file normalize [file join [pwd] $dir]] set list [lassign [file split $dir] parent] lappend list . $txt configure -state normal $txt delete 1.end end $txt mark set subdir end foreach d $list { treeOpen $w $parent subdir $d set parent [file join $parent $d] } $txt yview subdir-5l TreeSelect $w subdir } proc ::ttk::dialog::file::treeOpen {w path {index insert} {subdir .}} { upvar ::ttk::dialog::file::[winfo name $w](text) txt set level [llength [file split $path]] set tabs [string repeat "\t" [expr {$level - 1}]] set img [lindex [$txt dump -image \ "$index linestart" "$index lineend"] 1] if {[string length $img] && \ [string equal [$txt image cget $img -name] diropen]} { $txt image configure $img -image ::ttk::dialog::image::dirclose } else { set img "" } # Do we already have this data available, but perhaps elided? if {[llength [$txt tag ranges $path]]} { # Also show all subdirectories that were expanded before set list [lsearch -all -inline [$txt tag names] $path/*] foreach n [lappend list $path] { $txt tag configure $n -elide 0 } return } # This may take a little longer so give some indication to the user $w configure -cursor watch update $txt configure -state normal $txt mark set insert $index set list [glob -nocomplain -tails -dir $path -type d -- * .*] foreach d [lsort -dictionary $list] { # Skip . and .. if {[string equal $d .] || [string equal $d ..]} continue # Specify no tags so the tags at the current position are used $txt insert insert "\n" # Insert the line with the appropriate tags $txt insert insert $tabs [list $path] file stat [file join $path $d] stat if {$stat(nlink) != 2} { set img [$txt image create insert -name diropen \ -image ::ttk::dialog::image::diropen -padx 3] $txt tag add $path $img } $txt insert insert "\t" [list $path] set img [$txt image create insert -padx 1 \ -image ::ttk::dialog::image::folder] $txt tag add $path $img $txt insert insert " $d" [list name $path] # Remove tags from the lineend foreach n [$txt tag names insert] { $txt tag remove $n insert } # Add the correct tag to the lineend $txt tag add $path insert # Put a mark if this is the specified subdirectory if {[string equal $d $subdir]} { $txt mark set subdir insert } } # Directory is considered empty if it only contains . and .. if {[llength $list] <= 2 && [string length $img]} { $txt delete $img } $txt configure -state disabled $w configure -cursor "" } proc ::ttk::dialog::file::treeClose {w path} { upvar ::ttk::dialog::file::[winfo name $w](text) txt set img root set pathindex [lindex [$txt tag ranges $path] 0] lassign [$txt dump -image "$pathindex-1l" $pathindex] - img pos if {[string match diropen* $img]} { $txt image configure $img -image ::ttk::dialog::image::diropen } set list [lsearch -all -inline [$txt tag names] $path/*] lappend list $path $txt configure -state normal foreach n $list { # Eliding sounds promising, but doesn't work correctly # $txt tag configure $n -elide 1 eval [list $txt delete] [$txt tag ranges $n] $txt tag delete $n } $txt configure -state disabled } proc ::ttk::dialog::file::TreeDone {w} { upvar ::ttk::dialog::file::[winfo name $w] data if {[file exists $data(selectPath)]} { if {![file isdirectory $data(selectPath)]} { return } } elseif {[string is true $data(-mustexists)]} { return } variable selectFilePath $data(selectPath) } proc ::ttk::dialog::file::cdTree {w dir {subdir .}} { upvar ::ttk::dialog::file::[winfo name $w](text) txt set parent [file dirname $dir] set ranges [$txt tag ranges $parent] if {[llength $ranges]} { set pat [format {^\t* %s$} [file tail $dir]] foreach {index1 index2} $ranges { set idx [$txt search -regexp $pat $index1 $index2] if {[string length $idx]} { $txt mark set subdir "$idx lineend" break } } } else { cdTree $w $parent [file tail $dir] } ::ttk::dialog::file::treeOpen $w $dir subdir $subdir } proc ::ttk::dialog::file::TreeSelect {w index} { upvar ::ttk::dialog::file::[winfo name [winfo toplevel $w]] data set idx [$data(text) index "$index lineend"] set range [$data(text) tag prevrange name $idx "$idx linestart"] if {[llength $range]} { lassign $range index1 index2 $data(text) tag remove sel 1.0 end $data(text) tag add sel $index1-1c $index2+1c set path [lsearch -inline [$data(text) tag names $index1] /*] set dir [$data(text) get $index1+1c $index2] set data(selectPath) [file join $path $dir] } } proc ::ttk::dialog::file::TreeRelease1 {w} { set w [winfo toplevel $w] upvar ::ttk::dialog::file::[winfo name $w](text) txt if {[string length [$w cget -cursor]]} { $w configure -cursor "" return } set dir [string range [$txt get sel.first sel.last] 1 end-1] set path [lsearch -inline [$txt tag names sel.first] /*] if {![catch {$txt image cget sel.first-2c -image} name]} { set index [$txt index sel.last-1c] $txt mark set selmark sel.first switch -glob -- $name { *::diropen { treeOpen $w [file join $path $dir] $index } *::dirclose { treeClose $w [file join $path $dir] } } $txt tag remove sel 1.0 end $txt tag add sel selmark "selmark lineend+1c" } } proc ::ttk::dialog::file::TreeMotion1 {w} { [winfo toplevel $w] configure -cursor "X_cursor #C00 #000" } proc ::ttk::dialog::file::TreeReturn {w} { upvar ::ttk::dialog::file::[winfo name $w] data if {[file isdirectory $data(selectPath)]} { ::ttk::dialog::file::cdTree $w $data(selectPath) $data(text) yview subdir-5l TreeSelect $w subdir } return -code break } proc ttk::chooseDirectory {args} { set dataName __ttk_dirdialog upvar ::ttk::dialog::file::$dataName data set specs { {-initialdir "" "" .} {-mustexist "" "" 0} {-parent "" "" .} {-title "" "" ""} } tclParseConfigSpec ::ttk::dialog::file::$dataName $specs "" $args if {$data(-title) == ""} { set data(-title) "[::tk::mc "Choose Directory"]" } if {![winfo exists $data(-parent)]} { error "bad window path name \"$data(-parent)\"" } if {[string equal $data(-parent) .]} { set w .$dataName } else { set w $data(-parent).$dataName } if {![winfo exists $w]} { ::ttk::dialog::file::treeCreate $w } ::tk::PlaceWindow $w widget $data(-parent) wm title $w $data(-title) ::tk::SetFocusGrab $w $data(text) ::ttk::dialog::file::treeUpdate $w $data(-initialdir) tkwait variable ::ttk::dialog::file::selectFilePath ::tk::RestoreFocusGrab $w $data(text) withdraw return $::ttk::dialog::file::selectFilePath } # Alternative procedure names interp alias {} ttk_getOpenFile {} ::ttk::dialog::file::tkFDialog open interp alias {} ttk_getSaveFile {} ::ttk::dialog::file::tkFDialog save interp alias {} ttk_getAppendFile {} ::ttk::dialog::file::tkFDialog append # Need to have a lassign procedure if {![llength [info procs lassign]]} { proc lassign {list args} { uplevel 1 [list foreach $args $list break] lrange $list [llength $args] end } } option add *TkFDialog*selectBackground #0a5f89 option add *TkFDialog*selectForeground #ffffff option add *TkFDialog*Toolbar*takeFocus 0 option add *TkFDialog*Text.background white option add *TkFDialog*Menu.activeBackground #0a5f89 option add *TkFDialog*Menu.activeForeground #ffffff option add *TkFDialog*Menu.activeBorderWidth 1 option add *TkFDialog*Menu.borderWidth 1 option add *TkFDialog*Menu.relief solid option add *TkFDialog*Menu.Image ::ttk::dialog::image::blank16 option add *TkFDialog*Menu*selectImage ::ttk::dialog::image::tick16 # Bindings bind FileDialogDir {::ttk::dialog::file::DirButton1 %W %x %y} bind FileDialogDir {::ttk::dialog::file::DirRelease1 %W %x %y} bind FileDialogDir {::ttk::dialog::file::DirDouble1 %W %x %y} bind FileDialogDir {::ttk::dialog::file::DirMotion1 %W %x %y} bind FileDialogDir <4> {%W yview scroll -5 units} bind FileDialogDir <5> {%W yview scroll 5 units} bind FileDialogFile {::ttk::dialog::file::FileButton1 %W %x %y} bind FileDialogFile {::ttk::dialog::file::FileRelease1 %W %x %y} bind FileDialogFile {::ttk::dialog::file::FileMotion1 %W %x %y} bind FileDialogFile {::ttk::dialog::file::Done [winfo toplevel %W]} bind FileDialogFile <4> \ {::ttk::dialog::file::xview [winfo toplevel %W] scroll -1 units} bind FileDialogFile <5> \ {::ttk::dialog::file::xview [winfo toplevel %W] scroll 1 units} bind FileDialogList {::ttk::dialog::file::FileButton1 %W %x %y} bind FileDialogList {::ttk::dialog::file::FileRelease1 %W %x %y} bind FileDialogList {::ttk::dialog::file::FileMotion1 %W %x %y} bind FileDialogList {::ttk::dialog::file::Done [winfo toplevel %W]} bind FileDialogList <4> {%W yview scroll -5 units} bind FileDialogList <5> {%W yview scroll 5 units} bind DirDialog <4> {%W yview scroll -5 units} bind DirDialog <5> {%W yview scroll 5 units} bind DirDialog {::ttk::dialog::file::TreeSelect %W @%x,%y} bind DirDialog {::ttk::dialog::file::TreeRelease1 %W} bind DirDialog {::ttk::dialog::file::TreeMotion1 %W} coccinella-0.96.20/components/taskbar/000077500000000000000000000000001167435367600176225ustar00rootroot00000000000000coccinella-0.96.20/components/taskbar/Taskbar.tcl000066400000000000000000000335261167435367600217260ustar00rootroot00000000000000# Taskbar.tcl --- # # This file is part of The Coccinella application. # It implements the taskbar on Windows and the tray on X11. # # Copyright (c) 2004-2008 Mats Bengtsson # # 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 3 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, see . # # $Id: Taskbar.tcl,v 1.45 2008-07-25 13:46:54 matben Exp $ package require balloonhelp namespace eval ::Taskbar { switch -- [tk windowingsystem] { win32 { if {[catch {package require Winico}]} { return } } x11 { if {[catch {package require tktray}]} { return } } default { return } } component::define Taskbar "Creates a system tray icon" } proc ::Taskbar::Load {} { global tcl_platform this variable wtray .tskbar variable wtearoff "" ::Debug 2 "::Taskbar::Load" switch -- [tk windowingsystem] { win32 { if {![WinInit]} { return 0 } } x11 { if {![X11Init]} { return 0 } } default { return 0 } } component::register Taskbar # Add all event hooks. ::hooks::register initHook ::Taskbar::InitHook ::hooks::register quitAppHook ::Taskbar::QuitAppHook ::hooks::register setPresenceHook ::Taskbar::SetPresenceHook ::hooks::register loginHook ::Taskbar::LoginHook ::hooks::register logoutHook ::Taskbar::LogoutHook ::hooks::register preCloseWindowHook ::Taskbar::CloseHook 20 ::hooks::register jabberBuildMain ::Taskbar::BuildMainHook ::hooks::register prefsInitHook ::Taskbar::InitPrefsHook ::hooks::register prefsBuildCustomHook ::Taskbar::BuildCustomPrefsHook ::hooks::register prefsSaveHook ::Taskbar::SavePrefsHook ::hooks::register prefsCancelHook ::Taskbar::CancelPrefsHook return 1 } proc ::Taskbar::WinInit {} { global this prefs variable icon variable iconFile variable wtray variable wmenu if {[catch {package require Winico}]} { return 0 } set wmenu .tskbrpop set icon "" option add *taskbarIconWin coccinella.ico widgetDefault # The Winico is pretty buggy! Need to cd to avoid path troubles! set iconf [option get . taskbarIconWin {}] set iconFile [::Theme::FindExactIconFile icons/others/$iconf] set oldDir [pwd] set dir [file dirname $iconFile] # Winico doesn't understand vfs! if {[info exists starkit::topdir]} { set tmp [file join $this(tmpPath) $iconf] file copy -force $iconFile $tmp cd $this(tmpPath) } else { cd $dir } if {[catch {set icon [winico create $iconf]} err]} { ::Debug 2 "\t winico create $iconFile failed" cd $oldDir return 0 } cd $oldDir set statusStr [::Roster::MapShowToText [::Jabber::GetMyStatus]] set str "$prefs(theAppName) - $statusStr" winico taskbar add $icon \ -callback [list [namespace current]::WinCmd %m %X %Y] -text $str return 1 } proc ::Taskbar::X11Init {} { global prefs variable wtray variable wmenu if {[catch {package require tktray}]} { return 0 } set wmenu $wtray.pop option add *taskbarIcon coccinella widgetDefault set image [::Theme::Find32Icon . taskbarIcon] ::tktray::icon $wtray -image $image bind $wtray { ::Taskbar::X11Cmd %X %Y } bind $wtray { ::Taskbar::X11Popup %X %Y } bind $wtray { ::Taskbar::X11Configure %w %h } set statusStr [::Roster::MapShowToText [::Jabber::GetMyStatus]] set str "$prefs(theAppName) - $statusStr" ::balloonhelp::balloonforwindow $wtray $str return 1 } proc ::Taskbar::BuildMainHook {} { variable tprefs # Not sure how this workd. if {$tprefs(quitMini) || $tprefs(startMini)} { ::UI::WithdrawAllToplevels } bind [::JUI::GetMainWindow] [list [namespace current]::Update %W] } proc ::Taskbar::InitHook {} { global prefs this variable wmenu variable menuIndex # Build popup menu. set m $wmenu menu $m -tearoff 1 -postcommand [list [namespace current]::Post $m] \ -tearoffcommand [namespace current]::TearOff -title $prefs(theAppName) set COCI [::Theme::FindIconSize 16 coccinella] set INFO [::Theme::FindIconSize 16 dialog-information] set SET [::Theme::FindIconSize 16 preferences] set MSG [::Theme::FindIconSize 16 mail-message-new] set ADD [::Theme::FindIconSize 16 list-add-user] set EXIT [::Theme::FindIconSize 16 application-exit] set STAT [::Roster::GetMyPresenceIcon] set menuDef { {cascade mStatus {[mc "Status"]} {} {-image @STAT -compound left}} {command mMinimize {[mc "Mi&nimize"]} ::Taskbar::HideMain } {command mMessage... {[mc "&Message"]...} ::NewMsg::Build {-image @MSG -compound left}} {command mPreferences... {[mc "&Preferences"]...} ::Taskbar::Prefs {-image @SET -compound left}} {command mAddContact... {[mc "&Add Contact"]...} ::JUser::NewDlg {-image @ADD -compound left}} {cascade mInfo {[mc "&Info"]} { {command mAboutCoccinella {[mc "&About Coccinella"]} ::Splash::SplashScreen {-image @COCI -compound left}} {command mCoccinellaHome... {[mc "&Home Page"]...} ::JUI::OpenCoccinellaURL} {command mBugReport... {[mc "&Report Bug"]...} ::JUI::OpenBugURL } } {-image @INFO -compound left} } {separator} {command mQuit {[mc "&Quit"]} ::UserActions::DoQuit {-image @EXIT -compound left}} } set menuDef [string map [list \ @STAT $STAT @COCI $COCI @ADD $ADD @INFO $INFO @SET $SET \ @MSG $MSG @EXIT $EXIT] $menuDef] ::AMenu::Build $m $menuDef array set menuIndex [::AMenu::GetMenuIndexArray $m] } proc ::Taskbar::Prefs {} { ::Preferences::Build ::Preferences::Show {Jabber Customization} } proc ::Taskbar::WinCmd {event x y} { variable wmenu # It can happen that during launch we exist before main window does. if {![winfo exists [::JUI::GetMainWindow]]} { return } switch -- $event { WM_LBUTTONUP { ToggleVisibility } WM_RBUTTONUP { tk_popup $wmenu [expr {$x - 40}] [expr {$y}] [$wmenu index end] } } } proc ::Taskbar::X11Configure {width height} { variable wtray if {$width < 32 || $height < 32} { $wtray configure -image [::Theme::FindIconSize 22 coccinella] } } proc ::Taskbar::X11Cmd {x y} { # It can happen that during launch we exist before main window does. if {![winfo exists [::JUI::GetMainWindow]]} { return } ToggleVisibility } proc ::Taskbar::X11Popup {x y} { variable wmenu variable wtray # It can happen that during launch we exist before main window does. if {![winfo exists [::JUI::GetMainWindow]]} { return } # Try to figure out if top or bottom. set bbox [$wtray bbox] set ybot [expr {[lindex $bbox 3] + [winfo reqheight $wmenu]}] set H [$wmenu yposition 1] if {$ybot > [winfo screenheight $wtray]} { tk_popup $wmenu $x [expr {[lindex $bbox 1] - $H}] [$wmenu index end] } else { tk_popup $wmenu $x [expr {[lindex $bbox 3] + 4}] } } proc ::Taskbar::ToggleVisibility {} { variable tprefs switch -- [wm state [::JUI::GetMainWindow]] { zoomed - normal { if {$tprefs(hideAll)} { ::UI::WithdrawAllToplevels } else { wm withdraw [::JUI::GetMainWindow] } } default { # This includes the iconic state. if {$tprefs(hideAll)} { ::UI::ShowAllToplevels } else { wm deiconify [::JUI::GetMainWindow] foreach w [::UI::GetAllToplevels] { if {[wm state $w] eq "withdrawn"} { wm deiconify $w } } } } } } proc ::Taskbar::Post {m} { global config variable menuIndex switch -- [wm state [::JUI::GetMainWindow]] { zoomed - normal { set state1 disabled set state2 normal } default { set state1 normal set state2 disabled } } Update [::JUI::GetMainWindow] # {available away chat dnd xa invisible unavailable} set status [::Jabber::GetMyStatus] if {$status eq "unavailable"} { set state0 disabled set state3 normal } else { set state0 normal set state3 disabled } $m entryconfigure $menuIndex(mMessage...) -state $state0 $m entryconfigure $menuIndex(mAddContact...) -state $state0 set mstatus [$m entrycget $menuIndex(mStatus) -menu] $mstatus delete 0 end if {$config(ui,status,menu) eq "plain"} { ::Status::BuildMainMenu $mstatus } elseif {$config(ui,status,menu) eq "dynamic"} { ::Status::ExBuildMainMenu $mstatus } } proc ::Taskbar::TearOff {wm wt} { variable wtearoff set wtearoff $wt } proc ::Taskbar::HideMain {} { ::UI::WithdrawAllToplevels Update [::JUI::GetMainWindow] } proc ::Taskbar::ShowMain {} { ::UI::ShowAllToplevels } proc ::Taskbar::LoginHook {} { variable wtearoff variable menuIndex if {[winfo exists $wtearoff] && [winfo ismapped $wtearoff]} { set m $wtearoff $m entryconfigure $menuIndex(mMessage...) -state normal $m entryconfigure $menuIndex(mAddContact...) -state normal } } proc ::Taskbar::LogoutHook {} { variable wtearoff variable menuIndex if {[winfo exists $wtearoff] && [winfo ismapped $wtearoff]} { set m $wtearoff $m entryconfigure $menuIndex(mMessage...) -state disabled $m entryconfigure $menuIndex(mAddContact...) -state disabled } } proc ::Taskbar::Update {w} { variable wtearoff variable wmenu variable menuIndex if {[winfo toplevel $w] ne $w} { return } set m $wmenu switch -- [wm state [::JUI::GetMainWindow]] { zoomed - normal { set state1 disabled set state2 normal ::AMenu::EntryConfigure $m mMinimize -label [mc "Mi&nimize"] \ -command ::Taskbar::HideMain } default { set state1 normal set state2 disabled ::AMenu::EntryConfigure $m mMinimize -label [mc "&Restore"] \ -command ::Taskbar::ShowMain } } } proc ::Taskbar::SetPresenceHook {type args} { global prefs variable icon variable wtray variable wmenu # This can be used to update any specific icon in taskbar. switch -- [tk windowingsystem] { win32 { if {$icon ne ""} { set statusStr [::Roster::MapShowToText [::Jabber::GetMyStatus]] set str "$prefs(theAppName) - $statusStr" winico taskbar modify $icon -text $str } } x11 { set statusStr [::Roster::MapShowToText [::Jabber::GetMyStatus]] set str "$prefs(theAppName) - $statusStr" ::balloonhelp::balloonforwindow $wtray $str } } set m $wmenu set opts [list -compound left -image [::Roster::GetMyPresenceIcon]] eval {::AMenu::EntryConfigure $m mStatus} $opts } proc ::Taskbar::CloseHook {wclose} { variable tprefs set result "" if {[string equal $wclose [::JUI::GetMainWindow]]} { #HideMain if {$tprefs(hideAll)} { ::UI::WithdrawAllToplevels } else { wm withdraw [::JUI::GetMainWindow] } set result stop } return $result } proc ::Taskbar::QuitAppHook {} { variable icon variable tprefs set tprefs(quitMini) 1 set wmstate [wm state [::JUI::GetMainWindow]] if {($wmstate eq "normal") || ($wmstate eq "zoomed")} { set tprefs(quitMini) 0 } if {[tk windowingsystem] eq "win32"} { if {$icon ne ""} { winico taskbar delete $icon } } } # Taskbar::Debug -- # # Use this to bugtrack windows visibility issues. proc ::Taskbar::Debug {} { puts "::UI::GetAllToplevels=[::UI::GetAllToplevels]" puts "::UI::topcache: state=$::UI::topcache(state)" parray ::UI::topcache *,prevstate foreach w [::UI::GetAllToplevels] { puts "w=$w, wm state=[wm state $w]" } } # Preference page -------------------------------------------------------------- proc ::Taskbar::InitPrefsHook {} { variable tprefs set tprefs(quitMini) 0 set tprefs(startMini) 0 set tprefs(hideAll) 1 ::PrefUtils::Add [list \ [list ::Taskbar::tprefs(quitMini) taskbar_quitMini $tprefs(quitMini)] \ [list ::Taskbar::tprefs(startMini) taskbar_startMini $tprefs(startMini)] \ [list ::Taskbar::tprefs(hideAll) taskbar_hideAll $tprefs(hideAll)]] } proc ::Taskbar::BuildCustomPrefsHook {win} { variable tprefs variable tmpPrefs set tmpPrefs(startMini) $tprefs(startMini) set tmpPrefs(hideAll) $tprefs(hideAll) switch -- [tk windowingsystem] { win32 { set str [mc "Start minimized in taskbar"] } x11 { set str [mc "Start minimized in system tray"] } } set strHide [mc "Hide/Show all when main window is hidden/shown"] ttk::checkbutton $win.tskbmini -text $str \ -variable [namespace current]::tmpPrefs(startMini) ttk::checkbutton $win.tskbhide -text $strHide \ -variable [namespace current]::tmpPrefs(hideAll) grid $win.tskbmini -sticky w grid $win.tskbhide -sticky w } proc ::Taskbar::SavePrefsHook {} { variable tprefs variable tmpPrefs set tprefs(startMini) $tmpPrefs(startMini) set tprefs(hideAll) $tmpPrefs(hideAll) } proc ::Taskbar::CancelPrefsHook {} { variable tprefs variable tmpPrefs if {$tprefs(startMini) ne $tmpPrefs(startMini)} { ::Preferences::HasChanged } if {$tprefs(hideAll) ne $tmpPrefs(hideAll)} { ::Preferences::HasChanged } } #------------------------------------------------------------------------------- coccinella-0.96.20/components/taskbar/cmpntIndex.tcl000066400000000000000000000001751167435367600224420ustar00rootroot00000000000000# See contrib/component.tcl for explanations. # component::attempt Taskbar [file join $dir Taskbar.tcl] ::Taskbar::Load coccinella-0.96.20/contrib/000077500000000000000000000000001167435367600154465ustar00rootroot00000000000000coccinella-0.96.20/contrib/MSSpeech.tcl000066400000000000000000000041271167435367600176250ustar00rootroot00000000000000# MSSpeech.tcl --- # # This file is part of The Coccinella application. It implements # glue to Microsoft Speech via tcom for connecting to COM. # # Copyright (c) 2002 Mats Bengtsson # # This source file is distributed under the BSD license. # # See the README file for license, bugs etc. # # $Id: MSSpeech.tcl,v 1.7 2008-03-17 13:28:29 matben Exp $ namespace eval ::MSSpeech { # Main speech object. variable idVoice variable voiceName2ObjectArr } proc ::MSSpeech::Init {} { variable idVoice variable voiceName2ObjectArr variable allVoices if {[catch {package require tcom} ret]} { error "Failed finding the tcom extension" return } if {[catch {::tcom::ref createobject Sapi.SpVoice} ret]} { error "Failed finding Speech COM object" } else { set idVoice $ret set idVoiceToken [$idVoice Voice] set name [$idVoiceToken GetDescription] set voiceName2ObjectArr($name) $idVoice set allVoices [GetVoices] } } proc ::MSSpeech::Speak {msg {voice ""}} { variable idVoice variable voiceName2ObjectArr variable allVoices # 1 means async. if {$voice eq ""} { $idVoice Speak $msg 1 } else { set ind [lsearch $allVoices $voice] if {$ind < 0} { $idVoice Speak $msg 1 } else { if {![info exists voiceName2ObjectArr($voice)]} { if {[catch {::tcom::ref createobject Sapi.SpVoice} ret]} { error "Failed finding Speech COM object" } else { set id $ret set idVoicesToken [$id GetVoices] $id Voice [$idVoicesToken Item $ind] set voiceName2ObjectArr($voice) $id } } catch { $voiceName2ObjectArr($voice) Speak $msg 1 } } } } proc ::MSSpeech::GetVoices {} { variable idVoice set voices [list] set idVoicesToken [$idVoice GetVoices] ::tcom::foreach item $idVoicesToken { lappend voices [$item GetDescription] } return $voices } # If this fails, package loading fails. ::MSSpeech::Init package require tcom package provide MSSpeech 1.0 #------------------------------------------------------------------------------- coccinella-0.96.20/contrib/README000066400000000000000000000003111167435367600163210ustar00rootroot00000000000000 The "contrib" directory contains packages that are possible to use standalone, and not necessarily together with the whiteboard. Some of these packages are written by me, some are written by others. coccinella-0.96.20/contrib/RegisterFileType.tcl000066400000000000000000000130551167435367600214040ustar00rootroot00000000000000# RegisterFileType::RegisterFileType -- # # Register a file type on Windows # # Author: # Kevin Kenny . # Last revised: 27 Nov 2000, 22:35 UTC # Mats Bengtsson # $Id: RegisterFileType.tcl,v 1.1 2007-10-05 07:00:14 matben Exp $ # # Parameters: # extension -- Extension (e.g., .tcl) of the new type # being registered. # className -- Class name (e.g., "tclfile") of the new type # textName -- Textual name (e.g. "Tcl Script") of the # new type. # script -- Name of the file containing a Tcl script # to run when a file of the given type is # opened. The script will receive the name # of the file in [lindex $argv 0]. # # Options: # -icon FILENAME,NUMBER # Set the icon for files of the new type # to be the NUMBER'th icon in the given file. # The file must be a full path name. # -mimetype TYPE # Set the MIME type corresponding to the new # file type to the specified string. # -new BOOLEAN # If BOOLEAN is true, set things up so that # the new file type appears in the "New" menu # in the Explorer and the system tray. # -text BOOLEAN # If BOOLEAN is true, the new file type contains # plain ASCII text of some sort. Set the # Edit and Print actions to open and print # ASCII files. # # Results: # None. # # Side effects: # Adds the following keys to the system registry: # # HKEY_CLASSES_ROOT # (Extension) (Default value) ClassName # "Content Type" MimeType [1] # ShellNew "NullFile" "" [2] # (ClassName) (Default value) TextName # DefaultIcon (Default value) IconName,# [3] # Shell # Open # command (Default value) -SEE BELOW- # Edit # command (Default value) -SEE BELOW- [4] # Print # command (Default value) -SEE BELOW- [4] # MIME # Database # Content Type # (MimeType) (Default value) Extension [1] # # [1] These values are added only if the -mimetype option is used. # [2] This value is added only if the -new option is true. # [3] This value is added only if the -icon option is used. # [4] These values are added only if the -text option is true. # # The command to open the file consists of three arguments. # The first is the name of the current Tcl executable. The # second is the script name, and the third is "%1", which causes # the target file to be passed as a command-line argument. # The edit command is the command that opens text files, and the # print command is the command that prints text files. # #---------------------------------------------------------------------- if {[tk windowingsystem] ne "win32"} { return } package require registry package provide RegisterFileType 1.0 namespace eval RegisterFileType {} proc RegisterFileType::RegisterFileType { extension className textName openCommand args } { # extPath is the class path for the file's extension set extPath "HKEY_CLASSES_ROOT\\$extension" registry set $extPath {} $className sz # classPath is the class path for the file's class set classPath "HKEY_CLASSES_ROOT\\$className" registry set $classPath {} $textName sz # shellPath is the shell key within classPath set shellPath "$classPath\\Shell" # Set up the 'Open' action registry set "$shellPath\\open\\command" {} $openCommand sz # Process optional args foreach {key val} $args { switch -exact -- $key { -mimetype { # Set up the handler for the MIME content type, # and add the content type item to the database registry set $extPath "Content Type" $val sz set mimeDbPath "HKEY_CLASSES_ROOT\\MIME\\Database" append mimeDbPath "\\Content Type\\" $val registry set $mimeDbPath Extension $extension sz } -icon { # Add the file icon to the shell database if {![regexp {^(.*),([^,]*)} $val junk file icon]} { error "-icon option requires fileName,iconNumber" } registry set "$classPath\\DefaultIcon" {} [file nativename $file],$icon sz } -text { if {$val} { # Copy the Print action for text files # into the Print action for the new type set textPath "HKEY_CLASSES_ROOT\\txtfile\\Shell" if {![catch { registry get "$textPath\\print\\command" {} } pCmd]} { registry set "$shellPath\\print\\command" {} $pCmd sz registry set "$shellPath\\print" {} &Print sz } # Copy the Open action for text files # into the Edit action for the new type. if {![catch { registry get "$textPath\\open\\command" {} } eCmd]} { registry set "$shellPath\\edit\\command" {} $eCmd sz registry set "$shellPath\\edit" {} &Edit sz } } } -new { if {$val} { # Add the 'NullFile' action to the # shell's New menu registry set "$extPath\\ShellNew" NullFile {} sz } } default { error "unknown option $key, must be -icon, -mimetype, -new or -text" } } } }coccinella-0.96.20/contrib/TestTree.tcl000066400000000000000000000036331167435367600177160ustar00rootroot00000000000000 package require tree ::tree::tree .t1 -width 150 -height 300 -styleicons triangle -treecolor black \ -yscrollcommand {.sb1 set} -selectcommand SelectCmd -sortcommand {lsort -decreasing} \ -highlightcolor #6363CE -highlightbackground gray87 \ -doubleclickcommand DoubleClickCmd -opencommand OpenCmd \ -rightclickcommand RightClickCmd -buttonpresscommand PressedCmd \ -eventlist {{ RightClickCmd}} scrollbar .sb1 -orient vertical -command {.t1 yview} pack .sb1 -side right -fill y pack .t1 -side right -fill both -expand 1 ::tree::tree .t2 -width 150 -height 300 -background white -pyjamascolor {} \ -yscrollcommand {.sb2 set} -silent 1 scrollbar .sb2 -orient vertical -command {.t2 yview} pack .sb2 -side right -fill y pack .t2 -fill both -expand 1 foreach w {.t1 .t2} dirim [list $::tree::folderimmac $::tree::idir] \ fileim [list $::tree::fileimmac $::tree::ifile] { foreach z {1 2 3} { $w newitem [list dir$z] -image $dirim foreach x {1 2 3 4 5} { $w newitem [list dir$z file$x] -image $fileim -tags t$x$z } $w newitem [list dir$z subdir] -image $dirim -text {Text not item} foreach y {1 2} { $w newitem [list dir$z subdir file$y] -tags xxx -image $fileim -fontstyle italic } foreach zz {1 2 3} { $w newitem [list dir$z subdir ssdir$zz] -image $dirim -text2 {Mats Be} $w newitem [list dir$z subdir ssdir$zz file1] ;# No icon! $w newitem [list dir$z subdir ssdir$zz file2] -image $fileim } } } .t1 itemconfigure {dir3 subdir ssdir2 file1} -background gray70 .t2 itemconfigure {dir1 subdir ssdir1 file1} -background lightblue proc SelectCmd {w v} { puts "SelectCmd: w=$w, v='$v'" } proc DoubleClickCmd {w v} { puts "DoubleClickCmd: w=$w, v='$v'" } proc RightClickCmd {w v x y} { puts "RightClickCmd w=$w, v='$v'" } proc PressedCmd {w v x y} { puts "PressedCmd w=$w, v='$v', x=$x, y=$y" } proc OpenCmd {w v} { puts "OpenCmd: w=$w, v='$v'" } coccinella-0.96.20/contrib/TkInteractorPackage.tcl000066400000000000000000000364351167435367600220520ustar00rootroot00000000000000 # TkInteractorPackage.tcl -- # # Collection of the 'TkInteractor.tcl', 'vtkInt.tcl', and # 'WidgetObject.tcl' files from the VTK distro as a package. # This solves the terrible "path" problem. # ## Procedure should be called to set bindings and initialize variables # package provide TkInteractor 1.0 # instead for source vtkInt.tcl................................................ # a generic interactor for tcl and vtk # catch {unset vtkInteract.bold} catch {unset vtkInteract.normal} catch {unset vtkInteract.tagcount} set vtkInteractBold "-background #43ce80 -foreground #221133 -relief raised -borderwidth 1" set vtkInteractNormal "-background #dddddd -foreground #221133 -relief flat" set vtkInteractTagcount 1 set vtkInteractCommandList "" set vtkInteractCommandIndex 0 proc vtkInteract {} { global vtkInteractCommandList vtkInteractCommandIndex global vtkInteractTagcount proc dovtk {s w} { global vtkInteractBold vtkInteractNormal vtkInteractTagcount global vtkInteractCommandList vtkInteractCommandIndex set tag [append tagnum $vtkInteractTagcount] set vtkInteractCommandIndex $vtkInteractTagcount incr vtkInteractTagcount 1 .vtkInteract.display.text configure -state normal .vtkInteract.display.text insert end $s $tag set vtkInteractCommandList [linsert $vtkInteractCommandList end $s] eval .vtkInteract.display.text tag configure $tag $vtkInteractNormal .vtkInteract.display.text tag bind $tag \ ".vtkInteract.display.text tag configure $tag $vtkInteractBold" .vtkInteract.display.text tag bind $tag \ ".vtkInteract.display.text tag configure $tag $vtkInteractNormal" .vtkInteract.display.text tag bind $tag <1> "dovtk [list $s] .vtkInteract" .vtkInteract.display.text insert end \n; .vtkInteract.display.text insert end [uplevel 1 $s] .vtkInteract.display.text insert end \n\n .vtkInteract.display.text configure -state disabled .vtkInteract.display.text yview end } catch {destroy .vtkInteract} toplevel .vtkInteract -bg #bbbbbb wm title .vtkInteract "vtk Interactor" wm iconname .vtkInteract "vtk" frame .vtkInteract.buttons -bg #bbbbbb pack .vtkInteract.buttons -side bottom -fill both -expand 0 -pady 2m button .vtkInteract.buttons.dismiss -text Dismiss \ -command "wm withdraw .vtkInteract" \ -bg #bbbbbb -fg #221133 -activebackground #cccccc -activeforeground #221133 pack .vtkInteract.buttons.dismiss -side left -expand 1 -fill x frame .vtkInteract.file -bg #bbbbbb label .vtkInteract.file.label -text "Command:" -width 10 -anchor w \ -bg #bbbbbb -fg #221133 entry .vtkInteract.file.entry -width 40 \ -bg #dddddd -fg #221133 -highlightthickness 1 -highlightcolor #221133 bind .vtkInteract.file.entry { dovtk [%W get] .vtkInteract; %W delete 0 end} pack .vtkInteract.file.label -side left pack .vtkInteract.file.entry -side left -expand 1 -fill x frame .vtkInteract.display -bg #bbbbbb text .vtkInteract.display.text -yscrollcommand ".vtkInteract.display.scroll set" \ -setgrid true -width 60 -height 8 -wrap word -bg #dddddd -fg #331144 \ -state disabled scrollbar .vtkInteract.display.scroll \ -command ".vtkInteract.display.text yview" -bg #bbbbbb \ -troughcolor #bbbbbb -activebackground #cccccc -highlightthickness 0 pack .vtkInteract.display.text -side left -expand 1 -fill both pack .vtkInteract.display.scroll -side left -expand 0 -fill y pack .vtkInteract.display -side bottom -expand 1 -fill both pack .vtkInteract.file -pady 3m -padx 2m -side bottom -fill x set vtkInteractCommandIndex 0 bind .vtkInteract { if { $vtkInteractCommandIndex < [expr {$vtkInteractTagcount - 1}] } { incr vtkInteractCommandIndex set command_string [lindex $vtkInteractCommandList $vtkInteractCommandIndex] .vtkInteract.file.entry delete 0 end .vtkInteract.file.entry insert end $command_string } elseif { $vtkInteractCommandIndex == [expr {$vtkInteractTagcount - 1}] } { .vtkInteract.file.entry delete 0 end } } bind .vtkInteract { if { $vtkInteractCommandIndex > 0 } { set vtkInteractCommandIndex [expr {$vtkInteractCommandIndex - 1}] set command_string [lindex $vtkInteractCommandList $vtkInteractCommandIndex] .vtkInteract.file.entry delete 0 end .vtkInteract.file.entry insert end $command_string } } wm withdraw .vtkInteract } vtkInteract # end of vtkInt.tcl......................................................... # start of WidgetObject.tcl................................................. # These procs allow widgets to behave like objects with their own # state variables of processing objects. # generate a "unique" name for a widget variable proc GetWidgetVariable {widget varName} { regsub -all {\.} $widget "_" base return "$varName$base" } # returns an object which will be associated with a widget # A convienience method that creates a name for you # based on the widget name and varible value/ proc NewWidgetObject {widget type varName} { set var "[GetWidgetVariable $widget $varName]_Object" # create the vtk object $type $var # It is better to keep interface consistent # setting objects as variable values, and NewWidgetObject. SetWidgetVariableValue $widget $varName $var return $var } # obsolete!!!!!!! # returns the same thing as GetWidgetVariableValue proc GetWidgetObject {widget varName} { puts "Warning: obsolete call: GetWidgetObject" puts "Please use GetWidgetVariableValue" return "[GetWidgetVariable $widget $varName]_Object" } # sets the value of a widget variable proc SetWidgetVariableValue {widget varName value} { set var [GetWidgetVariable $widget $varName] global $var set $var $value } # This proc has alway eluded me. proc GetWidgetVariableValue {widget varName} { set var [GetWidgetVariable $widget $varName] global $var set temp "" catch {eval "set temp [format {$%s} $var]"} return $temp } # end of WidgetObject.tcl..................................................... # here comes the TkInteractor.tcl file........................................ proc BindTkRenderWidget {widget} { bind $widget {StartMotion %W %x %y} bind $widget {EndMotion %W %x %y} bind $widget {Rotate %W %x %y} bind $widget {Pan %W %x %y} bind $widget {Zoom %W %x %y} bind $widget {Pan %W %x %y} bind $widget {Reset %W %x %y} bind $widget {wm deiconify .vtkInteract} bind $widget {Wireframe %W} bind $widget {Surface %W} bind $widget {PickActor %W %x %y} bind $widget {Enter %W %x %y} bind $widget {focus $oldFocus} bind $widget {Expose %W} } # a litle more complex than just "bind $widget {%W Render}" # we have to handle all pending expose events otherwise they que up. proc Expose {widget} { if {[GetWidgetVariableValue $widget InExpose] == 1} { return } SetWidgetVariableValue $widget InExpose 1 update [$widget GetRenderWindow] Render SetWidgetVariableValue $widget InExpose 0 } # Global variable keeps track of whether active renderer was found set RendererFound 0 # Create event bindings # proc Render {widget} { global CurrentCamera CurrentLight eval $CurrentLight SetPosition [$CurrentCamera GetPosition] eval $CurrentLight SetFocalPoint [$CurrentCamera GetFocalPoint] $widget Render } proc UpdateRenderer {widget x y} { global CurrentCamera CurrentLight global CurrentRenderWindow CurrentRenderer global RendererFound LastX LastY global WindowCenterX WindowCenterY # Get the renderer window dimensions set WindowX [lindex [$widget configure -width] 4] set WindowY [lindex [$widget configure -height] 4] # Find which renderer event has occurred in set CurrentRenderWindow [$widget GetRenderWindow] set renderers [$CurrentRenderWindow GetRenderers] set numRenderers [$renderers GetNumberOfItems] $renderers InitTraversal; set RendererFound 0 for {set i 0} {$i < $numRenderers} {incr i} { set CurrentRenderer [$renderers GetNextItem] set vx [expr {double($x) / $WindowX}] set vy [expr {($WindowY - double($y)) / $WindowY}] set viewport [$CurrentRenderer GetViewport] set vpxmin [lindex $viewport 0] set vpymin [lindex $viewport 1] set vpxmax [lindex $viewport 2] set vpymax [lindex $viewport 3] if { $vx >= $vpxmin && $vx <= $vpxmax && \ $vy >= $vpymin && $vy <= $vpymax} { set RendererFound 1 set WindowCenterX [expr {double($WindowX)*(($vpxmax - $vpxmin)/2.0\ + $vpxmin)}] set WindowCenterY [expr {double($WindowY)*(($vpymax - $vpymin)/2.0\ + $vpymin)}] break } } set CurrentCamera [$CurrentRenderer GetActiveCamera] set lights [$CurrentRenderer GetLights] $lights InitTraversal; set CurrentLight [$lights GetNextItem] set LastX $x set LastY $y } proc Enter {widget x y} { global oldFocus set oldFocus [focus] focus $widget UpdateRenderer $widget $x $y } proc StartMotion {widget x y} { global CurrentCamera CurrentLight global CurrentRenderWindow CurrentRenderer global LastX LastY global RendererFound UpdateRenderer $widget $x $y if { ! $RendererFound } { return } $CurrentRenderWindow SetDesiredUpdateRate 1.0 } proc EndMotion {widget x y} { global CurrentRenderWindow global RendererFound if { ! $RendererFound } {return} $CurrentRenderWindow SetDesiredUpdateRate 0.01 Render $widget } proc Rotate {widget x y} { global CurrentCamera global LastX LastY global RendererFound if { ! $RendererFound } { return } $CurrentCamera Azimuth [expr {($LastX - $x)}] $CurrentCamera Elevation [expr {($y - $LastY)}] $CurrentCamera OrthogonalizeViewUp set LastX $x set LastY $y Render $widget } proc Pan {widget x y} { global CurrentRenderer CurrentCamera global WindowCenterX WindowCenterY LastX LastY global RendererFound if { ! $RendererFound } { return } set FPoint [$CurrentCamera GetFocalPoint] set FPoint0 [lindex $FPoint 0] set FPoint1 [lindex $FPoint 1] set FPoint2 [lindex $FPoint 2] set PPoint [$CurrentCamera GetPosition] set PPoint0 [lindex $PPoint 0] set PPoint1 [lindex $PPoint 1] set PPoint2 [lindex $PPoint 2] $CurrentRenderer SetWorldPoint $FPoint0 $FPoint1 $FPoint2 1.0 $CurrentRenderer WorldToDisplay set DPoint [$CurrentRenderer GetDisplayPoint] set focalDepth [lindex $DPoint 2] set APoint0 [expr {$WindowCenterX + ($x - $LastX)}] set APoint1 [expr {$WindowCenterY - ($y - $LastY)}] $CurrentRenderer SetDisplayPoint $APoint0 $APoint1 $focalDepth $CurrentRenderer DisplayToWorld set RPoint [$CurrentRenderer GetWorldPoint] set RPoint0 [lindex $RPoint 0] set RPoint1 [lindex $RPoint 1] set RPoint2 [lindex $RPoint 2] set RPoint3 [lindex $RPoint 3] if { $RPoint3 != 0.0 } { set RPoint0 [expr {$RPoint0 / $RPoint3}] set RPoint1 [expr {$RPoint1 / $RPoint3}] set RPoint2 [expr {$RPoint2 / $RPoint3}] } $CurrentCamera SetFocalPoint \ [expr {($FPoint0 - $RPoint0)/2.0 + $FPoint0}] \ [expr {($FPoint1 - $RPoint1)/2.0 + $FPoint1}] \ [expr {($FPoint2 - $RPoint2)/2.0 + $FPoint2}] $CurrentCamera SetPosition \ [expr {($FPoint0 - $RPoint0)/2.0 + $PPoint0}] \ [expr {($FPoint1 - $RPoint1)/2.0 + $PPoint1}] \ [expr {($FPoint2 - $RPoint2)/2.0 + $PPoint2}] set LastX $x set LastY $y Render $widget } proc Zoom {widget x y} { global CurrentCamera global LastX LastY global RendererFound if { ! $RendererFound } { return } set zoomFactor [expr {pow(1.02,(0.5*($y - $LastY)))}] if {[$CurrentCamera GetParallelProjection]} { set parallelScale [expr {[$CurrentCamera GetParallelScale] * $zoomFactor}]; $CurrentCamera SetParallelScale $parallelScale; } else { set clippingRange [$CurrentCamera GetClippingRange] set minRange [lindex $clippingRange 0] set maxRange [lindex $clippingRange 1] $CurrentCamera SetClippingRange [expr {$minRange / $zoomFactor}] \ [expr {$maxRange / $zoomFactor}] $CurrentCamera Dolly $zoomFactor } set LastX $x set LastY $y Render $widget } proc Reset {widget x y} { global CurrentRenderWindow global RendererFound global CurrentRenderer # Get the renderer window dimensions set WindowX [lindex [$widget configure -width] 4] set WindowY [lindex [$widget configure -height] 4] # Find which renderer event has occurred in set CurrentRenderWindow [$widget GetRenderWindow] set renderers [$CurrentRenderWindow GetRenderers] set numRenderers [$renderers GetNumberOfItems] $renderers InitTraversal; set RendererFound 0 for {set i 0} {$i < $numRenderers} {incr i} { set CurrentRenderer [$renderers GetNextItem] set vx [expr {double($x) / $WindowX}] set vy [expr {($WindowY - double($y)) / $WindowY}] set viewport [$CurrentRenderer GetViewport] set vpxmin [lindex $viewport 0] set vpymin [lindex $viewport 1] set vpxmax [lindex $viewport 2] set vpymax [lindex $viewport 3] if { $vx >= $vpxmin && $vx <= $vpxmax && \ $vy >= $vpymin && $vy <= $vpymax} { set RendererFound 1 break } } if { $RendererFound } {$CurrentRenderer ResetCamera} Render $widget } proc Wireframe {widget} { global CurrentRenderer set actors [$CurrentRenderer GetActors] $actors InitTraversal set actor [$actors GetNextItem] while { $actor != "" } { [$actor GetProperty] SetRepresentationToWireframe set actor [$actors GetNextItem] } Render $widget } proc Surface {widget} { global CurrentRenderer set actors [$CurrentRenderer GetActors] $actors InitTraversal set actor [$actors GetNextItem] while { $actor != "" } { [$actor GetProperty] SetRepresentationToSurface set actor [$actors GetNextItem] } Render $widget } # Used to support picking operations # set PickedAssembly "" vtkCellPicker ActorPicker vtkProperty PickedProperty PickedProperty SetColor 1 0 0 set PrePickedProperty "" proc PickActor {widget x y} { global CurrentRenderer RendererFound global PickedAssembly PrePickedProperty WindowY set WindowY [lindex [$widget configure -height] 4] if { ! $RendererFound } { return } ActorPicker Pick $x [expr {$WindowY - $y - 1}] 0.0 $CurrentRenderer set assembly [ActorPicker GetAssembly] if { $PickedAssembly != "" && $PrePickedProperty != "" } { $PickedAssembly SetProperty $PrePickedProperty # release hold on the property $PrePickedProperty UnRegister $PrePickedProperty } if { $assembly != "" } { set PickedAssembly $assembly set PrePickedProperty [$PickedAssembly GetProperty] # hold onto the property $PrePickedProperty Register $PrePickedProperty $PickedAssembly SetProperty PickedProperty } Render $widget } coccinella-0.96.20/contrib/TracedText.tcl000066400000000000000000000170021167435367600202210ustar00rootroot00000000000000#---------------------------------------------------------------------- # # TracedText.tcl -- # # Package that implements a change to the text widget that # allows a -textvariable option to be specified at creation # time. # #---------------------------------------------------------------------- # Copyright (c) 1999, by Kevin B. Kenny. All rights reserved. package provide TracedText 1.0 namespace eval TracedText { namespace export TracedText # The traced text widgets have a binding that # cleans up internal storage. Establish it here so that # the widget creation procedure just has to fiddle binding # tags. bind TracedText [namespace code {cleanup %W}] } #---------------------------------------------------------------------- # # TracedText::TracedText -- # # Create a text widget that supports a -textvariable flag # # Parameters: # w -- Path name of the widget # args -- Option-value pairs # # Results: # Returns the path name of the newly-created widget. # # Side effects: # The widget is created. If a -textvariable option is # supplied, the widget command is renamed, and an alias # is installed in the global namespace. The alias command # intercepts the 'insert' and 'delete' subcommands and # updates the text variable. In addition, a trace is # established on the text variable to keep the text # variable up to date. # # Options: # The TracedText command accepts all the options of a text # widget, plus a -textvariable option that gives the name # of a variable or array element in the global namespace # that will contain the same content as the widget itself. # # Limitations: # The code does not work entirely correctly in the presence # of embedded images. The -textvariable option cannot be # set via 'configure' or interrogated via 'cget'. # #---------------------------------------------------------------------- proc TracedText::TracedText { w args } { variable textvar # Extract the special '-textvariable' option. set textArgs {} foreach { option value } $args { switch -exact -- $option { -textvariable { set textvar($w) $value } default { lappend textArgs $option $value } } } # Create the widget eval [list text $w] $textArgs # Rename the widget command to an alias in the "TracedText" # namespace. Create a new command that looks just like the # widget command but goes off to the "widgetCmd" procedure. if {[info exists textvar($w)]} { rename $w alias$w proc ::$w args { # p is the name of this procedure, which may or # may not have a :: qualifier. set p [lindex [info level 0] 0] # w is the name of the traced text widget. set w [namespace tail $p] # Go to the TracedText::widgetCmd procedure to # process the command. return [eval [list TracedText::widgetCmd $w] $args] } # Adjust the bind tags so that the binding will fire. bindtags $w [linsert [bindtags $w] 1 TracedText] # If the variable exists, update the widget content. # Otherwise, create the variable. # the original had a upvar \#0 here upvar 1 $textvar($w) theVariable if { [info exists theVariable] } { alias$w insert 1.0 $theVariable } else { set theVariable {} } # Put a trace on the text variable so that we can update # the widget if it changes. trace variable theVariable w \ [namespace code [list traceCallback $w]] } return $w } #---------------------------------------------------------------------- # # TracedText::widgetCmd -- # # Widget command for a text widget with a textvariable. # # Parameters: # w -- Path name of the widget # args -- Arguments to the widget command # # Results: # Returns whatever the text widget does in response to the # widget command. # # Side effects: # In addition to whatever side effects the text widget # has in response to the widget command, the 'insert' and # 'delete' widget commands cause the text variable of the # widget to be updated. # #---------------------------------------------------------------------- proc TracedText::widgetCmd {w args} { # Execute the widget command set retval [eval [list alias$w] $args] # After the widget command returns, set the text variable if # the command was 'insert' or 'delete.' switch -exact [lindex $args 0] { del - dele - delet - delete - ins - inse - inser - insert { variable textvar variable busy # The 'busy' variable keeps the traceCallback # procedure from attempting to reload the widget # content. upvar \#0 $textvar($w) content set busy($w) {} set content [$w get 1.0 end] unset busy($w) } } return $retval } #---------------------------------------------------------------------- # # TracedText::traceCallback -- # # Trace callback entered when the text variable of a text widget # is changed. # # Parameters: # w -- Path name of the widget # name1 -- Name of the text variable in the calling namespace. # name2 -- Subscript name of the text variable, if any. # op -- Traced variable operation (always "w") # # Results: # None. # # Side effects: # If the variable was being changed in response to an 'insert' # or 'delete' command on the widget, the procedure does nothing. # Otherwise, it deletes the entire content of the widget and # replaces it with the new contents of the variable; it does this # even if the widget is disabled. # #---------------------------------------------------------------------- proc TracedText::traceCallback { w name1 name2 op } { variable busy if { ! [info exists busy($w)] } { variable textvar # Retrieve the changed content of the textvariable upvar 2 $name1 theVariable if { [array exists theVariable] } { set content $theVariable($name2) } else { set content $theVariable } # Enable the widget temporarily, and adjust its content. set state [alias$w cget -state] alias$w configure -state normal alias$w delete 1.0 end alias$w insert 1.0 $content alias$w configure -state $state } return } #---------------------------------------------------------------------- # # TracedText::cleanup -- # # Clean up after destroyoing a text widget with a textvariable. # # Parameters: # w -- Path name of the destroyed widget. # # Results: # None. # # Side effects: # The variables and traces that belong to the widget are deleted, # as is the procedure that aliases the widget command. # #---------------------------------------------------------------------- proc TracedText::cleanup { w } { variable textvar upvar #0 $textvar($w) theVariable trace vdelete theVariable w \ [namespace code [list traceCallback $w]] unset textvar($w) rename ::$w {} return } coccinella-0.96.20/contrib/TreeCtrlDnD.tcl000066400000000000000000000243301167435367600202660ustar00rootroot00000000000000# TreeCtrlDnD.tcl --- # # An attempt to add dnd code to treectrl in a simple way. # # Usage: # set idx [lsearch [bindtags $T] TreeCtrl] # bindtags $T [linsert [bindtags $T] $idx TreeCtrlDnD] # # $T notify install # $T notify install # $T notify install # $T notify install # $T notify install # # List of lists: {column style element ...} specifying elements # added to the drag sources and targets when dragging selected items. # # ::TreeCtrl::DnDSetDragSources $T listOfLists # ::TreeCtrl::DnDSetDropTargets $T listOfLists # # This file is distributed under BSD style license. # # Copyright (c) 2007-2008 Mats Bengtsson package require treectrl package provide TreeCtrlDnD 0.1 # Command-click should provide a discontinuous selection on OSX switch -- [tk windowingsystem] { "aqua" { set modifier Command } default { set modifier Control } } bind TreeCtrlDnD <$modifier-ButtonPress-1> { set TreeCtrl::Priv(selectMode) toggle ::TreeCtrl::DnDButton1 %W %x %y break } bind TreeCtrlDnD { set TreeCtrl::Priv(selectMode) add ::TreeCtrl::DnDButton1 %W %x %y break } bind TreeCtrlDnD { set TreeCtrl::Priv(selectMode) set ::TreeCtrl::DnDButton1 %W %x %y break } bind TreeCtrlDnD { ::TreeCtrl::DnDMotion1 %W %x %y break } bind TreeCtrlDnD { ::TreeCtrl::DnDRelease1 %W %x %y break } bind TreeCtrlDnD { ::TreeCtrl::DnDFree %W } bind TreeCtrlDnD { TreeCtrl::DnDLeave %W %x %y } # ::TreeCtrl::DnDSetDragSources -- # # List of lists: {column style element ...} specifying elements # added to the drag image when dragging selected items proc ::TreeCtrl::DnDSetDragSources {T listOfLists} { variable dnd foreach list $listOfLists { set column [lindex $list 0] set style [lindex $list 1] set elements [lrange $list 2 end] if {[$T column id $column] eq ""} { error "column \"$column\" doesn't exist" } if {[lsearch -exact [$T style names] $style] == -1} { error "style \"$style\" doesn't exist" } foreach element $elements { if {[lsearch -exact [$T element names] $element] == -1} { error "element \"$element\" doesn't exist" } } } set dnd(dragimage,$T) $listOfLists return } proc ::TreeCtrl::DnDIsDragSource {T item} { variable dnd if {![$T item enabled $item]} { return 0 } if {![info exists dnd(dragimage,$T)]} { puts stderr "Need to call ::TreeCtrl::DnDSetDragSources" return 0 } foreach list $dnd(dragimage,$T) { set C [lindex $list 0] set S [lindex $list 1] if {[$T item style set $item $C] ne $S} continue return 1 } return 0 } # ::TreeCtrl::DnDSetDropTargets -- # # List of lists: {column style element ...} specifying elements # the user can drop items on. proc ::TreeCtrl::DnDSetDropTargets {T listOfLists} { variable dnd foreach list $listOfLists { set column [lindex $list 0] set style [lindex $list 1] set elements [lrange $list 2 end] if {[$T column id $column] eq ""} { error "column \"$column\" doesn't exist" } if {[lsearch -exact [$T style names] $style] == -1} { error "style \"$style\" doesn't exist" } foreach element $elements { if {[lsearch -exact [$T element names] $element] == -1} { error "element \"$element\" doesn't exist" } } } set dnd(dropTargets,$T) $listOfLists } proc ::TreeCtrl::DnDIsDropTarget {T x y} { variable dnd if {![info exists dnd(dropTargets,$T)]} { return 0 } set id [$T identify $x $y] if {[lindex $id 0] ne "item" || [llength $id] != 6} { return 0 } lassign $id where item arg1 arg2 arg3 arg4 if {![$T item enabled $item]} { return 0 } foreach list $dnd(dropTargets,$T) { set C [lindex $list 0] set S [lindex $list 1] set eList [lrange $list 2 end] if {[$T column compare $arg2 != $C]} continue if {[$T item style set $item $C] ne $S} continue if {[lsearch -exact $eList $arg4] == -1} continue return 1 } return 0 } proc ::TreeCtrl::DnDButton1 {T x y} { variable Priv variable dnd focus $T set id [$T identify $x $y] set dnd(buttonMode) "" # Click outside any item if {$id eq ""} { $T selection clear # Click in header } elseif {[lindex $id 0] eq "header"} { ButtonPress1 $T $x $y # Click in item } else { lassign $id where item arg1 arg2 arg3 arg4 switch $arg1 { button { $T item toggle $item } line { $T item toggle $arg2 } column { set dnd(drag,motion) 0 set dnd(drag,click,x) $x set dnd(drag,click,y) $y set dnd(drag,x) [$T canvasx $x] set dnd(drag,y) [$T canvasy $y] set dnd(drop) "" set dnd(lastDrop) "" set dnd(dragged) [list] if {$Priv(selectMode) eq "add"} { BeginExtend $T $item } elseif {$Priv(selectMode) eq "toggle"} { BeginToggle $T $item } elseif {![$T selection includes $item]} { BeginSelect $T $item } $T activate $item if {[$T selection includes $item]} { set dnd(buttonMode) drag } } } } return } proc ::TreeCtrl::DnDMotion1 {T x y} { variable Priv variable dnd if {![info exists dnd(buttonMode)]} return switch $dnd(buttonMode) { "drag" { set Priv(autoscan,command,$T) {::TreeCtrl::DnDMotion %T %x %y} AutoScanCheck $T $x $y DnDMotion $T $x $y } default { TreeCtrl::Motion1 $T $x $y } } return } # TreeCtrl::DnDMotion -- # # We must be very careful to handle changes that happen during the # drag process since items may have been deleted. proc ::TreeCtrl::DnDMotion {T x y} { variable Priv variable dnd if {$dnd(buttonMode) ne "drag"} { return } if {!$dnd(drag,motion)} { # Detect initial mouse movement if {(abs($x - $dnd(drag,click,x)) <= 4) && (abs($y - $dnd(drag,click,y)) <= 4)} return set Priv(selection) [$T selection get] set dnd(dragged) [list] foreach item $Priv(selection) { if {[DnDIsDragSource $T $item]} { lappend dnd(dragged) $item } } if {![llength $dnd(dragged)]} { return } set dnd(drop) "" $T dragimage clear # For each dragged item, add some elements to the dragimage foreach I $dnd(dragged) { foreach list $dnd(dragimage,$T) { set C [lindex $list 0] set S [lindex $list 1] if {[$T item style set $I $C] eq $S} { eval $T dragimage add $I $C [lrange $list 2 end] } } } set dnd(lastDrop) "" set dnd(drag,motion) 1 TryEvent $T Drag begin {} } else { # Dragged items may have been deleted during dragging. # Also the 'drop' item may have been deleted. if {![DnDCheckExistence $T]} { unset dnd(buttonMode) return } } # Find the item under the cursor set cursor X_cursor set drop "" set id [$T identify $x $y] if {[DnDIsDropTarget $T $x $y]} { set item [lindex $id 1] # If the item is not in the pre-drag selection # (i.e. not being dragged) see if we can drop on it if {[lsearch -exact $dnd(dragged) $item] == -1} { set drop $item # We can drop if dragged item isn't an ancestor foreach item2 $dnd(dragged) { if {[$T item isancestor $item2 $item]} { set drop "" break } } if {$drop ne ""} { scan [$T item bbox $drop] "%d %d %d %d" x1 y1 x2 y2 if {$y < $y1 + 3} { set cursor top_side set dnd(drop,pos) prevsibling } elseif {$y >= $y2 - 3} { set cursor bottom_side set dnd(drop,pos) nextsibling } else { set cursor "" set dnd(drop,pos) lastchild } } } } # Enter/Leave events if any. if {$dnd(lastDrop) != $drop} { if {$dnd(lastDrop) ne ""} { TryEvent $T Drag leave [list I $dnd(lastDrop) l $dnd(dragged)] } if {$drop ne ""} { TryEvent $T Drag enter [list I $drop l $dnd(dragged)] } } set dnd(lastDrop) $drop if {[$T cget -cursor] ne $cursor} { $T configure -cursor $cursor } # Select the item under the cursor (if any) and deselect # the previous drop-item (if any) $T selection modify $drop $dnd(drop) set dnd(drop) $drop # Show the dragimage in its new position set x [expr {[$T canvasx $x] - $dnd(drag,x)}] set y [expr {[$T canvasy $y] - $dnd(drag,y)}] $T dragimage offset $x $y $T dragimage configure -visible yes return } proc ::TreeCtrl::DnDRelease1 {T x y} { variable Priv variable dnd if {![info exists dnd(buttonMode)]} return switch $dnd(buttonMode) { "drag" { if {![DnDCheckExistence $T]} { unset dnd(buttonMode) return } AutoScanCancel $T $T dragimage configure -visible no $T configure -cursor "" if {[DnDItemExists $T $dnd(drop)]} { $T selection modify {} $dnd(drop) TryEvent $T Drag receive [list I $dnd(drop) l $dnd(dragged)] } TryEvent $T Drag end {} unset dnd(buttonMode) } default { Release1 $T $x $y } } return } proc ::TreeCtrl::DnDLeave {T x y} { variable dnd if {![info exists dnd(buttonMode)]} return switch $dnd(buttonMode) { "drag" { $T dragimage configure -visible no $T configure -cursor "" if {[DnDItemExists $T $dnd(drop)]} { $T selection modify {} $dnd(drop) } TryEvent $T Drag end {} set dnd(buttonMode) "" } } } # TreeCtrl::DnDCheckExistence -- # # Dragged items may have been deleted during dragging. # Also the 'drop' item may have been deleted. # Check both drop targets and dragged that still exist. proc ::TreeCtrl::DnDCheckExistence {T} { variable Priv variable dnd set dragged [list] foreach item $dnd(dragged) { if {[$T item id $item] ne ""} { lappend dragged $item } } set dnd(dragged) $dragged if {![llength $dragged]} { $T dragimage configure -visible no $T configure -cursor "" } if {![DnDItemExists $T $dnd(drop)]} { set dnd(drop) "" } if {![DnDItemExists $T $dnd(lastDrop)]} { set dnd(lastDrop) "" } return [llength $dragged] } proc ::TreeCtrl::DnDItemExists {T item} { return [expr {($item ne "") && ([$T item id $item] ne "")}] } proc ::TreeCtrl::DnDFree {T} { variable dnd array unset dnd *,$T } coccinella-0.96.20/contrib/anigif.tcl000066400000000000000000000164501167435367600174150ustar00rootroot00000000000000# AniGif Package written in pure Tcl/Tk # # anigif.tcl v1.3 2002-09-09 (c) 2001-2002 Ryan Casey # # AniGif is distributed under the same license as Tcl/Tk. As of # AniGif 1.3, this license is applicable to all previous versions. # # Modified by Alexey Shchepin # # Modified by Mats Bengtsson # # ############################### USAGE ################################# # # ::anigif::anigif FILENAME NAME INDEX # FILENAME: appropriate path and file to use for the animated gif # INDEX: what image to begin on (first image is 0) (Default: 0) # # ::anigif::stop IMAGE # ::anigif::restart IMAGE INDEX # INDEX: defaults to next index in loop # ::anigif::destroy IMAGE # ::anigif::delete IMAGE # # NOTES: # There is currently a -zoom and -subsample hack to keep transparency. # Anigif does not handle interlaced gifs properly. The image will look # distorted. # A delay of 0 renders as fast as possible, per the GIF specification. # This is currently set to 40 ms to approximate the IE default. # If you experience a problem with a compressed gif, try uncompressing # it. Search the web for gifsicle. # # ############################## HISTORY ################################# # # 1.4: Major rewrite by Mats # 1.3: Fixed error in disposal flag handling. # Added handling for non-valid comment/graphic blocks. # Searches for actual loop control block. If it extists, loops. # Added more comments. # 1.2: Now handles single playthrough gifs or gifs with partial images # Fixed bug in delay time (unsigned int was being treated as signed) # 1.1: Reads default timing instead of 100 ms or user-defined. # You can no longer set the delay manually. # 1.0: Moved all anigif variables to the anigif namespace # 0.9: Initial release # package provide anigif 1.4 namespace eval ::anigif { variable allNames {} variable heartbeat array set heartbeat { ms 2000 } proc anigif {fileName name {idx 0}} { variable allNames variable heartbeat set n 0 set images {} set delay {} # Read image file. set fd [open $fileName r] fconfigure $fd -translation binary set data [read $fd [file size $fileName]] close $fd if {$name == ""} { set img [image create photo -file $fileName] } else { set img [image create photo $name -file $fileName] } lappend allNames $img set token [GetToken $img] upvar 0 $token state variable $token # Find Loop Record set start [string first "\x21\xFF\x0B" $data] if {$start < 0} { set repeat 0 } else { set repeat 1 } # Find Control Records set start [string first "\x21\xF9\x04" $data] set cmd [list image create photo -file $fileName \ -format [list gif89 -index $n]] while {![catch $cmd tmpname]} { set stop [string first "\x00" $data [expr {$start + 1}]] if {$stop < $start} { break } set record [string range $data $start $stop] if {[binary scan $record @4c1 thisdelay]} { # Change to unsigned integer set thisdelay [expr {$thisdelay & 0xFF}] # Convert hundreths to thousandths for after set thisdelay [expr {$thisdelay * 10}] # If 0, set to fastest (25 ms min to seem to match browser default) if {$thisdelay == 0} { set thisdelay 40 } lappend delay $thisdelay binary scan $record @2b3b3b1b1 -> disposalval userinput transflag lappend images $tmpname lappend disposal $disposalval incr n } set cmd [list image create photo -file $fileName \ -format [list gif89 -index $n]] if {($start >= 0) && ($stop >= 0)} { set start [string first "\x21\xF9\x04" $data [expr {$stop + 1}]] } else { break } } set state(repeat) $repeat set state(delay) $delay set state(disposal) $disposal set state(current) $img set state(images) $images set state(idx) $idx set state(runs) 1 $state(current) blank $state(current) copy [lindex $images 0] if {![info exists heartbeat(after)]} { Beat } return $img } proc GetToken {img} { # Protect from the case when the image name contains any :: # Not 100% foolproof! #set img [string map {- --} $img] return ::anigif::[string map {:: -} $img] } proc Step {token {idx 0}} { upvar 0 $token state variable $token # Need a way to detect if original image was deleted. # Internal error handling in tk seems inconsistent! if {![array exists state]} { return } set img $state(current) if {[catch {image inuse $img}]} { delete $img return } if {$idx >= [llength $state(images)]} { set idx 0 if {$state(repeat) == 0} { # Non-repeating GIF stop $img return } } set dispflag [lindex $state(disposal) $idx] switch -- $dispflag { "000" { # Do nothing } "001" { # Do not dispose } "100" { # Restore to background if {[catch {$state(current) blank}]} { delete $img return } } "101" { # Restore to previous - not supported # As recommended, since this is not supported, it is set to blank if {[catch {$state(current) blank}]} { delete $img return } } default { puts "no match: $dispflag" } } if {[catch {$state(current) copy [lindex $state(images) $idx]}]} { delete $img return } if {[lindex $state(delay) $idx] == 0} { stop $img return } # Reschedule. set delay [lindex $state(delay) $idx] set state(after) [after $delay [list ::anigif::Step $token [incr idx]]] set state(idx) [incr idx] } proc stop {img} { set token [GetToken $img] upvar 0 $token state variable $token catch { after cancel $state(after) } set state(runs) 0 unset -nocomplain state(after) } # TODO proc restart {img {idx -1}} { set token [GetToken $img] upvar 0 $token state variable $token if {$idx == -1} { if {[lindex $state(delay) $idx] < 0} { set idx 0 } else { set idx $state(idx) } } catch { stop $img Step $token $idx } } proc destroy {img} { delete $img } proc delete {img} { set token [GetToken $img] upvar 0 $token state variable $token variable allNames set allNames [lsearch -all -not -inline $allNames $img] catch { stop $img eval {image delete $state(current)} $state(images) unset state } } proc isanigif {img} { set token [GetToken $img] upvar 0 $token state return [array exists state] } proc Pause {token} { upvar 0 $token state variable $token catch { after cancel $state(after) } unset -nocomplain state(after) } # Static procedure to schedule timers only when needed. proc Beat { } { variable allNames variable heartbeat if {$allNames == {}} { catch {after cancel $heartbeat(after)} unset -nocomplain heartbeat(after) return } # This shall start and stop timers for each image when needed. foreach name $allNames { set token [GetToken $name] upvar 0 $token state variable $token # Need a way to detect if original image was deleted. if {[catch {image inuse $name} inuse]} { delete $name continue } if {$inuse && ![info exists state(after)]} { Step $token } elseif {!$inuse && [info exists state(after)]} { Pause [GetToken $name] } } set heartbeat(after) [after $heartbeat(ms) [namespace current]::Beat] } } coccinella-0.96.20/contrib/autoproxy.tcl000066400000000000000000000261531167435367600202330ustar00rootroot00000000000000# autoproxy.tcl - Copyright (C) 2002 Pat Thoyts # # On Unix the standard for identifying the local HTTP proxy server # seems to be to use the environment variable http_proxy or ftp_proxy and # no_proxy to list those domains to be excluded from proxying. # # On Windows we can retrieve the Internet Settings values from the registry # to obtain pretty much the same information. # # With this information we can setup a suitable filter procedure for the # Tcl http package and arrange for automatic use of the proxy. # # Example: # package require autoproxy # autoproxy::init # set tok [http::geturl http://wiki.tcl.tk/] # http::data $tok # # @(#)$Id: autoproxy.tcl,v 1.1 2005-08-27 13:50:49 matben Exp $ package require http; # tcl package require uri; # tcllib package require base64; # tcllib namespace eval ::autoproxy { variable rcsid {$Id: autoproxy.tcl,v 1.1 2005-08-27 13:50:49 matben Exp $} variable version 1.2.1 variable options if {! [info exists options]} { array set options { proxy_host "" proxy_port 80 no_proxy {} basic {} authProc {} } } variable winregkey set winregkey [join { HKEY_CURRENT_USER Software Microsoft Windows CurrentVersion "Internet Settings" } \\] } # ------------------------------------------------------------------------- # Description: # Obtain configuration options for the server. # proc ::autoproxy::cget {option} { variable options switch -glob -- $option] { -host - -proxy_h* { set options(proxy_host) } -port - -proxy_p* { set options(proxy_port) } -no* { set options(no_proxy) } -basic { set options(basic) } -authProc { set options(authProc) } default { set err [join [lsort [array names options]] ", -"] return -code error "bad option \"$option\":\ must be one of -$err" } } } # ------------------------------------------------------------------------- # Description: # Configure the autoproxy package settings. # You may only configure one type of authorisation at a time as once we hit # -basic, -digest or -ntlm - all further args are passed to the protocol # specific script. # # Of course, most of the point of this package is to fill as many of these # fields as possible automatically. You should call autoproxy::init to # do automatic configuration and then call this method to refine the details. # proc ::autoproxy::configure {args} { variable options if {[llength $args] == 0} { foreach {opt value} [array get options] { lappend r -$opt $value } return $r } while {[string match "-*" [set option [lindex $args 0]]]} { switch -glob -- $option { -host - -proxy_h* { set options(proxy_host) [Pop args 1]} -port - -proxy_p* { set options(proxy_port) [Pop args 1]} -no* { set options(no_proxy) [Pop args 1] } -basic { Pop args; configure:basic $args ; break } -authProc { set options(authProc) [Pop args] } -- { Pop args; break } default { set opts [join [lsort [array names options]] ", -"] return -code error "bad option \"$option\":\ must be one of -$opts" } } Pop args } } # ------------------------------------------------------------------------- # Description: # Initialise the http proxy information from the environment or the # registry (Win32) # # This procedure will load the http package and re-writes the # http::geturl method to add in the authorisation header. # # A better solution will be to arrange for the http package to request the # authorisation key on receiving an authorisation reqest. # proc ::autoproxy::init {} { global tcl_platform global env variable winregkey variable options set no_proxy {} set httpproxy {} # Look for standard environment variables. if {[info exists env(http_proxy)]} { set httpproxy $env(http_proxy) if {[info exists env(no_proxy)]} { set no_proxy $env(no_proxy) } } else { if {$tcl_platform(platform) == "windows"} { package require registry 1.0 array set reg {ProxyEnable 0 ProxyServer "" ProxyOverride {}} catch { # IE5 changed ProxyEnable from a binary to a dword value. switch -exact -- [registry type $winregkey "ProxyEnable"] { dword { set reg(ProxyEnable) [registry get $winregkey "ProxyEnable"] } binary { set v [registry get $winregkey "ProxyEnable"] binary scan $v i reg(ProxyEnable) } default { return -code error "unexpected type found for\ ProxyEnable registry item" } } set reg(ProxyServer) [GetWin32Proxy http] set reg(ProxyOverride) [registry get $winregkey "ProxyOverride"] } if {![string is bool $reg(ProxyEnable)]} { set reg(ProxyEnable) 0 } if {$reg(ProxyEnable)} { set httpproxy $reg(ProxyServer) set no_proxy $reg(ProxyOverride) } } } # If we found something ... if {$httpproxy != {}} { # The http_proxy is supposed to be a URL - lets make sure. if {![regexp {\w://.*} $httpproxy]} { set httpproxy "http://$httpproxy" } # decompose the string. array set proxy [uri::split $httpproxy] # turn the no_proxy value into a tcl list set no_proxy [string map {; " " , " "} $no_proxy] # configure ourselves configure -proxy_host $proxy(host) \ -proxy_port $proxy(port) \ -no_proxy $no_proxy # Lift the authentication details from the environment if present. if {[string length $proxy(user)] < 1 \ && [info exists env(http_proxy_user)] \ && [info exists env(http_proxy_pass)]} { set proxy(user) $env(http_proxy_user) set proxy(pwd) $env(http_proxy_pass) } # Maybe the proxy url has authentication parameters? # At this time, only Basic is supported. if {[string length $proxy(user)] > 0} { configure -basic -username $proxy(user) -password $proxy(pwd) } # setup and configure the http package to use our proxy info. http::config -proxyfilter [namespace origin filter] } return $httpproxy } # autoproxy::GetWin32Proxy -- # # Parse the Windows Internet Settings registry key and return the # protocol proxy requested. If the same proxy is in use for all # protocols, then that will be returned. Otherwise the string is # parsed. Example: # ftp=proxy:80;http=proxy:80;https=proxy:80 # proc ::autoproxy::GetWin32Proxy {protocol} { variable winregkey set proxies [split [registry get $winregkey "ProxyServer"] ";"] foreach proxy $proxies { if {[string first = $proxy] == -1} { return $proxy } else { foreach {prot host} [split $proxy =] break if {[string compare $protocol $prot] == 0} { return $host } } } return -code error "failed to identify an '$protocol' proxy" } # ------------------------------------------------------------------------- # Description: # Pop the nth element off a list. Used in options processing. proc ::autoproxy::Pop {varname {nth 0}} { upvar $varname args set r [lindex $args $nth] set args [lreplace $args $nth $nth] return $r } # ------------------------------------------------------------------------- # Description # An example user authentication procedure. # Returns: # A two element list consisting of the users authentication id and # password. proc ::autoproxy::defAuthProc {{user {}} {passwd {}} {realm {}}} { package require BWidget if {[string length $realm] > 0} { set title "Realm: $realm" } else { set title {} } return [PasswdDlg .defAuthDlg -parent {} -transient 0 -title $title \ -logintext $user -passwdtext $passwd] } # ------------------------------------------------------------------------- # Description: # Implement support for the Basic authentication scheme (RFC 1945,2617). # Options: # -user userid - pass in the user ID (May require Windows NT domain # as DOMAIN\\username) # -password pwd - pass in the user's password. # -realm realm - pass in the http realm. # proc ::autoproxy::configure:basic {arglist} { variable options array set opts {user {} passwd {} realm {}} foreach {opt value} $arglist { switch -glob -- $opt { -u* { set opts(user) $value} -p* { set opts(passwd) $value} -r* { set opts(realm) $value} default { return -code error "invalid option \"$opt\": must be one of\ -username or -password or -realm" } } } # If nothing was provided, try calling the authProc if {$options(authProc) != {} \ && ($opts(user) == {} || $opts(passwd) == {})} { set r [$options(authProc) $opts(user) $opts(passwd) $opts(realm)] set opts(user) [lindex $r 0] set opts(passwd) [lindex $r 1] } # Store the encoded string to avoid re-encoding all the time. set options(basic) [list "Proxy-Authorization" \ [concat "Basic" \ [base64::encode $opts(user):$opts(passwd)]]] return } # ------------------------------------------------------------------------- # Description: # An http package proxy filter. This attempts to work out if a request # should go via the configured proxy using a glob comparison against the # no_proxy list items. A typical no_proxy list might be # [list localhost *.my.domain.com 127.0.0.1] # # If we are going to use the proxy - then insert the proxy authorization # header. # proc ::autoproxy::filter {host} { variable options if {$options(proxy_host) == {}} { return {} } foreach domain $options(no_proxy) { if {[string match $domain $host]} { return {} } } # Add authorisation header to the request (by Anders Ramdahl) catch { upvar state State if {$options(basic) != {}} { set State(-headers) [concat $options(basic) $State(-headers)] } } return [list $options(proxy_host) $options(proxy_port)] } # ------------------------------------------------------------------------- package provide autoproxy $::autoproxy::version # ------------------------------------------------------------------------- # # Local variables: # mode: tcl # indent-tabs-mode: nil # End: coccinella-0.96.20/contrib/autosocks.tcl000066400000000000000000000122201167435367600201620ustar00rootroot00000000000000# autosocks.tcl --- # # Interface to socks4/5 to make usage of 'socket' transparent. # Can also be used as a wrapper for the 'socket' command without any # proxy configured. # # (c) 2007 Mats Bengtsson # # This file is distributed under BSD style license. # # This source file is distributed under the BSD license. # # $Id: autosocks.tcl,v 1.9 2007-09-21 09:42:48 matben Exp $ package provide autosocks 0.1 namespace eval autosocks { variable options array set options { -proxy "" -proxyhost "" -proxyport "" -proxyusername "" -proxypassword "" -proxyno "" -proxyfilter autosocks::filter } variable packs foreach name {socks4 socks5} { if {![catch {package require $name}]} { set packs($name) 1 } } } # autosocks::config -- # # Get or set configuration options for the SOCKS proxy. # # Arguments: # args: # -proxy ""|socks4|socks5 # -proxyhost hostname # -proxyport port number # -proxyusername user ID # -proxypassword (socks5) password # -proxyno glob list of hosts to not use proxy # -proxyfilter tclProc {host} # # Results: # one or many option values depending on arguments. proc autosocks::config {args} { variable options variable packs if {[llength $args] == 0} { return [array get options] } elseif {[llength $args] == 1} { return $options($args) } else { set idx [lsearch $args -proxy] if {$idx >= 0} { set proxy [lindex $args [incr idx]] if {[string length $proxy] && ![info exists packs($proxy)]} { return -code error "unsupported proxy \"$proxy\"" } } array set options $args } } proc autosocks::init {} { # @@@ Here we should get default settings from some system API. } # autosocks::socket -- # # Subclassing the 'socket' command. Only client side. # We use -command tclProc instead of -async + fileevent writable. # # Arguments: # host: the peer address, not SOCKS server # port: the peer's port number # args: # -command tclProc {token status} # the 'status' is any of: # ok, error, timeout, network-failure, # rsp_*, err_* (see socks4/5) proc autosocks::socket {host port args} { variable options array set argsA $args array set optsA $args unset -nocomplain optsA(-command) set proxy $options(-proxy) set hostport [$options(-proxyfilter) $host] if {[llength $hostport]} { set ahost [lindex $hostport 0] set aport [lindex $hostport 1] } else { set ahost $host set aport $port } # Connect ahost + aport. if {[info exists argsA(-command)]} { set sock [eval ::socket -async [array get optsA] {$ahost $aport}] # Take some precautions here since WiFi behaves odd. if {[catch {eof $sock} iseof] || $iseof} { return -code error eof } set err [fconfigure $sock -error] if {$err ne ""} { return -code error $err } set token [namespace current]::$sock variable $token upvar 0 $token state set state(host) $host set state(port) $port set state(sock) $sock set state(cmd) $argsA(-command) fconfigure $sock -blocking 0 # There is a potential problem if the socket becomes writable in # this call before we return! Therefore 'after idle'. after idle [list \ fileevent $sock writable [namespace code [list writable $token]]] } else { set sock [eval {::socket $ahost $aport} [array get optsA]] if {[string length $options(-proxy)]} { eval {${proxy}::init $sock $host $port} [get_opts] } } return $sock } proc autosocks::get_opts {} { variable options set opts [list] if {[string length $options(-proxyusername)]} { lappend opts -username $options(-proxyusername) } if {[string length $options(-proxypassword)]} { lappend opts -password $options(-proxypassword) } return $opts } proc autosocks::writable {token} { variable $token upvar 0 $token state variable options set proxy $options(-proxy) set sock $state(sock) fileevent $sock writable {} if {[catch {eof $sock} iseof] || $iseof} { uplevel #0 $state(cmd) network-failure unset -nocomplain state } else { if {[string length $proxy]} { if {[catch { eval { $options(-proxy)::init $sock $state(host) $state(port) \ -command [namespace code [list socks_cb $token]] } [get_opts] } err]} { uplevel #0 $state(cmd) $err unset -nocomplain state } } else { uplevel #0 $state(cmd) ok unset -nocomplain state } } } proc autosocks::socks_cb {token stok status} { variable $token upvar 0 $token state variable options uplevel #0 $state(cmd) $status $options(-proxy)::free $stok unset -nocomplain state } proc autosocks::filter {host} { variable options if {[llength $options(-proxy)]} { foreach domain $options(-proxyno) { if {[string match $domain $host]} { return {} } } return [list $options(-proxyhost) $options(-proxyport)] } else { return [list] } } coccinella-0.96.20/contrib/balloonhelp.tcl000066400000000000000000000275321167435367600204620ustar00rootroot00000000000000# balloonhelp.tcl -- # # By Mats Bengtsson # # Code idee from Harrison & McLennan # This source file is distributed under the BSD license. # # @@@ Treectrl is problematic since items come and go and are not free'd. # Perhaps a callback based method instead? # # This file is distributed under BSD style license. # # $Id: balloonhelp.tcl,v 1.34 2008-04-27 06:50:15 matben Exp $ package require treeutil package provide balloonhelp 1.0 namespace eval ::balloonhelp:: { variable locals variable debug 0 variable w .balloonhelp set locals(active) 1 set locals(alpha) 0 set locals(fadeout) {0.9 0.8 0.7 0.6 0.5 0.4 0.3 0.2 0.15 0.1 0.05} # Java style popup: light blue schemata: bg=#D8E1F4, bd=#4A6EBC # Standard: light yellow: bg=#FFFF9F option add *Balloonhelp.background "#FFFF9F" widgetDefault option add *Balloonhelp.foreground black widgetDefault option add *Balloonhelp.wrapLength 180 widgetDefault option add *Balloonhelp.justify left widgetDefault option add *Balloonhelp.millisecs 2000 widgetDefault option add *Balloonhelp.timeout 0 widgetDefault switch -- [tk windowingsystem] { x11 { option add *Balloonhelp.font {Helvetica -10} widgetDefault } win32 { option add *Balloonhelp.font {Arial 8} widgetDefault } aqua { option add *Balloonhelp.font {Geneva 9} widgetDefault } } if {[tk windowingsystem] eq "aqua"} { bind Balloonhelp { ::balloonhelp::OnMap %W } } } proc ::balloonhelp::Init {} { variable w variable locals if {![winfo exists $w]} { Build set locals(millisecs) [option get $w millisecs {}] set locals(timeout) [option get $w timeout {}] array set wmA [wm attributes $w] if {[info exists wmA(-alpha)]} { set locals(alpha) 1 } } } proc ::balloonhelp::Toplevel {w} { toplevel $w -class Balloonhelp -bd 0 -relief flat -takefocus 0 wm overrideredirect $w 1 wm withdraw $w switch -- [tk windowingsystem] { aqua { if {[info tclversion] >= 8.5} { tk::unsupported::MacWindowStyle style $w help hideOnSuspend } else { tk::unsupported::MacWindowStyle style $w help none } # NB: If we do this before 'unsupported' it takes focus !? wm resizable $w 0 0 } default { wm transient $w wm resizable $w 0 0 } } return $w } proc ::balloonhelp::Build {} { variable w variable locals Toplevel $w # Inherit toplevel's db values. set bg [option get $w background {}] set fg [option get $w foreground {}] set wrap [option get $w wrapLength {}] set just [option get $w justify {}] label $w.info -bg $bg -fg $fg -wraplength $wrap -justify $just \ -takefocus 0 pack $w.info -side left -fill y return $w } proc ::balloonhelp::configure {args} { variable locals array set opts [list -active $locals(active) -millisecs $locals(millisecs)] if {[llength $args] == 0} { return $opts } elseif {[llength $args] == 1} { return $locals($args) } foreach {key value} $args { switch -regexp -- $key { -act* { set locals(active) [regexp -nocase {^(1|yes|true|on)$} $value] } -mil* { set locals(millisecs) $value } -time* { set locals(timeout) $value } } } } proc ::balloonhelp::balloonforwindow {win msg args} { variable locals Init set locals($win) $msg set locals($win,args) $args # Perhaps we shall have "+" for all bindings to not interfere... bind $win {+::balloonhelp::Pending %W "window" } bind $win {+::balloonhelp::Cancel %W } bind $win